misc.lisp

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