/specials.lisp

http://github.com/edicl/hunchentoot · Lisp · 310 lines · 224 code · 61 blank · 25 comment · 32 complexity · 7e4f3606ec3b5997e31794745e853eac MD5 · raw file

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