acceptor.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
   2 ;;; $Header: /usr/local/cvsrep/hunchentoot/server.lisp,v 1.43 2008/04/09 08:17:48 edi Exp $
   3
   4 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz.  All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot)
  31
  32 (defclass acceptor ()
  33   ((port :initarg :port
  34          :reader acceptor-port
  35          :documentation "The port the acceptor is listening on.  The
  36 default is 80.  Note that depending on your operating system you might
  37 need special privileges to listen on port 80.")
  38    (address :initarg :address
  39             :reader acceptor-address
  40             :documentation "The address the acceptor is listening on.
  41 If address is a string denoting an IP address, then the server only
  42 receives connections for that address.  This must be one of the
  43 addresses associated with the machine and allowed values are host
  44 names such as \"www.zappa.com\" and address strings such as
  45 \"72.3.247.29\".  If address is NIL, then the server will receive
  46 connections to all IP addresses on the machine. This is the default.")
  47    (name :initarg :name
  48          :accessor acceptor-name
  49          :documentation "The optional name of the acceptor, a symbol.
  50 This name can be utilized when defining \"easy handlers\" - see
  51 DEFINE-EASY-HANDLER.  The default name is an uninterned symbol as
  52 returned by GENSYM.")
  53    (request-class :initarg :request-class
  54                   :accessor acceptor-request-class
  55                   :documentation "Determines which class of request
  56 objects is created when a request comes in and should be \(a symbol
  57 naming) a class which inherits from REQUEST.  The default is the
  58 symbol REQUEST.")
  59    (reply-class :initarg :reply-class
  60                 :accessor acceptor-reply-class
  61                   :documentation "Determines which class of reply
  62 objects is created when a request is served in and should be \(a
  63 symbol naming) a class which inherits from REPLY.  The default is the
  64 symbol REPLY.")
  65    (request-dispatcher :initarg :request-dispatcher
  66                        :accessor acceptor-request-dispatcher
  67                        :documentation "A designator for the request
  68 dispatcher function used by this acceptor.  A function which accepts a
  69 REQUEST object and calls a request handler of its choice \(and returns
  70 its return value).  The default is the unexported symbol
  71 LIST-REQUEST-DISPATCHER which works through the list
  72 *DISPATCH-TABLE*.")
  73    (taskmaster :initarg :taskmaster
  74                :reader acceptor-taskmaster
  75                :documentation "The taskmaster \(i.e. an instance of a
  76 subclass of TASKMASTER) that is responsible for scheduling the work
  77 for this acceptor.  The default depends on the MP capabilities of the
  78 underlying Lisp.")
  79    (output-chunking-p :initarg :output-chunking-p
  80                       :accessor acceptor-output-chunking-p
  81                       :documentation "A generalized boolean denoting
  82 whether the acceptor may use chunked encoding for output, i.e. when
  83 sending data to the client.  The default is T and there's usually no
  84 reason to change this to NIL.")
  85    (input-chunking-p :initarg :input-chunking-p
  86                      :accessor acceptor-input-chunking-p
  87                       :documentation "A generalized boolean denoting
  88 whether the acceptor may use chunked encoding for input, i.e. when
  89 accepting request bodies from the client.  The default is T and
  90 there's usually no reason to change this to NIL.")
  91    (persistent-connections-p :initarg :persistent-connections-p
  92                              :accessor acceptor-persistent-connections-p
  93                              :documentation "A generalized boolean
  94 denoting whether the acceptor supports persistent connections, which
  95 is the default for threaded acceptors.  If this property is NIL,
  96 Hunchentoot closes each incoming connection after having processed one
  97 request.  This is the default for non-threaded acceptors.")
  98    (read-timeout :initarg :read-timeout
  99                  :reader acceptor-read-timeout
 100                  :documentation "The read timeout of the acceptor,
 101 specified in \(fractional) seconds.  The precise semantics of this
 102 parameter is determined by the underlying Lisp's implementation of
 103 socket timeouts.  NIL means no timeout.")
 104    (write-timeout :initarg :write-timeout
 105                   :reader acceptor-write-timeout
 106                   :documentation "The write timeout of the acceptor,
 107 specified in \(fractional) seconds.  The precise semantics of this
 108 parameter is determined by the underlying Lisp's implementation of
 109 socket timeouts.  NIL means no timeout.")
 110    #+:lispworks
 111    (process :accessor acceptor-process
 112             :documentation "The Lisp process which accepts incoming
 113 requests.  This is the process started by COMM:START-UP-SERVER and no
 114 matter what kind of taskmaster you are using this will always be a new
 115 process different from the one where START was called.")
 116    #-:lispworks
 117    (listen-socket :initform nil
 118                   :accessor acceptor-listen-socket
 119                   :documentation "The socket listening for incoming
 120 connections.")
 121    (acceptor-shutdown-p :initform nil
 122                         :accessor acceptor-shutdown-p
 123                         :documentation "A flag that makes the acceptor
 124 shutdown itself when set to something other than NIL.")
 125    (access-logger :initarg :access-logger
 126                   :accessor acceptor-access-logger
 127                   :documentation "Designator for a function to call to
 128 log access to the acceptor.  The function must accept the RETURN-CODE,
 129 CONTENT and CONTENT-LENGTH keyword arguments which are used to pass in
 130 additional information about the request to log.  In addition, it can
 131 use the standard request accessor functions that are available to
 132 handler functions to find out more information about the request.
 133 This slot defaults to a function which logs the information to the
 134 file determined by *ACCESS-LOG-PATHNAME* \(unless that value is NIL)
 135 in a format that can be parsed by most Apache log analysis tools.
 136
 137 If the value of this slot is NIL, access logging is turned off for
 138 this acceptor.")
 139    (message-logger :initarg :message-logger
 140                    :accessor acceptor-message-logger
 141                    :documentation "Designator for a function to call
 142 to log messages by the acceptor.  It must accept a severity level for
 143 the message, which will be one of :ERROR, :INFO, or :WARNING, a format
 144 string and an arbitary number of formatting arguments.  This slot
 145 defaults to a function which writes to the file determined by
 146 *MESSAGE-LOG-PATHNAME* \(unless that value is NIL).
 147
 148 If the value of this slot is NIL, message logging is turned off for
 149 this acceptor."))
 150   (:default-initargs
 151    :address nil
 152    :port 80
 153    :name (gensym)
 154    :request-class 'request
 155    :reply-class 'reply
 156    :request-dispatcher 'list-request-dispatcher
 157    :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster)
 158                                     (t 'single-threaded-taskmaster)))
 159    :output-chunking-p t
 160    :input-chunking-p t
 161    :persistent-connections-p t
 162    :read-timeout *default-connection-timeout*
 163    :write-timeout *default-connection-timeout*
 164    :access-logger 'log-access-to-file
 165    :message-logger 'log-message-to-file)
 166   (:documentation "To create a Hunchentoot webserver, you make an
 167 instance of this class and use the generic function START to start it
 168 \(and STOP to stop it).  Use the :PORT initarg if you don't want to
 169 listen on the default http port 80.  There are other initargs most of
 170 which you probably won't need very often.  They are explained in
 171 detail in the docstrings of the slot definitions for this class.
 172
 173 Unless you are in a Lisp without MP capabilities, you can have several
 174 active instances of ACCEPTOR \(listening on different ports) at the
 175 same time."))
 176
 177 (defmethod print-object ((acceptor acceptor) stream)
 178   (print-unreadable-object (acceptor stream :type t)
 179     (format stream "\(host ~A, port ~A)"
 180             (or (acceptor-address acceptor) "*") (acceptor-port acceptor))))
 181
 182 (defgeneric start (acceptor)
 183   (:documentation "Starts the ACCEPTOR so that it begins accepting
 184 connections.  Returns the acceptor."))
 185
 186 (defgeneric stop (acceptor)
 187   (:documentation "Stops the ACCEPTOR so that it no longer accepts
 188 requests."))
 189
 190 (defgeneric start-listening (acceptor)
 191   (:documentation "Sets up a listen socket for the given ACCEPTOR and
 192 enables it to listen to incoming connections.  This function is called
 193 from the thread that starts the acceptor initially and may return
 194 errors resulting from the listening operation \(like 'address in use'
 195 or similar)."))
 196
 197 (defgeneric accept-connections (acceptor)
 198   (:documentation "In a loop, accepts a connection and hands it over
 199 to the acceptor's taskmaster for processing using
 200 HANDLE-INCOMING-CONNECTION.  On LispWorks, this function returns
 201 immediately, on other Lisps it retusn only once the acceptor has been
 202 stopped."))
 203
 204 (defgeneric initialize-connection-stream (acceptor stream)
 205  (:documentation "Can be used to modify the stream which is used to
 206 communicate between client and server before the request is read.  The
 207 default method of ACCEPTOR does nothing, but see for example the
 208 method defined for SSL-ACCEPTOR.  All methods of this generic function
 209 must return the stream to use."))
 210
 211 (defgeneric reset-connection-stream (acceptor stream)
 212   (:documentation "Resets the stream which is used to communicate
 213 between client and server after one request has been served so that it
 214 can be used to process the next request.  This generic function is
 215 called after a request has been processed and must return the
 216 stream."))
 217
 218 (defgeneric process-connection (acceptor socket)
 219   (:documentation "This function is called by the taskmaster when a
 220 new client connection has been established.  Its arguments are the
 221 ACCEPTOR object and a LispWorks socket handle or a usocket socket
 222 stream object in SOCKET.  It reads the request headers, sets up the
 223 request and reply objects, and hands over to PROCESS-REQUEST.  This is
 224 done in a loop until the stream has to be closed or until a connection
 225 timeout occurs.
 226
 227 It is probably not a good idea to re-implement this method until you
 228 really, really know what you're doing."))
 229
 230 (defgeneric handle-request (acceptor request)
 231   (:documentation "This function is called once the request has been
 232 read and a REQUEST object has been created.  Its job is to actually
 233 handle the request, i.e. to return something to the client.
 234
 235 Might be a good place for around methods specialized for your subclass
 236 of ACCEPTOR which bind or rebind special variables which can then be
 237 accessed by your handlers."))
 238
 239 (defgeneric acceptor-ssl-p (acceptor)
 240   (:documentation "Returns a true value if ACCEPTOR uses SSL
 241 connections.  The default is to unconditionally return NIL and
 242 subclasses of ACCEPTOR must specialize this method to signal that
 243 they're using secure connections - see the SSL-ACCEPTOR class."))
 244
 245 ;; general implementation
 246
 247 (defmethod start ((acceptor acceptor))
 248   (start-listening acceptor)
 249   (let ((taskmaster (acceptor-taskmaster acceptor)))
 250     (setf (taskmaster-acceptor taskmaster) acceptor)
 251     (execute-acceptor taskmaster))
 252   acceptor)
 253
 254 (defmethod stop ((acceptor acceptor))
 255   (setf (acceptor-shutdown-p acceptor) t)
 256   (shutdown (acceptor-taskmaster acceptor))
 257   #-:lispworks
 258   (usocket:socket-close (acceptor-listen-socket acceptor))
 259   #-:lispworks
 260   (setf (acceptor-listen-socket acceptor) nil)
 261   acceptor)
 262
 263 (defmethod initialize-connection-stream ((acceptor acceptor) stream)
 264  (declare (ignore acceptor))
 265  ;; default method does nothing
 266  stream)
 267
 268 (defmethod reset-connection-stream ((acceptor acceptor) stream)
 269   (declare (ignore acceptor))
 270   ;; turn chunking off at this point
 271   (cond ((typep stream 'chunked-stream)
 272          ;; flush the stream first and check if there's unread input
 273          ;; which would be an error
 274          (setf (chunked-stream-output-chunking-p stream) nil
 275                (chunked-stream-input-chunking-p stream) nil)
 276          ;; switch back to bare socket stream
 277          (chunked-stream-stream stream))
 278         (t stream)))
 279
 280 (defmethod process-connection :around ((*acceptor* acceptor) (socket t))
 281   ;; this around method is used for error handling
 282   (declare (ignore socket))
 283   ;; note that this method also binds *ACCEPTOR*
 284   (handler-bind ((error
 285                   ;; abort if there's an error which isn't caught inside
 286                   (lambda (cond)
 287                     (log-message *lisp-errors-log-level*
 288                                  "Error while processing connection: ~A" cond)
 289                     (return-from process-connection)))
 290                  (warning
 291                   ;; log all warnings which aren't caught inside
 292                   (lambda (cond)
 293                     (log-message *lisp-warnings-log-level*
 294                                  "Warning while processing connection: ~A" cond))))
 295     (with-mapped-conditions ()
 296       (call-next-method))))
 297
 298 (defmethod process-connection ((*acceptor* acceptor) (socket t))
 299   (let ((*hunchentoot-stream*
 300          (initialize-connection-stream *acceptor* (make-socket-stream socket *acceptor*))))
 301     (unwind-protect
 302         ;; process requests until either the acceptor is shut down,
 303         ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
 304         ;; handler, or the peer fails to send a request
 305         (loop
 306           (let ((*close-hunchentoot-stream* t))
 307             (when (acceptor-shutdown-p *acceptor*)
 308               (return))
 309             (multiple-value-bind (headers-in method url-string protocol)
 310                 (get-request-data *hunchentoot-stream*)
 311               ;; check if there was a request at all
 312               (unless method
 313                 (return))
 314               ;; bind per-request special variables, then process the
 315               ;; request - note that *ACCEPTOR* was bound above already
 316               (let ((*reply* (make-instance (acceptor-reply-class *acceptor*)))
 317                     (*session* nil)
 318                     (transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
 319                 (when transfer-encodings
 320                   (setq transfer-encodings
 321                         (split "\\s*,\\s*" transfer-encodings))
 322                   (when (member "chunked" transfer-encodings :test #'equalp)
 323                     (cond ((acceptor-input-chunking-p *acceptor*)
 324                            ;; turn chunking on before we read the request body
 325                            (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
 326                                  (chunked-stream-input-chunking-p *hunchentoot-stream*) t))
 327                           (t (hunchentoot-error "Client tried to use ~
 328 chunked encoding, but acceptor is configured to not use it.")))))
 329                 (multiple-value-bind (remote-addr remote-port)
 330                     (get-peer-address-and-port socket)
 331                   (process-request (make-instance (acceptor-request-class *acceptor*)
 332                                       :acceptor *acceptor*
 333                                       :remote-addr remote-addr
 334                                       :remote-port remote-port
 335                                       :headers-in headers-in
 336                                       :content-stream *hunchentoot-stream*
 337                                       :method method
 338                                       :uri url-string
 339                                       :server-protocol protocol))))
 340               (force-output *hunchentoot-stream*)
 341               (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*))
 342               (when *close-hunchentoot-stream*
 343                 (return)))))
 344       (when *hunchentoot-stream*
 345         ;; as we are at the end of the request here, we ignore all
 346         ;; errors that may occur while flushing and/or closing the
 347         ;; stream.
 348         (ignore-errors*
 349           (force-output *hunchentoot-stream*))
 350         (ignore-errors*
 351           (close *hunchentoot-stream* :abort t))))))
 352
 353 (defmethod acceptor-ssl-p ((acceptor t))
 354   ;; the default is to always answer "no"
 355   nil)
 356
 357 ;; usocket implementation
 358
 359 #-:lispworks
 360 (defmethod start-listening ((acceptor acceptor))
 361   (when (acceptor-listen-socket acceptor)
 362     (hunchentoot-error "acceptor ~A is already listening" acceptor))
 363   (setf (acceptor-listen-socket acceptor)
 364         (usocket:socket-listen (or (acceptor-address acceptor)
 365                                    usocket:*wildcard-host*)
 366                                (acceptor-port acceptor)
 367                                :reuseaddress t
 368                                :element-type '(unsigned-byte 8)))
 369   (values))
 370
 371 #-:lispworks
 372 (defmethod accept-connections ((acceptor acceptor))
 373   (usocket:with-server-socket (listener (acceptor-listen-socket acceptor))
 374     (loop
 375      (when (acceptor-shutdown-p acceptor)
 376        (return))
 377      (when (usocket:wait-for-input listener :ready-only t :timeout +new-connection-wait-time+)
 378        (when-let (client-connection
 379                   (handler-case (usocket:socket-accept listener)
 380                     ;; ignore condition
 381                     (usocket:connection-aborted-error ())))
 382          (set-timeouts client-connection
 383                        (acceptor-read-timeout acceptor)
 384                        (acceptor-write-timeout acceptor))
 385          (handle-incoming-connection (acceptor-taskmaster acceptor)
 386                                      client-connection))))))
 387
 388 ;; LispWorks implementation
 389
 390 #+:lispworks
 391 (defmethod start-listening ((acceptor acceptor))
 392   (multiple-value-bind (listener-process startup-condition)
 393       (comm:start-up-server :service (acceptor-port acceptor)
 394                             :address (acceptor-address acceptor)
 395                             :process-name (format nil "Hunchentoot listener \(~A:~A)"
 396                                                   (or (acceptor-address acceptor) "*")
 397                                                   (acceptor-port acceptor))
 398                             ;; this function is called once on startup - we
 399                             ;; use it to check for errors
 400                             :announce (lambda (socket &optional condition)
 401                                         (declare (ignore socket))
 402                                         (when condition
 403                                           (error condition)))
 404                             ;; this function is called whenever a connection
 405                             ;; is made
 406                             :function (lambda (handle)
 407                                         (unless (acceptor-shutdown-p acceptor)
 408                                           (handle-incoming-connection
 409                                            (acceptor-taskmaster acceptor) handle)))
 410                             ;; wait until the acceptor was successfully started
 411                             ;; or an error condition is returned
 412                             :wait t)
 413     (when startup-condition
 414       (error startup-condition))
 415     (mp:process-stop listener-process)
 416     (setf (acceptor-process acceptor) listener-process)
 417     (values)))
 418
 419 #+:lispworks
 420 (defmethod accept-connections ((acceptor acceptor))
 421   (mp:process-unstop (acceptor-process acceptor))
 422   nil)
 423
 424 (defun list-request-dispatcher (request)
 425   "The default request dispatcher which selects a request handler
 426 based on a list of individual request dispatchers all of which can
 427 either return a handler or neglect by returning NIL."
 428   (loop for dispatcher in *dispatch-table*
 429         for action = (funcall dispatcher request)
 430         when action return (funcall action)
 431         finally (setf (return-code *reply*) +http-not-found+)))
 432
 433 (defmethod handle-request ((*acceptor* acceptor) (*request* request))
 434   "Standard method for request handling.  Calls the request dispatcher
 435 of *ACCEPTOR* to determine how the request should be handled.  Also
 436 sets up standard error handling which catches any errors within the
 437 handler."
 438   (handler-bind ((error
 439                   (lambda (cond)
 440                     ;; if the headers were already sent, the error
 441                     ;; happened within the body and we have to close
 442                     ;; the stream
 443                     (when *headers-sent*
 444                       (setq *close-hunchentoot-stream* t))
 445                     (throw 'handler-done
 446                       (values nil cond (and *show-lisp-backtraces-p* (get-backtrace))))))
 447                  (warning
 448                   (lambda (cond)
 449                     (when *log-lisp-warnings-p*
 450                       (log-message *lisp-warnings-log-level* "~A" cond)))))
 451     (with-debugger
 452       (funcall (acceptor-request-dispatcher *acceptor*) *request*))))