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
  59 \(which should be an integer) or NIL for return codes Hunchentoot
  60 doesn't know."
  61   (gethash return-code *http-reason-phrase-map*
  62            "No reason phrase known"))
  63
  64 (defgeneric assoc* (thing alist)
  65   (:documentation "Similar to CL:ASSOC, but 'does the right thing' if
  66 THING is a string or a symbol.")
  67   (:method ((thing symbol) alist)
  68    (assoc thing alist :test #'eq))
  69   (:method ((thing string) alist)
  70    (assoc thing alist :test #'string-equal))
  71   (:method (thing alist)
  72    (assoc thing alist :test #'eql)))
  73
  74 (defun md5-hex (string)
  75   "Calculates the md5 sum of the string STRING and returns it as a hex string."
  76   (with-output-to-string (s)
  77     (loop for code across (md5:md5sum-sequence (coerce string 'simple-string))
  78           do (format s "~2,'0x" code))))
  79
  80 (defun escape-for-html (string)
  81   "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML 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   "Tests whether TOKEN is a string which is a valid 'token'
  96 according to HTTP/1.1 \(RFC 2068)."
  97   (and (stringp token)
  98        (plusp (length token))
  99        (every (lambda (char)
 100                 (and ;; CHAR is US-ASCII but not control character or ESC
 101                      (< 31 (char-code char) 127)
 102                      ;; CHAR is not 'tspecial'
 103                      (not (find char "()<>@,;:\\\"/[]?={} " :test #'char=))))
 104               token)))
 105
 106
 107 (defun rfc-1123-date (&optional (time (get-universal-time)))
 108   "Generates a time string according to RFC 1123.  Default is current time."
 109   (multiple-value-bind
 110         (second minute hour date month year day-of-week)
 111       (decode-universal-time time 0)
 112     (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
 113             (svref +day-names+ day-of-week)
 114             date
 115             (svref +month-names+ (1- month))
 116             year
 117             hour
 118             minute
 119             second)))
 120
 121 (defun iso-time (&optional (time (get-universal-time)))
 122   "Returns the universal time TIME as a string in full ISO format."
 123   (multiple-value-bind (second minute hour date month year)
 124       (decode-universal-time time)
 125     (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
 126             year month date hour minute second)))
 127
 128 (let ((counter 0))
 129   (declare (ignorable counter))
 130   (defun make-tmp-file-name (&optional (prefix "hunchentoot"))
 131     "Generates a unique name for a temporary file.  This function is
 132 called from the RFC2388 library when a file is uploaded."
 133     (let ((tmp-file-name
 134            #+:allegro
 135            (pathname (system:make-temp-file-name prefix *tmp-directory*))
 136            #-:allegro
 137            (loop for pathname = (make-pathname :name (format nil "~A-~A"
 138                                                              prefix (incf counter))
 139                                                :type nil
 140                                                :defaults *tmp-directory*)
 141                  unless (probe-file pathname)
 142                  return pathname)))
 143       (push tmp-file-name *tmp-files*)
 144       ;; maybe call hook for file uploads
 145       (when *file-upload-hook*
 146         (funcall *file-upload-hook* tmp-file-name))
 147       tmp-file-name)))
 148
 149 (defun quote-string (string)
 150   "Quotes string according to RFC 2616's definition of `quoted-string'."
 151   (with-output-to-string (out)
 152     (with-input-from-string (in string)
 153       (loop for char = (read-char in nil nil)
 154             while char
 155             unless (or (char< char #\Space)
 156                        (char= char #\Rubout))
 157               do (case char
 158                    ((#\\) (write-string "\\\\" out))
 159                    ((#\") (write-string "\\\"" out))
 160                    (otherwise (write-char char out)))))))
 161
 162 (defmacro upgrade-vector (vector new-type &key converter)
 163   "Returns a vector with the same length and the same elements as
 164 VECTOR \(a variable holding a vector) but having element type
 165 NEW-TYPE.  If CONVERTER is not NIL, it should designate a function
 166 which will be applied to each element of VECTOR before the result is
 167 stored in the new vector.  The resulting vector will have a fill
 168 pointer set to its end.
 169
 170 The macro also uses SETQ to store the new vector in VECTOR."
 171   `(setq ,vector
 172          (loop with length = (length ,vector)
 173                with new-vector = (make-array length
 174                                              :element-type ,new-type
 175                                              :fill-pointer length)
 176                for i below length
 177                do (setf (aref new-vector i) ,(if converter
 178                                                `(funcall ,converter (aref ,vector i))
 179                                                `(aref ,vector i)))
 180                finally (return new-vector))))
 181
 182 (defun url-decode (string &optional (external-format *hunchentoot-default-external-format*))
 183   "Decodes a URL-encoded STRING which is assumed to be encoded using
 184 the external format EXTERNAL-FORMAT."
 185   (when (zerop (length string))
 186     (return-from url-decode ""))
 187   (let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0))
 188         (i 0)
 189         unicodep)
 190     (loop
 191       (unless (< i (length string))
 192         (return))
 193       (let ((char (aref string i)))
 194        (labels ((decode-hex (length)
 195                   (prog1
 196                       (parse-integer string :start i :end (+ i length) :radix 16)
 197                     (incf i length)))
 198                 (push-integer (integer)
 199                   (vector-push integer vector))
 200                 (peek ()
 201                   (aref string i))
 202                 (advance ()
 203                   (setq char (peek))
 204                   (incf i)))
 205          (cond
 206           ((char= #\% char)
 207            (advance)
 208            (cond
 209             ((char= #\u (peek))
 210              (unless unicodep
 211                (setq unicodep t)
 212                (upgrade-vector vector '(integer 0 65535)))
 213              (advance)
 214              (push-integer (decode-hex 4)))
 215             (t
 216              (push-integer (decode-hex 2)))))
 217           (t
 218            (push-integer (char-code (case char
 219                                       ((#\+) #\Space)
 220                                       (otherwise char))))
 221            (advance))))))
 222     (cond (unicodep
 223            (upgrade-vector vector 'character :converter #'code-char))
 224           (t (octets-to-string vector :external-format external-format)))))
 225
 226 (defun form-url-encoded-list-to-alist (form-url-encoded-list
 227                                        &optional (external-format *hunchentoot-default-external-format*))
 228   "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
 229 alist.  Both names and values are url-decoded while doing this."
 230   (mapcar #'(lambda (entry)
 231               (destructuring-bind (name &optional value)
 232                   (split "=" entry :limit 2)
 233                 (cons (string-trim " " (url-decode name external-format))
 234                       (url-decode (or value "") external-format))))
 235           form-url-encoded-list))
 236
 237 (defun cookies-to-alist (cookies)
 238   "Converts a list of cookies of the form \"key=value\" to an alist.  No
 239   character set processing is done."
 240   (mapcar #'(lambda (entry)
 241               (destructuring-bind (name &optional value)
 242                   (split "=" entry :limit 2)
 243                 (cons (string-trim " " name) (or value ""))))
 244           cookies))
 245
 246 (defun url-encode (string &optional (external-format *hunchentoot-default-external-format*))
 247   "URL-encodes a string using the external format EXTERNAL-FORMAT."
 248   (with-output-to-string (s)
 249     (loop for c across string
 250           for index from 0
 251           do (cond ((or (char<= #\0 c #\9)
 252                         (char<= #\a c #\z)
 253                         (char<= #\A c #\Z)
 254                         ;; note that there's no comma in there - because of cookies
 255                         (find c "$-_.!*'()" :test #'char=))
 256                      (write-char c s))
 257                    (t (loop for octet across (string-to-octets string
 258                                                                :start index
 259                                                                :end (1+ index)
 260                                                                :external-format external-format)
 261                             do (format s "%~2,'0x" octet)))))))
 262
 263 (defun parse-content-type (content-type-header)
 264   "Reads and parses a `Content-Type' header and returns it as three
 265 values - the type, the subtype, and the requests' character set as
 266 specified in the 'charset' parameter in the header, if there is one
 267 and if the content type is \"text\".  CONTENT-TYPE-HEADER is supposed
 268 to be the corresponding header value as a string."
 269   (with-input-from-sequence (stream (map 'list 'char-code content-type-header))
 270     (with-character-stream-semantics
 271      (let* ((*current-error-message* "Corrupted Content-Type header:")
 272             (type (read-token stream))
 273             (subtype (if (eql #\/ (read-char* stream nil))
 274                        (read-token stream)
 275                        (return-from parse-content-type
 276                          ;; try to return something meaningful
 277                          (values "application" "octet-stream" nil))))
 278             (parameters (read-name-value-pairs stream))
 279             (charset (cdr (assoc "charset" parameters :test #'string=)))
 280             (charset
 281              (when (string-equal type "text")
 282                charset)))
 283        (values type subtype charset)))))
 284
 285 (defun keep-alive-p (request)
 286   "Returns a true value unless the incoming request's headers or the
 287 server's PERSISTENT-CONNECTIONS-P setting obviate a keep-alive reply.
 288 The second return value denotes whether the client has explicitly
 289 asked for a persistent connection."
 290   (let ((connection-values
 291          ;; the header might consist of different values separated by commas
 292          (when-let (connection-header (header-in :connection request))
 293            (split "\\s*,\\s*" connection-header))))
 294     (flet ((connection-value-p (value)
 295              "Checks whether the string VALUE is one of the
 296 values of the `Connection' header."
 297              (member value connection-values :test #'string-equal)))
 298       (let ((keep-alive-requested-p (connection-value-p "keep-alive")))
 299         (values (and (acceptor-persistent-connections-p *acceptor*)
 300                      (or (and (eq (server-protocol request) :http/1.1)
 301                               (not (connection-value-p "close")))
 302                          (and (eq (server-protocol request) :http/1.0)
 303                               keep-alive-requested-p)))
 304                 keep-alive-requested-p)))))
 305
 306 (defun address-string ()
 307   "Returns a string with information about Hunchentoot suitable for
 308 inclusion in HTML output."
 309   (flet ((escape-for-html (arg)
 310            (if arg
 311                (escape-for-html arg)
 312                arg)))
 313     (format nil "<address><a href='http://weitz.de/hunchentoot/'>Hunchentoot ~A</a> <a href='~A'>(~A ~A)</a>~@[ at ~A~:[ (port ~D)~;~]~]</address>"
 314             *hunchentoot-version*
 315             +implementation-link+
 316             (escape-for-html (lisp-implementation-type))
 317             (escape-for-html (lisp-implementation-version))
 318             (escape-for-html (or (host *request*) (acceptor-address *acceptor*)))
 319             (scan ":\\d+$" (or (host *request*) ""))
 320             (acceptor-port *acceptor*))))
 321
 322 (defun input-chunking-p ()
 323   "Whether input chunking is currently switched on for
 324 *HUNCHENTOOT-STREAM* - note that this will return NIL if the stream
 325 not a chunked stream."
 326   (chunked-stream-input-chunking-p *hunchentoot-stream*))
 327
 328 (defun ssl-p (&optional (acceptor *acceptor*))
 329   "Whether the current connection to the client is secure."
 330   (acceptor-ssl-p acceptor))
 331
 332 (defmacro with-mapped-conditions (() &body body)
 333   "Run BODY with usocket condition mapping in effect, i.e. platform specific network errors will be
 334   signalled as usocket conditions.  For Lispworks, no mapping is performed."
 335   #+:lispworks
 336   `(progn ,@body)
 337   #-:lispworks
 338   `(usocket:with-mapped-conditions ()
 339     ,@body))