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                                     (decode-plus t))
 198   "Decodes a URL-encoded string which is assumed to be encoded using the
 199 external format EXTERNAL-FORMAT, i.e. this is the inverse of
 200 URL-ENCODE. It is assumed that you'll rarely need this function, if
 201 ever. But just in case - here it is. The default for EXTERNAL-FORMAT is
 202 the value of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
 203   (when (zerop (length string))
 204     (return-from url-decode ""))
 205   (let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0))
 206         (i 0)
 207         unicodep)
 208     (loop
 209       (unless (< i (length string))
 210         (return))
 211       (let ((char (aref string i)))
 212        (labels ((decode-hex (length)
 213                   (ensure-parse-integer string :start i :end (incf i length)
 214                                                :radix 16))
 215                 (push-integer (integer)
 216                   (vector-push integer vector))
 217                 (peek ()
 218                   (if (array-in-bounds-p string i)
 219                       (aref string i)
 220                       (error 'bad-request)))
 221                 (advance ()
 222                   (setq char (peek))
 223                   (incf i)))
 224          (cond
 225           ((char= #\% char)
 226            (advance)
 227            (cond
 228             ((char= #\u (peek))
 229              (unless unicodep
 230                (setq unicodep t)
 231                (upgrade-vector vector '(integer 0 65535)))
 232              (advance)
 233              (push-integer (decode-hex 4)))
 234             (t
 235              (push-integer (decode-hex 2)))))
 236           (t
 237            (push-integer (char-code (case char
 238                                       ((#\+)
 239                                        (if decode-plus
 240                                            #\Space
 241                                            char))
 242                                       (otherwise char))))
 243            (advance))))))
 244     (cond (unicodep
 245            (upgrade-vector vector 'character :converter #'code-char))
 246           (t (octets-to-string vector :external-format external-format)))))
 247
 248 (defun form-url-encoded-list-to-alist (form-url-encoded-list
 249                                        &optional (external-format *hunchentoot-default-external-format*))
 250   "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
 251 alist.  Both names and values are url-decoded while doing this."
 252   (mapcar #'(lambda (entry)
 253               (destructuring-bind (name &optional value)
 254                   (split "=" entry :limit 2)
 255                 (cons (string-trim " " (url-decode name external-format))
 256                       (url-decode (or value "") external-format))))
 257           form-url-encoded-list))
 258
 259 (defun cookies-to-alist (cookies)
 260   "Converts a list of cookies of the form \"key=value\" to an alist.  No
 261   character set processing is done."
 262   (mapcar #'(lambda (entry)
 263               (destructuring-bind (name &optional value)
 264                   (split "=" entry :limit 2)
 265                 (cons (string-trim " " name) (or value ""))))
 266           cookies))
 267
 268 (defun url-encode (string &optional (external-format *hunchentoot-default-external-format*))
 269   "URL-encodes a string using the external format EXTERNAL-FORMAT. The
 270 default for EXTERNAL-FORMAT is the value of
 271 *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
 272   (with-output-to-string (s)
 273     (loop for c across string
 274           for index from 0
 275           do (cond ((or (char<= #\0 c #\9)
 276                         (char<= #\a c #\z)
 277                         (char<= #\A c #\Z)
 278                         ;; note that there's no comma in there - because of cookies
 279                         (find c "$-_.!*'()" :test #'char=))
 280                      (write-char c s))
 281                    (t (loop for octet across (string-to-octets string
 282                                                                :start index
 283                                                                :end (1+ index)
 284                                                                :external-format external-format)
 285                             do (format s "%~2,'0x" octet)))))))
 286
 287 (defun parse-content-type (content-type-header)
 288   "Reads and parses a `Content-Type' header and returns it as three
 289 values - the type, the subtype, and the requests' character set as
 290 specified in the 'charset' parameter in the header, if there is one
 291 and if the content type is \"text\".  CONTENT-TYPE-HEADER is supposed
 292 to be the corresponding header value as a string."
 293   (with-input-from-sequence (stream (map 'list 'char-code content-type-header))
 294     (with-character-stream-semantics
 295      (let* ((*current-error-message* (format nil "Corrupted Content-Type header ~S:" content-type-header))
 296             (type (read-token stream))
 297             (subtype (if (eql #\/ (read-char* stream nil))
 298                        (read-token stream)
 299                        (return-from parse-content-type
 300                          ;; try to return something meaningful
 301                          (values "application" "octet-stream" nil))))
 302             (parameters (read-name-value-pairs stream))
 303             (charset (cdr (assoc "charset" parameters :test #'string=)))
 304             (charset
 305              (when (string-equal type "text")
 306                charset)))
 307        (values type subtype charset)))))
 308
 309 (defun keep-alive-p (request)
 310   "Returns a true value unless the incoming request's headers or the
 311 server's PERSISTENT-CONNECTIONS-P setting obviate a keep-alive reply.
 312 The second return value denotes whether the client has explicitly
 313 asked for a persistent connection."
 314   (let ((connection-values
 315          ;; the header might consist of different values separated by commas
 316          (when-let (connection-header (header-in :connection request))
 317            (split "\\s*,\\s*" connection-header))))
 318     (flet ((connection-value-p (value)
 319              "Checks whether the string VALUE is one of the
 320 values of the `Connection' header."
 321              (member value connection-values :test #'string-equal)))
 322       (let ((keep-alive-requested-p (connection-value-p "keep-alive")))
 323         (values (and (acceptor-persistent-connections-p *acceptor*)
 324                      (or (and (eq (server-protocol request) :http/1.1)
 325                               (not (connection-value-p "close")))
 326                          (and (eq (server-protocol request) :http/1.0)
 327                               keep-alive-requested-p)))
 328                 keep-alive-requested-p)))))
 329
 330 (defun address-string ()
 331   "Returns a string with information about Hunchentoot suitable for
 332 inclusion in HTML output."
 333   (flet ((escape-for-html (arg)
 334            (if arg
 335                (escape-for-html arg)
 336                arg)))
 337     (format nil "<address><a href='http://weitz.de/hunchentoot/'>Hunchentoot ~A</a> <a href='~A'>(~A ~A)</a>~@[ at ~A~:[ (port ~D)~;~]~]</address>"
 338             *hunchentoot-version*
 339             +implementation-link+
 340             (escape-for-html (lisp-implementation-type))
 341             (escape-for-html (lisp-implementation-version))
 342             (escape-for-html (or (host *request*) (acceptor-address *acceptor*)))
 343             (scan ":\\d+$" (or (host *request*) ""))
 344             (acceptor-port *acceptor*))))
 345
 346 (defun input-chunking-p ()
 347   "Whether input chunking is currently switched on for
 348 *HUNCHENTOOT-STREAM* - note that this will return NIL if the stream
 349 not a chunked stream."
 350   (chunked-stream-input-chunking-p *hunchentoot-stream*))
 351
 352 (defun ssl-p (&optional (acceptor *acceptor*))
 353   "Whether the current connection to the client is secure. See
 354 ACCEPTOR-SSL-P."
 355   (acceptor-ssl-p acceptor))
 356
 357 (defmacro with-mapped-conditions (() &body body)
 358   "Run BODY with usocket condition mapping in effect, i.e. platform specific network errors will be
 359   signalled as usocket conditions.  For Lispworks, no mapping is performed."
 360   #+:lispworks
 361   `(progn ,@body)
 362   #-:lispworks
 363   `(usocket:with-mapped-conditions ()
 364     ,@body))
 365
 366 (defmacro with-conditions-caught-and-logged (() &body body)
 367   "Run BODY with conditions caught and logged by the *ACCEPTOR*. Errors are
 368 stopped right away so no other part of the software is impacted by them."
 369   `(block nil
 370      (handler-bind
 371          ((error
 372            ;; abort if there's an error which isn't caught inside
 373            (lambda (cond)
 374              (when *log-lisp-errors-p*
 375                (log-message* *lisp-errors-log-level*
 376                              "Error while processing connection: ~A" cond))
 377              (when *catch-errors-p*
 378                (return))))
 379           (warning
 380            ;; log all warnings which aren't caught inside
 381            (lambda (cond)
 382              (when *log-lisp-warnings-p*
 383                (log-message* *lisp-warnings-log-level*
 384                              "Warning while processing connection: ~A" cond)))))
 385        ,@body)))