util.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
  32 (defun starts-with-p (seq subseq &key (test 'eql))
  33   "Tests whether the sequence SEQ starts with the sequence
  34 SUBSEQ.  Individual elements are compared with TEST."
  35   (let* ((length (length subseq))
  36          (mismatch (mismatch subseq seq
  37                              :test test)))
  38     (or (null mismatch)
  39         (<= length mismatch))))
  40
  41 (defun starts-with-one-of-p (seq subseq-list &key (test 'eql))
  42   "Tests whether the sequence SEQ starts with one of the
  43 sequences in SUBSEQ-LIST.  Individual elements are compared with
  44 TEST."
  45   (some (lambda (subseq)
  46           (starts-with-p seq subseq :test test))
  47         subseq-list))
  48
  49 (defun create-random-string (&optional (n 10) (base 16))
  50   "Returns a random number \(as a string) with base BASE and N
  51 digits."
  52   (with-output-to-string (s)
  53     (dotimes (i n)
  54       (format s "~VR" base
  55               (random base *the-random-state*)))))
  56
  57 (defun reason-phrase (return-code)
  58   "Returns a reason phrase for the HTTP return code RETURN-CODE \(which
  59 should be an integer) or NIL for return codes Hunchentoot doesn't know."
  60   (gethash return-code *http-reason-phrase-map*
  61            "No reason phrase known"))
  62
  63 (defgeneric assoc* (thing alist)
  64   (:documentation "Similar to CL:ASSOC, but 'does the right thing' if
  65 THING is a string or a symbol.")
  66   (:method ((thing symbol) alist)
  67    (assoc thing alist :test #'eq))
  68   (:method ((thing string) alist)
  69    (assoc thing alist :test #'string-equal))
  70   (:method (thing alist)
  71    (assoc thing alist :test #'eql)))
  72
  73 (defun md5-hex (string)
  74   "Calculates the md5 sum of the string STRING and returns it as a hex string."
  75   (with-output-to-string (s)
  76     (loop for code across (md5:md5sum-string string)
  77           do (format s "~2,'0x" code))))
  78
  79 (defun escape-for-html (string)
  80   "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML
  81 output."
  82   (with-output-to-string (out)
  83     (with-input-from-string (in string)
  84       (loop for char = (read-char in nil nil)
  85             while char
  86             do (case char
  87                  ((#\<) (write-string "&lt;" out))
  88                  ((#\>) (write-string "&gt;" out))
  89                  ((#\") (write-string "&quot;" out))
  90                  ((#\') (write-string "&#039;" out))
  91                  ((#\&) (write-string "&amp;" out))
  92                  (otherwise (write-char char out)))))))
  93
  94 (defun http-token-p (token)
  95   "This function tests whether OBJECT is a non-empty string which is a
  96 TOKEN according to RFC 2068 \(i.e. whether it may be used for, say,
  97 cookie names)."
  98   (and (stringp token)
  99        (plusp (length token))
 100        (every (lambda (char)
 101                 (and ;; CHAR is US-ASCII but not control character or ESC
 102                      (< 31 (char-code char) 127)
 103                      ;; CHAR is not 'tspecial'
 104                      (not (find char "()<>@,;:\\\"/[]?={} " :test #'char=))))
 105               token)))
 106
 107
 108 (defun rfc-1123-date (&optional (time (get-universal-time)))
 109   "Generates a time string according to RFC 1123. Default is current time.
 110 This can be used to send a 'Last-Modified' header - see
 111 HANDLE-IF-MODIFIED-SINCE."
 112   (multiple-value-bind
 113         (second minute hour date month year day-of-week)
 114       (decode-universal-time time 0)
 115     (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
 116             (svref +day-names+ day-of-week)
 117             date
 118             (svref +month-names+ (1- month))
 119             year
 120             hour
 121             minute
 122             second)))
 123
 124 (defun iso-time (&optional (time (get-universal-time)))
 125   "Returns the universal time TIME as a string in full ISO format."
 126   (multiple-value-bind (second minute hour date month year)
 127       (decode-universal-time time)
 128     (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
 129             year month date hour minute second)))
 130
 131 (let ((counter 0))
 132   (declare (ignorable counter))
 133   (defun make-tmp-file-name (&optional (prefix "hunchentoot"))
 134     "Generates a unique name for a temporary file.  This function is
 135 called from the RFC2388 library when a file is uploaded."
 136     (let ((tmp-file-name
 137            #+:allegro
 138            (pathname (system:make-temp-file-name prefix *tmp-directory*))
 139            #-:allegro
 140            (loop for pathname = (make-pathname :name (format nil "~A-~A"
 141                                                              prefix (incf counter))
 142                                                :type nil
 143                                                :defaults *tmp-directory*)
 144                  unless (probe-file pathname)
 145                  return pathname)))
 146       (push tmp-file-name *tmp-files*)
 147       ;; maybe call hook for file uploads
 148       (when *file-upload-hook*
 149         (funcall *file-upload-hook* tmp-file-name))
 150       tmp-file-name)))
 151
 152 (defun quote-string (string)
 153   "Quotes string according to RFC 2616's definition of `quoted-string'."
 154   (with-output-to-string (out)
 155     (with-input-from-string (in string)
 156       (loop for char = (read-char in nil nil)
 157             while char
 158             unless (or (char< char #\Space)
 159                        (char= char #\Rubout))
 160               do (case char
 161                    ((#\\) (write-string "\\\\" out))
 162                    ((#\") (write-string "\\\"" out))
 163                    (otherwise (write-char char out)))))))
 164
 165 (defmacro upgrade-vector (vector new-type &key converter)
 166   "Returns a vector with the same length and the same elements as
 167 VECTOR \(a variable holding a vector) but having element type
 168 NEW-TYPE.  If CONVERTER is not NIL, it should designate a function
 169 which will be applied to each element of VECTOR before the result is
 170 stored in the new vector.  The resulting vector will have a fill
 171 pointer set to its end.
 172
 173 The macro also uses SETQ to store the new vector in VECTOR."
 174   `(setq ,vector
 175          (loop with length = (length ,vector)
 176                with new-vector = (make-array length
 177                                              :element-type ,new-type
 178                                              :fill-pointer length)
 179                for i below length
 180                do (setf (aref new-vector i) ,(if converter
 181                                                `(funcall ,converter (aref ,vector i))
 182                                                `(aref ,vector i)))
 183                finally (return new-vector))))
 184
 185 (defun ensure-parse-integer (string &key (start 0) end (radix 10))
 186   (let ((end (or end (length string))))
 187     (if (or (>= start (length string))
 188             (> end (length string)))
 189         (error 'bad-request)
 190         (multiple-value-bind (integer stopped)
 191             (parse-integer string :start start :end end :radix radix :junk-allowed t)
 192           (if (/= stopped end)
 193               (error 'bad-request)
 194               integer)))))
 195
 196 (defun url-decode (string &optional (external-format *hunchentoot-default-external-format*))
 197   "Decodes a URL-encoded string which is assumed to be encoded using the
 198 external format EXTERNAL-FORMAT, i.e. this is the inverse of
 199 URL-ENCODE. It is assumed that you'll rarely need this function, if
 200 ever. But just in case - here it is. The default for EXTERNAL-FORMAT is
 201 the value of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
 202   (when (zerop (length string))
 203     (return-from url-decode ""))
 204   (let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0))
 205         (i 0)
 206         unicodep)
 207     (loop
 208       (unless (< i (length string))
 209         (return))
 210       (let ((char (aref string i)))
 211        (labels ((decode-hex (length)
 212                   (ensure-parse-integer string :start i :end (incf i length)
 213                                                :radix 16))
 214                 (push-integer (integer)
 215                   (vector-push integer vector))
 216                 (peek ()
 217                   (if (array-in-bounds-p string i)
 218                       (aref string i)
 219                       (error 'bad-request)))
 220                 (advance ()
 221                   (setq char (peek))
 222                   (incf i)))
 223          (cond
 224           ((char= #\% char)
 225            (advance)
 226            (cond
 227             ((char= #\u (peek))
 228              (unless unicodep
 229                (setq unicodep t)
 230                (upgrade-vector vector '(integer 0 65535)))
 231              (advance)
 232              (push-integer (decode-hex 4)))
 233             (t
 234              (push-integer (decode-hex 2)))))
 235           (t
 236            (push-integer (char-code (case char
 237                                       ((#\+) #\Space)
 238                                       (otherwise char))))
 239            (advance))))))
 240     (cond (unicodep
 241            (upgrade-vector vector 'character :converter #'code-char))
 242           (t (octets-to-string vector :external-format external-format)))))
 243
 244 (defun form-url-encoded-list-to-alist (form-url-encoded-list
 245                                        &optional (external-format *hunchentoot-default-external-format*))
 246   "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
 247 alist.  Both names and values are url-decoded while doing this."
 248   (mapcar #'(lambda (entry)
 249               (destructuring-bind (name &optional value)
 250                   (split "=" entry :limit 2)
 251                 (cons (string-trim " " (url-decode name external-format))
 252                       (url-decode (or value "") external-format))))
 253           form-url-encoded-list))
 254
 255 (defun cookies-to-alist (cookies)
 256   "Converts a list of cookies of the form \"key=value\" to an alist.  No
 257   character set processing is done."
 258   (mapcar #'(lambda (entry)
 259               (destructuring-bind (name &optional value)
 260                   (split "=" entry :limit 2)
 261                 (cons (string-trim " " name) (or value ""))))
 262           cookies))
 263
 264 (defun url-encode (string &optional (external-format *hunchentoot-default-external-format*))
 265   "URL-encodes a string using the external format EXTERNAL-FORMAT. The
 266 default for EXTERNAL-FORMAT is the value of
 267 *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
 268   (with-output-to-string (s)
 269     (loop for c across string
 270           for index from 0
 271           do (cond ((or (char<= #\0 c #\9)
 272                         (char<= #\a c #\z)
 273                         (char<= #\A c #\Z)
 274                         ;; note that there's no comma in there - because of cookies
 275                         (find c "$-_.!*'()" :test #'char=))
 276                      (write-char c s))
 277                    (t (loop for octet across (string-to-octets string
 278                                                                :start index
 279                                                                :end (1+ index)
 280                                                                :external-format external-format)
 281                             do (format s "%~2,'0x" octet)))))))
 282
 283 (defun parse-content-type (content-type-header)
 284   "Reads and parses a `Content-Type' header and returns it as three
 285 values - the type, the subtype, and the requests' character set as
 286 specified in the 'charset' parameter in the header, if there is one
 287 and if the content type is \"text\".  CONTENT-TYPE-HEADER is supposed
 288 to be the corresponding header value as a string."
 289   (with-input-from-sequence (stream (map 'list 'char-code content-type-header))
 290     (with-character-stream-semantics
 291      (let* ((*current-error-message* (format nil "Corrupted Content-Type header ~S:" content-type-header))
 292             (type (read-token stream))
 293             (subtype (if (eql #\/ (read-char* stream nil))
 294                        (read-token stream)
 295                        (return-from parse-content-type
 296                          ;; try to return something meaningful
 297                          (values "application" "octet-stream" nil))))
 298             (parameters (read-name-value-pairs stream))
 299             (charset (cdr (assoc "charset" parameters :test #'string=)))
 300             (charset
 301              (when (string-equal type "text")
 302                charset)))
 303        (values type subtype charset)))))
 304
 305 (defun keep-alive-p (request)
 306   "Returns a true value unless the incoming request's headers or the
 307 server's PERSISTENT-CONNECTIONS-P setting obviate a keep-alive reply.
 308 The second return value denotes whether the client has explicitly
 309 asked for a persistent connection."
 310   (let ((connection-values
 311          ;; the header might consist of different values separated by commas
 312          (when-let (connection-header (header-in :connection request))
 313            (split "\\s*,\\s*" connection-header))))
 314     (flet ((connection-value-p (value)
 315              "Checks whether the string VALUE is one of the
 316 values of the `Connection' header."
 317              (member value connection-values :test #'string-equal)))
 318       (let ((keep-alive-requested-p (connection-value-p "keep-alive")))
 319         (values (and (acceptor-persistent-connections-p *acceptor*)
 320                      (or (and (eq (server-protocol request) :http/1.1)
 321                               (not (connection-value-p "close")))
 322                          (and (eq (server-protocol request) :http/1.0)
 323                               keep-alive-requested-p)))
 324                 keep-alive-requested-p)))))
 325
 326 (defun address-string ()
 327   "Returns a string with information about Hunchentoot suitable for
 328 inclusion in HTML output."
 329   (flet ((escape-for-html (arg)
 330            (if arg
 331                (escape-for-html arg)
 332                arg)))
 333     (format nil "<address><a href='http://weitz.de/hunchentoot/'>Hunchentoot ~A</a> <a href='~A'>(~A ~A)</a>~@[ at ~A~:[ (port ~D)~;~]~]</address>"
 334             *hunchentoot-version*
 335             +implementation-link+
 336             (escape-for-html (lisp-implementation-type))
 337             (escape-for-html (lisp-implementation-version))
 338             (escape-for-html (or (host *request*) (acceptor-address *acceptor*)))
 339             (scan ":\\d+$" (or (host *request*) ""))
 340             (acceptor-port *acceptor*))))
 341
 342 (defun input-chunking-p ()
 343   "Whether input chunking is currently switched on for
 344 *HUNCHENTOOT-STREAM* - note that this will return NIL if the stream
 345 not a chunked stream."
 346   (chunked-stream-input-chunking-p *hunchentoot-stream*))
 347
 348 (defun ssl-p (&optional (acceptor *acceptor*))
 349   "Whether the current connection to the client is secure. See
 350 ACCEPTOR-SSL-P."
 351   (acceptor-ssl-p acceptor))
 352
 353 (defmacro with-mapped-conditions (() &body body)
 354   "Run BODY with usocket condition mapping in effect, i.e. platform specific network errors will be
 355   signalled as usocket conditions.  For Lispworks, no mapping is performed."
 356   #+:lispworks
 357   `(progn ,@body)
 358   #-:lispworks
 359   `(usocket:with-mapped-conditions ()
 360     ,@body))
 361
 362 (defmacro with-conditions-caught-and-logged (() &body body)
 363   "Run BODY with conditions caught and logged by the *ACCEPTOR*. Errors are
 364 stopped right away so no other part of the software is impacted by them."
 365   `(block nil
 366      (handler-bind
 367          ((error
 368            ;; abort if there's an error which isn't caught inside
 369            (lambda (cond)
 370              (log-message* *lisp-errors-log-level*
 371                            "Error while processing connection: ~A" cond)
 372              (return)))
 373           (warning
 374            ;; log all warnings which aren't caught inside
 375            (lambda (cond)
 376              (when *log-lisp-warnings-p*
 377                (log-message* *lisp-warnings-log-level*
 378                              "Warning while processing connection: ~A" cond)))))
 379        ,@body)))