acceptor.lisp 1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; 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 (eval-when (:load-toplevel :compile-toplevel :execute)
32 (defun default-document-directory (&optional sub-directory)
33 (let ((source-directory #.(or *compile-file-truename* *load-truename*)))
34 (merge-pathnames (make-pathname :directory (append (pathname-directory source-directory)
35 (list "www")
36 (when sub-directory
37 (list sub-directory)))
38 :name nil
39 :type nil
40 :defaults source-directory)))))
41
42 (defclass acceptor ()
43 ((port :initarg :port
44 :reader acceptor-port
45 :documentation "The port the acceptor is listening on. The
46 default is 80. Note that depending on your operating system you might
47 need special privileges to listen on port 80. When 0, the port will be
48 chosen by the system the first time the acceptor is started.")
49 (address :initarg :address
50 :reader acceptor-address
51 :documentation "The address the acceptor is listening on.
52 If address is a string denoting an IP address, then the server only
53 receives connections for that address. This must be one of the
54 addresses associated with the machine and allowed values are host
55 names such as \"www.zappa.com\" and address strings such as
56 \"72.3.247.29\". If address is NIL, then the server will receive
57 connections to all IP addresses on the machine. This is the default.")
58 (name :initarg :name
59 :accessor acceptor-name
60 :documentation "The optional name of the acceptor, a symbol.
61 This name can be utilized when defining \"easy handlers\" - see
62 DEFINE-EASY-HANDLER. The default name is an uninterned symbol as
63 returned by GENSYM.")
64 (request-class :initarg :request-class
65 :accessor acceptor-request-class
66 :documentation "Determines which class of request
67 objects is created when a request comes in and should be \(a symbol
68 naming) a class which inherits from REQUEST. The default is the
69 symbol REQUEST.")
70 (reply-class :initarg :reply-class
71 :accessor acceptor-reply-class
72 :documentation "Determines which class of reply
73 objects is created when a request is served in and should be \(a
74 symbol naming) a class which inherits from REPLY. The default is the
75 symbol REPLY.")
76 (taskmaster :initarg :taskmaster
77 :reader acceptor-taskmaster
78 :documentation "The taskmaster \(i.e. an instance of a
79 subclass of TASKMASTER) that is responsible for scheduling the work
80 for this acceptor. The default depends on the MP capabilities of the
81 underlying Lisp.")
82 (output-chunking-p :initarg :output-chunking-p
83 :accessor acceptor-output-chunking-p
84 :documentation "A generalized boolean denoting
85 whether the acceptor may use chunked encoding for output, i.e. when
86 sending data to the client. The default is T and there's usually no
87 reason to change this to NIL.")
88 (input-chunking-p :initarg :input-chunking-p
89 :accessor acceptor-input-chunking-p
90 :documentation "A generalized boolean denoting
91 whether the acceptor may use chunked encoding for input, i.e. when
92 accepting request bodies from the client. The default is T and
93 there's usually no reason to change this to NIL.")
94 (persistent-connections-p :initarg :persistent-connections-p
95 :accessor acceptor-persistent-connections-p
96 :documentation "A generalized boolean
97 denoting whether the acceptor supports persistent connections, which
98 is the default for threaded acceptors. If this property is NIL,
99 Hunchentoot closes each incoming connection after having processed one
100 request. This is the default for non-threaded acceptors.")
101 (read-timeout :initarg :read-timeout
102 :reader acceptor-read-timeout
103 :documentation "The read timeout of the acceptor,
104 specified in \(fractional) seconds. The precise semantics of this
105 parameter is determined by the underlying Lisp's implementation of
106 socket timeouts. NIL means no timeout.")
107 (write-timeout :initarg :write-timeout
108 :reader acceptor-write-timeout
109 :documentation "The write timeout of the acceptor,
110 specified in \(fractional) seconds. The precise semantics of this
111 parameter is determined by the underlying Lisp's implementation of
112 socket timeouts. NIL means no timeout.")
113 #+:lispworks
114 (process :accessor acceptor-process
115 :documentation "The Lisp process which accepts incoming
116 requests. This is the process started by COMM:START-UP-SERVER and no
117 matter what kind of taskmaster you are using this will always be a new
118 process different from the one where START was called.")
119 #-:lispworks
120 (listen-socket :initform nil
121 :accessor acceptor-listen-socket
122 :documentation "The socket listening for incoming
123 connections.")
124 #-:lispworks
125 (listen-backlog :initarg :listen-backlog
126 :reader acceptor-listen-backlog
127 :documentation "Number of pending connections
128 allowed in the listen socket before the kernel rejects
129 further incoming connections.")
130 (acceptor-shutdown-p :initform t
131 :accessor acceptor-shutdown-p
132 :documentation "A flag that makes the acceptor
133 shutdown itself when set to something other than NIL.")
134 (requests-in-progress :initform 0
135 :accessor accessor-requests-in-progress
136 :documentation "The number of
137 requests currently in progress.")
138 (shutdown-queue :initform (make-condition-variable)
139 :accessor acceptor-shutdown-queue
140 :documentation "A condition variable
141 used with soft shutdown, signaled when all requests
142 have been processed.")
143 (shutdown-lock :initform (make-lock "hunchentoot-acceptor-shutdown")
144 :accessor acceptor-shutdown-lock
145 :documentation "The lock protecting the shutdown-queue
146 condition variable and the requests-in-progress counter.")
147 (access-log-destination :initarg :access-log-destination
148 :accessor acceptor-access-log-destination
149 :documentation "Destination of the access log
150 which contains one log entry per request handled in a format similar
151 to Apache's access.log. Can be set to a pathname or string
152 designating the log file, to a open output stream or to NIL to
153 suppress logging.")
154 (message-log-destination :initarg :message-log-destination
155 :accessor acceptor-message-log-destination
156 :documentation "Destination of the server
157 error log which is used to log informational, warning and error
158 messages in a free-text format intended for human inspection. Can be
159 set to a pathname or string designating the log file, to a open output
160 stream or to NIL to suppress logging.")
161 (error-template-directory :initarg :error-template-directory
162 :accessor acceptor-error-template-directory
163 :documentation "Directory pathname that
164 contains error message template files for server-generated error
165 messages. Files must be named <return-code>.html with <return-code>
166 representing the HTTP return code that the file applies to,
167 i.e. 404.html would be used as the content for a HTTP 404 Not found
168 response.")
169 (document-root :initarg :document-root
170 :accessor acceptor-document-root
171 :documentation "Directory pathname that points to
172 files that are served by the acceptor if no more specific
173 acceptor-dispatch-request method handles the request."))
174 (:default-initargs
175 :address nil
176 :port 80
177 :name (gensym)
178 :request-class 'request
179 :reply-class 'reply
180 #-lispworks :listen-backlog #-lispworks 50
181 :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster)
182 (t 'single-threaded-taskmaster)))
183 :output-chunking-p t
184 :input-chunking-p t
185 :persistent-connections-p t
186 :read-timeout *default-connection-timeout*
187 :write-timeout *default-connection-timeout*
188 :access-log-destination *error-output*
189 :message-log-destination *error-output*
190 :document-root (load-time-value (default-document-directory))
191 :error-template-directory (load-time-value (default-document-directory "errors")))
192 (:documentation "To create a Hunchentoot webserver, you make an
193 instance of this class and use the generic function START to start it
194 \(and STOP to stop it). Use the :PORT initarg if you don't want to
195 listen on the default http port 80. There are other initargs most of
196 which you probably won't need very often. They are explained in
197 detail in the docstrings of the slot definitions for this class.
198
199 Unless you are in a Lisp without MP capabilities, you can have several
200 active instances of ACCEPTOR \(listening on different ports) at the
201 same time."))
202
203 (defmethod print-object ((acceptor acceptor) stream)
204 (print-unreadable-object (acceptor stream :type t)
205 (format stream "\(host ~A, port ~A)"
206 (or (acceptor-address acceptor) "*") (acceptor-port acceptor))))
207
208 (defmethod initialize-instance :after ((acceptor acceptor) &key)
209 (with-accessors ((document-root acceptor-document-root)
210 (persistent-connections-p acceptor-persistent-connections-p)
211 (taskmaster acceptor-taskmaster)
212 (error-template-directory acceptor-error-template-directory)) acceptor
213 (when (typep taskmaster
214 'single-threaded-taskmaster)
215 (setf persistent-connections-p nil))
216 (when document-root
217 (setf document-root (translate-logical-pathname document-root)))
218 (when error-template-directory
219 (setf error-template-directory (translate-logical-pathname error-template-directory)))))
220
221 (defgeneric start (acceptor)
222 (:documentation "Starts the ACCEPTOR so that it begins accepting
223 connections. Returns the acceptor."))
224
225 (defgeneric stop (acceptor &key soft)
226 (:documentation "Stops the ACCEPTOR so that it no longer accepts
227 requests. If SOFT is true, and there are any requests in progress,
228 wait until all requests are fully processed, but meanwhile do not
229 accept new requests. Note that SOFT must not be set when calling
230 STOP from within a request handler, as that will deadlock."))
231
232 (defgeneric started-p (acceptor)
233 (:documentation "Tells if ACCEPTOR has been started.
234 The default implementation simply queries ACCEPTOR for its listening
235 status, so if T is returned to the calling thread, then some thread
236 has called START or some thread's call to STOP hasn't finished. If NIL
237 is returned either some thread has called STOP, or some thread's call
238 to START hasn't finished or START was never called at all for
239 ACCEPTOR.")
240 (:method (acceptor)
241 #-lispworks (and (acceptor-listen-socket acceptor) t)
242 #+lispworks (not (acceptor-shutdown-p acceptor))))
243
244 (defgeneric start-listening (acceptor)
245 (:documentation "Sets up a listen socket for the given ACCEPTOR and
246 enables it to listen to incoming connections. This function is called
247 from the thread that starts the acceptor initially and may return
248 errors resulting from the listening operation \(like 'address in use'
249 or similar)."))
250
251 (defgeneric accept-connections (acceptor)
252 (:documentation "In a loop, accepts a connection and hands it over
253 to the acceptor's taskmaster for processing using
254 HANDLE-INCOMING-CONNECTION. On LispWorks, this function returns
255 immediately, on other Lisps it retusn only once the acceptor has been
256 stopped."))
257
258 (defgeneric initialize-connection-stream (acceptor stream)
259 (:documentation "Can be used to modify the stream which is used to
260 communicate between client and server before the request is read. The
261 default method of ACCEPTOR does nothing, but see for example the
262 method defined for SSL-ACCEPTOR. All methods of this generic function
263 must return the stream to use."))
264
265 (defgeneric reset-connection-stream (acceptor stream)
266 (:documentation "Resets the stream which is used to communicate
267 between client and server after one request has been served so that it
268 can be used to process the next request. This generic function is
269 called after a request has been processed and must return the
270 stream."))
271
272 (defgeneric process-connection (acceptor socket)
273 (:documentation "This function is called by the taskmaster when a
274 new client connection has been established. Its arguments are the
275 ACCEPTOR object and a LispWorks socket handle or a usocket socket
276 stream object in SOCKET. It reads the request headers, sets up the
277 request and reply objects, and hands over to PROCESS-REQUEST. This is
278 done in a loop until the stream has to be closed or until a connection
279 timeout occurs.
280
281 It is probably not a good idea to re-implement this method until you
282 really, really know what you're doing."))
283
284 (defgeneric handle-request (acceptor request)
285 (:documentation "This function is called once the request has been
286 read and a REQUEST object has been created. Its job is to set up
287 standard error handling and request logging.
288
289 Might be a good place for around methods specialized for your subclass
290 of ACCEPTOR which bind or rebind special variables which can then be
291 accessed by your handlers."))
292
293 (defgeneric acceptor-dispatch-request (acceptor request)
294 (:documentation "This function is called to actually dispatch the
295 request once the standard logging and error handling has been set up.
296 ACCEPTOR subclasses implement methods for this function in order to
297 perform their own request routing. If a method does not want to
298 handle the request, it is supposed to invoke CALL-NEXT-METHOD so that
299 the next ACCEPTOR in the inheritance chain gets a chance to handle the
300 request."))
301
302 (defgeneric acceptor-ssl-p (acceptor)
303 (:documentation "Returns a true value if ACCEPTOR uses SSL
304 connections. The default is to unconditionally return NIL and
305 subclasses of ACCEPTOR must specialize this method to signal that
306 they're using secure connections - see the SSL-ACCEPTOR class."))
307
308 ;; general implementation
309
310 (defmethod start ((acceptor acceptor))
311 (setf (acceptor-shutdown-p acceptor) nil)
312 (let ((taskmaster (acceptor-taskmaster acceptor)))
313 (setf (taskmaster-acceptor taskmaster) acceptor)
314 (start-listening acceptor)
315 (execute-acceptor taskmaster))
316 acceptor)
317
318 (defmethod stop ((acceptor acceptor) &key soft)
319 (with-lock-held ((acceptor-shutdown-lock acceptor))
320 (setf (acceptor-shutdown-p acceptor) t))
321 #-lispworks
322 (wake-acceptor-for-shutdown acceptor)
323 (when soft
324 (with-lock-held ((acceptor-shutdown-lock acceptor))
325 (when (plusp (accessor-requests-in-progress acceptor))
326 (condition-variable-wait (acceptor-shutdown-queue acceptor)
327 (acceptor-shutdown-lock acceptor)))))
328 (shutdown (acceptor-taskmaster acceptor))
329 #-lispworks
330 (usocket:socket-close (acceptor-listen-socket acceptor))
331 #-lispworks
332 (setf (acceptor-listen-socket acceptor) nil)
333 #+lispworks
334 (mp:process-kill (acceptor-process acceptor))
335 acceptor)
336
337 #-lispworks
338 (defun wake-acceptor-for-shutdown (acceptor)
339 "Creates a dummy connection to the acceptor, waking ACCEPT-CONNECTIONS while it is waiting.
340 This is supposed to force a check of ACCEPTOR-SHUTDOWN-P."
341 (handler-case
342 (multiple-value-bind (address port) (usocket:get-local-name (acceptor-listen-socket acceptor))
343 (let ((conn (usocket:socket-connect address port)))
344 (usocket:socket-close conn)))
345 (error (e)
346 (acceptor-log-message acceptor :error "Wake-for-shutdown connect failed: ~A" e))))
347
348 (defmethod initialize-connection-stream ((acceptor acceptor) stream)
349 ;; default method does nothing
350 stream)
351
352 (defmethod reset-connection-stream ((acceptor acceptor) stream)
353 ;; turn chunking off at this point
354 (cond ((typep stream 'chunked-stream)
355 ;; flush the stream first and check if there's unread input
356 ;; which would be an error
357 (setf (chunked-stream-output-chunking-p stream) nil
358 (chunked-stream-input-chunking-p stream) nil)
359 ;; switch back to bare socket stream
360 (chunked-stream-stream stream))
361 (t stream)))
362
363 (defmethod process-connection :around ((*acceptor* acceptor) (socket t))
364 ;; this around method is used for error handling
365 ;; note that this method also binds *ACCEPTOR*
366 (with-conditions-caught-and-logged ()
367 (with-mapped-conditions ()
368 (call-next-method))))
369
370 (defun do-with-acceptor-request-count-incremented (*acceptor* function)
371 (with-lock-held ((acceptor-shutdown-lock *acceptor*))
372 (incf (accessor-requests-in-progress *acceptor*)))
373 (unwind-protect
374 (funcall function)
375 (with-lock-held ((acceptor-shutdown-lock *acceptor*))
376 (decf (accessor-requests-in-progress *acceptor*))
377 (when (acceptor-shutdown-p *acceptor*)
378 (condition-variable-signal (acceptor-shutdown-queue *acceptor*))))))
379
380 (defmacro with-acceptor-request-count-incremented ((acceptor) &body body)
381 "Execute BODY with ACCEPTOR-REQUESTS-IN-PROGRESS of ACCEPTOR
382 incremented by one. If the ACCEPTOR-SHUTDOWN-P returns true after
383 the BODY has been executed, the ACCEPTOR-SHUTDOWN-QUEUE condition
384 variable of the ACCEPTOR is signalled in order to finish shutdown
385 processing."
386 `(do-with-acceptor-request-count-incremented ,acceptor (lambda () ,@body)))
387
388 (defun acceptor-make-request (acceptor socket
389 &key
390 headers-in
391 content-stream
392 method
393 uri
394 server-protocol)
395 "Make a REQUEST instance for the ACCEPTOR, setting up those slots
396 that are determined from the SOCKET by calling the appropriate
397 socket query functions."
398 (multiple-value-bind (remote-addr remote-port)
399 (get-peer-address-and-port socket)
400 (multiple-value-bind (local-addr local-port)
401 (get-local-address-and-port socket)
402 (make-instance (acceptor-request-class acceptor)
403 :acceptor acceptor
404 :local-addr local-addr
405 :local-port local-port
406 :remote-addr remote-addr
407 :remote-port remote-port
408 :headers-in headers-in
409 :content-stream content-stream
410 :method method
411 :uri uri
412 :server-protocol server-protocol))))
413
414 (defgeneric detach-socket (acceptor)
415 (:documentation "Indicate to Hunchentoot that it should stop serving
416 requests on the current request's socket.
417 Hunchentoot will finish processing the current
418 request and then return from PROCESS-CONNECTION
419 without closing the connection to the client.
420 DETACH-SOCKET can only be called from within a
421 request handler function."))
422
423 (defmethod detach-socket ((acceptor acceptor))
424 (setf *finish-processing-socket* t
425 *close-hunchentoot-stream* nil))
426
427 (defmethod process-connection ((*acceptor* acceptor) (socket t))
428 (let* ((socket-stream (make-socket-stream socket *acceptor*))
429 (*hunchentoot-stream*)
430 (*close-hunchentoot-stream* t))
431 (unwind-protect
432 ;; process requests until either the acceptor is shut down,
433 ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
434 ;; handler, or the peer fails to send a request
435 (progn
436 (setq *hunchentoot-stream* (initialize-connection-stream *acceptor* socket-stream))
437 (loop
438 (let ((*finish-processing-socket* t))
439 (when (acceptor-shutdown-p *acceptor*)
440 (return))
441 (multiple-value-bind (headers-in method url-string protocol)
442 (get-request-data *hunchentoot-stream*)
443 ;; check if there was a request at all
444 (unless method
445 (return))
446 ;; bind per-request special variables, then process the
447 ;; request - note that *ACCEPTOR* was bound above already
448 (let ((*reply* (make-instance (acceptor-reply-class *acceptor*)))
449 (*session* nil)
450 (transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
451 (when transfer-encodings
452 (setq transfer-encodings
453 (split "\\s*,\\s*" transfer-encodings))
454 (when (member "chunked" transfer-encodings :test #'equalp)
455 (cond ((acceptor-input-chunking-p *acceptor*)
456 ;; turn chunking on before we read the request body
457 (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
458 (chunked-stream-input-chunking-p *hunchentoot-stream*) t))
459 (t (hunchentoot-error "Client tried to use ~
460 chunked encoding, but acceptor is configured to not use it.")))))
461 (with-acceptor-request-count-incremented (*acceptor*)
462 (process-request (acceptor-make-request *acceptor* socket
463 :headers-in headers-in
464 :content-stream *hunchentoot-stream*
465 :method method
466 :uri url-string
467 :server-protocol protocol))))
468 (finish-output *hunchentoot-stream*)
469 (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*))
470 (when *finish-processing-socket*
471 (return))))))
472 (when *close-hunchentoot-stream*
473 (flet ((close-stream (stream)
474 ;; as we are at the end of the request here, we ignore all
475 ;; errors that may occur while flushing and/or closing the
476 ;; stream.
477 (ignore-errors*
478 (finish-output stream))
479 (ignore-errors*
480 (close stream :abort t))))
481 (unless (or (not *hunchentoot-stream*)
482 (eql socket-stream *hunchentoot-stream*))
483 (close-stream *hunchentoot-stream*))
484 (close-stream socket-stream))))))
485
486 (defmethod acceptor-ssl-p ((acceptor t))
487 ;; the default is to always answer "no"
488 nil)
489
490 (defgeneric acceptor-log-access (acceptor &key return-code)
491 (:documentation
492 "Function to call to log access to the acceptor. The RETURN-CODE,
493 CONTENT and CONTENT-LENGTH keyword arguments contain additional
494 information about the request to log. In addition, it can use the
495 standard request accessor functions that are available to handler
496 functions to find out more information about the request."))
497
498 (defmethod acceptor-log-access ((acceptor acceptor) &key return-code)
499 "Default method for access logging. It logs the information to the
500 destination determined by (ACCEPTOR-ACCESS-LOG-DESTINATION ACCEPTOR)
501 \(unless that value is NIL) in a format that can be parsed by most
502 Apache log analysis tools.)"
503
504 (with-log-stream (stream (acceptor-access-log-destination acceptor) *access-log-lock*)
505 (format stream "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
506 ~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
507 (remote-addr*)
508 (header-in* :x-forwarded-for)
509 (authorization)
510 (iso-time)
511 (request-method*)
512 (script-name*)
513 (query-string*)
514 (server-protocol*)
515 return-code
516 (content-length*)
517 (referer)
518 (user-agent))))
519
520 (defgeneric acceptor-log-message (acceptor log-level format-string &rest format-arguments)
521 (:documentation
522 "Function to call to log messages by the ACCEPTOR. It must accept
523 a severity level for the message, which will be one of :ERROR, :INFO,
524 or :WARNING, a format string and an arbitary number of formatting
525 arguments."))
526
527 (defmethod acceptor-log-message ((acceptor acceptor) log-level format-string &rest format-arguments)
528 "Default function to log server messages. Sends a formatted message
529 to the destination denoted by (ACCEPTOR-MESSAGE-LOG-DESTINATION
530 ACCEPTOR). FORMAT and ARGS are as in FORMAT. LOG-LEVEL is a
531 keyword denoting the log level or NIL in which case it is ignored."
532 (with-log-stream (stream (acceptor-message-log-destination acceptor) *message-log-lock*)
533 (handler-case
534 (format stream "[~A~@[ [~A]~]] ~?~%"
535 (iso-time) log-level
536 format-string format-arguments)
537 (error (e)
538 (ignore-errors
539 (format *trace-output* "error ~A while writing to error log, error not logged~%" e))))))
540
541 (defun log-message* (log-level format-string &rest format-arguments)
542 "Convenience function which calls the message logger of the current
543 acceptor \(if there is one) with the same arguments it accepts.
544
545 This is the function which Hunchentoot itself uses to log errors it
546 catches during request processing."
547 (apply 'acceptor-log-message *acceptor* log-level format-string format-arguments))
548
549 ;; usocket implementation
550
551 #-:lispworks
552 (defmethod start-listening ((acceptor acceptor))
553 (when (acceptor-listen-socket acceptor)
554 (hunchentoot-error "acceptor ~A is already listening" acceptor))
555 (setf (acceptor-listen-socket acceptor)
556 (usocket:socket-listen (or (acceptor-address acceptor)
557 usocket:*wildcard-host*)
558 (acceptor-port acceptor)
559 :reuseaddress t
560 :backlog (acceptor-listen-backlog acceptor)
561 :element-type '(unsigned-byte 8)))
562 (values))
563
564 #-:lispworks
565 (defmethod start-listening :after ((acceptor acceptor))
566 (when (zerop (acceptor-port acceptor))
567 (setf (slot-value acceptor 'port) (usocket:get-local-port (acceptor-listen-socket acceptor)))))
568
569 #-:lispworks
570 (defmethod accept-connections ((acceptor acceptor))
571 (usocket:with-server-socket (listener (acceptor-listen-socket acceptor))
572 (loop
573 (with-lock-held ((acceptor-shutdown-lock acceptor))
574 (when (acceptor-shutdown-p acceptor)
575 (return)))
576 (when (usocket:wait-for-input listener :ready-only t)
577 (when-let (client-connection
578 (handler-case (usocket:socket-accept listener)
579 ;; ignore condition
580 (usocket:connection-aborted-error ())))
581 (set-timeouts client-connection
582 (acceptor-read-timeout acceptor)
583 (acceptor-write-timeout acceptor))
584 (handle-incoming-connection (acceptor-taskmaster acceptor)
585 client-connection))))))
586
587 ;; LispWorks implementation
588
589 #+:lispworks
590 (defmethod start-listening ((acceptor acceptor))
591 (multiple-value-bind (listener-process startup-condition)
592 (comm:start-up-server :service (acceptor-port acceptor)
593 :address (acceptor-address acceptor)
594 :process-name (format nil "Hunchentoot listener \(~A:~A)"
595 (or (acceptor-address acceptor) "*")
596 (acceptor-port acceptor))
597 ;; this function is called once on startup - we
598 ;; use it to check for errors and random port
599 :announce (lambda (socket &optional condition)
600 (when condition
601 (error condition))
602 (when (or (null (acceptor-port acceptor))
603 (zerop (acceptor-port acceptor)))
604 (multiple-value-bind (address port)
605 (comm:get-socket-address socket)
606 (declare (ignore address))
607 (setf (slot-value acceptor 'port) port))))
608 ;; this function is called whenever a connection
609 ;; is made
610 :function (lambda (handle)
611 (unless (acceptor-shutdown-p acceptor)
612 (handle-incoming-connection
613 (acceptor-taskmaster acceptor) handle)))
614 ;; wait until the acceptor was successfully started
615 ;; or an error condition is returned
616 :wait t)
617 (when startup-condition
618 (error startup-condition))
619 (mp:process-stop listener-process)
620 (setf (acceptor-process acceptor) listener-process)
621 (values)))
622
623 #+:lispworks
624 (defmethod accept-connections ((acceptor acceptor))
625 (mp:process-unstop (acceptor-process acceptor))
626 nil)
627
628 (defmethod acceptor-dispatch-request ((acceptor acceptor) request)
629 "Detault implementation of the request dispatch method, generates an
630 +http-not-found+ error."
631 (let ((path (and (acceptor-document-root acceptor)
632 (request-pathname request))))
633 (cond
634 (path
635 (handle-static-file
636 (merge-pathnames (if (equal "/" (script-name request)) #p"index.html" path)
637 (acceptor-document-root acceptor))))
638 (t
639 (setf (return-code *reply*) +http-not-found+)
640 (abort-request-handler)))))
641
642 (defmethod handle-request ((*acceptor* acceptor) (*request* request))
643 "Standard method for request handling. Calls the request dispatcher
644 of *ACCEPTOR* to determine how the request should be handled. Also
645 sets up standard error handling which catches any errors within the
646 handler."
647 (handler-bind ((error
648 (lambda (cond)
649 ;; if the headers were already sent, the error
650 ;; happened within the body and we have to close
651 ;; the stream
652 (when *headers-sent*
653 (setq *finish-processing-socket* t))
654 (throw 'handler-done
655 (values nil cond (get-backtrace))))))
656 (with-debugger
657 (acceptor-dispatch-request *acceptor* *request*))))
658
659 (defgeneric acceptor-status-message (acceptor http-status-code &key &allow-other-keys)
660 (:documentation
661 "This function is called after the request's handler has been
662 invoked to convert the HTTP-STATUS-CODE to a HTML message to be
663 displayed to the user. If this function returns a string, that
664 string is sent to the client instead of the content produced by the
665 handler, if any.
666
667 If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and
668 the directory contains a file corresponding to HTTP-STATUS-CODE
669 named <code>.html, that file is sent to the client after variable
670 substitution. Variables are referenced by ${<variable-name>}.
671
672 Additional keyword arguments may be provided which are made
673 available to the templating logic as substitution variables. These
674 variables can be interpolated into error message templates in,
675 which contains the current URL relative to the server and without
676 GET parameters.
677
678 In addition to the variables corresponding to keyword arguments,
679 the script-name, lisp-implementation-type,
680 lisp-implementation-version and hunchentoot-version variables are
681 available."))
682
683 (defun make-cooked-message (http-status-code &key error backtrace)
684 (labels ((cooked-message (format &rest arguments)
685 (setf (content-type*) "text/html; charset=iso-8859-1")
686 (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~?<p><hr>~A</p></body></html>"
687 http-status-code (reason-phrase http-status-code)
688 format (mapcar (lambda (arg)
689 (if (stringp arg)
690 (escape-for-html arg)
691 arg))
692 arguments)
693 (address-string))))
694 (case http-status-code
695 ((#.+http-moved-temporarily+
696 #.+http-moved-permanently+)
697 (cooked-message "The document has moved <a href='~A'>here</a>" (header-out :location)))
698 ((#.+http-authorization-required+)
699 (cooked-message "The server could not verify that you are authorized to access the document requested. ~
700 Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't ~
701 understand how to supply the credentials required."))
702 ((#.+http-forbidden+)
703 (cooked-message "You don't have permission to access ~A on this server."
704 (script-name *request*)))
705 ((#.+http-not-found+)
706 (cooked-message "The requested URL ~A was not found on this server."
707 (script-name *request*)))
708 ((#.+http-bad-request+)
709 (cooked-message "Your browser sent a request that this server could not understand."))
710 ((#.+http-internal-server-error+)
711 (if *show-lisp-errors-p*
712 (cooked-message "<pre>~A~@[~%~%Backtrace:~%~%~A~]</pre>"
713 (escape-for-html (princ-to-string error))
714 (when *show-lisp-backtraces-p*
715 (escape-for-html (princ-to-string backtrace))))
716 (cooked-message "An error has occurred")))
717 (t
718 (when (<= 400 http-status-code)
719 (cooked-message "An error has occurred"))))))
720
721 (defmethod acceptor-status-message ((acceptor t) http-status-code &rest args &key &allow-other-keys)
722 (apply 'make-cooked-message http-status-code args))
723
724 (defmethod acceptor-status-message :around ((acceptor acceptor) http-status-code &rest args &key &allow-other-keys)
725 (handler-case
726 (call-next-method)
727 (error (e)
728 (log-message* :error "error ~A during error processing, sending cooked message to client" e)
729 (apply 'make-cooked-message http-status-code args))))
730
731 (defun string-as-keyword (string)
732 "Intern STRING as keyword using the reader so that case conversion is done with the reader defaults."
733 (let ((*package* (find-package :keyword)))
734 (read-from-string string)))
735
736 (defmethod acceptor-status-message ((acceptor acceptor) http-status-code &rest properties &key &allow-other-keys)
737 "Default function to generate error message sent to the client."
738 (labels
739 ((substitute-request-context-variables (string)
740 (let ((properties (append `(:script-name ,(script-name*)
741 :lisp-implementation-type ,(lisp-implementation-type)
742 :lisp-implementation-version ,(lisp-implementation-version)
743 :hunchentoot-version ,*hunchentoot-version*)
744 properties)))
745 (unless *show-lisp-backtraces-p*
746 (setf (getf properties :backtrace) nil))
747 (cl-ppcre:regex-replace-all "(?i)\\$\\{([a-z0-9-_]+)\\}"
748 string
749 (lambda (target-string start end match-start match-end reg-starts reg-ends)
750 (declare (ignore start end match-start match-end))
751 (let ((variable-name (string-as-keyword (subseq target-string
752 (aref reg-starts 0)
753 (aref reg-ends 0)))))
754 (escape-for-html (princ-to-string (getf properties variable-name variable-name))))))))
755 (file-contents (file)
756 (let ((buf (make-string (file-length file))))
757 (read-sequence buf file)
758 buf))
759 (error-contents-from-template ()
760 (let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor)
761 (probe-file (make-pathname :name (princ-to-string http-status-code)
762 :type "html"
763 :defaults (acceptor-error-template-directory acceptor))))))
764 (when error-file-template-pathname
765 (with-open-file (file error-file-template-pathname :if-does-not-exist nil :element-type 'character)
766 (when file
767 (setf (content-type*) "text/html")
768 (substitute-request-context-variables (file-contents file))))))))
769 (or (unless (< 300 http-status-code)
770 (call-next-method)) ; don't ever try template for positive return codes
771 (when *show-lisp-errors-p*
772 (error-contents-from-template)) ; try template
773 (call-next-method)))) ; fall back to cooked message
774
775 (defgeneric acceptor-remove-session (acceptor session)
776 (:documentation
777 "This function is called whenever a session in ACCEPTOR is being
778 destroyed because of a session timout or an explicit REMOVE-SESSION
779 call."))
780
781 (defmethod acceptor-remove-session ((acceptor acceptor) (session t))
782 "Default implementation for the session removal hook function. This
783 function is called whenever a session is destroyed."
784 nil)
785
786 (defgeneric acceptor-server-name (acceptor)
787 (:documentation "Returns a string which can be used for 'Server' headers.")
788 (:method ((acceptor acceptor))
789 (format nil "Hunchentoot ~A" *hunchentoot-version*)))