acceptor.lisp

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