Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 697 lines (638 sloc) 35.106 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-

;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.

;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :hunchentoot)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun default-document-directory (&optional sub-directory)
    (asdf:system-relative-pathname :hunchentoot (format nil "www/~@[~A~]" sub-directory))))

(defclass acceptor ()
  ((port :initarg :port
         :reader acceptor-port
         :documentation "The port the acceptor is listening on. The
default is 80. Note that depending on your operating system you might
need special privileges to listen on port 80.")
   (address :initarg :address
            :reader acceptor-address
            :documentation "The address the acceptor is listening on.
If address is a string denoting an IP address, then the server only
receives connections for that address. This must be one of the
addresses associated with the machine and allowed values are host
names such as \"www.zappa.com\" and address strings such as
\"72.3.247.29\". If address is NIL, then the server will receive
connections to all IP addresses on the machine. This is the default.")
   (name :initarg :name
         :accessor acceptor-name
         :documentation "The optional name of the acceptor, a symbol.
This name can be utilized when defining \"easy handlers\" - see
DEFINE-EASY-HANDLER. The default name is an uninterned symbol as
returned by GENSYM.")
   (request-class :initarg :request-class
                  :accessor acceptor-request-class
                  :documentation "Determines which class of request
objects is created when a request comes in and should be \(a symbol
naming) a class which inherits from REQUEST. The default is the
symbol REQUEST.")
   (reply-class :initarg :reply-class
                :accessor acceptor-reply-class
                  :documentation "Determines which class of reply
objects is created when a request is served in and should be \(a
symbol naming) a class which inherits from REPLY. The default is the
symbol REPLY.")
   (taskmaster :initarg :taskmaster
               :reader acceptor-taskmaster
               :documentation "The taskmaster \(i.e. an instance of a
subclass of TASKMASTER) that is responsible for scheduling the work
for this acceptor. The default depends on the MP capabilities of the
underlying Lisp.")
   (output-chunking-p :initarg :output-chunking-p
                      :accessor acceptor-output-chunking-p
                      :documentation "A generalized boolean denoting
whether the acceptor may use chunked encoding for output, i.e. when
sending data to the client. The default is T and there's usually no
reason to change this to NIL.")
   (input-chunking-p :initarg :input-chunking-p
                     :accessor acceptor-input-chunking-p
                      :documentation "A generalized boolean denoting
whether the acceptor may use chunked encoding for input, i.e. when
accepting request bodies from the client. The default is T and
there's usually no reason to change this to NIL.")
   (persistent-connections-p :initarg :persistent-connections-p
                             :accessor acceptor-persistent-connections-p
                             :documentation "A generalized boolean
denoting whether the acceptor supports persistent connections, which
is the default for threaded acceptors. If this property is NIL,
Hunchentoot closes each incoming connection after having processed one
request. This is the default for non-threaded acceptors.")
   (read-timeout :initarg :read-timeout
                 :reader acceptor-read-timeout
                 :documentation "The read timeout of the acceptor,
specified in \(fractional) seconds. The precise semantics of this
parameter is determined by the underlying Lisp's implementation of
socket timeouts. NIL means no timeout.")
   (write-timeout :initarg :write-timeout
                  :reader acceptor-write-timeout
                  :documentation "The write timeout of the acceptor,
specified in \(fractional) seconds. The precise semantics of this
parameter is determined by the underlying Lisp's implementation of
socket timeouts. NIL means no timeout.")
   #+:lispworks
   (process :accessor acceptor-process
            :documentation "The Lisp process which accepts incoming
requests. This is the process started by COMM:START-UP-SERVER and no
matter what kind of taskmaster you are using this will always be a new
process different from the one where START was called.")
   #-:lispworks
   (listen-socket :initform nil
                  :accessor acceptor-listen-socket
                  :documentation "The socket listening for incoming
connections.")
   #-:lispworks
   (listen-backlog :initarg :listen-backlog
:reader acceptor-listen-backlog
:documentation "Number of pending connections
allowed in the listen socket before the kernel rejects
further incoming connections.")
   (acceptor-shutdown-p :initform t
                        :accessor acceptor-shutdown-p
                        :documentation "A flag that makes the acceptor
shutdown itself when set to something other than NIL.")
   (requests-in-progress :initform 0
                         :accessor accessor-requests-in-progress
                         :documentation "The number of
requests currently in progress.")
   (shutdown-queue :initform (make-condition-variable)
                   :accessor acceptor-shutdown-queue
                   :documentation "A condition variable
used with soft shutdown, signaled when all requests
have been processed.")
   (shutdown-lock :initform (make-lock "hunchentoot-acceptor-shutdown")
                  :accessor acceptor-shutdown-lock
                  :documentation "The lock protecting the shutdown-queue
condition variable and the requests-in-progress counter.")
   (access-log-destination :initarg :access-log-destination
                        :accessor acceptor-access-log-destination
                        :documentation "Destination of the access log
which contains one log entry per request handled in a format similar
to Apache's access.log. Can be set to a pathname or string
designating the log file, to a open output stream or to NIL to
suppress logging.")
   (message-log-destination :initarg :message-log-destination
                         :accessor acceptor-message-log-destination
                         :documentation "Destination of the server
error log which is used to log informational, warning and error
messages in a free-text format intended for human inspection. Can be
set to a pathname or string designating the log file, to a open output
stream or to NIL to suppress logging.")
   (error-template-directory :initarg :error-template-directory
                             :accessor acceptor-error-template-directory
                             :documentation "Directory pathname that
contains error message template files for server-generated error
messages. Files must be named <return-code>.html with <return-code>
representing the HTTP return code that the file applies to,
i.e. 404.html would be used as the content for a HTTP 404 Not found
response.")
   (document-root :initarg :document-root
                  :accessor acceptor-document-root
                  :documentation "Directory pathname that points to
files that are served by the acceptor if no more specific
acceptor-dispatch-request method handles the request."))
  (:default-initargs
   :address nil
   :port 80
   :name (gensym)
   :request-class 'request
   :reply-class 'reply
   #-lispworks :listen-backlog #-lispworks 50
   :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster)
                                    (t 'single-threaded-taskmaster)))
   :output-chunking-p t
   :input-chunking-p t
   :persistent-connections-p t
   :read-timeout *default-connection-timeout*
   :write-timeout *default-connection-timeout*
   :access-log-destination *error-output*
   :message-log-destination *error-output*
   :document-root (load-time-value (default-document-directory))
   :error-template-directory (load-time-value (default-document-directory "errors/")))
  (:documentation "To create a Hunchentoot webserver, you make an
instance of this class and use the generic function START to start it
\(and STOP to stop it). Use the :PORT initarg if you don't want to
listen on the default http port 80. There are other initargs most of
which you probably won't need very often. They are explained in
detail in the docstrings of the slot definitions for this class.

Unless you are in a Lisp without MP capabilities, you can have several
active instances of ACCEPTOR \(listening on different ports) at the
same time."))

(defmethod print-object ((acceptor acceptor) stream)
  (print-unreadable-object (acceptor stream :type t)
    (format stream "\(host ~A, port ~A)"
            (or (acceptor-address acceptor) "*") (acceptor-port acceptor))))

(defgeneric start (acceptor)
  (:documentation "Starts the ACCEPTOR so that it begins accepting
connections. Returns the acceptor."))

(defgeneric stop (acceptor &key soft)
  (:documentation "Stops the ACCEPTOR so that it no longer accepts
requests. If SOFT is true, and there are any requests in progress,
wait until all requests are fully processed, but meanwhile do
not accept new requests."))

(defgeneric start-listening (acceptor)
  (:documentation "Sets up a listen socket for the given ACCEPTOR and
enables it to listen to incoming connections. This function is called
from the thread that starts the acceptor initially and may return
errors resulting from the listening operation \(like 'address in use'
or similar)."))

(defgeneric accept-connections (acceptor)
  (:documentation "In a loop, accepts a connection and hands it over
to the acceptor's taskmaster for processing using
HANDLE-INCOMING-CONNECTION. On LispWorks, this function returns
immediately, on other Lisps it retusn only once the acceptor has been
stopped."))

(defgeneric initialize-connection-stream (acceptor stream)
 (:documentation "Can be used to modify the stream which is used to
communicate between client and server before the request is read. The
default method of ACCEPTOR does nothing, but see for example the
method defined for SSL-ACCEPTOR. All methods of this generic function
must return the stream to use."))

(defgeneric reset-connection-stream (acceptor stream)
  (:documentation "Resets the stream which is used to communicate
between client and server after one request has been served so that it
can be used to process the next request. This generic function is
called after a request has been processed and must return the
stream."))

(defgeneric process-connection (acceptor socket)
  (:documentation "This function is called by the taskmaster when a
new client connection has been established. Its arguments are the
ACCEPTOR object and a LispWorks socket handle or a usocket socket
stream object in SOCKET. It reads the request headers, sets up the
request and reply objects, and hands over to PROCESS-REQUEST. This is
done in a loop until the stream has to be closed or until a connection
timeout occurs.

It is probably not a good idea to re-implement this method until you
really, really know what you're doing."))

(defgeneric handle-request (acceptor request)
  (:documentation "This function is called once the request has been
read and a REQUEST object has been created. Its job is to set up
standard error handling and request logging.

Might be a good place for around methods specialized for your subclass
of ACCEPTOR which bind or rebind special variables which can then be
accessed by your handlers."))

(defgeneric acceptor-dispatch-request (acceptor request)
  (:documentation "This function is called to actually dispatch the
request once the standard logging and error handling has been set up.
ACCEPTOR subclasses implement methods for this function in order to
perform their own request routing. If a method does not want to
handle the request, it is supposed to invoke CALL-NEXT-METHOD so that
the next ACCEPTOR in the inheritance chain gets a chance to handle the
request."))

(defgeneric acceptor-ssl-p (acceptor)
  (:documentation "Returns a true value if ACCEPTOR uses SSL
connections. The default is to unconditionally return NIL and
subclasses of ACCEPTOR must specialize this method to signal that
they're using secure connections - see the SSL-ACCEPTOR class."))

;; general implementation

(defmethod start ((acceptor acceptor))
  (setf (acceptor-shutdown-p acceptor) nil)
  (start-listening acceptor)
  (let ((taskmaster (acceptor-taskmaster acceptor)))
    (setf (taskmaster-acceptor taskmaster) acceptor)
    (execute-acceptor taskmaster))
  acceptor)

(defmethod stop ((acceptor acceptor) &key soft)
  (setf (acceptor-shutdown-p acceptor) t)
  (shutdown (acceptor-taskmaster acceptor))
  (when soft
    (with-lock-held ((acceptor-shutdown-lock acceptor))
      (when (plusp (accessor-requests-in-progress acceptor))
        (condition-variable-wait (acceptor-shutdown-queue acceptor)
                                 (acceptor-shutdown-lock acceptor)))))
  #-lispworks
  (usocket:socket-close (acceptor-listen-socket acceptor))
  #-lispworks
  (setf (acceptor-listen-socket acceptor) nil)
  #+lispworks
  (mp:process-kill (acceptor-process acceptor))
  acceptor)

(defmethod initialize-connection-stream ((acceptor acceptor) stream)
 ;; default method does nothing
 stream)

(defmethod reset-connection-stream ((acceptor acceptor) stream)
  ;; turn chunking off at this point
  (cond ((typep stream 'chunked-stream)
         ;; flush the stream first and check if there's unread input
         ;; which would be an error
         (setf (chunked-stream-output-chunking-p stream) nil
               (chunked-stream-input-chunking-p stream) nil)
         ;; switch back to bare socket stream
         (chunked-stream-stream stream))
        (t stream)))

(defmethod process-connection :around ((*acceptor* acceptor) (socket t))
  ;; this around method is used for error handling
  ;; note that this method also binds *ACCEPTOR*
  (handler-bind ((error
                  ;; abort if there's an error which isn't caught inside
                  (lambda (cond)
                    (log-message* *lisp-errors-log-level*
                                  "Error while processing connection: ~A" cond)
                    (return-from process-connection)))
                 (warning
                  ;; log all warnings which aren't caught inside
                  (lambda (cond)
                    (log-message* *lisp-warnings-log-level*
                                  "Warning while processing connection: ~A" cond))))
    (with-mapped-conditions ()
      (call-next-method))))

(defun do-with-acceptor-request-count-incremented (*acceptor* function)
  (with-lock-held ((acceptor-shutdown-lock *acceptor*))
    (incf (accessor-requests-in-progress *acceptor*)))
  (unwind-protect
       (funcall function)
    (with-lock-held ((acceptor-shutdown-lock *acceptor*))
      (decf (accessor-requests-in-progress *acceptor*))
      (when (acceptor-shutdown-p *acceptor*)
        (condition-variable-signal (acceptor-shutdown-queue *acceptor*))))))

(defmacro with-acceptor-request-count-incremented ((acceptor) &body body)
  "Execute BODY with ACCEPTOR-REQUESTS-IN-PROGRESS of ACCEPTOR
incremented by one. If the ACCEPTOR-SHUTDOWN-P returns true after
the BODY has been executed, the ACCEPTOR-SHUTDOWN-QUEUE condition
variable of the ACCEPTOR is signalled in order to finish shutdown
processing."
  `(do-with-acceptor-request-count-incremented ,acceptor (lambda () ,@body)))

(defmethod process-connection ((*acceptor* acceptor) (socket t))
  (let ((*hunchentoot-stream*
         (initialize-connection-stream *acceptor* (make-socket-stream socket *acceptor*))))
    (unwind-protect
        ;; process requests until either the acceptor is shut down,
        ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
        ;; handler, or the peer fails to send a request
        (loop
          (let ((*close-hunchentoot-stream* t))
            (when (acceptor-shutdown-p *acceptor*)
              (return))
            (multiple-value-bind (headers-in method url-string protocol)
                (get-request-data *hunchentoot-stream*)
              ;; check if there was a request at all
              (unless method
                (return))
              ;; bind per-request special variables, then process the
              ;; request - note that *ACCEPTOR* was bound above already
              (let ((*reply* (make-instance (acceptor-reply-class *acceptor*)))
                    (*session* nil)
                    (transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
                (when transfer-encodings
                  (setq transfer-encodings
                        (split "\\s*,\\s*" transfer-encodings))
                  (when (member "chunked" transfer-encodings :test #'equalp)
                    (cond ((acceptor-input-chunking-p *acceptor*)
                           ;; turn chunking on before we read the request body
                           (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
                                 (chunked-stream-input-chunking-p *hunchentoot-stream*) t))
                          (t (hunchentoot-error "Client tried to use ~
chunked encoding, but acceptor is configured to not use it.")))))
                (multiple-value-bind (remote-addr remote-port)
                    (get-peer-address-and-port socket)
                  (with-acceptor-request-count-incremented (*acceptor*)
                    (process-request (make-instance (acceptor-request-class *acceptor*)
                                                    :acceptor *acceptor*
                                                    :remote-addr remote-addr
                                                    :remote-port remote-port
                                                    :headers-in headers-in
                                                    :content-stream *hunchentoot-stream*
                                                    :method method
                                                    :uri url-string
                                                    :server-protocol protocol)))))
              (finish-output *hunchentoot-stream*)
              (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*))
              (when *close-hunchentoot-stream*
                (return)))))
      (when *hunchentoot-stream*
        ;; as we are at the end of the request here, we ignore all
        ;; errors that may occur while flushing and/or closing the
        ;; stream.
        (ignore-errors*
          (finish-output *hunchentoot-stream*))
        (ignore-errors*
          (close *hunchentoot-stream* :abort t))))))

(defmethod acceptor-ssl-p ((acceptor t))
  ;; the default is to always answer "no"
  nil)

(defgeneric acceptor-log-access (acceptor &key return-code)
  (:documentation
   "Function to call to log access to the acceptor. The RETURN-CODE,
CONTENT and CONTENT-LENGTH keyword arguments contain additional
information about the request to log. In addition, it can use the
standard request accessor functions that are available to handler
functions to find out more information about the request."))

(defmethod acceptor-log-access ((acceptor acceptor) &key return-code)
  "Default method for access logging. It logs the information to the
destination determined by (ACCEPTOR-ACCESS-LOG-DESTINATION ACCEPTOR)
\(unless that value is NIL) in a format that can be parsed by most
Apache log analysis tools.)"

  (with-log-stream (stream (acceptor-access-log-destination acceptor) *access-log-lock*)
    (format stream "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
            (remote-addr*)
            (header-in* :x-forwarded-for)
            (authorization)
            (iso-time)
            (request-method*)
            (script-name*)
            (query-string*)
            (server-protocol*)
            return-code
            (content-length*)
            (referer)
            (user-agent))))

(defgeneric acceptor-log-message (acceptor log-level format-string &rest format-arguments)
  (:documentation
   "Function to call to log messages by the ACCEPTOR. It must accept
a severity level for the message, which will be one of :ERROR, :INFO,
or :WARNING, a format string and an arbitary number of formatting
arguments."))

(defmethod acceptor-log-message ((acceptor acceptor) log-level format-string &rest format-arguments)
  "Default function to log server messages. Sends a formatted message
to the destination denoted by (ACCEPTOR-MESSAGE-LOG-DESTINATION
ACCEPTOR). FORMAT and ARGS are as in FORMAT. LOG-LEVEL is a
keyword denoting the log level or NIL in which case it is ignored."
  (with-log-stream (stream (acceptor-message-log-destination acceptor) *message-log-lock*)
    (handler-case
        (format stream "[~A~@[ [~A]~]] ~?~%"
                (iso-time) log-level
                format-string format-arguments)
      (error (e)
        (ignore-errors
         (format *trace-output* "error ~A while writing to error log, error not logged~%" e))))))

(defun log-message* (log-level format-string &rest format-arguments)
  "Convenience function which calls the message logger of the current
acceptor \(if there is one) with the same arguments it accepts.

This is the function which Hunchentoot itself uses to log errors it
catches during request processing."
  (apply 'acceptor-log-message *acceptor* log-level format-string format-arguments))

;; usocket implementation

#-:lispworks
(defmethod start-listening ((acceptor acceptor))
  (when (acceptor-listen-socket acceptor)
    (hunchentoot-error "acceptor ~A is already listening" acceptor))
  (setf (acceptor-listen-socket acceptor)
        (usocket:socket-listen (or (acceptor-address acceptor)
                                   usocket:*wildcard-host*)
                               (acceptor-port acceptor)
                               :reuseaddress t
:backlog (acceptor-listen-backlog acceptor)
                               :element-type '(unsigned-byte 8)))
  (values))

#-:lispworks
(defmethod accept-connections ((acceptor acceptor))
  (usocket:with-server-socket (listener (acceptor-listen-socket acceptor))
    (loop
     (when (acceptor-shutdown-p acceptor)
       (return))
     (when (usocket:wait-for-input listener :ready-only t :timeout +new-connection-wait-time+)
       (when-let (client-connection
                  (handler-case (usocket:socket-accept listener)
                    ;; ignore condition
                    (usocket:connection-aborted-error ())))
         (set-timeouts client-connection
                       (acceptor-read-timeout acceptor)
                       (acceptor-write-timeout acceptor))
         (handle-incoming-connection (acceptor-taskmaster acceptor)
                                     client-connection))))))

;; LispWorks implementation

#+:lispworks
(defmethod start-listening ((acceptor acceptor))
  (multiple-value-bind (listener-process startup-condition)
      (comm:start-up-server :service (acceptor-port acceptor)
                            :address (acceptor-address acceptor)
                            :process-name (format nil "Hunchentoot listener \(~A:~A)"
                                                  (or (acceptor-address acceptor) "*")
                                                  (acceptor-port acceptor))
                            ;; this function is called once on startup - we
                            ;; use it to check for errors
                            :announce (lambda (socket &optional condition)
                                        (declare (ignore socket))
                                        (when condition
                                          (error condition)))
                            ;; this function is called whenever a connection
                            ;; is made
                            :function (lambda (handle)
                                        (unless (acceptor-shutdown-p acceptor)
                                          (handle-incoming-connection
                                           (acceptor-taskmaster acceptor) handle)))
                            ;; wait until the acceptor was successfully started
                            ;; or an error condition is returned
                            :wait t)
    (when startup-condition
      (error startup-condition))
    (mp:process-stop listener-process)
    (setf (acceptor-process acceptor) listener-process)
    (values)))

#+:lispworks
(defmethod accept-connections ((acceptor acceptor))
  (mp:process-unstop (acceptor-process acceptor))
  nil)

(defmethod acceptor-dispatch-request ((acceptor acceptor) request)
  "Detault implementation of the request dispatch method, generates an
+http-not-found+ error."
  (if (acceptor-document-root acceptor)
      (let ((path (request-pathname request)))
(if (not path)
(setf (return-code *reply*) +http-forbidden+)
(handle-static-file
(merge-pathnames (if (equal "/" (script-name request)) #p"index.html" path)
(acceptor-document-root acceptor)))))
      (setf (return-code *reply*) +http-not-found+)))

(defmethod handle-request ((*acceptor* acceptor) (*request* request))
  "Standard method for request handling. Calls the request dispatcher
of *ACCEPTOR* to determine how the request should be handled. Also
sets up standard error handling which catches any errors within the
handler."
  (handler-bind ((error
                  (lambda (cond)
                    ;; if the headers were already sent, the error
                    ;; happened within the body and we have to close
                    ;; the stream
                    (when *headers-sent*
                      (setq *close-hunchentoot-stream* t))
                    (throw 'handler-done
                      (values nil cond (get-backtrace)))))
                 (warning
                  (lambda (cond)
                    (when *log-lisp-warnings-p*
                      (log-message* *lisp-warnings-log-level* "~A" cond)))))
    (with-debugger
      (acceptor-dispatch-request *acceptor* *request*))))

(defgeneric acceptor-status-message (acceptor http-status-code &key &allow-other-keys)
  (:documentation
   "This function is called after the request's handler has been
invoked to convert the HTTP-STATUS-CODE to a HTML message to be
displayed to the user. If this function returns a string, that
string is sent to the client instead of the content produced by the
handler, if any.

If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and
the directory contains a file corresponding to HTTP-STATUS-CODE
named <code>.html, that file is sent to the client after variable
substitution. Variables are referenced by ${<variable-name>}.

Additional keyword arguments may be provided which are made
available to the templating logic as substitution variables. These
variables can be interpolated into error message templates in,
which contains the current URL relative to the server and without
GET parameters.

In addition to the variables corresponding to keyword arguments,
the script-name, lisp-implementation-type,
lisp-implementation-version and hunchentoot-version variables are
available."))

(defun make-cooked-message (http-status-code &key error backtrace)
  (labels ((cooked-message (format &rest arguments)
             (setf (content-type*) "text/html; charset=iso-8859-1")
             (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~?<p><hr>~A</p></body></html>"
                     http-status-code (reason-phrase http-status-code)
                     format (mapcar (lambda (arg)
                                      (if (stringp arg)
                                          (escape-for-html arg)
                                          arg))
                                    arguments)
                     (address-string))))
    (case http-status-code
      ((#.+http-moved-temporarily+
        #.+http-moved-permanently+)
       (cooked-message "The document has moved <a href='~A'>here</a>" (header-out :location)))
      ((#.+http-authorization-required+)
       (cooked-message "The server could not verify that you are authorized to access the document requested. ~
Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't ~
understand how to supply the credentials required."))
      ((#.+http-forbidden+)
       (cooked-message "You don't have permission to access ~A on this server."
                       (script-name *request*)))
      ((#.+http-not-found+)
       (cooked-message "The requested URL ~A was not found on this server."
                       (script-name *request*)))
      ((#.+http-bad-request+)
       (cooked-message "Your browser sent a request that this server could not understand."))
      ((#.+http-internal-server-error+)
       (if *show-lisp-errors-p*
           (cooked-message "<pre>~A~@[~%~%Backtrace:~%~%~A~]</pre>"
                           (escape-for-html (princ-to-string error))
                           (when *show-lisp-backtraces-p*
                             (escape-for-html (princ-to-string backtrace))))
           (cooked-message "An error has occurred")))
      (t
         (when (<= 400 http-status-code)
           (cooked-message "An error has occurred"))))))

(defmethod acceptor-status-message ((acceptor t) http-status-code &rest args &key &allow-other-keys)
  (apply 'make-cooked-message http-status-code args))

(defmethod acceptor-status-message :around ((acceptor acceptor) http-status-code &rest args &key &allow-other-keys)
  (handler-case
      (call-next-method)
    (error (e)
      (log-message* :error "error ~A during error processing, sending cooked message to client" e)
      (apply 'make-cooked-message http-status-code args))))

(defun string-as-keyword (string)
  "Intern STRING as keyword using the reader so that case conversion is done with the reader defaults."
  (let ((*package* (find-package :keyword)))
    (read-from-string string)))

(defmethod acceptor-status-message ((acceptor acceptor) http-status-code &rest properties &key &allow-other-keys)
  "Default function to generate error message sent to the client."
  (labels
      ((substitute-request-context-variables (string)
         (let ((properties (append `(:script-name ,(script-name*)
                                     :lisp-implementation-type ,(lisp-implementation-type)
                                     :lisp-implementation-version ,(lisp-implementation-version)
                                     :hunchentoot-version ,*hunchentoot-version*)
                                   properties)))
           (cl-ppcre:regex-replace-all "(?i)\\$\\{([a-z0-9-_]+)\\}"
                                       string
                                       (lambda (target-string start end match-start match-end reg-starts reg-ends)
                                         (declare (ignore start end match-start match-end))
                                         (let ((variable-name (string-as-keyword (subseq target-string
                                                                                         (aref reg-starts 0)
                                                                                         (aref reg-ends 0)))))
                                           (escape-for-html (princ-to-string (getf properties variable-name variable-name))))))))
       (file-contents (file)
         (let ((buf (make-string (file-length file))))
           (read-sequence buf file)
           buf))
       (error-contents-from-template ()
         (let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor)
                                                  (probe-file (make-pathname :name (princ-to-string http-status-code)
                                                                             :type "html"
                                                                             :defaults (acceptor-error-template-directory acceptor))))))
           (when error-file-template-pathname
             (with-open-file (file error-file-template-pathname :if-does-not-exist nil :element-type 'character)
               (when file
                 (setf (content-type*) "text/html")
                 (substitute-request-context-variables (file-contents file))))))))
    (or (unless (< 300 http-status-code)
          (call-next-method)) ; don't ever try template for positive return codes
        (error-contents-from-template) ; try template
        (call-next-method)))) ; fall back to cooked message

(defgeneric acceptor-remove-session (acceptor session)
  (:documentation
   "This function is called whenever a session in ACCEPTOR is being
destroyed because of a session timout or an explicit REMOVE-SESSION
call."))

(defmethod acceptor-remove-session ((acceptor acceptor) (session t))
  "Default implementation for the session removal hook function. This
function is called whenever a session is destroyed."
  )

(defgeneric acceptor-server-name (acceptor)
  (:documentation "Returns a string which can be used for 'Server' headers.")
  (:method ((acceptor acceptor))
    (format nil "Hunchentoot ~A" *hunchentoot-version*)))
Something went wrong with that request. Please try again.