misc.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
   2 ;;; $Header: /usr/local/cvsrep/hunchentoot/misc.lisp,v 1.17 2008/03/17 11:40:25 edi Exp $
   3
   4 ;;; Copyright (c) 2004-2009, Dr. Edmund Weitz. All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot)
  31
  32 (let ((scanner-hash (make-hash-table :test #'equal)))
  33   (defun scanner-for-get-param (param-name)
  34     "Returns a CL-PPCRE scanner which matches a GET parameter in a
  35 URL.  Scanners are memoized in SCANNER-HASH once they are created."
  36     (or (gethash param-name scanner-hash)
  37         (setf (gethash param-name scanner-hash)
  38                 (create-scanner
  39                  `(:alternation
  40                    ;; session=value at end of URL
  41                    (:sequence
  42                     (:char-class #\? #\&)
  43                     ,param-name
  44                     #\=
  45                     (:greedy-repetition 0 nil (:inverted-char-class #\&))
  46                     :end-anchor)
  47                    ;; session=value with other parameters following
  48                    (:sequence
  49                     (:register (:char-class #\? #\&))
  50                     ,param-name
  51                     #\=
  52                     (:greedy-repetition 0 nil (:inverted-char-class #\&))
  53                     #\&))))))
  54   (defun add-cookie-value-to-url (url &key
  55                                       (cookie-name (session-cookie-name *acceptor*))
  56                                       (value (when-let (session (session *request*))
  57                                                (session-cookie-value session)))
  58                                       (replace-ampersands-p t))
  59     "Removes all GET parameters named COOKIE-NAME from URL and then
  60 adds a new GET parameter with the name COOKIE-NAME and the value
  61 VALUE.  If REPLACE-AMPERSANDS-P is true all literal ampersands in URL
  62 are replaced with '&amp;'. The resulting URL is returned."
  63     (unless url
  64       ;; see URL-REWRITE:*URL-REWRITE-FILL-TAGS*
  65       (setq url (request-uri *request*)))
  66     (setq url (regex-replace-all (scanner-for-get-param cookie-name) url "\\1"))
  67     (when value
  68       (setq url (format nil "~A~:[?~;&~]~A=~A"
  69                         url
  70                         (find #\? url)
  71                         cookie-name
  72                         (url-encode value))))
  73     (when replace-ampersands-p
  74       (setq url (regex-replace-all "&" url "&amp;")))
  75     url))
  76
  77 (defun maybe-rewrite-urls-for-session (html &key
  78                                             (cookie-name (session-cookie-name *acceptor*))
  79                                             (value (when-let (session (session *request*))
  80                                                      (session-cookie-value session))))
  81   "Rewrites the HTML page HTML such that the name/value pair
  82 COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a
  83 cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is
  84 true.  See the docs for URL-REWRITE:REWRITE-URLS."
  85   (cond ((or (not *rewrite-for-session-urls*)
  86              (null value)
  87              (cookie-in cookie-name))
  88           html)
  89         (t
  90           (with-input-from-string (*standard-input* html)
  91             (with-output-to-string (*standard-output*)
  92               (url-rewrite:rewrite-urls
  93                (lambda (url)
  94                  (add-cookie-value-to-url url
  95                                           :cookie-name cookie-name
  96                                           :value value))))))))
  97
  98 (defun default-dispatcher (request)
  99   "Default dispatch function which handles every request with the
 100 function stored in *DEFAULT-HANDLER*."
 101   (declare (ignore request))
 102   *default-handler*)
 103
 104 (defun default-handler ()
 105   "The handler that is supposed to serve the request if no other
 106 handler is called."
 107   (log-message :info "Default handler called for script ~A" (script-name*))
 108   (format nil "<html><head><title>Hunchentoot</title></head><body><h2>Hunchentoot Default Page</h2><p>This is the Hunchentoot default page. You're most likely seeing it because the server administrator hasn't set up a custom default page yet.</p><p>Hunchentoot is a web server written in <a href='http://www.lisp.org/'>Common Lisp</a>.  More info about Hunchentoot can be found at <a href='http://weitz.de/hunchentoot/'>http://weitz.de/hunchentoot/</a>.</p></p><p><hr>~A</p></body></html>"
 109           (address-string)))
 110
 111 (defun create-prefix-dispatcher (prefix handler)
 112   "Creates a request dispatch function which will dispatch to the
 113 function denoted by HANDLER if the file name of the current request
 114 starts with the string PREFIX."
 115   (lambda (request)
 116     (let ((mismatch (mismatch (script-name request) prefix
 117                               :test #'char=)))
 118       (and (or (null mismatch)
 119                (>= mismatch (length prefix)))
 120            handler))))
 121
 122 (defun create-regex-dispatcher (regex handler)
 123   "Creates a request dispatch function which will dispatch to the
 124 function denoted by HANDLER if the file name of the current request
 125 matches the CL-PPCRE regular expression REGEX."
 126   (let ((scanner (create-scanner regex)))
 127     (lambda (request)
 128       (and (scan scanner (script-name request))
 129            handler))))
 130
 131 (defun abort-request-handler (&optional result)
 132   "This function can be called by a request handler at any time to
 133 immediately abort handling the request.  This works as if the handler
 134 had returned RESULT.  See the source code of REDIRECT for an example."
 135   (throw 'handler-done result))
 136
 137 (defun handle-static-file (path &optional content-type)
 138   "A function which acts like a Hunchentoot handler for the file
 139 denoted by PATH.  Sends a content type header corresponding to
 140 CONTENT-TYPE or \(if that is NIL) tries to determine the content type
 141 via the file's suffix."
 142   (when (or (wild-pathname-p path)
 143             (not (fad:file-exists-p path))
 144             (fad:directory-exists-p path))
 145     ;; file does not exist
 146     (setf (return-code*) +http-not-found+)
 147     (abort-request-handler))
 148   (let ((time (or (file-write-date path) (get-universal-time))))
 149     (setf (content-type*) (or content-type
 150                               (mime-type path)
 151                               "application/octet-stream"))
 152     (handle-if-modified-since time)
 153     (with-open-file (file path
 154                      :direction :input
 155                      :element-type 'octet
 156                      :if-does-not-exist nil)
 157       (setf (header-out :last-modified) (rfc-1123-date time)
 158             (content-length*) (file-length file))
 159       (let ((out (send-headers)))
 160         #+:clisp
 161         (setf (flexi-stream-element-type *hunchentoot-stream*) 'octet)
 162         (loop with buf = (make-array +buffer-length+ :element-type 'octet)
 163               for pos = (read-sequence buf file)
 164               until (zerop pos)
 165               do (write-sequence buf out :end pos)
 166                  (finish-output out))))))
 167
 168 (defun create-static-file-dispatcher-and-handler (uri path &optional content-type)
 169   "Creates and returns a request dispatch function which will dispatch
 170 to a handler function which emits the file denoted by the pathname
 171 designator PATH with content type CONTENT-TYPE if the SCRIPT-NAME of
 172 the request matches the string URI.  If CONTENT-TYPE is NIL, tries to
 173 determine the content type via the file's suffix."
 174   ;; the dispatcher
 175   (lambda (request)
 176     (when (equal (script-name request) uri)
 177       ;; the handler
 178       (lambda ()
 179         (handle-static-file path content-type)))))
 180
 181 (defun enough-url (url url-prefix)
 182   "Returns the relative portion of URL relative to URL-PREFIX, similar
 183 to what ENOUGH-NAMESTRING does for pathnames."
 184   (subseq url (or (mismatch url url-prefix) (length url-prefix))))
 185
 186 (defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type)
 187   "Creates and returns a dispatch function which will dispatch to a
 188 handler function which emits the file relative to BASE-PATH that is
 189 denoted by the URI of the request relative to URI-PREFIX.  URI-PREFIX
 190 must be a string ending with a slash, BASE-PATH must be a pathname
 191 designator for an existing directory.  If CONTENT-TYPE is not NIL,
 192 it'll be the content type used for all files in the folder."
 193   (unless (and (stringp uri-prefix)
 194                (plusp (length uri-prefix))
 195                (char= (char uri-prefix (1- (length uri-prefix))) #\/))
 196     (parameter-error "~S must be string ending with a slash." uri-prefix))
 197   (when (or (pathname-name base-path)
 198             (pathname-type base-path))
 199     (parameter-error "~S is supposed to denote a directory." base-path))
 200   (flet ((handler ()
 201            (let* ((script-name (url-decode (script-name*)))
 202                   (script-path (enough-url (regex-replace-all "\\\\" script-name "/")
 203                                            uri-prefix))
 204                   (script-path-directory (pathname-directory script-path)))
 205              (unless (or (stringp script-path-directory)
 206                          (null script-path-directory)
 207                          (and (listp script-path-directory)
 208                               (eq (first script-path-directory) :relative)
 209                               (loop for component in (rest script-path-directory)
 210                                     always (stringp component))))
 211                (setf (return-code*) +http-forbidden+)
 212                (abort-request-handler))
 213              (handle-static-file (merge-pathnames script-path base-path) content-type))))
 214     (create-prefix-dispatcher uri-prefix #'handler)))
 215
 216 (defun no-cache ()
 217   "Adds appropriate headers to completely prevent caching on most browsers."
 218   (setf (header-out :expires)
 219           "Mon, 26 Jul 1997 05:00:00 GMT"
 220         (header-out :cache-control)
 221           "no-store, no-cache, must-revalidate, post-check=0, pre-check=0"
 222         (header-out :pragma)
 223           "no-cache"
 224         (header-out :last-modified)
 225           (rfc-1123-date))
 226   (values))
 227
 228 (defun redirect (target &key (host (host *request*) host-provided-p)
 229                              port
 230                              (protocol (if (ssl-p) :https :http))
 231                              (add-session-id (not (or host-provided-p
 232                                                       (starts-with-scheme-p target)
 233                                                       (cookie-in (session-cookie-name *acceptor*)))))
 234                              (code +http-moved-temporarily+))
 235   "Redirects the browser to TARGET which should be a string.  If
 236 TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL
 237 are ignored.  Otherwise, TARGET should denote the path part of a URL,
 238 PROTOCOL must be one of the keywords :HTTP or :HTTPS, and the URL to
 239 redirect to will be constructed from HOST, PORT, PROTOCOL, and TARGET.
 240 Adds a session ID if ADD-SESSION-ID is true.  If CODE is a 3xx
 241 redirection code, it will be sent as status code."
 242   (check-type code (integer 300 399))
 243   (let ((url (if (starts-with-scheme-p target)
 244                target
 245                (format nil "~A://~A~@[:~A~]~A"
 246                        (ecase protocol
 247                          ((:http) "http")
 248                          ((:https) "https"))
 249                        (if port
 250                          (first (ppcre:split ":" (or host "")))
 251                          host)
 252                        port target))))
 253     (when add-session-id
 254       (setq url (add-cookie-value-to-url url :replace-ampersands-p nil)))
 255     (setf (header-out :location) url
 256           (return-code*) code)
 257     (abort-request-handler)))
 258
 259 (defun require-authorization (&optional (realm "Hunchentoot"))
 260   "Sends back appropriate headers to require basic HTTP authentication
 261 \(see RFC 2617) for the realm REALM."
 262   (setf (header-out :www-authenticate)
 263           (format nil "Basic realm=\"~A\"" (quote-string realm))
 264         (return-code *reply*)
 265           +http-authorization-required+)
 266   (abort-request-handler))