taskmaster.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*-
   2 ;;; $Header$
   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 taskmaster ()
  33   ((acceptor :accessor taskmaster-acceptor
  34              :documentation "A backpointer to the acceptor instance
  35 this taskmaster works for."))
  36   (:documentation "An instance of this class is responsible for
  37 distributing the work of handling requests for its acceptor.  This is
  38 an \"abstract\" class in the sense that usually only instances of
  39 subclasses of TASKMASTER will be used."))
  40
  41 (defgeneric execute-acceptor (taskmaster)
  42   (:documentation "This is a callback called by the acceptor once it
  43 has performed all initial processing to start listening for incoming
  44 connections \(see START-LISTENING).  It usually calls the
  45 ACCEPT-CONNECTIONS method of the acceptor, but depending on the
  46 taskmaster instance the method might be called from a new thread."))
  47
  48 (defgeneric handle-incoming-connection (taskmaster socket)
  49   (:documentation "This function is called by the acceptor to start
  50 processing of requests on a new incoming connection.  SOCKET is the
  51 usocket instance that represents the new connection \(or a socket
  52 handle on LispWorks).  The taskmaster starts processing requests on
  53 the incoming connection by calling the PROCESS-CONNECTION method of
  54 the acceptor instance.  The SOCKET argument is passed to
  55 PROCESS-CONNECTION as an argument."))
  56
  57 (defgeneric shutdown (taskmaster)
  58   (:documentation "Shuts down the taskmaster, i.e. frees all resources
  59 that were set up by it.  For example, a multi-threaded taskmaster
  60 might terminate all threads that are currently associated with it.
  61 This function is called by the acceptor's STOP method."))
  62
  63 (defgeneric create-request-handler-thread (taskmaster socket)
  64   (:documentation
  65    "Create a new thread in which to process the request.
  66     This thread will call PROCESS-CONNECTION to process the request."))
  67
  68 (defgeneric too-many-taskmaster-requests (taskmaster socket)
  69   (:documentation
  70    "Signal a \"too many requests\" error, just prior to closing the connection."))
  71
  72 (defgeneric taskmaster-max-thread-count (taskmaster)
  73   (:documentation
  74    "The maximum number of request threads this taskmaster will simultaneously
  75     run before refusing or queueing new connections requests.  If the value
  76     is null, then there is no limit.")
  77   (:method ((taskmaster taskmaster))
  78     "Default method -- no limit on the number of threads."
  79     nil))
  80
  81 (defgeneric taskmaster-max-accept-count (taskmaster)
  82   (:documentation
  83    "The maximum number of connections this taskmaster will accept before refusing
  84     new connections.  If supplied, this must be greater than MAX-THREAD-COUNT.
  85     The number of queued requests is the difference between MAX-ACCEPT-COUNT
  86     and MAX-THREAD-COUNT.")
  87   (:method ((taskmaster taskmaster))
  88     "Default method -- no limit on the number of connections."
  89     nil))
  90
  91 (defgeneric taskmaster-request-count (taskmaster)
  92   (:documentation
  93    "Returns the current number of taskmaster requests.")
  94   (:method ((taskmaster taskmaster))
  95     "Default method -- claim there is one connection thread."
  96     1))
  97
  98 (defgeneric increment-taskmaster-request-count (taskmaster)
  99   (:documentation
 100    "Atomically increment the number of taskmaster requests.")
 101   (:method  ((taskmaster taskmaster))
 102     "Default method -- do nothing."
 103     nil))
 104
 105 (defgeneric decrement-taskmaster-request-count (taskmaster)
 106   (:documentation
 107    "Atomically decrement the number of taskmaster requests")
 108   (:method ((taskmaster taskmaster))
 109     "Default method -- do nothing."
 110     nil))
 111
 112
 113 (defclass single-threaded-taskmaster (taskmaster)
 114   ()
 115   (:documentation "A taskmaster that runs synchronously in the thread
 116 where the START function was invoked \(or in the case of LispWorks in
 117 the thread started by COMM:START-UP-SERVER).  This is the simplest
 118 possible taskmaster implementation in that its methods do nothing but
 119 calling their acceptor \"sister\" methods - EXECUTE-ACCEPTOR calls
 120 ACCEPT-CONNECTIONS, HANDLE-INCOMING-CONNECTION calls
 121 PROCESS-CONNECTION."))
 122
 123 (defmethod execute-acceptor ((taskmaster single-threaded-taskmaster))
 124   ;; in a single-threaded environment we just call ACCEPT-CONNECTIONS
 125   (accept-connections (taskmaster-acceptor taskmaster)))
 126
 127 (defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket)
 128   ;; in a single-threaded environment we just call PROCESS-CONNECTION
 129   (process-connection (taskmaster-acceptor taskmaster) socket))
 130
 131 (defvar *default-max-thread-count* 100)
 132 (defvar *default-max-accept-count* (+ *default-max-thread-count* 20))
 133
 134 ;; You might think it would be nice to provide a taskmaster that takes
 135 ;; threads out of a thread pool.  There are two things to consider:
 136 ;;  - On a 2010-ish Linux box, thread creation takes less than 250 microseconds.
 137 ;;  - Bordeaux Threads doesn't provide a way to "reset" and restart a thread,
 138 ;;    and it's not clear how many Lisp implementations can do this.
 139 ;; So for now, we leave this out of the mix.
 140 (defclass one-thread-per-connection-taskmaster (taskmaster)
 141   (#-:lispworks
 142    (acceptor-process
 143     :accessor acceptor-process
 144     :documentation
 145     "A process that accepts incoming connections and hands them off to new processes
 146      for request handling.")
 147    ;; Support for bounding the number of threads we'll create
 148    (max-thread-count
 149     :type (or integer null)
 150     :initarg :max-thread-count
 151     :initform nil
 152     :accessor taskmaster-max-thread-count
 153     :documentation
 154     "The maximum number of request threads this taskmaster will simultaneously
 155      run before refusing or queueing new connections requests.  If the value
 156      is null, then there is no limit.")
 157    (max-accept-count
 158     :type (or integer null)
 159     :initarg :max-accept-count
 160     :initform nil
 161     :accessor taskmaster-max-accept-count
 162     :documentation
 163     "The maximum number of connections this taskmaster will accept before refusing
 164      new connections.  If supplied, this must be greater than MAX-THREAD-COUNT.
 165      The number of queued requests is the difference between MAX-ACCEPT-COUNT
 166      and MAX-THREAD-COUNT.")
 167    (request-count
 168     :type integer
 169     :initform 0
 170     :accessor taskmaster-request-count
 171     :documentation
 172     "The number of taskmaster threads currently running.")
 173    (request-count-lock
 174     :initform (make-lock "taskmaster-request-count")
 175     :reader taskmaster-request-count-lock
 176     :documentation
 177     "In the absence of 'atomic-incf', we need this to atomically
 178      increment and decrement the request count.")
 179    (wait-queue
 180     :initform (make-condition-variable)
 181     :reader taskmaster-wait-queue
 182     :documentation
 183     "A queue that we use to wait for a free connection.")
 184    (wait-lock
 185     :initform (make-lock "taskmaster-thread-lock")
 186     :reader taskmaster-wait-lock
 187     :documentation
 188     "The lock for the connection wait queue.")
 189    (worker-thread-name-format
 190     :type (or string null)
 191     :initarg :worker-thread-name-format
 192     :initform "hunchentoot-worker-~A"
 193     :accessor taskmaster-worker-thread-name-format))
 194   (:default-initargs
 195    :max-thread-count *default-max-thread-count*
 196    :max-accept-count *default-max-accept-count*)
 197   (:documentation "A taskmaster that starts one thread for listening
 198 to incoming requests and one new thread for each incoming connection.
 199
 200 If MAX-THREAD-COUNT is null, a new thread will always be created for
 201 each request.
 202
 203 If MAX-THREAD-COUNT is supplied, the number of request threads is
 204 limited to that.  Furthermore, if MAX-ACCEPT-COUNT is not supplied, an
 205 HTTP 503 will be sent if the thread limit is exceeded.  Otherwise, if
 206 MAX-ACCEPT-COUNT is supplied, it must be greater than MAX-THREAD-COUNT;
 207 in this case, requests are accepted up to MAX-ACCEPT-COUNT, and only
 208 then is HTTP 503 sent.
 209
 210 In a load-balanced environment with multiple Hunchentoot servers, it's
 211 reasonable to provide MAX-THREAD-COUNT but leave MAX-ACCEPT-COUNT null.
 212 This will immediately result in HTTP 503 when one server is out of
 213 resources, so the load balancer can try to find another server.
 214
 215 In an environment with a single Hunchentoot server, it's reasonable
 216 to provide both MAX-THREAD-COUNT and a somewhat larger value for
 217 MAX-ACCEPT-COUNT.  This will cause a server that's almost out of
 218 resources to wait a bit; if the server is completely out of resources,
 219 then the reply will be HTTP 503.
 220
 221 This is the default taskmaster implementation for multi-threaded Lisp
 222 implementations."))
 223
 224 (defmethod initialize-instance :after ((taskmaster one-thread-per-connection-taskmaster) &rest init-args)
 225   "Ensure the if MAX-ACCEPT-COUNT is supplied, that it is greater than MAX-THREAD-COUNT."
 226   (declare (ignore init-args))
 227   (when (taskmaster-max-accept-count taskmaster)
 228     (unless (taskmaster-max-thread-count taskmaster)
 229       (parameter-error "MAX-THREAD-COUNT must be supplied if MAX-ACCEPT-COUNT is supplied"))
 230     (unless (> (taskmaster-max-accept-count taskmaster) (taskmaster-max-thread-count taskmaster))
 231       (parameter-error "MAX-ACCEPT-COUNT must be greater than MAX-THREAD-COUNT"))))
 232
 233 (defmethod increment-taskmaster-request-count ((taskmaster one-thread-per-connection-taskmaster))
 234   (when (taskmaster-max-thread-count taskmaster)
 235     (with-lock-held ((taskmaster-request-count-lock taskmaster))
 236       (incf (taskmaster-request-count taskmaster)))))
 237
 238 (defmethod decrement-taskmaster-request-count ((taskmaster one-thread-per-connection-taskmaster))
 239   (when (taskmaster-max-thread-count taskmaster)
 240     (prog1
 241         (with-lock-held ((taskmaster-request-count-lock taskmaster))
 242           (decf (taskmaster-request-count taskmaster)))
 243       (when (and (taskmaster-max-accept-count taskmaster)
 244                  (< (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster)))
 245         (note-free-connection taskmaster)))))
 246
 247 (defmethod note-free-connection ((taskmaster one-thread-per-connection-taskmaster))
 248   "Note that a connection has been freed up"
 249   (with-lock-held ((taskmaster-wait-lock taskmaster))
 250     (condition-variable-signal (taskmaster-wait-queue taskmaster))))
 251
 252 (defmethod wait-for-free-connection ((taskmaster one-thread-per-connection-taskmaster))
 253   "Wait for a connection to be freed up"
 254   (with-lock-held ((taskmaster-wait-lock taskmaster))
 255     (loop until (< (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))
 256           do (condition-variable-wait (taskmaster-wait-queue taskmaster) (taskmaster-wait-lock taskmaster)))))
 257
 258 (defmethod too-many-taskmaster-requests ((taskmaster one-thread-per-connection-taskmaster) socket)
 259   (declare (ignore socket))
 260   (acceptor-log-message (taskmaster-acceptor taskmaster)
 261                         :warning "Can't handle a new request, too many request threads already"))
 262
 263 ;;; usocket implementation
 264
 265 #-:lispworks
 266 (defmethod shutdown ((taskmaster taskmaster))
 267   taskmaster)
 268
 269 #-:lispworks
 270 (defmethod shutdown ((taskmaster one-thread-per-connection-taskmaster))
 271   ;; just wait until the acceptor process has finished, then return
 272   (loop
 273    (unless (bt:thread-alive-p (acceptor-process taskmaster))
 274      (return))
 275    (sleep 1))
 276   taskmaster)
 277
 278 #-:lispworks
 279 (defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster))
 280   (setf (acceptor-process taskmaster)
 281         (bt:make-thread
 282          (lambda ()
 283            (accept-connections (taskmaster-acceptor taskmaster)))
 284          :name (format nil "hunchentoot-listener-~A:~A"
 285                        (or (acceptor-address (taskmaster-acceptor taskmaster)) "*")
 286                        (acceptor-port (taskmaster-acceptor taskmaster))))))
 287
 288 #-:lispworks
 289 (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
 290   ;; Here's the idea, with the stipulations given in ONE-THREAD-PER-CONNECTION-TASKMASTER
 291   ;;  - If MAX-THREAD-COUNT is null, just start a taskmaster
 292   ;;  - If the connection count will exceed MAX-ACCEPT-COUNT or if MAX-ACCEPT-COUNT
 293   ;;    is null and the connection count will exceed MAX-THREAD-COUNT,
 294   ;;    return an HTTP 503 error to the client
 295   ;;  - Otherwise if we're between MAX-THREAD-COUNT and MAX-ACCEPT-COUNT,
 296   ;;    wait until the connection count drops, then handle the request
 297   ;;  - Otherwise, increment REQUEST-COUNT and start a taskmaster
 298   (cond ((null (taskmaster-max-thread-count taskmaster))
 299          ;; No limit on number of requests, just start a taskmaster
 300          (create-request-handler-thread taskmaster socket))
 301         ((if (taskmaster-max-accept-count taskmaster)
 302            (>= (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster))
 303            (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster)))
 304          ;; Send HTTP 503 to indicate that we can't handle the request right now
 305          (too-many-taskmaster-requests taskmaster socket)
 306          (send-service-unavailable-reply taskmaster socket))
 307         ((and (taskmaster-max-accept-count taskmaster)
 308               (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster)))
 309          ;; Wait for a request to finish, then carry on
 310          (wait-for-free-connection taskmaster)
 311          (increment-taskmaster-request-count taskmaster)
 312          (create-request-handler-thread taskmaster socket))
 313         (t
 314          ;; We're within both limits, just start a taskmaster
 315          (increment-taskmaster-request-count taskmaster)
 316          (create-request-handler-thread taskmaster socket))))
 317
 318 (defun send-service-unavailable-reply (taskmaster socket)
 319   "A helper function to send out a quick error reply, before any state
 320 is set up via PROCESS-REQUEST."
 321   (let ((acceptor (taskmaster-acceptor taskmaster)))
 322     (send-response acceptor
 323                    (initialize-connection-stream acceptor (make-socket-stream socket acceptor))
 324                    +http-service-unavailable+
 325                    :content (acceptor-status-message acceptor +http-service-unavailable+))))
 326
 327 #-:lispworks
 328 (defun client-as-string (socket)
 329   "A helper function which returns the client's address and port as a
 330    string and tries to act robustly in the presence of network problems."
 331   (let ((address (usocket:get-peer-address socket))
 332         (port (usocket:get-peer-port socket)))
 333     (when (and address port)
 334       (format nil "~A:~A"
 335               (usocket:vector-quad-to-dotted-quad address)
 336               port))))
 337
 338 #-:lispworks
 339 (defmethod create-request-handler-thread ((taskmaster one-thread-per-connection-taskmaster) socket)
 340   "Create a thread for handling a single request"
 341   ;; we are handling all conditions here as we want to make sure that
 342   ;; the acceptor process never crashes while trying to create a
 343   ;; worker thread; one such problem exists in
 344   ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on
 345   ;; some platforms in certain situations.
 346   (handler-case*
 347    (bt:make-thread
 348     (lambda ()
 349       (unwind-protect
 350            (process-connection (taskmaster-acceptor taskmaster) socket)
 351         (decrement-taskmaster-request-count taskmaster)))
 352     :name (format nil (taskmaster-worker-thread-name-format taskmaster) (client-as-string socket)))
 353    (error (cond)
 354           ;; need to bind *ACCEPTOR* so that LOG-MESSAGE* can do its work.
 355           (let ((*acceptor* (taskmaster-acceptor taskmaster)))
 356             (log-message* *lisp-errors-log-level*
 357                          "Error while creating worker thread for new incoming connection: ~A" cond)))))
 358
 359 ;; LispWorks implementation
 360
 361 #+:lispworks
 362 (defmethod shutdown ((taskmaster taskmaster))
 363   (when-let (process (acceptor-process (taskmaster-acceptor taskmaster)))
 364     ;; kill the main acceptor process, see LW documentation for
 365     ;; COMM:START-UP-SERVER
 366     (mp:process-kill process))
 367   taskmaster)
 368
 369 #+:lispworks
 370 (defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster))
 371   (accept-connections (taskmaster-acceptor taskmaster)))
 372
 373 #+:lispworks
 374 (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
 375   (incf *worker-counter*)
 376   ;; check if we need to perform a global GC
 377   (when (and *cleanup-interval*
 378              (zerop (mod *worker-counter* *cleanup-interval*)))
 379     (when *cleanup-function*
 380       (funcall *cleanup-function*)))
 381   (cond ((null (taskmaster-max-thread-count taskmaster))
 382          ;; No limit on number of requests, just start a taskmaster
 383          (create-request-handler-thread taskmaster socket))
 384         ((if (taskmaster-max-accept-count taskmaster)
 385            (>= (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster))
 386            (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster)))
 387          ;; Send HTTP 503 to indicate that we can't handle the request right now
 388          (too-many-taskmaster-requests taskmaster socket)
 389          (send-service-unavailable-reply taskmaster socket))
 390         ((and (taskmaster-max-accept-count taskmaster)
 391               (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster)))
 392          ;; Lispworks doesn't have condition variables, so punt
 393          (too-many-taskmaster-requests taskmaster socket)
 394          (send-service-unavailable-reply taskmaster socket))
 395         (t
 396          ;; We're within both limits, just start a taskmaster
 397          (increment-taskmaster-request-count taskmaster)
 398          (create-request-handler-thread taskmaster socket))))
 399
 400 #+:lispworks
 401 (defmethod create-request-handler-thread ((taskmaster one-thread-per-connection-taskmaster) socket)
 402   (flet ((process (taskmaster sock)
 403            (unwind-protect
 404                 (process-connection (taskmaster-acceptor taskmaster) socket)
 405              (decrement-taskmaster-request-count taskmaster))))
 406     (mp:process-run-function (format nil "hunchentoot-worker~{-~A:~A~})"
 407                                      (multiple-value-list
 408                                       (get-peer-address-and-port socket)))
 409                              nil #'process taskmaster socket)))