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-precondition-required+ 428 "Precondition Required")
101 (def-http-return-code +http-too-many-requests+ 429 "Too Many Requests")
102 (def-http-return-code +http-request-header-fields-too-large+ 431 "Request Header Fields Too Large")
103 (def-http-return-code +http-internal-server-error+ 500 "Internal Server Error")
104 (def-http-return-code +http-not-implemented+ 501 "Not Implemented")
105 (def-http-return-code +http-bad-gateway+ 502 "Bad Gateway")
106 (def-http-return-code +http-service-unavailable+ 503 "Service Unavailable")
107 (def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out")
108 (def-http-return-code +http-version-not-supported+ 505 "Version not supported")
109 (def-http-return-code +http-network-authentication-required+ 511 "Network Authentication Required")
110 
111 (defconstant +day-names+
112   #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
113   "The three-character names of the seven days of the week - needed
114 for cookie date format.")
115 
116 (defconstant +month-names+
117   #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
118   "The three-character names of the twelve months - needed for cookie
119 date format.")
120 
121 (defvar *rewrite-for-session-urls* t
122   "Whether HTML pages should possibly be rewritten for cookie-less
123 session-management.")
124 
125 (defvar *content-types-for-url-rewrite*
126   '("text/html" "application/xhtml+xml")
127   "The content types for which url-rewriting is OK. See
128 *REWRITE-FOR-SESSION-URLS*.")
129 
130 (defvar *the-random-state* (make-random-state t)
131   "A fresh random state.")
132 
133 (defvar-unbound *session-secret*
134   "A random ASCII string that's used to encode the public session
135 data.  This variable is initially unbound and will be set \(using
136 RESET-SESSION-SECRET) the first time a session is created, if
137 necessary.  You can prevent this from happening if you set the value
138 yourself before starting acceptors.")
139 
140 (defvar-unbound *hunchentoot-stream*
141   "The stream representing the socket Hunchentoot is listening on.")
142 
143 (defvar-unbound *finish-processing-socket*
144   "Will be set to T if PROCESS-CONNECTION is to stop processing more
145   requests on the current socket connection.")
146 
147 (defvar-unbound *close-hunchentoot-stream*
148   "This variable is set to NIL during the processing of a handler to
149 tell the acceptor not to close the connection after it is done.")
150 
151 (defvar *headers-sent* nil
152   "Used internally to check whether the reply headers have
153 already been sent for this request.")
154 
155 (defvar *file-upload-hook* nil
156   "If this is not NIL, it should be a unary function which will
157 be called with a pathname for each file which is uploaded to
158 Hunchentoot.  The pathname denotes the temporary file to which
159 the uploaded file is written.  The hook is called directly before
160 the file is created.")
161 
162 (defvar *session-db* nil
163   "The default \(global) session database.")
164 
165 (defvar *session-max-time* #.(* 30 60)
166   "The default time \(in seconds) after which a session times out.")
167 
168 (defvar *session-gc-frequency* 50
169   "A session GC \(see function SESSION-GC) will happen every
170 *SESSION-GC-FREQUENCY* requests \(counting only requests which create
171 a new session) if this variable is not NIL.  See SESSION-CREATED.")
172 
173 (defvar *use-user-agent-for-sessions* t
174   "Whether the 'User-Agent' header should be encoded into the session
175 string.  If this value is true, a session will cease to be accessible
176 if the client sends a different 'User-Agent' header.")
177 
178 (defvar *use-remote-addr-for-sessions* nil
179   "Whether the client's remote IP \(as returned by REAL-REMOTE-ADDR)
180 should be encoded into the session string.  If this value is true, a
181 session will cease to be accessible if the client's remote IP changes.
182 
183 This might for example be an issue if the client uses a proxy server
184 which doesn't send correct 'X_FORWARDED_FOR' headers.")
185 
186 (defvar *default-content-type* "text/html"
187   "The default content-type header which is returned to the client.
188 If this is text content type, the character set used for encoding the
189 response will automatically be added to the content type in a
190 ``charset'' attribute.")
191 
192 (defvar *methods-for-post-parameters* '(:post)
193   "A list of the request method types \(as keywords) for which
194 Hunchentoot will try to compute POST-PARAMETERS.")
195 
196 (defvar *header-stream* nil
197   "If this variable is not NIL, it should be bound to a stream to
198 which incoming and outgoing headers will be written for debugging
199 purposes.")
200 
201 (defvar *show-lisp-errors-p* nil
202   "Whether Lisp errors in request handlers should be shown in HTML output.")
203 
204 (defvar *show-lisp-backtraces-p* t
205   "Whether Lisp errors shown in HTML output should contain backtrace information.")
206 
207 (defvar *log-lisp-errors-p* t
208   "Whether Lisp errors in request handlers should be logged.")
209 
210 (defvar *log-lisp-backtraces-p* t
211   "Whether Lisp backtraces should be logged.  Only has an effect if
212 *LOG-LISP-ERRORS-P* is true as well.")
213 
214 (defvar *log-lisp-warnings-p* t
215   "Whether Lisp warnings in request handlers should be logged.")
216 
217 (defvar *lisp-errors-log-level* :error
218   "Log level for Lisp errors.  Should be one of :ERROR \(the default),
219 :WARNING, or :INFO.")
220 
221 (defvar *lisp-warnings-log-level* :warning
222   "Log level for Lisp warnings.  Should be one of :ERROR, :WARNING
223 \(the default), or :INFO.")
224 
225 (defvar *message-log-lock* (make-lock "global-message-log-lock")
226   "A global lock to prevent concurrent access to the log file used by
227 the ACCEPTOR-LOG-MESSAGE function.")
228 
229 (defvar *access-log-lock* (make-lock "global-access-log-lock")
230   "A global lock to prevent concurrent access to the log file used by
231 the ACCEPTOR-LOG-ACCESS function.")
232 
233 (defvar *catch-errors-p* t
234   "Whether Hunchentoot should catch and log errors \(or rather invoke
235 the debugger).")
236 
237 (defvar-unbound *acceptor*
238   "The current ACCEPTOR object while in the context of a request.")
239 
240 (defvar-unbound *request*
241   "The current REQUEST object while in the context of a request.")
242 
243 (defvar-unbound *reply*
244   "The current REPLY object while in the context of a request.")
245 
246 (defvar-unbound *session*
247   "The current session while in the context of a request, or NIL.")
248 
249 (defconstant +implementation-link+
250   #+:cmu "http://www.cons.org/cmucl/"
251   #+:sbcl "http://www.sbcl.org/"
252   #+:allegro "http://www.franz.com/products/allegrocl/"
253   #+:lispworks "http://www.lispworks.com/"
254   #+:openmcl "http://openmcl.clozure.com/"
255   "A link to the website of the underlying Lisp implementation.")
256 
257 (defvar *tmp-directory*
258   #+(or :win32 :mswindows) "c:\\hunchentoot-temp\\"
259   #-(or :win32 :mswindows) "/tmp/hunchentoot/"
260   "Directory for temporary files created by MAKE-TMP-FILE-NAME.")
261 
262 (defvar *tmp-files* nil
263   "A list of temporary files created while a request was handled.")
264 
265 (defconstant +latin-1+
266   (make-external-format :latin1 :eol-style :lf)
267   "A FLEXI-STREAMS external format used for `faithful' input and
268 output of binary data.")
269 
270 (defconstant +utf-8+
271   (make-external-format :utf8 :eol-style :lf)
272   "A FLEXI-STREAMS external format used internally for logging and to
273 encode cookie values.")
274 
275 (defvar *hunchentoot-default-external-format* +utf-8+
276   "The external format used to compute the REQUEST object.")
277 
278 (defconstant +buffer-length+ 8192
279   "Length of buffers used for internal purposes.")
280 
281 (defvar *default-connection-timeout* 20
282   "The default connection timeout used when an acceptor is reading
283 from and writing to a socket stream.")
284 
285 (eval-when (:compile-toplevel :load-toplevel :execute)
286  (define-symbol-macro *supports-threads-p*
287    #+:lispworks t
288    #-:lispworks bt:*supports-threads-p*))
289 
290 (defvar *global-session-db-lock*
291   (load-time-value (and *supports-threads-p* (make-lock "global-session-db-lock")))
292   "A global lock to prevent two threads from modifying *session-db* at
293 the same time \(or NIL for Lisps which don't have threads).")
294 
295 (pushnew :hunchentoot *features*)
296 
297 ;; stuff for Nikodemus Siivola's HYPERDOC
298 ;; see <http://common-lisp.net/project/hyperdoc/>
299 ;; and <http://www.cliki.net/hyperdoc>
300 
301 (defvar *hyperdoc-base-uri* "http://weitz.de/hunchentoot/")
302 
303 (let ((exported-symbols-alist
304        (loop for symbol being the external-symbols of :hunchentoot
305              collect (cons symbol (concatenate 'string "#" (string-downcase symbol))))))
306   (defun hyperdoc-lookup (symbol type)
307     (declare (ignore type))
308     (cdr (assoc symbol exported-symbols-alist :test #'eq))))
309 
310 (defparameter hunchentoot:*hunchentoot-version* #.(asdf:component-version (asdf:find-system :hunchentoot)))