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    #-:lispworks
 118    (listen-backlog :initarg :listen-backlog
 119                    :reader acceptor-listen-backlog
 120                    :documentation "Number of pending connections
 121           allowed in the listen socket before the kernel rejects
 122           further incoming connections.")
 123    (acceptor-shutdown-p :initform t
 124                         :accessor acceptor-shutdown-p
 125                         :documentation "A flag that makes the acceptor
 126 shutdown itself when set to something other than NIL.")
 127    (requests-in-progress :initform 0
 128                          :accessor accessor-requests-in-progress
 129                          :documentation "The number of
 130 requests currently in progress.")
 131    (shutdown-queue :initform (make-condition-variable)
 132                    :accessor acceptor-shutdown-queue
 133                    :documentation "A condition variable
 134 used with soft shutdown, signaled when all requests
 135 have been processed.")
 136    (shutdown-lock :initform (make-lock "hunchentoot-acceptor-shutdown")
 137                   :accessor acceptor-shutdown-lock
 138                   :documentation "The lock protecting the shutdown-queue
 139 condition variable and the requests-in-progress counter.")
 140    (access-log-destination :initarg :access-log-destination
 141                         :accessor acceptor-access-log-destination
 142                         :documentation "Destination of the access log
 143 which contains one log entry per request handled in a format similar
 144 to Apache's access.log.  Can be set to a pathname or string
 145 designating the log file, to a open output stream or to NIL to
 146 suppress logging.")
 147    (message-log-destination :initarg :message-log-destination
 148                          :accessor acceptor-message-log-destination
 149                          :documentation "Destination of the server
 150 error log which is used to log informational, warning and error
 151 messages in a free-text format intended for human inspection. Can be
 152 set to a pathname or string designating the log file, to a open output
 153 stream or to NIL to suppress logging.")
 154    (error-template-directory :initarg :error-template-directory
 155                              :accessor acceptor-error-template-directory
 156                              :documentation "Directory pathname that
 157  contains error message template files for server-generated error
 158  messages.  Files must be named <return-code>.html with <return-code>
 159  representing the HTTP return code that the file applies to,
 160  i.e. 404.html would be used as the content for a HTTP 404 Not found
 161  response.")
 162    (document-root :initarg :document-root
 163                   :accessor acceptor-document-root
 164                   :documentation "Directory pathname that points to
 165 files that are served by the acceptor if no more specific
 166 acceptor-dispatch-request method handles the request."))
 167   (:default-initargs
 168    :address nil
 169    :port 80
 170    :name (gensym)
 171    :request-class 'request
 172    :reply-class 'reply
 173    :listen-backlog 50
 174    :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster)
 175                                     (t 'single-threaded-taskmaster)))
 176    :output-chunking-p t
 177    :input-chunking-p t
 178    :persistent-connections-p t
 179    :read-timeout *default-connection-timeout*
 180    :write-timeout *default-connection-timeout*
 181    :access-log-destination *error-output*
 182    :message-log-destination *error-output*
 183    :document-root (load-time-value (default-document-directory))
 184    :error-template-directory (load-time-value (default-document-directory "errors/")))
 185   (:documentation "To create a Hunchentoot webserver, you make an
 186 instance of this class and use the generic function START to start it
 187 \(and STOP to stop it).  Use the :PORT initarg if you don't want to
 188 listen on the default http port 80.  There are other initargs most of
 189 which you probably won't need very often.  They are explained in
 190 detail in the docstrings of the slot definitions for this class.
 191
 192 Unless you are in a Lisp without MP capabilities, you can have several
 193 active instances of ACCEPTOR \(listening on different ports) at the
 194 same time."))
 195
 196 (defmethod print-object ((acceptor acceptor) stream)
 197   (print-unreadable-object (acceptor stream :type t)
 198     (format stream "\(host ~A, port ~A)"
 199             (or (acceptor-address acceptor) "*") (acceptor-port acceptor))))
 200
 201 (defgeneric start (acceptor)
 202   (:documentation "Starts the ACCEPTOR so that it begins accepting
 203 connections.  Returns the acceptor."))
 204
 205 (defgeneric stop (acceptor &key soft)
 206   (:documentation "Stops the ACCEPTOR so that it no longer accepts
 207 requests.  If SOFT is true, and there are any requests in progress,
 208 wait until all requests are fully processed, but meanwhile do
 209 not accept new requests."))
 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 actually
 254 handle the request, i.e. to return something to the client.
 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-ssl-p (acceptor)
 261   (:documentation "Returns a true value if ACCEPTOR uses SSL
 262 connections.  The default is to unconditionally return NIL and
 263 subclasses of ACCEPTOR must specialize this method to signal that
 264 they're using secure connections - see the SSL-ACCEPTOR class."))
 265
 266 ;; general implementation
 267
 268 (defmethod start ((acceptor acceptor))
 269   (setf (acceptor-shutdown-p acceptor) nil)
 270   (start-listening acceptor)
 271   (let ((taskmaster (acceptor-taskmaster acceptor)))
 272     (setf (taskmaster-acceptor taskmaster) acceptor)
 273     (execute-acceptor taskmaster))
 274   acceptor)
 275
 276 (defmethod stop ((acceptor acceptor) &key soft)
 277   (setf (acceptor-shutdown-p acceptor) t)
 278   (shutdown (acceptor-taskmaster acceptor))
 279   (when soft
 280     (with-lock-held ((acceptor-shutdown-lock acceptor))
 281       (when (plusp (accessor-requests-in-progress acceptor))
 282         (condition-variable-wait (acceptor-shutdown-queue acceptor)
 283                                  (acceptor-shutdown-lock acceptor)))))
 284   (#+:lispworks close
 285    #-:lispworks usocket:socket-close
 286    (acceptor-listen-socket acceptor))
 287   (setf (acceptor-listen-socket acceptor) nil)
 288   acceptor)
 289
 290 (defmethod initialize-connection-stream ((acceptor acceptor) stream)
 291  (declare (ignore acceptor))
 292  ;; default method does nothing
 293  stream)
 294
 295 (defmethod reset-connection-stream ((acceptor acceptor) stream)
 296   (declare (ignore acceptor))
 297   ;; turn chunking off at this point
 298   (cond ((typep stream 'chunked-stream)
 299          ;; flush the stream first and check if there's unread input
 300          ;; which would be an error
 301          (setf (chunked-stream-output-chunking-p stream) nil
 302                (chunked-stream-input-chunking-p stream) nil)
 303          ;; switch back to bare socket stream
 304          (chunked-stream-stream stream))
 305         (t stream)))
 306
 307 (defmethod process-connection :around ((*acceptor* acceptor) (socket t))
 308   ;; this around method is used for error handling
 309   (declare (ignore socket))
 310   ;; note that this method also binds *ACCEPTOR*
 311   (handler-bind ((error
 312                   ;; abort if there's an error which isn't caught inside
 313                   (lambda (cond)
 314                     (log-message* *lisp-errors-log-level*
 315                                   "Error while processing connection: ~A" cond)
 316                     (return-from process-connection)))
 317                  (warning
 318                   ;; log all warnings which aren't caught inside
 319                   (lambda (cond)
 320                     (log-message* *lisp-warnings-log-level*
 321                                   "Warning while processing connection: ~A" cond))))
 322     (with-mapped-conditions ()
 323       (call-next-method))))
 324
 325 (defun do-with-acceptor-request-count-incremented (*acceptor* function)
 326   (with-lock-held ((acceptor-shutdown-lock *acceptor*))
 327     (incf (accessor-requests-in-progress *acceptor*)))
 328   (unwind-protect
 329        (funcall function)
 330     (with-lock-held ((acceptor-shutdown-lock *acceptor*))
 331       (decf (accessor-requests-in-progress *acceptor*))
 332       (when (acceptor-shutdown-p *acceptor*)
 333         (condition-variable-signal (acceptor-shutdown-queue *acceptor*))))))
 334
 335 (defmacro with-acceptor-request-count-incremented ((acceptor) &body body)
 336   "Execute BODY with ACCEPTOR-REQUESTS-IN-PROGRESS of ACCEPTOR
 337   incremented by one.  If the ACCEPTOR-SHUTDOWN-P returns true after
 338   the BODY has been executed, the ACCEPTOR-SHUTDOWN-QUEUE condition
 339   variable of the ACCEPTOR is signalled in order to finish shutdown
 340   processing."
 341   `(do-with-acceptor-request-count-incremented ,acceptor (lambda () ,@body)))
 342
 343 (defmethod process-connection ((*acceptor* acceptor) (socket t))
 344   (let ((*hunchentoot-stream*
 345          (initialize-connection-stream *acceptor* (make-socket-stream socket *acceptor*))))
 346     (unwind-protect
 347         ;; process requests until either the acceptor is shut down,
 348         ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
 349         ;; handler, or the peer fails to send a request
 350         (loop
 351           (let ((*close-hunchentoot-stream* t))
 352             (when (acceptor-shutdown-p *acceptor*)
 353               (return))
 354             (multiple-value-bind (headers-in method url-string protocol)
 355                 (get-request-data *hunchentoot-stream*)
 356               ;; check if there was a request at all
 357               (unless method
 358                 (return))
 359               ;; bind per-request special variables, then process the
 360               ;; request - note that *ACCEPTOR* was bound above already
 361               (let ((*reply* (make-instance (acceptor-reply-class *acceptor*)))
 362                     (*session* nil)
 363                     (transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
 364                 (when transfer-encodings
 365                   (setq transfer-encodings
 366                         (split "\\s*,\\s*" transfer-encodings))
 367                   (when (member "chunked" transfer-encodings :test #'equalp)
 368                     (cond ((acceptor-input-chunking-p *acceptor*)
 369                            ;; turn chunking on before we read the request body
 370                            (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
 371                                  (chunked-stream-input-chunking-p *hunchentoot-stream*) t))
 372                           (t (hunchentoot-error "Client tried to use ~
 373 chunked encoding, but acceptor is configured to not use it.")))))
 374                 (multiple-value-bind (remote-addr remote-port)
 375                     (get-peer-address-and-port socket)
 376                   (with-acceptor-request-count-incremented (*acceptor*)
 377                     (process-request (make-instance (acceptor-request-class *acceptor*)
 378                                                     :acceptor *acceptor*
 379                                                     :remote-addr remote-addr
 380                                                     :remote-port remote-port
 381                                                     :headers-in headers-in
 382                                                     :content-stream *hunchentoot-stream*
 383                                                     :method method
 384                                                     :uri url-string
 385                                                     :server-protocol protocol)))))
 386               (force-output *hunchentoot-stream*)
 387               (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*))
 388               (when *close-hunchentoot-stream*
 389                 (return)))))
 390       (when *hunchentoot-stream*
 391         ;; as we are at the end of the request here, we ignore all
 392         ;; errors that may occur while flushing and/or closing the
 393         ;; stream.
 394         (ignore-errors*
 395           (force-output *hunchentoot-stream*))
 396         (ignore-errors*
 397           (close *hunchentoot-stream* :abort t))))))
 398
 399 (defmethod acceptor-ssl-p ((acceptor t))
 400   ;; the default is to always answer "no"
 401   nil)
 402
 403 (defgeneric acceptor-log-access (acceptor &key return-code)
 404   (:documentation
 405    "Function to call to log access to the acceptor.  The RETURN-CODE,
 406 CONTENT and CONTENT-LENGTH keyword arguments contain additional
 407 information about the request to log.  In addition, it can use the
 408 standard request accessor functions that are available to handler
 409 functions to find out more information about the request."))
 410
 411 (defmethod acceptor-log-access ((acceptor acceptor) &key return-code)
 412   "Default method for access logging.  It logs the information to the
 413 destination determined by (ACCEPTOR-ACCESS-LOG-DESTINATION ACCEPTOR)
 414 \(unless that value is NIL) in a format that can be parsed by most
 415 Apache log analysis tools.)"
 416
 417   (with-log-stream (stream (acceptor-access-log-destination acceptor) *access-log-lock*)
 418     (format stream "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
 419                     ~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
 420             (remote-addr*)
 421             (header-in* :x-forwarded-for)
 422             (authorization)
 423             (iso-time)
 424             (request-method*)
 425             (script-name*)
 426             (query-string*)
 427             (server-protocol*)
 428             return-code
 429             (content-length*)
 430             (referer)
 431             (user-agent))))
 432
 433 (defgeneric acceptor-log-message (acceptor log-level format-string &rest format-arguments)
 434   (:documentation
 435    "Function to call to log messages by the ACCEPTOR.  It must accept
 436 a severity level for the message, which will be one of :ERROR, :INFO,
 437 or :WARNING, a format string and an arbitary number of formatting
 438 arguments."))
 439
 440 (defmethod acceptor-log-message ((acceptor acceptor) log-level format-string &rest format-arguments)
 441   "Default function to log server messages.  Sends a formatted message
 442   to the destination denoted by (ACCEPTOR-MESSAGE-LOG-DESTINATION
 443   ACCEPTOR).  FORMAT and ARGS are as in FORMAT.  LOG-LEVEL is a
 444   keyword denoting the log level or NIL in which case it is ignored."
 445   (with-log-stream (stream (acceptor-message-log-destination acceptor) *message-log-lock*)
 446     (format stream "[~A~@[ [~A]~]] ~?~%"
 447             (iso-time) log-level
 448             format-string format-arguments)))
 449
 450 (defun log-message* (log-level format-string &rest format-arguments)
 451   "Convenience function which calls the message logger of the current
 452 acceptor \(if there is one) with the same arguments it accepts.
 453
 454 This is the function which Hunchentoot itself uses to log errors it
 455 catches during request processing."
 456   (apply 'acceptor-log-message *acceptor* log-level format-string format-arguments))
 457
 458 ;; usocket implementation
 459
 460 #-:lispworks
 461 (defmethod start-listening ((acceptor acceptor))
 462   (when (acceptor-listen-socket acceptor)
 463     (hunchentoot-error "acceptor ~A is already listening" acceptor))
 464   (setf (acceptor-listen-socket acceptor)
 465         (usocket:socket-listen (or (acceptor-address acceptor)
 466                                    usocket:*wildcard-host*)
 467                                (acceptor-port acceptor)
 468                                :reuseaddress t
 469                                :backlog (acceptor-listen-backlog acceptor)
 470                                :element-type '(unsigned-byte 8)))
 471   (values))
 472
 473 #-:lispworks
 474 (defmethod accept-connections ((acceptor acceptor))
 475   (usocket:with-server-socket (listener (acceptor-listen-socket acceptor))
 476     (loop
 477      (when (acceptor-shutdown-p acceptor)
 478        (return))
 479      (when (usocket:wait-for-input listener :ready-only t :timeout +new-connection-wait-time+)
 480        (when-let (client-connection
 481                   (handler-case (usocket:socket-accept listener)
 482                     ;; ignore condition
 483                     (usocket:connection-aborted-error ())))
 484          (set-timeouts client-connection
 485                        (acceptor-read-timeout acceptor)
 486                        (acceptor-write-timeout acceptor))
 487          (handle-incoming-connection (acceptor-taskmaster acceptor)
 488                                      client-connection))))))
 489
 490 ;; LispWorks implementation
 491
 492 #+:lispworks
 493 (defmethod start-listening ((acceptor acceptor))
 494   (multiple-value-bind (listener-process startup-condition)
 495       (comm:start-up-server :service (acceptor-port acceptor)
 496                             :address (acceptor-address acceptor)
 497                             :process-name (format nil "Hunchentoot listener \(~A:~A)"
 498                                                   (or (acceptor-address acceptor) "*")
 499                                                   (acceptor-port acceptor))
 500                             ;; this function is called once on startup - we
 501                             ;; use it to check for errors
 502                             :announce (lambda (socket &optional condition)
 503                                         (declare (ignore socket))
 504                                         (when condition
 505                                           (error condition)))
 506                             ;; this function is called whenever a connection
 507                             ;; is made
 508                             :function (lambda (handle)
 509                                         (unless (acceptor-shutdown-p acceptor)
 510                                           (handle-incoming-connection
 511                                            (acceptor-taskmaster acceptor) handle)))
 512                             ;; wait until the acceptor was successfully started
 513                             ;; or an error condition is returned
 514                             :wait t)
 515     (when startup-condition
 516       (error startup-condition))
 517     (mp:process-stop listener-process)
 518     (setf (acceptor-process acceptor) listener-process)
 519     (values)))
 520
 521 #+:lispworks
 522 (defmethod accept-connections ((acceptor acceptor))
 523   (mp:process-unstop (acceptor-process acceptor))
 524   nil)
 525
 526 (defmethod acceptor-dispatch-request ((acceptor acceptor) request)
 527   "Detault implementation of the request dispatch method, generates a +http-not-found+ error+."
 528   (declare (ignore request))
 529   (if (acceptor-document-root acceptor)
 530       (handle-static-file (merge-pathnames (if (equal (script-name*) "/")
 531                                                "index.html"
 532                                                (subseq (script-name*) 1))
 533                                            (acceptor-document-root acceptor)))
 534       (setf (return-code *reply*) +http-not-found+)))
 535
 536 (defmethod handle-request ((*acceptor* acceptor) (*request* request))
 537   "Standard method for request handling.  Calls the request dispatcher
 538 of *ACCEPTOR* to determine how the request should be handled.  Also
 539 sets up standard error handling which catches any errors within the
 540 handler."
 541   (handler-bind ((error
 542                   (lambda (cond)
 543                     ;; if the headers were already sent, the error
 544                     ;; happened within the body and we have to close
 545                     ;; the stream
 546                     (when *headers-sent*
 547                       (setq *close-hunchentoot-stream* t))
 548                     (throw 'handler-done
 549                       (values nil cond (when (or *log-lisp-backtraces-p* *show-lisp-backtraces-p*)
 550                                          (get-backtrace))))))
 551                  (warning
 552                   (lambda (cond)
 553                     (when *log-lisp-warnings-p*
 554                       (log-message* *lisp-warnings-log-level* "~A" cond)))))
 555     (with-debugger
 556       (acceptor-dispatch-request *acceptor* *request*))))
 557
 558 (defgeneric acceptor-status-message (acceptor http-status-code &key &allow-other-keys)
 559   (:documentation
 560    "This function is called after the request's handler has been
 561    invoked to convert the HTTP-STATUS-CODE to a HTML message to be
 562    displayed to the user.  If this function returns a string, that
 563    string is sent to the client instead of the content produced by the
 564    handler, if any.
 565
 566    If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and
 567    the directory contains a file corresponding to HTTP-STATUS-CODE
 568    named <code>.html, that file is sent to the client after variable
 569    substitution.  Variables are referenced by ${<variable-name>}.
 570
 571    Additional keyword arguments may be provided which are made
 572    available to the templating logic as substitution variables.  These
 573    variables can be interpolated into error message templates in,
 574    which contains the current URL relative to the server and without
 575    GET parameters.
 576
 577    In addition to the variables corresponding to keyword arguments,
 578    the script-name, lisp-implementation-type,
 579    lisp-implementation-version and hunchentoot-version variables are
 580    available."))
 581
 582 (defun make-cooked-message (http-status-code &key error backtrace)
 583   (labels ((cooked-message (format &rest arguments)
 584              (setf (content-type*) "text/html; charset=iso-8859-1")
 585              (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~?<p><hr>~A</p></body></html>"
 586                      http-status-code (reason-phrase http-status-code)
 587                      format (mapcar (lambda (arg)
 588                                       (if (stringp arg)
 589                                           (escape-for-html arg)
 590                                           arg))
 591                                     arguments)
 592                      (address-string))))
 593     (case http-status-code
 594       ((#.+http-moved-temporarily+
 595         #.+http-moved-permanently+)
 596        (cooked-message "The document has moved <a href='~A'>here</a>" (header-out :location)))
 597       ((#.+http-authorization-required+)
 598        (cooked-message "The server could not verify that you are authorized to access the document requested.  ~
 599                         Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't ~
 600                         understand how to supply the credentials required."))
 601       ((#.+http-forbidden+)
 602        (cooked-message "You don't have permission to access ~A on this server."
 603                        (script-name *request*)))
 604       ((#.+http-not-found+)
 605        (cooked-message "The requested URL ~A was not found on this server."
 606                        (script-name *request*)))
 607       ((#.+http-bad-request+)
 608        (cooked-message "Your browser sent a request that this server could not understand."))
 609       ((#.+http-internal-server-error+)
 610        (if *show-lisp-errors-p*
 611            (cooked-message "<pre>~A~@[~%~%Backtrace:~%~%~A~]</pre>"
 612                            (escape-for-html (princ-to-string error))
 613                            (when *show-lisp-backtraces-p*
 614                              (escape-for-html (princ-to-string backtrace))))
 615            (cooked-message "An error has occured"))))))
 616
 617 (defmethod acceptor-status-message ((acceptor t) http-status-code &rest args &key &allow-other-keys)
 618   (apply 'make-cooked-message http-status-code args))
 619
 620 (defmethod acceptor-status-message :around ((acceptor acceptor) http-status-code &rest args &key &allow-other-keys)
 621   (handler-case
 622       (call-next-method)
 623     (error (e)
 624       (log-message* :error "error ~A during error processing, sending cooked message to client" e)
 625       (apply 'make-cooked-message http-status-code args))))
 626
 627 (defmethod acceptor-status-message ((acceptor acceptor) http-status-code &rest properties &key &allow-other-keys)
 628   "Default function to generate error message sent to the client."
 629   (labels
 630       ((substitute-request-context-variables (string)
 631          (let ((properties (append `(:script-name ,(script-name*)
 632                                      :lisp-implementation-type ,(lisp-implementation-type)
 633                                      :lisp-implementation-version ,(lisp-implementation-version)
 634                                      :hunchentoot-version ,*hunchentoot-version*)
 635                                    properties)))
 636            (cl-ppcre:regex-replace-all "(?i)\\$\\{([a-z0-9-_]+)\\}"
 637                                        string
 638                                        (lambda (target-string start end match-start match-end reg-starts reg-ends)
 639                                          (declare (ignore start end match-start match-end))
 640                                          (let ((variable-name (intern (string-upcase (subseq target-string
 641                                                                                              (aref reg-starts 0)
 642                                                                                              (aref reg-ends 0)))
 643                                                                       :keyword)))
 644                                            (escape-for-html (princ-to-string (getf properties variable-name variable-name))))))))
 645        (file-contents (file)
 646          (let ((buf (make-string (file-length file))))
 647            (read-sequence buf file)
 648            buf))
 649        (error-contents-from-template ()
 650          (let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor)
 651                                                   (probe-file (make-pathname :name (princ-to-string http-status-code)
 652                                                                              :type "html"
 653                                                                              :defaults (acceptor-error-template-directory acceptor))))))
 654            (when error-file-template-pathname
 655              (with-open-file (file error-file-template-pathname :if-does-not-exist nil :element-type 'character)
 656                (when file
 657                  (setf (content-type*) "text/html")
 658                  (substitute-request-context-variables (file-contents file))))))))
 659     (or (unless (< 300 http-status-code)
 660           (call-next-method))           ; don't ever try template for positive return codes
 661         (error-contents-from-template)  ; try template
 662         (call-next-method))))           ; fall back to cooked message
 663
 664 (defgeneric acceptor-remove-session (acceptor session)
 665   (:documentation
 666    "This function is called whenever a session in ACCEPTOR is being
 667    destroyed because of a session timout or an explicit REMOVE-SESSION
 668    call."))
 669
 670 (defmethod acceptor-remove-session ((acceptor acceptor) (session t))
 671   "Default implementation for the session removal hook function.  This
 672 function is called whenever a session is destroyed."
 673   )
 674
 675 (defgeneric acceptor-server-name (acceptor)
 676   (:documentation "Returns a string which can be used for 'Server' headers.")
 677   (:method ((acceptor acceptor))
 678     (format nil "Hunchentoot ~A" *hunchentoot-version*)))
 679