util.lisp

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