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     (asdf:system-relative-pathname :hunchentoot (format nil "www/~@[~A~]" sub-directory))))
  34
  35 (defclass acceptor ()
  36   ((port :initarg :port
  37          :reader acceptor-port
  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.")
  50    (name :initarg :name
  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
  55 returned by GENSYM.")
  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
  61 symbol REQUEST.")
  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
  67 symbol REPLY.")
  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
  73 underlying Lisp.")
  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.")
 105    #+:lispworks
 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.")
 111    #-:lispworks
 112    (listen-socket :initform nil
 113                   :accessor acceptor-listen-socket
 114                   :documentation "The socket listening for incoming
 115 connections.")
 116    #-:lispworks
 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
 145 suppress logging.")
 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
 160  response.")
 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."))
 166   (:default-initargs
 167    :address nil
 168    :port 80
 169    :name (gensym)
 170    :request-class 'request
 171    :reply-class 'reply
 172    #-lispworks :listen-backlog #-lispworks 50
 173    :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster)
 174                                     (t 'single-threaded-taskmaster)))
 175    :output-chunking-p t
 176    :input-chunking-p t
 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.
 190
 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
 193 same time."))
 194
 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))))
 199
 200 (defgeneric start (acceptor)
 201   (:documentation "Starts the ACCEPTOR so that it begins accepting
 202 connections.  Returns the acceptor."))
 203
 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 not
 208 accept new requests.  Note that SOFT must not be set when calling
 209 STOP from within a request handler, as that will deadlock."))
 210
 211 (defgeneric start-listening (acceptor)
 212   (:documentation "Sets up a listen socket for the given ACCEPTOR and
 213 enables it to listen to incoming connections.  This function is called
 214 from the thread that starts the acceptor initially and may return
 215 errors resulting from the listening operation \(like 'address in use'
 216 or similar)."))
 217
 218 (defgeneric accept-connections (acceptor)
 219   (:documentation "In a loop, accepts a connection and hands it over
 220 to the acceptor's taskmaster for processing using
 221 HANDLE-INCOMING-CONNECTION.  On LispWorks, this function returns
 222 immediately, on other Lisps it retusn only once the acceptor has been
 223 stopped."))
 224
 225 (defgeneric initialize-connection-stream (acceptor stream)
 226  (:documentation "Can be used to modify the stream which is used to
 227 communicate between client and server before the request is read.  The
 228 default method of ACCEPTOR does nothing, but see for example the
 229 method defined for SSL-ACCEPTOR.  All methods of this generic function
 230 must return the stream to use."))
 231
 232 (defgeneric reset-connection-stream (acceptor stream)
 233   (:documentation "Resets the stream which is used to communicate
 234 between client and server after one request has been served so that it
 235 can be used to process the next request.  This generic function is
 236 called after a request has been processed and must return the
 237 stream."))
 238
 239 (defgeneric process-connection (acceptor socket)
 240   (:documentation "This function is called by the taskmaster when a
 241 new client connection has been established.  Its arguments are the
 242 ACCEPTOR object and a LispWorks socket handle or a usocket socket
 243 stream object in SOCKET.  It reads the request headers, sets up the
 244 request and reply objects, and hands over to PROCESS-REQUEST.  This is
 245 done in a loop until the stream has to be closed or until a connection
 246 timeout occurs.
 247
 248 It is probably not a good idea to re-implement this method until you
 249 really, really know what you're doing."))
 250
 251 (defgeneric handle-request (acceptor request)
 252   (:documentation "This function is called once the request has been
 253 read and a REQUEST object has been created.  Its job is to set up
 254 standard error handling and request logging.
 255
 256 Might be a good place for around methods specialized for your subclass
 257 of ACCEPTOR which bind or rebind special variables which can then be
 258 accessed by your handlers."))
 259
 260 (defgeneric acceptor-dispatch-request (acceptor request)
 261   (:documentation "This function is called to actually dispatch the
 262 request once the standard logging and error handling has been set up.
 263 ACCEPTOR subclasses implement methods for this function in order to
 264 perform their own request routing.  If a method does not want to
 265 handle the request, it is supposed to invoke CALL-NEXT-METHOD so that
 266 the next ACCEPTOR in the inheritance chain gets a chance to handle the
 267 request."))
 268
 269 (defgeneric acceptor-ssl-p (acceptor)
 270   (:documentation "Returns a true value if ACCEPTOR uses SSL
 271 connections.  The default is to unconditionally return NIL and
 272 subclasses of ACCEPTOR must specialize this method to signal that
 273 they're using secure connections - see the SSL-ACCEPTOR class."))
 274
 275 ;; general implementation
 276
 277 (defmethod start ((acceptor acceptor))
 278   (setf (acceptor-shutdown-p acceptor) nil)
 279   (start-listening acceptor)
 280   (let ((taskmaster (acceptor-taskmaster acceptor)))
 281     (setf (taskmaster-acceptor taskmaster) acceptor)
 282     (execute-acceptor taskmaster))
 283   acceptor)
 284
 285 (defmethod stop ((acceptor acceptor) &key soft)
 286   (setf (acceptor-shutdown-p acceptor) t)
 287   (shutdown (acceptor-taskmaster acceptor))
 288   (when soft
 289     (with-lock-held ((acceptor-shutdown-lock acceptor))
 290       (when (plusp (accessor-requests-in-progress acceptor))
 291         (condition-variable-wait (acceptor-shutdown-queue acceptor)
 292                                  (acceptor-shutdown-lock acceptor)))))
 293   #-lispworks
 294   (usocket:socket-close (acceptor-listen-socket acceptor))
 295   #-lispworks
 296   (setf (acceptor-listen-socket acceptor) nil)
 297   #+lispworks
 298   (mp:process-kill (acceptor-process acceptor))
 299   acceptor)
 300
 301 (defmethod initialize-connection-stream ((acceptor acceptor) stream)
 302  ;; default method does nothing
 303  stream)
 304
 305 (defmethod reset-connection-stream ((acceptor acceptor) stream)
 306   ;; turn chunking off at this point
 307   (cond ((typep stream 'chunked-stream)
 308          ;; flush the stream first and check if there's unread input
 309          ;; which would be an error
 310          (setf (chunked-stream-output-chunking-p stream) nil
 311                (chunked-stream-input-chunking-p stream) nil)
 312          ;; switch back to bare socket stream
 313          (chunked-stream-stream stream))
 314         (t stream)))
 315
 316 (defmethod process-connection :around ((*acceptor* acceptor) (socket t))
 317   ;; this around method is used for error handling
 318   ;; note that this method also binds *ACCEPTOR*
 319   (with-conditions-caught-and-logged ()
 320     (with-mapped-conditions ()
 321       (call-next-method))))
 322
 323 (defun do-with-acceptor-request-count-incremented (*acceptor* function)
 324   (with-lock-held ((acceptor-shutdown-lock *acceptor*))
 325     (incf (accessor-requests-in-progress *acceptor*)))
 326   (unwind-protect
 327        (funcall function)
 328     (with-lock-held ((acceptor-shutdown-lock *acceptor*))
 329       (decf (accessor-requests-in-progress *acceptor*))
 330       (when (acceptor-shutdown-p *acceptor*)
 331         (condition-variable-signal (acceptor-shutdown-queue *acceptor*))))))
 332
 333 (defmacro with-acceptor-request-count-incremented ((acceptor) &body body)
 334   "Execute BODY with ACCEPTOR-REQUESTS-IN-PROGRESS of ACCEPTOR
 335   incremented by one.  If the ACCEPTOR-SHUTDOWN-P returns true after
 336   the BODY has been executed, the ACCEPTOR-SHUTDOWN-QUEUE condition
 337   variable of the ACCEPTOR is signalled in order to finish shutdown
 338   processing."
 339   `(do-with-acceptor-request-count-incremented ,acceptor (lambda () ,@body)))
 340
 341 (defun acceptor-make-request (acceptor socket
 342                               &key
 343                                   headers-in
 344                                   content-stream
 345                                   method
 346                                   uri
 347                                   server-protocol)
 348   "Make a REQUEST instance for the ACCEPTOR, setting up those slots
 349   that are determined from the SOCKET by calling the appropriate
 350   socket query functions."
 351   (multiple-value-bind (remote-addr remote-port)
 352       (get-peer-address-and-port socket)
 353     (multiple-value-bind (local-addr local-port)
 354         (get-local-address-and-port socket)
 355       (make-instance (acceptor-request-class acceptor)
 356                      :acceptor acceptor
 357                      :local-addr local-addr
 358                      :local-port local-port
 359                      :remote-addr remote-addr
 360                      :remote-port remote-port
 361                      :headers-in headers-in
 362                      :content-stream content-stream
 363                      :method method
 364                      :uri uri
 365                      :server-protocol server-protocol))))
 366
 367 (defmethod process-connection ((*acceptor* acceptor) (socket t))
 368   (let ((*hunchentoot-stream* (make-socket-stream socket *acceptor*)))
 369     (unwind-protect
 370         ;; process requests until either the acceptor is shut down,
 371         ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
 372         ;; handler, or the peer fails to send a request
 373         (let ((*hunchentoot-stream* (initialize-connection-stream *acceptor* *hunchentoot-stream*)))
 374           (loop
 375              (let ((*close-hunchentoot-stream* t))
 376                (when (acceptor-shutdown-p *acceptor*)
 377                  (return))
 378                (multiple-value-bind (headers-in method url-string protocol)
 379                    (get-request-data *hunchentoot-stream*)
 380                  ;; check if there was a request at all
 381                  (unless method
 382                    (return))
 383                  ;; bind per-request special variables, then process the
 384                  ;; request - note that *ACCEPTOR* was bound above already
 385                  (let ((*reply* (make-instance (acceptor-reply-class *acceptor*)))
 386                        (*session* nil)
 387                        (transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
 388                    (when transfer-encodings
 389                      (setq transfer-encodings
 390                            (split "\\s*,\\s*" transfer-encodings))
 391                      (when (member "chunked" transfer-encodings :test #'equalp)
 392                        (cond ((acceptor-input-chunking-p *acceptor*)
 393                               ;; turn chunking on before we read the request body
 394                               (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
 395                                     (chunked-stream-input-chunking-p *hunchentoot-stream*) t))
 396                              (t (hunchentoot-error "Client tried to use ~
 397 chunked encoding, but acceptor is configured to not use it.")))))
 398                    (with-acceptor-request-count-incremented (*acceptor*)
 399                      (process-request (acceptor-make-request *acceptor* socket
 400                                                              :headers-in headers-in
 401                                                              :content-stream *hunchentoot-stream*
 402                                                              :method method
 403                                                              :uri url-string
 404                                                              :server-protocol protocol))))
 405                  (finish-output *hunchentoot-stream*)
 406                  (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*))
 407                  (when *close-hunchentoot-stream*
 408                    (return))))))
 409       (when *hunchentoot-stream*
 410         ;; as we are at the end of the request here, we ignore all
 411         ;; errors that may occur while flushing and/or closing the
 412         ;; stream.
 413         (ignore-errors*
 414           (finish-output *hunchentoot-stream*))
 415         (ignore-errors*
 416           (close *hunchentoot-stream* :abort t))))))
 417
 418 (defmethod acceptor-ssl-p ((acceptor t))
 419   ;; the default is to always answer "no"
 420   nil)
 421
 422 (defgeneric acceptor-log-access (acceptor &key return-code)
 423   (:documentation
 424    "Function to call to log access to the acceptor.  The RETURN-CODE,
 425 CONTENT and CONTENT-LENGTH keyword arguments contain additional
 426 information about the request to log.  In addition, it can use the
 427 standard request accessor functions that are available to handler
 428 functions to find out more information about the request."))
 429
 430 (defmethod acceptor-log-access ((acceptor acceptor) &key return-code)
 431   "Default method for access logging.  It logs the information to the
 432 destination determined by (ACCEPTOR-ACCESS-LOG-DESTINATION ACCEPTOR)
 433 \(unless that value is NIL) in a format that can be parsed by most
 434 Apache log analysis tools.)"
 435
 436   (with-log-stream (stream (acceptor-access-log-destination acceptor) *access-log-lock*)
 437     (format stream "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
 438                     ~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
 439             (remote-addr*)
 440             (header-in* :x-forwarded-for)
 441             (authorization)
 442             (iso-time)
 443             (request-method*)
 444             (script-name*)
 445             (query-string*)
 446             (server-protocol*)
 447             return-code
 448             (content-length*)
 449             (referer)
 450             (user-agent))))
 451
 452 (defgeneric acceptor-log-message (acceptor log-level format-string &rest format-arguments)
 453   (:documentation
 454    "Function to call to log messages by the ACCEPTOR.  It must accept
 455 a severity level for the message, which will be one of :ERROR, :INFO,
 456 or :WARNING, a format string and an arbitary number of formatting
 457 arguments."))
 458
 459 (defmethod acceptor-log-message ((acceptor acceptor) log-level format-string &rest format-arguments)
 460   "Default function to log server messages.  Sends a formatted message
 461   to the destination denoted by (ACCEPTOR-MESSAGE-LOG-DESTINATION
 462   ACCEPTOR).  FORMAT and ARGS are as in FORMAT.  LOG-LEVEL is a
 463   keyword denoting the log level or NIL in which case it is ignored."
 464   (with-log-stream (stream (acceptor-message-log-destination acceptor) *message-log-lock*)
 465     (handler-case
 466         (format stream "[~A~@[ [~A]~]] ~?~%"
 467                 (iso-time) log-level
 468                 format-string format-arguments)
 469       (error (e)
 470         (ignore-errors
 471          (format *trace-output* "error ~A while writing to error log, error not logged~%" e))))))
 472
 473 (defun log-message* (log-level format-string &rest format-arguments)
 474   "Convenience function which calls the message logger of the current
 475 acceptor \(if there is one) with the same arguments it accepts.
 476
 477 This is the function which Hunchentoot itself uses to log errors it
 478 catches during request processing."
 479   (apply 'acceptor-log-message *acceptor* log-level format-string format-arguments))
 480
 481 ;; usocket implementation
 482
 483 #-:lispworks
 484 (defmethod start-listening ((acceptor acceptor))
 485   (when (acceptor-listen-socket acceptor)
 486     (hunchentoot-error "acceptor ~A is already listening" acceptor))
 487   (setf (acceptor-listen-socket acceptor)
 488         (usocket:socket-listen (or (acceptor-address acceptor)
 489                                    usocket:*wildcard-host*)
 490                                (acceptor-port acceptor)
 491                                :reuseaddress t
 492                                :backlog (acceptor-listen-backlog acceptor)
 493                                :element-type '(unsigned-byte 8)))
 494   (values))
 495
 496 #-:lispworks
 497 (defmethod accept-connections ((acceptor acceptor))
 498   (usocket:with-server-socket (listener (acceptor-listen-socket acceptor))
 499     (loop
 500      (when (acceptor-shutdown-p acceptor)
 501        (return))
 502      (when (usocket:wait-for-input listener :ready-only t :timeout +new-connection-wait-time+)
 503        (when-let (client-connection
 504                   (handler-case (usocket:socket-accept listener)
 505                     ;; ignore condition
 506                     (usocket:connection-aborted-error ())))
 507          (set-timeouts client-connection
 508                        (acceptor-read-timeout acceptor)
 509                        (acceptor-write-timeout acceptor))
 510          (handle-incoming-connection (acceptor-taskmaster acceptor)
 511                                      client-connection))))))
 512
 513 ;; LispWorks implementation
 514
 515 #+:lispworks
 516 (defmethod start-listening ((acceptor acceptor))
 517   (multiple-value-bind (listener-process startup-condition)
 518       (comm:start-up-server :service (acceptor-port acceptor)
 519                             :address (acceptor-address acceptor)
 520                             :process-name (format nil "Hunchentoot listener \(~A:~A)"
 521                                                   (or (acceptor-address acceptor) "*")
 522                                                   (acceptor-port acceptor))
 523                             ;; this function is called once on startup - we
 524                             ;; use it to check for errors
 525                             :announce (lambda (socket &optional condition)
 526                                         (declare (ignore socket))
 527                                         (when condition
 528                                           (error condition)))
 529                             ;; this function is called whenever a connection
 530                             ;; is made
 531                             :function (lambda (handle)
 532                                         (unless (acceptor-shutdown-p acceptor)
 533                                           (handle-incoming-connection
 534                                            (acceptor-taskmaster acceptor) handle)))
 535                             ;; wait until the acceptor was successfully started
 536                             ;; or an error condition is returned
 537                             :wait t)
 538     (when startup-condition
 539       (error startup-condition))
 540     (mp:process-stop listener-process)
 541     (setf (acceptor-process acceptor) listener-process)
 542     (values)))
 543
 544 #+:lispworks
 545 (defmethod accept-connections ((acceptor acceptor))
 546   (mp:process-unstop (acceptor-process acceptor))
 547   nil)
 548
 549 (defmethod acceptor-dispatch-request ((acceptor acceptor) request)
 550   "Detault implementation of the request dispatch method, generates an
 551 +http-not-found+ error."
 552   (if (acceptor-document-root acceptor)
 553       (let ((path (request-pathname request)))
 554         (if (not path)
 555             (setf (return-code *reply*) +http-forbidden+)
 556             (handle-static-file
 557              (merge-pathnames (if (equal "/" (script-name request)) #p"index.html" path)
 558                               (acceptor-document-root acceptor)))))
 559       (setf (return-code *reply*) +http-not-found+)))
 560
 561 (defmethod handle-request ((*acceptor* acceptor) (*request* request))
 562   "Standard method for request handling.  Calls the request dispatcher
 563 of *ACCEPTOR* to determine how the request should be handled.  Also
 564 sets up standard error handling which catches any errors within the
 565 handler."
 566   (handler-bind ((error
 567                   (lambda (cond)
 568                     ;; if the headers were already sent, the error
 569                     ;; happened within the body and we have to close
 570                     ;; the stream
 571                     (when *headers-sent*
 572                       (setq *close-hunchentoot-stream* t))
 573                     (throw 'handler-done
 574                       (values nil cond (get-backtrace)))))
 575                  (warning
 576                   (lambda (cond)
 577                     (when *log-lisp-warnings-p*
 578                       (log-message* *lisp-warnings-log-level* "~A" cond)))))
 579     (with-debugger
 580       (acceptor-dispatch-request *acceptor* *request*))))
 581
 582 (defgeneric acceptor-status-message (acceptor http-status-code &key &allow-other-keys)
 583   (:documentation
 584    "This function is called after the request's handler has been
 585    invoked to convert the HTTP-STATUS-CODE to a HTML message to be
 586    displayed to the user.  If this function returns a string, that
 587    string is sent to the client instead of the content produced by the
 588    handler, if any.
 589
 590    If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and
 591    the directory contains a file corresponding to HTTP-STATUS-CODE
 592    named <code>.html, that file is sent to the client after variable
 593    substitution.  Variables are referenced by ${<variable-name>}.
 594
 595    Additional keyword arguments may be provided which are made
 596    available to the templating logic as substitution variables.  These
 597    variables can be interpolated into error message templates in,
 598    which contains the current URL relative to the server and without
 599    GET parameters.
 600
 601    In addition to the variables corresponding to keyword arguments,
 602    the script-name, lisp-implementation-type,
 603    lisp-implementation-version and hunchentoot-version variables are
 604    available."))
 605
 606 (defun make-cooked-message (http-status-code &key error backtrace)
 607   (labels ((cooked-message (format &rest arguments)
 608              (setf (content-type*) "text/html; charset=iso-8859-1")
 609              (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~?<p><hr>~A</p></body></html>"
 610                      http-status-code (reason-phrase http-status-code)
 611                      format (mapcar (lambda (arg)
 612                                       (if (stringp arg)
 613                                           (escape-for-html arg)
 614                                           arg))
 615                                     arguments)
 616                      (address-string))))
 617     (case http-status-code
 618       ((#.+http-moved-temporarily+
 619         #.+http-moved-permanently+)
 620        (cooked-message "The document has moved <a href='~A'>here</a>" (header-out :location)))
 621       ((#.+http-authorization-required+)
 622        (cooked-message "The server could not verify that you are authorized to access the document requested.  ~
 623                         Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't ~
 624                         understand how to supply the credentials required."))
 625       ((#.+http-forbidden+)
 626        (cooked-message "You don't have permission to access ~A on this server."
 627                        (script-name *request*)))
 628       ((#.+http-not-found+)
 629        (cooked-message "The requested URL ~A was not found on this server."
 630                        (script-name *request*)))
 631       ((#.+http-bad-request+)
 632        (cooked-message "Your browser sent a request that this server could not understand."))
 633       ((#.+http-internal-server-error+)
 634        (if *show-lisp-errors-p*
 635            (cooked-message "<pre>~A~@[~%~%Backtrace:~%~%~A~]</pre>"
 636                            (escape-for-html (princ-to-string error))
 637                            (when *show-lisp-backtraces-p*
 638                              (escape-for-html (princ-to-string backtrace))))
 639            (cooked-message "An error has occurred")))
 640       (t
 641          (when (<= 400 http-status-code)
 642            (cooked-message "An error has occurred"))))))
 643
 644 (defmethod acceptor-status-message ((acceptor t) http-status-code &rest args &key &allow-other-keys)
 645   (apply 'make-cooked-message http-status-code args))
 646
 647 (defmethod acceptor-status-message :around ((acceptor acceptor) http-status-code &rest args &key &allow-other-keys)
 648   (handler-case
 649       (call-next-method)
 650     (error (e)
 651       (log-message* :error "error ~A during error processing, sending cooked message to client" e)
 652       (apply 'make-cooked-message http-status-code args))))
 653
 654 (defun string-as-keyword (string)
 655   "Intern STRING as keyword using the reader so that case conversion is done with the reader defaults."
 656   (let ((*package* (find-package :keyword)))
 657     (read-from-string string)))
 658
 659 (defmethod acceptor-status-message ((acceptor acceptor) http-status-code &rest properties &key &allow-other-keys)
 660   "Default function to generate error message sent to the client."
 661   (labels
 662       ((substitute-request-context-variables (string)
 663          (let ((properties (append `(:script-name ,(script-name*)
 664                                      :lisp-implementation-type ,(lisp-implementation-type)
 665                                      :lisp-implementation-version ,(lisp-implementation-version)
 666                                      :hunchentoot-version ,*hunchentoot-version*)
 667                                    properties)))
 668            (cl-ppcre:regex-replace-all "(?i)\\$\\{([a-z0-9-_]+)\\}"
 669                                        string
 670                                        (lambda (target-string start end match-start match-end reg-starts reg-ends)
 671                                          (declare (ignore start end match-start match-end))
 672                                          (let ((variable-name (string-as-keyword (subseq target-string
 673                                                                                          (aref reg-starts 0)
 674                                                                                          (aref reg-ends 0)))))
 675                                            (escape-for-html (princ-to-string (getf properties variable-name variable-name))))))))
 676        (file-contents (file)
 677          (let ((buf (make-string (file-length file))))
 678            (read-sequence buf file)
 679            buf))
 680        (error-contents-from-template ()
 681          (let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor)
 682                                                   (probe-file (make-pathname :name (princ-to-string http-status-code)
 683                                                                              :type "html"
 684                                                                              :defaults (acceptor-error-template-directory acceptor))))))
 685            (when error-file-template-pathname
 686              (with-open-file (file error-file-template-pathname :if-does-not-exist nil :element-type 'character)
 687                (when file
 688                  (setf (content-type*) "text/html")
 689                  (substitute-request-context-variables (file-contents file))))))))
 690     (or (unless (< 300 http-status-code)
 691           (call-next-method))           ; don't ever try template for positive return codes
 692         (error-contents-from-template)  ; try template
 693         (call-next-method))))           ; fall back to cooked message
 694
 695 (defgeneric acceptor-remove-session (acceptor session)
 696   (:documentation
 697    "This function is called whenever a session in ACCEPTOR is being
 698    destroyed because of a session timout or an explicit REMOVE-SESSION
 699    call."))
 700
 701 (defmethod acceptor-remove-session ((acceptor acceptor) (session t))
 702   "Default implementation for the session removal hook function.  This
 703 function is called whenever a session is destroyed."
 704   )
 705
 706 (defgeneric acceptor-server-name (acceptor)
 707   (:documentation "Returns a string which can be used for 'Server' headers.")
 708   (:method ((acceptor acceptor))
 709     (format nil "Hunchentoot ~A" *hunchentoot-version*)))