specials.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 (defmacro defconstant (name value &optional doc)
  32   "Make sure VALUE is evaluated only once \(to appease SBCL)."
  33   `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
  34      ,@(when doc (list doc))))
  35
  36 (eval-when (:compile-toplevel :execute :load-toplevel)
  37   (defmacro defvar-unbound (name &optional (doc-string ""))
  38     "Convenience macro to declare unbound special variables with a
  39 documentation string."
  40     `(progn
  41       (defvar ,name)
  42       (setf (documentation ',name 'variable) ,doc-string)
  43       ',name))
  44
  45   (defvar *http-reason-phrase-map* (make-hash-table)
  46     "Used to map numerical return codes to reason phrases.")
  47
  48   (defmacro def-http-return-code (name value reason-phrase)
  49     "Shortcut to define constants for return codes.  NAME is a
  50 Lisp symbol, VALUE is the numerical value of the return code, and
  51 REASON-PHRASE is the phrase \(a string) to be shown in the
  52 server's status line."
  53     `(eval-when (:compile-toplevel :execute :load-toplevel)
  54        (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'."
  55                                           value reason-phrase))
  56        (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase))))
  57
  58 (defconstant +crlf+
  59   (make-array 2 :element-type '(unsigned-byte 8)
  60               :initial-contents (mapcar 'char-code '(#\Return #\Linefeed)))
  61   "A 2-element array consisting of the character codes for a CRLF
  62 sequence.")
  63
  64 (def-http-return-code +http-continue+ 100 "Continue")
  65 (def-http-return-code +http-switching-protocols+ 101 "Switching Protocols")
  66 (def-http-return-code +http-ok+ 200 "OK")
  67 (def-http-return-code +http-created+ 201 "Created")
  68 (def-http-return-code +http-accepted+ 202 "Accepted")
  69 (def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information")
  70 (def-http-return-code +http-no-content+ 204 "No Content")
  71 (def-http-return-code +http-reset-content+ 205 "Reset Content")
  72 (def-http-return-code +http-partial-content+ 206 "Partial Content")
  73 (def-http-return-code +http-multi-status+ 207 "Multi-Status")
  74 (def-http-return-code +http-multiple-choices+ 300 "Multiple Choices")
  75 (def-http-return-code +http-moved-permanently+ 301 "Moved Permanently")
  76 (def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily")
  77 (def-http-return-code +http-see-other+ 303 "See Other")
  78 (def-http-return-code +http-not-modified+ 304 "Not Modified")
  79 (def-http-return-code +http-use-proxy+ 305 "Use Proxy")
  80 (def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect")
  81 (def-http-return-code +http-bad-request+ 400 "Bad Request")
  82 (def-http-return-code +http-authorization-required+ 401 "Authorization Required")
  83 (def-http-return-code +http-payment-required+ 402  "Payment Required")
  84 (def-http-return-code +http-forbidden+ 403 "Forbidden")
  85 (def-http-return-code +http-not-found+ 404 "Not Found")
  86 (def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed")
  87 (def-http-return-code +http-not-acceptable+ 406 "Not Acceptable")
  88 (def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required")
  89 (def-http-return-code +http-request-time-out+ 408 "Request Time-out")
  90 (def-http-return-code +http-conflict+ 409 "Conflict")
  91 (def-http-return-code +http-gone+ 410 "Gone")
  92 (def-http-return-code +http-length-required+ 411 "Length Required")
  93 (def-http-return-code +http-precondition-failed+ 412 "Precondition Failed")
  94 (def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large")
  95 (def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large")
  96 (def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type")
  97 (def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable")
  98 (def-http-return-code +http-expectation-failed+ 417 "Expectation Failed")
  99 (def-http-return-code +http-failed-dependency+ 424 "Failed Dependency")
 100 (def-http-return-code +http-internal-server-error+ 500 "Internal Server Error")
 101 (def-http-return-code +http-not-implemented+ 501 "Not Implemented")
 102 (def-http-return-code +http-bad-gateway+ 502 "Bad Gateway")
 103 (def-http-return-code +http-service-unavailable+ 503 "Service Unavailable")
 104 (def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out")
 105 (def-http-return-code +http-version-not-supported+ 505 "Version not supported")
 106
 107 (defconstant +day-names+
 108   #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
 109   "The three-character names of the seven days of the week - needed
 110 for cookie date format.")
 111
 112 (defconstant +month-names+
 113   #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
 114   "The three-character names of the twelve months - needed for cookie
 115 date format.")
 116
 117 (defvar *rewrite-for-session-urls* t
 118   "Whether HTML pages should possibly be rewritten for cookie-less
 119 session-management.")
 120
 121 (defvar *content-types-for-url-rewrite*
 122   '("text/html" "application/xhtml+xml")
 123   "The content types for which url-rewriting is OK. See
 124 *REWRITE-FOR-SESSION-URLS*.")
 125
 126 (defvar *the-random-state* (make-random-state t)
 127   "A fresh random state.")
 128
 129 (defvar-unbound *session-secret*
 130   "A random ASCII string that's used to encode the public session
 131 data.  This variable is initially unbound and will be set \(using
 132 RESET-SESSION-SECRET) the first time a session is created, if
 133 necessary.  You can prevent this from happening if you set the value
 134 yourself before starting acceptors.")
 135
 136 (defvar-unbound *hunchentoot-stream*
 137   "The stream representing the socket Hunchentoot is listening on.")
 138
 139 (defvar-unbound *finish-processing-socket*
 140   "Will be set to T if PROCESS-CONNECTION is to stop processing more
 141   requests on the current socket connection.")
 142
 143 (defvar-unbound *close-hunchentoot-stream*
 144   "This variable is set to NIL during the processing of a handler to
 145 tell the acceptor not to close the connection after it is done.")
 146
 147 (defvar *headers-sent* nil
 148   "Used internally to check whether the reply headers have
 149 already been sent for this request.")
 150
 151 (defvar *file-upload-hook* nil
 152   "If this is not NIL, it should be a unary function which will
 153 be called with a pathname for each file which is uploaded to
 154 Hunchentoot.  The pathname denotes the temporary file to which
 155 the uploaded file is written.  The hook is called directly before
 156 the file is created.")
 157
 158 (defvar *session-db* nil
 159   "The default \(global) session database.")
 160
 161 (defvar *session-max-time* #.(* 30 60)
 162   "The default time \(in seconds) after which a session times out.")
 163
 164 (defvar *session-gc-frequency* 50
 165   "A session GC \(see function SESSION-GC) will happen every
 166 *SESSION-GC-FREQUENCY* requests \(counting only requests which create
 167 a new session) if this variable is not NIL.  See SESSION-CREATED.")
 168
 169 (defvar *use-user-agent-for-sessions* t
 170   "Whether the 'User-Agent' header should be encoded into the session
 171 string.  If this value is true, a session will cease to be accessible
 172 if the client sends a different 'User-Agent' header.")
 173
 174 (defvar *use-remote-addr-for-sessions* nil
 175   "Whether the client's remote IP \(as returned by REAL-REMOTE-ADDR)
 176 should be encoded into the session string.  If this value is true, a
 177 session will cease to be accessible if the client's remote IP changes.
 178
 179 This might for example be an issue if the client uses a proxy server
 180 which doesn't send correct 'X_FORWARDED_FOR' headers.")
 181
 182 (defvar *default-content-type* "text/html"
 183   "The default content-type header which is returned to the client.
 184 If this is text content type, the character set used for encoding the
 185 response will automatically be added to the content type in a
 186 ``charset'' attribute.")
 187
 188 (defvar *methods-for-post-parameters* '(:post)
 189   "A list of the request method types \(as keywords) for which
 190 Hunchentoot will try to compute POST-PARAMETERS.")
 191
 192 (defvar *header-stream* nil
 193   "If this variable is not NIL, it should be bound to a stream to
 194 which incoming and outgoing headers will be written for debugging
 195 purposes.")
 196
 197 (defvar *show-lisp-errors-p* nil
 198   "Whether Lisp errors in request handlers should be shown in HTML output.")
 199
 200 (defvar *show-lisp-backtraces-p* t
 201   "Whether Lisp errors shown in HTML output should contain backtrace information.")
 202
 203 (defvar *log-lisp-errors-p* t
 204   "Whether Lisp errors in request handlers should be logged.")
 205
 206 (defvar *log-lisp-backtraces-p* t
 207   "Whether Lisp backtraces should be logged.  Only has an effect if
 208 *LOG-LISP-ERRORS-P* is true as well.")
 209
 210 (defvar *log-lisp-warnings-p* t
 211   "Whether Lisp warnings in request handlers should be logged.")
 212
 213 (defvar *lisp-errors-log-level* :error
 214   "Log level for Lisp errors.  Should be one of :ERROR \(the default),
 215 :WARNING, or :INFO.")
 216
 217 (defvar *lisp-warnings-log-level* :warning
 218   "Log level for Lisp warnings.  Should be one of :ERROR, :WARNING
 219 \(the default), or :INFO.")
 220
 221 (defvar *message-log-lock* (make-lock "global-message-log-lock")
 222   "A global lock to prevent concurrent access to the log file used by
 223 the ACCEPTOR-LOG-MESSAGE function.")
 224
 225 (defvar *access-log-lock* (make-lock "global-access-log-lock")
 226   "A global lock to prevent concurrent access to the log file used by
 227 the ACCEPTOR-LOG-ACCESS function.")
 228
 229 (defvar *catch-errors-p* t
 230   "Whether Hunchentoot should catch and log errors \(or rather invoke
 231 the debugger).")
 232
 233 (defvar-unbound *acceptor*
 234   "The current ACCEPTOR object while in the context of a request.")
 235
 236 (defvar-unbound *request*
 237   "The current REQUEST object while in the context of a request.")
 238
 239 (defvar-unbound *reply*
 240   "The current REPLY object while in the context of a request.")
 241
 242 (defvar-unbound *session*
 243   "The current session while in the context of a request, or NIL.")
 244
 245 (defconstant +implementation-link+
 246   #+:cmu "http://www.cons.org/cmucl/"
 247   #+:sbcl "http://www.sbcl.org/"
 248   #+:allegro "http://www.franz.com/products/allegrocl/"
 249   #+:lispworks "http://www.lispworks.com/"
 250   #+:openmcl "http://openmcl.clozure.com/"
 251   "A link to the website of the underlying Lisp implementation.")
 252
 253 (defvar *tmp-directory*
 254   #+(or :win32 :mswindows) "c:\\hunchentoot-temp\\"
 255   #-(or :win32 :mswindows) "/tmp/hunchentoot/"
 256   "Directory for temporary files created by MAKE-TMP-FILE-NAME.")
 257
 258 (defvar *tmp-files* nil
 259   "A list of temporary files created while a request was handled.")
 260
 261 (defconstant +latin-1+
 262   (make-external-format :latin1 :eol-style :lf)
 263   "A FLEXI-STREAMS external format used for `faithful' input and
 264 output of binary data.")
 265
 266 (defconstant +utf-8+
 267   (make-external-format :utf8 :eol-style :lf)
 268   "A FLEXI-STREAMS external format used internally for logging and to
 269 encode cookie values.")
 270
 271 (defvar *hunchentoot-default-external-format* +utf-8+
 272   "The external format used to compute the REQUEST object.")
 273
 274 (defconstant +buffer-length+ 8192
 275   "Length of buffers used for internal purposes.")
 276
 277 (defvar *default-connection-timeout* 20
 278   "The default connection timeout used when an acceptor is reading
 279 from and writing to a socket stream.")
 280
 281 (eval-when (:compile-toplevel :load-toplevel :execute)
 282  (define-symbol-macro *supports-threads-p*
 283    #+:lispworks t
 284    #-:lispworks bt:*supports-threads-p*))
 285
 286 (defvar *global-session-db-lock*
 287   (load-time-value (and *supports-threads-p* (make-lock "global-session-db-lock")))
 288   "A global lock to prevent two threads from modifying *session-db* at
 289 the same time \(or NIL for Lisps which don't have threads).")
 290
 291 #-:lispworks
 292 (defconstant +new-connection-wait-time+ 2
 293   "Time in seconds to wait for a new connection to arrive before
 294 performing a cleanup run.")
 295
 296 (pushnew :hunchentoot *features*)
 297
 298 ;; stuff for Nikodemus Siivola's HYPERDOC
 299 ;; see <http://common-lisp.net/project/hyperdoc/>
 300 ;; and <http://www.cliki.net/hyperdoc>
 301
 302 (defvar *hyperdoc-base-uri* "http://weitz.de/hunchentoot/")
 303
 304 (let ((exported-symbols-alist
 305        (loop for symbol being the external-symbols of :hunchentoot
 306              collect (cons symbol (concatenate 'string "#" (string-downcase symbol))))))
 307   (defun hyperdoc-lookup (symbol type)
 308     (declare (ignore type))
 309     (cdr (assoc symbol exported-symbols-alist :test #'eq))))
 310
 311 (defparameter hunchentoot:*hunchentoot-version* #.(asdf:component-version (asdf:find-system :hunchentoot)))