1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
29 (in-package :hunchentoot
)
31 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
32 (defun default-document-directory (&optional sub-directory
)
33 (asdf:system-relative-pathname
:hunchentoot
(format nil
"www/~@[~A~]" sub-directory
))))
38 :documentation
"The port the acceptor is listening on. The
39 default is 80. Note that depending on your operating system you might
40 need special privileges to listen on port 80.")
41 (address :initarg
:address
42 :reader acceptor-address
43 :documentation
"The address the acceptor is listening on.
44 If address is a string denoting an IP address, then the server only
45 receives connections for that address. This must be one of the
46 addresses associated with the machine and allowed values are host
47 names such as \"www.zappa.com\" and address strings such as
48 \"72.3.247.29\". If address is NIL, then the server will receive
49 connections to all IP addresses on the machine. This is the default.")
51 :accessor acceptor-name
52 :documentation
"The optional name of the acceptor, a symbol.
53 This name can be utilized when defining \"easy handlers\" - see
54 DEFINE-EASY-HANDLER. The default name is an uninterned symbol as
56 (request-class :initarg
:request-class
57 :accessor acceptor-request-class
58 :documentation
"Determines which class of request
59 objects is created when a request comes in and should be \(a symbol
60 naming) a class which inherits from REQUEST. The default is the
62 (reply-class :initarg
:reply-class
63 :accessor acceptor-reply-class
64 :documentation
"Determines which class of reply
65 objects is created when a request is served in and should be \(a
66 symbol naming) a class which inherits from REPLY. The default is the
68 (taskmaster :initarg
:taskmaster
69 :reader acceptor-taskmaster
70 :documentation
"The taskmaster \(i.e. an instance of a
71 subclass of TASKMASTER) that is responsible for scheduling the work
72 for this acceptor. The default depends on the MP capabilities of the
74 (output-chunking-p :initarg
:output-chunking-p
75 :accessor acceptor-output-chunking-p
76 :documentation
"A generalized boolean denoting
77 whether the acceptor may use chunked encoding for output, i.e. when
78 sending data to the client. The default is T and there's usually no
79 reason to change this to NIL.")
80 (input-chunking-p :initarg
:input-chunking-p
81 :accessor acceptor-input-chunking-p
82 :documentation
"A generalized boolean denoting
83 whether the acceptor may use chunked encoding for input, i.e. when
84 accepting request bodies from the client. The default is T and
85 there's usually no reason to change this to NIL.")
86 (persistent-connections-p :initarg
:persistent-connections-p
87 :accessor acceptor-persistent-connections-p
88 :documentation
"A generalized boolean
89 denoting whether the acceptor supports persistent connections, which
90 is the default for threaded acceptors. If this property is NIL,
91 Hunchentoot closes each incoming connection after having processed one
92 request. This is the default for non-threaded acceptors.")
93 (read-timeout :initarg
:read-timeout
94 :reader acceptor-read-timeout
95 :documentation
"The read timeout of the acceptor,
96 specified in \(fractional) seconds. The precise semantics of this
97 parameter is determined by the underlying Lisp's implementation of
98 socket timeouts. NIL means no timeout.")
99 (write-timeout :initarg
:write-timeout
100 :reader acceptor-write-timeout
101 :documentation
"The write timeout of the acceptor,
102 specified in \(fractional) seconds. The precise semantics of this
103 parameter is determined by the underlying Lisp's implementation of
104 socket timeouts. NIL means no timeout.")
106 (process :accessor acceptor-process
107 :documentation
"The Lisp process which accepts incoming
108 requests. This is the process started by COMM:START-UP-SERVER and no
109 matter what kind of taskmaster you are using this will always be a new
110 process different from the one where START was called.")
112 (listen-socket :initform nil
113 :accessor acceptor-listen-socket
114 :documentation
"The socket listening for incoming
117 (listen-backlog :initarg
:listen-backlog
118 :reader acceptor-listen-backlog
119 :documentation
"Number of pending connections
120 allowed in the listen socket before the kernel rejects
121 further incoming connections.")
122 (acceptor-shutdown-p :initform t
123 :accessor acceptor-shutdown-p
124 :documentation
"A flag that makes the acceptor
125 shutdown itself when set to something other than NIL.")
126 (requests-in-progress :initform
0
127 :accessor accessor-requests-in-progress
128 :documentation
"The number of
129 requests currently in progress.")
130 (shutdown-queue :initform
(make-condition-variable)
131 :accessor acceptor-shutdown-queue
132 :documentation
"A condition variable
133 used with soft shutdown, signaled when all requests
134 have been processed.")
135 (shutdown-lock :initform
(make-lock "hunchentoot-acceptor-shutdown")
136 :accessor acceptor-shutdown-lock
137 :documentation
"The lock protecting the shutdown-queue
138 condition variable and the requests-in-progress counter.")
139 (access-log-destination :initarg
:access-log-destination
140 :accessor acceptor-access-log-destination
141 :documentation
"Destination of the access log
142 which contains one log entry per request handled in a format similar
143 to Apache's access.log. Can be set to a pathname or string
144 designating the log file, to a open output stream or to NIL to
146 (message-log-destination :initarg
:message-log-destination
147 :accessor acceptor-message-log-destination
148 :documentation
"Destination of the server
149 error log which is used to log informational, warning and error
150 messages in a free-text format intended for human inspection. Can be
151 set to a pathname or string designating the log file, to a open output
152 stream or to NIL to suppress logging.")
153 (error-template-directory :initarg
:error-template-directory
154 :accessor acceptor-error-template-directory
155 :documentation
"Directory pathname that
156 contains error message template files for server-generated error
157 messages. Files must be named <return-code>.html with <return-code>
158 representing the HTTP return code that the file applies to,
159 i.e. 404.html would be used as the content for a HTTP 404 Not found
161 (document-root :initarg
:document-root
162 :accessor acceptor-document-root
163 :documentation
"Directory pathname that points to
164 files that are served by the acceptor if no more specific
165 acceptor-dispatch-request method handles the request."))
170 :request-class
'request
172 #-lispworks
:listen-backlog
#-lispworks
50
173 :taskmaster
(make-instance (cond (*supports-threads-p
* 'one-thread-per-connection-taskmaster
)
174 (t 'single-threaded-taskmaster
)))
177 :persistent-connections-p t
178 :read-timeout
*default-connection-timeout
*
179 :write-timeout
*default-connection-timeout
*
180 :access-log-destination
*error-output
*
181 :message-log-destination
*error-output
*
182 :document-root
(load-time-value (default-document-directory))
183 :error-template-directory
(load-time-value (default-document-directory "errors/")))
184 (:documentation
"To create a Hunchentoot webserver, you make an
185 instance of this class and use the generic function START to start it
186 \(and STOP to stop it). Use the :PORT initarg if you don't want to
187 listen on the default http port 80. There are other initargs most of
188 which you probably won't need very often. They are explained in
189 detail in the docstrings of the slot definitions for this class.
191 Unless you are in a Lisp without MP capabilities, you can have several
192 active instances of ACCEPTOR \(listening on different ports) at the
195 (defmethod print-object ((acceptor acceptor
) stream
)
196 (print-unreadable-object (acceptor stream
:type t
)
197 (format stream
"\(host ~A, port ~A)"
198 (or (acceptor-address acceptor
) "*") (acceptor-port acceptor
))))
200 (defgeneric start
(acceptor)
201 (:documentation
"Starts the ACCEPTOR so that it begins accepting
202 connections. Returns the acceptor."))
204 (defgeneric stop
(acceptor &key soft
)
205 (:documentation
"Stops the ACCEPTOR so that it no longer accepts
206 requests. If SOFT is true, and there are any requests in progress,
207 wait until all requests are fully processed, but meanwhile do
208 not accept new requests."))
210 (defgeneric start-listening
(acceptor)
211 (:documentation
"Sets up a listen socket for the given ACCEPTOR and
212 enables it to listen to incoming connections. This function is called
213 from the thread that starts the acceptor initially and may return
214 errors resulting from the listening operation \(like 'address in use'
217 (defgeneric accept-connections
(acceptor)
218 (:documentation
"In a loop, accepts a connection and hands it over
219 to the acceptor's taskmaster for processing using
220 HANDLE-INCOMING-CONNECTION. On LispWorks, this function returns
221 immediately, on other Lisps it retusn only once the acceptor has been
224 (defgeneric initialize-connection-stream
(acceptor stream
)
225 (:documentation
"Can be used to modify the stream which is used to
226 communicate between client and server before the request is read. The
227 default method of ACCEPTOR does nothing, but see for example the
228 method defined for SSL-ACCEPTOR. All methods of this generic function
229 must return the stream to use."))
231 (defgeneric reset-connection-stream
(acceptor stream
)
232 (:documentation
"Resets the stream which is used to communicate
233 between client and server after one request has been served so that it
234 can be used to process the next request. This generic function is
235 called after a request has been processed and must return the
238 (defgeneric process-connection
(acceptor socket
)
239 (:documentation
"This function is called by the taskmaster when a
240 new client connection has been established. Its arguments are the
241 ACCEPTOR object and a LispWorks socket handle or a usocket socket
242 stream object in SOCKET. It reads the request headers, sets up the
243 request and reply objects, and hands over to PROCESS-REQUEST. This is
244 done in a loop until the stream has to be closed or until a connection
247 It is probably not a good idea to re-implement this method until you
248 really, really know what you're doing."))
250 (defgeneric handle-request
(acceptor request
)
251 (:documentation
"This function is called once the request has been
252 read and a REQUEST object has been created. Its job is to set up
253 standard error handling and request logging.
255 Might be a good place for around methods specialized for your subclass
256 of ACCEPTOR which bind or rebind special variables which can then be
257 accessed by your handlers."))
259 (defgeneric acceptor-dispatch-request
(acceptor request
)
260 (:documentation
"This function is called to actually dispatch the
261 request once the standard logging and error handling has been set up.
262 ACCEPTOR subclasses implement methods for this function in order to
263 perform their own request routing. If a method does not want to
264 handle the request, it is supposed to invoke CALL-NEXT-METHOD so that
265 the next ACCEPTOR in the inheritance chain gets a chance to handle the
268 (defgeneric acceptor-ssl-p
(acceptor)
269 (:documentation
"Returns a true value if ACCEPTOR uses SSL
270 connections. The default is to unconditionally return NIL and
271 subclasses of ACCEPTOR must specialize this method to signal that
272 they're using secure connections - see the SSL-ACCEPTOR class."))
274 ;; general implementation
276 (defmethod start ((acceptor acceptor
))
277 (setf (acceptor-shutdown-p acceptor
) nil
)
278 (start-listening acceptor
)
279 (let ((taskmaster (acceptor-taskmaster acceptor
)))
280 (setf (taskmaster-acceptor taskmaster
) acceptor
)
281 (execute-acceptor taskmaster
))
284 (defmethod stop ((acceptor acceptor
) &key soft
)
285 (setf (acceptor-shutdown-p acceptor
) t
)
286 (shutdown (acceptor-taskmaster acceptor
))
288 (with-lock-held ((acceptor-shutdown-lock acceptor
))
289 (when (plusp (accessor-requests-in-progress acceptor
))
290 (condition-variable-wait (acceptor-shutdown-queue acceptor
)
291 (acceptor-shutdown-lock acceptor
)))))
293 (usocket:socket-close
(acceptor-listen-socket acceptor
))
295 (setf (acceptor-listen-socket acceptor
) nil
)
297 (mp:process-kill
(acceptor-process acceptor
))
300 (defmethod initialize-connection-stream ((acceptor acceptor
) stream
)
301 ;; default method does nothing
304 (defmethod reset-connection-stream ((acceptor acceptor
) stream
)
305 ;; turn chunking off at this point
306 (cond ((typep stream
'chunked-stream
)
307 ;; flush the stream first and check if there's unread input
308 ;; which would be an error
309 (setf (chunked-stream-output-chunking-p stream
) nil
310 (chunked-stream-input-chunking-p stream
) nil
)
311 ;; switch back to bare socket stream
312 (chunked-stream-stream stream
))
315 (defmethod process-connection :around
((*acceptor
* acceptor
) (socket t
))
316 ;; this around method is used for error handling
317 ;; note that this method also binds *ACCEPTOR*
318 (handler-bind ((error
319 ;; abort if there's an error which isn't caught inside
321 (log-message* *lisp-errors-log-level
*
322 "Error while processing connection: ~A" cond
)
323 (return-from process-connection
)))
325 ;; log all warnings which aren't caught inside
327 (log-message* *lisp-warnings-log-level
*
328 "Warning while processing connection: ~A" cond
))))
329 (with-mapped-conditions ()
330 (call-next-method))))
332 (defun do-with-acceptor-request-count-incremented (*acceptor
* function
)
333 (with-lock-held ((acceptor-shutdown-lock *acceptor
*))
334 (incf (accessor-requests-in-progress *acceptor
*)))
337 (with-lock-held ((acceptor-shutdown-lock *acceptor
*))
338 (decf (accessor-requests-in-progress *acceptor
*))
339 (when (acceptor-shutdown-p *acceptor
*)
340 (condition-variable-signal (acceptor-shutdown-queue *acceptor
*))))))
342 (defmacro with-acceptor-request-count-incremented
((acceptor) &body body
)
343 "Execute BODY with ACCEPTOR-REQUESTS-IN-PROGRESS of ACCEPTOR
344 incremented by one. If the ACCEPTOR-SHUTDOWN-P returns true after
345 the BODY has been executed, the ACCEPTOR-SHUTDOWN-QUEUE condition
346 variable of the ACCEPTOR is signalled in order to finish shutdown
348 `(do-with-acceptor-request-count-incremented ,acceptor
(lambda () ,@body
)))
350 (defmethod process-connection ((*acceptor
* acceptor
) (socket t
))
351 (let ((*hunchentoot-stream
*
352 (initialize-connection-stream *acceptor
* (make-socket-stream socket
*acceptor
*))))
354 ;; process requests until either the acceptor is shut down,
355 ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
356 ;; handler, or the peer fails to send a request
358 (let ((*close-hunchentoot-stream
* t
))
359 (when (acceptor-shutdown-p *acceptor
*)
361 (multiple-value-bind (headers-in method url-string protocol
)
362 (get-request-data *hunchentoot-stream
*)
363 ;; check if there was a request at all
366 ;; bind per-request special variables, then process the
367 ;; request - note that *ACCEPTOR* was bound above already
368 (let ((*reply
* (make-instance (acceptor-reply-class *acceptor
*)))
370 (transfer-encodings (cdr (assoc* :transfer-encoding headers-in
))))
371 (when transfer-encodings
372 (setq transfer-encodings
373 (split "\\s*,\\s*" transfer-encodings
))
374 (when (member "chunked" transfer-encodings
:test
#'equalp
)
375 (cond ((acceptor-input-chunking-p *acceptor
*)
376 ;; turn chunking on before we read the request body
377 (setf *hunchentoot-stream
* (make-chunked-stream *hunchentoot-stream
*)
378 (chunked-stream-input-chunking-p *hunchentoot-stream
*) t
))
379 (t (hunchentoot-error "Client tried to use ~
380 chunked encoding, but acceptor is configured to not use it.")))))
381 (multiple-value-bind (remote-addr remote-port
)
382 (get-peer-address-and-port socket
)
383 (with-acceptor-request-count-incremented (*acceptor
*)
384 (process-request (make-instance (acceptor-request-class *acceptor
*)
386 :remote-addr remote-addr
387 :remote-port remote-port
388 :headers-in headers-in
389 :content-stream
*hunchentoot-stream
*
392 :server-protocol protocol
)))))
393 (finish-output *hunchentoot-stream
*)
394 (setq *hunchentoot-stream
* (reset-connection-stream *acceptor
* *hunchentoot-stream
*))
395 (when *close-hunchentoot-stream
*
397 (when *hunchentoot-stream
*
398 ;; as we are at the end of the request here, we ignore all
399 ;; errors that may occur while flushing and/or closing the
402 (finish-output *hunchentoot-stream
*))
404 (close *hunchentoot-stream
* :abort t
))))))
406 (defmethod acceptor-ssl-p ((acceptor t
))
407 ;; the default is to always answer "no"
410 (defgeneric acceptor-log-access
(acceptor &key return-code
)
412 "Function to call to log access to the acceptor. The RETURN-CODE,
413 CONTENT and CONTENT-LENGTH keyword arguments contain additional
414 information about the request to log. In addition, it can use the
415 standard request accessor functions that are available to handler
416 functions to find out more information about the request."))
418 (defmethod acceptor-log-access ((acceptor acceptor
) &key return-code
)
419 "Default method for access logging. It logs the information to the
420 destination determined by (ACCEPTOR-ACCESS-LOG-DESTINATION ACCEPTOR)
421 \(unless that value is NIL) in a format that can be parsed by most
422 Apache log analysis tools.)"
424 (with-log-stream (stream (acceptor-access-log-destination acceptor
) *access-log-lock
*)
425 (format stream
"~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
426 ~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
428 (header-in* :x-forwarded-for
)
440 (defgeneric acceptor-log-message
(acceptor log-level format-string
&rest format-arguments
)
442 "Function to call to log messages by the ACCEPTOR. It must accept
443 a severity level for the message, which will be one of :ERROR, :INFO,
444 or :WARNING, a format string and an arbitary number of formatting
447 (defmethod acceptor-log-message ((acceptor acceptor
) log-level format-string
&rest format-arguments
)
448 "Default function to log server messages. Sends a formatted message
449 to the destination denoted by (ACCEPTOR-MESSAGE-LOG-DESTINATION
450 ACCEPTOR). FORMAT and ARGS are as in FORMAT. LOG-LEVEL is a
451 keyword denoting the log level or NIL in which case it is ignored."
452 (with-log-stream (stream (acceptor-message-log-destination acceptor
) *message-log-lock
*)
454 (format stream
"[~A~@[ [~A]~]] ~?~%"
456 format-string format-arguments
)
459 (format *trace-output
* "error ~A while writing to error log, error not logged~%" e
))))))
461 (defun log-message* (log-level format-string
&rest format-arguments
)
462 "Convenience function which calls the message logger of the current
463 acceptor \(if there is one) with the same arguments it accepts.
465 This is the function which Hunchentoot itself uses to log errors it
466 catches during request processing."
467 (apply 'acceptor-log-message
*acceptor
* log-level format-string format-arguments
))
469 ;; usocket implementation
472 (defmethod start-listening ((acceptor acceptor
))
473 (when (acceptor-listen-socket acceptor
)
474 (hunchentoot-error "acceptor ~A is already listening" acceptor
))
475 (setf (acceptor-listen-socket acceptor
)
476 (usocket:socket-listen
(or (acceptor-address acceptor
)
477 usocket
:*wildcard-host
*)
478 (acceptor-port acceptor
)
480 :backlog
(acceptor-listen-backlog acceptor
)
481 :element-type
'(unsigned-byte 8)))
485 (defmethod accept-connections ((acceptor acceptor
))
486 (usocket:with-server-socket
(listener (acceptor-listen-socket acceptor
))
488 (when (acceptor-shutdown-p acceptor
)
490 (when (usocket:wait-for-input listener
:ready-only t
:timeout
+new-connection-wait-time
+)
491 (when-let (client-connection
492 (handler-case (usocket:socket-accept listener
)
494 (usocket:connection-aborted-error
())))
495 (set-timeouts client-connection
496 (acceptor-read-timeout acceptor
)
497 (acceptor-write-timeout acceptor
))
498 (handle-incoming-connection (acceptor-taskmaster acceptor
)
499 client-connection
))))))
501 ;; LispWorks implementation
504 (defmethod start-listening ((acceptor acceptor
))
505 (multiple-value-bind (listener-process startup-condition
)
506 (comm:start-up-server
:service
(acceptor-port acceptor
)
507 :address
(acceptor-address acceptor
)
508 :process-name
(format nil
"Hunchentoot listener \(~A:~A)"
509 (or (acceptor-address acceptor
) "*")
510 (acceptor-port acceptor
))
511 ;; this function is called once on startup - we
512 ;; use it to check for errors
513 :announce
(lambda (socket &optional condition
)
514 (declare (ignore socket
))
517 ;; this function is called whenever a connection
519 :function
(lambda (handle)
520 (unless (acceptor-shutdown-p acceptor
)
521 (handle-incoming-connection
522 (acceptor-taskmaster acceptor
) handle
)))
523 ;; wait until the acceptor was successfully started
524 ;; or an error condition is returned
526 (when startup-condition
527 (error startup-condition
))
528 (mp:process-stop listener-process
)
529 (setf (acceptor-process acceptor
) listener-process
)
533 (defmethod accept-connections ((acceptor acceptor
))
534 (mp:process-unstop
(acceptor-process acceptor
))
537 (defmethod acceptor-dispatch-request ((acceptor acceptor
) request
)
538 "Detault implementation of the request dispatch method, generates an
539 +http-not-found+ error."
540 (if (acceptor-document-root acceptor
)
541 (let ((path (request-pathname request
)))
543 (setf (return-code *reply
*) +http-forbidden
+)
545 (merge-pathnames (if (equal "/" (script-name request
)) #p
"index.html" path
)
546 (acceptor-document-root acceptor
)))))
547 (setf (return-code *reply
*) +http-not-found
+)))
549 (defmethod handle-request ((*acceptor
* acceptor
) (*request
* request
))
550 "Standard method for request handling. Calls the request dispatcher
551 of *ACCEPTOR* to determine how the request should be handled. Also
552 sets up standard error handling which catches any errors within the
554 (handler-bind ((error
556 ;; if the headers were already sent, the error
557 ;; happened within the body and we have to close
560 (setq *close-hunchentoot-stream
* t
))
562 (values nil cond
(get-backtrace)))))
565 (when *log-lisp-warnings-p
*
566 (log-message* *lisp-warnings-log-level
* "~A" cond
)))))
568 (acceptor-dispatch-request *acceptor
* *request
*))))
570 (defgeneric acceptor-status-message
(acceptor http-status-code
&key
&allow-other-keys
)
572 "This function is called after the request's handler has been
573 invoked to convert the HTTP-STATUS-CODE to a HTML message to be
574 displayed to the user. If this function returns a string, that
575 string is sent to the client instead of the content produced by the
578 If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and
579 the directory contains a file corresponding to HTTP-STATUS-CODE
580 named <code>.html, that file is sent to the client after variable
581 substitution. Variables are referenced by ${<variable-name>}.
583 Additional keyword arguments may be provided which are made
584 available to the templating logic as substitution variables. These
585 variables can be interpolated into error message templates in,
586 which contains the current URL relative to the server and without
589 In addition to the variables corresponding to keyword arguments,
590 the script-name, lisp-implementation-type,
591 lisp-implementation-version and hunchentoot-version variables are
594 (defun make-cooked-message (http-status-code &key error backtrace
)
595 (labels ((cooked-message (format &rest arguments
)
596 (setf (content-type*) "text/html; charset=iso-8859-1")
597 (format nil
"<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~?<p><hr>~A</p></body></html>"
598 http-status-code
(reason-phrase http-status-code
)
599 format
(mapcar (lambda (arg)
601 (escape-for-html arg
)
605 (case http-status-code
606 ((#.
+http-moved-temporarily
+
607 #.
+http-moved-permanently
+)
608 (cooked-message "The document has moved <a href='~A'>here</a>" (header-out :location
)))
609 ((#.
+http-authorization-required
+)
610 (cooked-message "The server could not verify that you are authorized to access the document requested. ~
611 Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't ~
612 understand how to supply the credentials required."))
613 ((#.
+http-forbidden
+)
614 (cooked-message "You don't have permission to access ~A on this server."
615 (script-name *request
*)))
616 ((#.
+http-not-found
+)
617 (cooked-message "The requested URL ~A was not found on this server."
618 (script-name *request
*)))
619 ((#.
+http-bad-request
+)
620 (cooked-message "Your browser sent a request that this server could not understand."))
621 ((#.
+http-internal-server-error
+)
622 (if *show-lisp-errors-p
*
623 (cooked-message "<pre>~A~@[~%~%Backtrace:~%~%~A~]</pre>"
624 (escape-for-html (princ-to-string error
))
625 (when *show-lisp-backtraces-p
*
626 (escape-for-html (princ-to-string backtrace
))))
627 (cooked-message "An error has occurred")))
629 (when (<= 400 http-status-code
)
630 (cooked-message "An error has occurred"))))))
632 (defmethod acceptor-status-message ((acceptor t
) http-status-code
&rest args
&key
&allow-other-keys
)
633 (apply 'make-cooked-message http-status-code args
))
635 (defmethod acceptor-status-message :around
((acceptor acceptor
) http-status-code
&rest args
&key
&allow-other-keys
)
639 (log-message* :error
"error ~A during error processing, sending cooked message to client" e
)
640 (apply 'make-cooked-message http-status-code args
))))
642 (defun string-as-keyword (string)
643 "Intern STRING as keyword using the reader so that case conversion is done with the reader defaults."
644 (let ((*package
* (find-package :keyword
)))
645 (read-from-string string
)))
647 (defmethod acceptor-status-message ((acceptor acceptor
) http-status-code
&rest properties
&key
&allow-other-keys
)
648 "Default function to generate error message sent to the client."
650 ((substitute-request-context-variables (string)
651 (let ((properties (append `(:script-name
,(script-name*)
652 :lisp-implementation-type
,(lisp-implementation-type)
653 :lisp-implementation-version
,(lisp-implementation-version)
654 :hunchentoot-version
,*hunchentoot-version
*)
656 (cl-ppcre:regex-replace-all
"(?i)\\$\\{([a-z0-9-_]+)\\}"
658 (lambda (target-string start end match-start match-end reg-starts reg-ends
)
659 (declare (ignore start end match-start match-end
))
660 (let ((variable-name (string-as-keyword (subseq target-string
662 (aref reg-ends
0)))))
663 (escape-for-html (princ-to-string (getf properties variable-name variable-name
))))))))
664 (file-contents (file)
665 (let ((buf (make-string (file-length file
))))
666 (read-sequence buf file
)
668 (error-contents-from-template ()
669 (let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor
)
670 (probe-file (make-pathname :name
(princ-to-string http-status-code
)
672 :defaults
(acceptor-error-template-directory acceptor
))))))
673 (when error-file-template-pathname
674 (with-open-file (file error-file-template-pathname
:if-does-not-exist nil
:element-type
'character
)
676 (setf (content-type*) "text/html")
677 (substitute-request-context-variables (file-contents file
))))))))
678 (or (unless (< 300 http-status-code
)
679 (call-next-method)) ; don't ever try template for positive return codes
680 (error-contents-from-template) ; try template
681 (call-next-method)))) ; fall back to cooked message
683 (defgeneric acceptor-remove-session
(acceptor session
)
685 "This function is called whenever a session in ACCEPTOR is being
686 destroyed because of a session timout or an explicit REMOVE-SESSION
689 (defmethod acceptor-remove-session ((acceptor acceptor
) (session t
))
690 "Default implementation for the session removal hook function. This
691 function is called whenever a session is destroyed."
694 (defgeneric acceptor-server-name
(acceptor)
695 (:documentation
"Returns a string which can be used for 'Server' headers.")
696 (:method
((acceptor acceptor
))
697 (format nil
"Hunchentoot ~A" *hunchentoot-version
*)))