taskmaster.lisp

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