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