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-2009, 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, but you can for example write
 229 an around method specialized for your subclass of ACCEPTOR which binds
 230 or rebinds special variables which can then be accessed by your
 231 handlers."))
 232
 233 (defgeneric acceptor-ssl-p (acceptor)
 234   (:documentation "Returns a true value if ACCEPTOR uses SSL
 235 connections.  The default is to unconditionally return NIL and
 236 subclasses of ACCEPTOR must specialize this method to signal that
 237 they're using secure connections - see the SSL-ACCEPTOR class."))
 238
 239 ;; general implementation
 240
 241 (defmethod start ((acceptor acceptor))
 242   (start-listening acceptor)
 243   (let ((taskmaster (acceptor-taskmaster acceptor)))
 244     (setf (taskmaster-acceptor taskmaster) acceptor)
 245     (execute-acceptor taskmaster))
 246   acceptor)
 247
 248 (defmethod stop ((acceptor acceptor))
 249   (setf (acceptor-shutdown-p acceptor) t)
 250   (shutdown (acceptor-taskmaster acceptor))
 251   #-:lispworks
 252   (usocket:socket-close (acceptor-listen-socket acceptor))
 253   #-:lispworks
 254   (setf (acceptor-listen-socket acceptor) nil)
 255   acceptor)
 256
 257 (defmethod initialize-connection-stream ((acceptor acceptor) stream)
 258  (declare (ignore acceptor))
 259  ;; default method does nothing
 260  stream)
 261
 262 (defmethod reset-connection-stream ((acceptor acceptor) stream)
 263   (declare (ignore acceptor))
 264   ;; turn chunking off at this point
 265   (cond ((typep stream 'chunked-stream)
 266          ;; flush the stream first and check if there's unread input
 267          ;; which would be an error
 268          (setf (chunked-stream-output-chunking-p stream) nil
 269                (chunked-stream-input-chunking-p stream) nil)
 270          ;; switch back to bare socket stream
 271          (chunked-stream-stream stream))
 272         (t stream)))
 273
 274 (defmethod process-connection :around ((*acceptor* acceptor) (socket t))
 275   ;; this around method is used for error handling
 276   (declare (ignore socket))
 277   ;; note that this method also binds *ACCEPTOR*
 278   (handler-bind ((error
 279                   ;; abort if there's an error which isn't caught inside
 280                   (lambda (cond)
 281                     (log-message *lisp-errors-log-level*
 282                                  "Error while processing connection: ~A" cond)
 283                     (return-from process-connection)))
 284                  (warning
 285                   ;; log all warnings which aren't caught inside
 286                   (lambda (cond)
 287                     (log-message *lisp-warnings-log-level*
 288                                  "Warning while processing connection: ~A" cond))))
 289     (with-mapped-conditions ()
 290       (call-next-method))))
 291
 292 (defmethod process-connection ((*acceptor* acceptor) (socket t))
 293   (let ((*hunchentoot-stream*
 294          (initialize-connection-stream *acceptor* (make-socket-stream socket *acceptor*))))
 295     (unwind-protect
 296         ;; process requests until either the acceptor is shut down,
 297         ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
 298         ;; handler, or the peer fails to send a request
 299         (loop
 300          (let ((*close-hunchentoot-stream* t))
 301            (when (acceptor-shutdown-p *acceptor*)
 302              (return))
 303            (multiple-value-bind (headers-in method url-string protocol)
 304                (get-request-data *hunchentoot-stream*)
 305              ;; check if there was a request at all
 306              (unless method
 307                (return))
 308              ;; bind per-request special variables, then process the
 309              ;; request - note that *ACCEPTOR* was bound above already
 310              (let ((*reply* (make-instance (acceptor-reply-class *acceptor*)))
 311                    (*session* nil)
 312                    (transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
 313                (when transfer-encodings
 314                  (setq transfer-encodings
 315                        (split "\\s*,\\*" transfer-encodings))
 316                  (when (member "chunked" transfer-encodings :test #'equalp)
 317                    (cond ((acceptor-input-chunking-p *acceptor*)
 318                           ;; turn chunking on before we read the request body
 319                           (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
 320                                 (chunked-stream-input-chunking-p *hunchentoot-stream*) t))
 321                          (t (hunchentoot-error "Client tried to use ~
 322 chunked encoding, but acceptor is configured to not use it.")))))
 323                (multiple-value-bind (remote-addr remote-port)
 324                    (get-peer-address-and-port socket)
 325                  (process-request (make-instance (acceptor-request-class *acceptor*)
 326                                                  :acceptor *acceptor*
 327                                                  :remote-addr remote-addr
 328                                                  :remote-port remote-port
 329                                                  :headers-in headers-in
 330                                                  :content-stream *hunchentoot-stream*
 331                                                  :method method
 332                                                  :uri url-string
 333                                                  :server-protocol protocol))))
 334              (force-output *hunchentoot-stream*)
 335              (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*))
 336              (when *close-hunchentoot-stream*
 337                (return)))))
 338       (when *hunchentoot-stream*
 339         ;; as we are at the end of the request here, we ignore all
 340         ;; errors that may occur while flushing and/or closing the
 341         ;; stream.
 342         (ignore-errors
 343           (force-output *hunchentoot-stream*)
 344           (close *hunchentoot-stream* :abort t))))))
 345
 346 (defmethod acceptor-ssl-p ((acceptor t))
 347   ;; the default is to always answer "no"
 348   nil)
 349
 350 ;; usocket implementation
 351
 352 #-:lispworks
 353 (defmethod start-listening ((acceptor acceptor))
 354   (when (acceptor-listen-socket acceptor)
 355     (hunchentoot-error "acceptor ~A is already listening" acceptor))
 356   (setf (acceptor-listen-socket acceptor)
 357         (usocket:socket-listen (or (acceptor-address acceptor)
 358                                    usocket:*wildcard-host*)
 359                                (acceptor-port acceptor)
 360                                :reuseaddress t
 361                                :element-type '(unsigned-byte 8)))
 362   (values))
 363
 364 #-:lispworks
 365 (defmethod accept-connections ((acceptor acceptor))
 366   (usocket:with-server-socket (listener (acceptor-listen-socket acceptor))
 367     (loop
 368      (when (acceptor-shutdown-p acceptor)
 369        (return))
 370      (when (usocket:wait-for-input listener :ready-only t :timeout +new-connection-wait-time+)
 371        (when-let (client-connection
 372                   (handler-case
 373                       (usocket:socket-accept listener)
 374
 375                     ;; ignore condition
 376                     (usocket:connection-aborted-error ())))
 377          (set-timeouts client-connection
 378                        (acceptor-read-timeout acceptor)
 379                        (acceptor-write-timeout acceptor))
 380          (handle-incoming-connection (acceptor-taskmaster acceptor)
 381                                      client-connection))))))
 382
 383 ;; LispWorks implementation
 384
 385 #+:lispworks
 386 (defmethod start-listening ((acceptor acceptor))
 387   (multiple-value-bind (listener-process startup-condition)
 388       (comm:start-up-server :service (acceptor-port acceptor)
 389                             :address (acceptor-address acceptor)
 390                             :process-name (format nil "Hunchentoot listener \(~A:~A)"
 391                                                   (or (acceptor-address acceptor) "*")
 392                                                   (acceptor-port acceptor))
 393                             ;; this function is called once on startup - we
 394                             ;; use it to check for errors
 395                             :announce (lambda (socket &optional condition)
 396                                         (declare (ignore socket))
 397                                         (when condition
 398                                           (error condition)))
 399                             ;; this function is called whenever a connection
 400                             ;; is made
 401                             :function (lambda (handle)
 402                                         (unless (acceptor-shutdown-p acceptor)
 403                                           (handle-incoming-connection
 404                                            (acceptor-taskmaster acceptor) handle)))
 405                             ;; wait until the acceptor was successfully started
 406                             ;; or an error condition is returned
 407                             :wait t)
 408     (when startup-condition
 409       (error startup-condition))
 410     (mp:process-stop listener-process)
 411     (setf (acceptor-process acceptor) listener-process)
 412     (values)))
 413
 414 #+:lispworks
 415 (defmethod accept-connections ((acceptor acceptor))
 416   (mp:process-unstop (acceptor-process acceptor))
 417   nil)
 418
 419 (defun list-request-dispatcher (request)
 420   "The default request dispatcher which selects a request handler
 421 based on a list of individual request dispatchers all of which can
 422 either return a handler or neglect by returning NIL."
 423   (loop for dispatcher in *dispatch-table*
 424         for action = (funcall dispatcher request)
 425         when action return (funcall action)
 426         finally (setf (return-code *reply*) +http-not-found+)))
 427