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