acceptor.lisp

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