The following patch adds a feature to Hunchentoot called "soft shutdown" or "soft stop". It provides a way to shut down the Hunchentoot server, but only after any pending requests have been processed (including sending back the reply).
Is this OK to add to the official Hunchentoot?
Thanks.
-- Dan
------------------------------------------------------------------------
*** /ita/hunchentoot/hunchentoot-1.1.1/acceptor.lisp 2010-08-22 15:33:01.000000000 -0400 --- /ita/work/four/qres/lisp/libs/hunchentoot/acceptor.lisp 2011-02-07 15:41:35.000000000 -0500 *************** *** 122,127 **** --- 125,143 ---- :accessor acceptor-shutdown-p :documentation "A flag that makes the acceptor shutdown itself when set to something other than NIL.") + (requests-in-progress :initform 0 + :accessor accessor-requests-in-progress + :documentation "The number of + requests currently in progress.") + (shutdown-queue :initform (make-condition-variable) + :accessor acceptor-shutdown-queue + :documentation "A condition variable + used with soft shutdown, signaled when all requests + have been processed.") + (shutdown-lock :initform (make-lock "hunchentoot-acceptor-shutdown") + :accessor acceptor-shutdown-lock + :documentation "The lock protecting the shutdown-queue + condition variable and the requests-in-progress counter.") (access-logger :initarg :access-logger :accessor acceptor-access-logger :documentation "Designator for a function to call to *************** *** 183,191 **** (:documentation "Starts the ACCEPTOR so that it begins accepting connections. Returns the acceptor."))
! (defgeneric stop (acceptor) (:documentation "Stops the ACCEPTOR so that it no longer accepts ! requests."))
(defgeneric start-listening (acceptor) (:documentation "Sets up a listen socket for the given ACCEPTOR and --- 199,209 ---- (:documentation "Starts the ACCEPTOR so that it begins accepting connections. Returns the acceptor."))
! (defgeneric stop (acceptor &key soft) (:documentation "Stops the ACCEPTOR so that it no longer accepts ! requests. If SOFT is true, and there are any requests in progress, ! wait until all requests are fully processed, but meanwhile do ! not accept new requests."))
(defgeneric start-listening (acceptor) (:documentation "Sets up a listen socket for the given ACCEPTOR and *************** *** 251,262 **** (execute-acceptor taskmaster)) acceptor)
! (defmethod stop ((acceptor acceptor)) (setf (acceptor-shutdown-p acceptor) t) (shutdown (acceptor-taskmaster acceptor)) ! #-:lispworks ! (usocket:socket-close (acceptor-listen-socket acceptor)) ! #-:lispworks (setf (acceptor-listen-socket acceptor) nil) acceptor)
--- 269,285 ---- (execute-acceptor taskmaster)) acceptor)
! (defmethod stop ((acceptor acceptor) &key soft) (setf (acceptor-shutdown-p acceptor) t) (shutdown (acceptor-taskmaster acceptor)) ! (when soft ! (with-lock-held ((acceptor-shutdown-lock acceptor)) ! (when (plusp (accessor-requests-in-progress acceptor)) ! (condition-variable-wait (acceptor-shutdown-queue acceptor) ! (acceptor-shutdown-lock acceptor))))) ! (#+:lispworks close ! #-:lispworks usocket:socket-close ! (acceptor-listen-socket acceptor)) (setf (acceptor-listen-socket acceptor) nil) acceptor)
*************** *** 328,346 **** chunked encoding, but acceptor is configured to not use it."))))) (multiple-value-bind (remote-addr remote-port) (get-peer-address-and-port socket) (process-request (make-instance (acceptor-request-class *acceptor*) ! :acceptor *acceptor* ! :remote-addr remote-addr ! :remote-port remote-port ! :headers-in headers-in ! :content-stream *hunchentoot-stream* ! :method method ! :uri url-string ! :server-protocol protocol)))) (force-output *hunchentoot-stream*) (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*)) (when *close-hunchentoot-stream* (return))))) (when *hunchentoot-stream* ;; as we are at the end of the request here, we ignore all ;; errors that may occur while flushing and/or closing the --- 351,379 ---- chunked encoding, but acceptor is configured to not use it."))))) (multiple-value-bind (remote-addr remote-port) (get-peer-address-and-port socket) + (with-lock-held ((acceptor-shutdown-lock *acceptor*)) + (incf (accessor-requests-in-progress *acceptor*))) (process-request (make-instance (acceptor-request-class *acceptor*) ! :acceptor *acceptor* ! :remote-addr remote-addr ! :remote-port remote-port ! :headers-in headers-in ! :content-stream *hunchentoot-stream* ! :method method ! :uri url-string ! :server-protocol protocol))) ! ) (force-output *hunchentoot-stream*) (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*)) (when *close-hunchentoot-stream* (return))))) + + ;; When we are finished processing the request: + (with-lock-held ((acceptor-shutdown-lock *acceptor*)) + (decf (accessor-requests-in-progress *acceptor*)) + (when (acceptor-shutdown-p *acceptor*) + (condition-variable-signal (acceptor-shutdown-queue *acceptor*)))) + (when *hunchentoot-stream* ;; as we are at the end of the request here, we ignore all ;; errors that may occur while flushing and/or closing the *** /ita/hunchentoot/hunchentoot-1.1.1/taskmaster.lisp 2010-08-22 15:33:01.000000000 -0400 --- /ita/work/four/qres/lisp/libs/hunchentoot/taskmaster.lisp 2011-02-03 14:17:16.000000000 -0500 *************** *** 27,32 **** --- 27,34 ---- ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ #+xcvb (module (:depends-on ("conditions"))) + (in-package :hunchentoot)
(defclass taskmaster () *************** *** 60,65 **** --- 62,117 ---- might terminate all threads that are currently associated with it. This function is called by the acceptor's STOP method."))
+ (defgeneric create-taskmaster-thread (taskmaster socket) + (:documentation + "Create a new thread in which to process the request. + This thread will call PROCESS-CONNECTION to process the request.")) + + (defgeneric too-many-taskmaster-requests (taskmaster socket) + (:documentation + "Signal a "too many requests" error, just prior to closing the connection.")) + + (defgeneric taskmaster-max-thread-count (taskmaster) + (:documentation + "The maximum number of request threads this taskmaster will simultaneously + run before refusing or queueing new connections requests. If the value + is null, then there is no limit.") + (:method ((taskmaster taskmaster)) + "Default method -- no limit on the number of threads." + nil)) + + (defgeneric taskmaster-max-accept-count (taskmaster) + (:documentation + "The maximum number of connections this taskmaster will accept before refusing + new connections. If supplied, this must be greater than MAX-THREAD-COUNT. + The number of queued requests is the difference between MAX-ACCEPT-COUNT + and MAX-THREAD-COUNT.") + (:method ((taskmaster taskmaster)) + "Default method -- no limit on the number of connections." + nil)) + + (defgeneric taskmaster-request-count (taskmaster) + (:documentation + "Returns the current number of taskmaster requests.") + (:method ((taskmaster taskmaster)) + "Default method -- claim there is one connection thread." + 1)) + + (defgeneric increment-taskmaster-request-count (taskmaster) + (:documentation + "Atomically increment the number of taskmaster requests.") + (:method ((taskmaster taskmaster)) + "Default method -- do nothing." + nil)) + + (defgeneric decrement-taskmaster-request-count (taskmaster) + (:documentation + "Atomically decrement the number of taskmaster requests") + (:method ((taskmaster taskmaster)) + "Default method -- do nothing." + nil)) + + (defclass single-threaded-taskmaster (taskmaster) () (:documentation "A taskmaster that runs synchronously in the thread *************** *** 78,96 **** ;; in a single-threaded environment we just call PROCESS-CONNECTION (process-connection (taskmaster-acceptor taskmaster) socket))
(defclass one-thread-per-connection-taskmaster (taskmaster) (#-:lispworks ! (acceptor-process :accessor acceptor-process ! :documentation "A process that accepts incoming ! connections and hands them off to new processes for request ! handling.")) (:documentation "A taskmaster that starts one thread for listening ! to incoming requests and one thread for each incoming connection.
This is the default taskmaster implementation for multi-threaded Lisp implementations."))
! ;; usocket implementation
#-:lispworks (defmethod shutdown ((taskmaster taskmaster)) --- 130,271 ---- ;; in a single-threaded environment we just call PROCESS-CONNECTION (process-connection (taskmaster-acceptor taskmaster) socket))
+ (defvar *default-max-thread-count* 100) + (defvar *default-max-accept-count* (+ *default-max-thread-count* 20)) + + ;; You might think it would be nice to provide a taskmaster that takes + ;; threads out of a thread pool. There are two things to consider: + ;; - On a 2010-ish Linux box, thread creation takes less than 250 microseconds. + ;; - Bordeaux Threads doesn't provide a way to "reset" and restart a thread, + ;; and it's not clear how many Lisp implementations can do this. + ;; So for now, we leave this out of the mix. (defclass one-thread-per-connection-taskmaster (taskmaster) (#-:lispworks ! (acceptor-process ! :accessor acceptor-process ! :documentation ! "A process that accepts incoming connections and hands them off to new processes ! for request handling.") ! ;; Support for bounding the number of threads we'll create ! (max-thread-count ! :type (or integer null) ! :initarg :max-thread-count ! :initform nil ! :accessor taskmaster-max-thread-count ! :documentation ! "The maximum number of request threads this taskmaster will simultaneously ! run before refusing or queueing new connections requests. If the value ! is null, then there is no limit.") ! (max-accept-count ! :type (or integer null) ! :initarg :max-accept-count ! :initform nil ! :accessor taskmaster-max-accept-count ! :documentation ! "The maximum number of connections this taskmaster will accept before refusing ! new connections. If supplied, this must be greater than MAX-THREAD-COUNT. ! The number of queued requests is the difference between MAX-ACCEPT-COUNT ! and MAX-THREAD-COUNT.") ! (request-count ! :type integer ! :initform 0 ! :accessor taskmaster-request-count ! :documentation ! "The number of taskmaster threads currently running.") ! (request-count-lock ! :initform (make-lock "taskmaster-request-count") ! :reader taskmaster-request-count-lock ! :documentation ! "In the absence of 'atomic-incf', we need this to atomically ! increment and decrement the request count.") ! (wait-queue ! :initform (make-condition-variable) ! :reader taskmaster-wait-queue ! :documentation ! "A queue that we use to wait for a free connection.") ! (wait-lock ! :initform (make-lock "taskmaster-thread-lock") ! :reader taskmaster-wait-lock ! :documentation ! "The lock for the connection wait queue.") ! (worker-thread-name-format ! :type (or string null) ! :initarg :worker-thread-name-format ! :initform "hunchentoot-worker-~A" ! :accessor taskmaster-worker-thread-name-format)) ! (:default-initargs ! :max-thread-count *default-max-thread-count* ! :max-accept-count *default-max-accept-count*) (:documentation "A taskmaster that starts one thread for listening ! to incoming requests and one new thread for each incoming connection. ! ! If MAX-THREAD-COUNT is null, a new thread will always be created for ! each request. ! ! If MAX-THREAD-COUNT is supplied, the number of request threads is ! limited to that. Furthermore, if MAX-ACCEPT-COUNT is not supplied, an ! HTTP 503 will be sent if the thread limit is exceeded. Otherwise, if ! MAX-ACCEPT-COUNT is supplied, it must be greater than MAX-THREAD-COUNT; ! in this case, requests are accepted up to MAX-ACCEPT-COUNT, and only ! then is HTTP 503 sent. ! ! In a load-balanced environment with multiple Hunchentoot servers, it's ! reasonable to provide MAX-THREAD-COUNT but leave MAX-ACCEPT-COUNT null. ! This will immediately result in HTTP 503 when one server is out of ! resources, so the load balancer can try to find another server. ! ! In an environment with a single Hunchentoot server, it's reasonable ! to provide both MAX-THREAD-COUNT and a somewhat larger value for ! MAX-ACCEPT-COUNT. This will cause a server that's almost out of ! resources to wait a bit; if the server is completely out of resources, ! then the reply will be HTTP 503.
This is the default taskmaster implementation for multi-threaded Lisp implementations."))
! (defmethod initialize-instance :after ((taskmaster one-thread-per-connection-taskmaster) &rest init-args) ! "Ensure the if MAX-ACCEPT-COUNT is supplied, that it is greater than MAX-THREAD-COUNT." ! (declare (ignore init-args)) ! (when (taskmaster-max-accept-count taskmaster) ! (unless (taskmaster-max-thread-count taskmaster) ! (parameter-error "MAX-THREAD-COUNT must be supplied if MAX-ACCEPT-COUNT is supplied")) ! (unless (> (taskmaster-max-accept-count taskmaster) (taskmaster-max-thread-count taskmaster)) ! (parameter-error "MAX-ACCEPT-COUNT must be greater than MAX-THREAD-COUNT")))) ! ! (defmethod increment-taskmaster-request-count ((taskmaster one-thread-per-connection-taskmaster)) ! (when (taskmaster-max-thread-count taskmaster) ! (with-lock-held ((taskmaster-request-count-lock taskmaster)) ! (incf (taskmaster-request-count taskmaster))))) ! ! (defmethod decrement-taskmaster-request-count ((taskmaster one-thread-per-connection-taskmaster)) ! (when (taskmaster-max-thread-count taskmaster) ! (prog1 ! (with-lock-held ((taskmaster-request-count-lock taskmaster)) ! (decf (taskmaster-request-count taskmaster))) ! (when (and (taskmaster-max-accept-count taskmaster) ! (< (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster))) ! (note-free-connection taskmaster))))) ! ! (defmethod note-free-connection ((taskmaster one-thread-per-connection-taskmaster)) ! "Note that a connection has been freed up" ! (with-lock-held ((taskmaster-wait-lock taskmaster)) ! (condition-variable-signal (taskmaster-wait-queue taskmaster)))) ! ! (defmethod wait-for-free-connection ((taskmaster one-thread-per-connection-taskmaster)) ! "Wait for a connection to be freed up" ! (with-lock-held ((taskmaster-wait-lock taskmaster)) ! (loop until (< (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster)) ! do (condition-variable-wait (taskmaster-wait-queue taskmaster) (taskmaster-wait-lock taskmaster))))) ! ! (defmethod too-many-taskmaster-requests ((taskmaster one-thread-per-connection-taskmaster) socket) ! (declare (ignore socket)) ! (let* ((acceptor (taskmaster-acceptor taskmaster)) ! (logger (and acceptor (acceptor-message-logger acceptor)))) ! (when logger ! (funcall logger :warning "Can't handle a new request, too many request threads already")))) ! ! ! ;;; usocket implementation
#-:lispworks (defmethod shutdown ((taskmaster taskmaster)) *************** *** 108,123 **** #-:lispworks (defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster)) (setf (acceptor-process taskmaster) ! (bt:make-thread (lambda () ! (accept-connections (taskmaster-acceptor taskmaster))) ! :name (format nil "Hunchentoot listener (~A:~A)" ! (or (acceptor-address (taskmaster-acceptor taskmaster)) "*") ! (acceptor-port (taskmaster-acceptor taskmaster))))))
#-:lispworks (defun client-as-string (socket) "A helper function which returns the client's address and port as a ! string and tries to act robustly in the presence of network problems." (let ((address (usocket:get-peer-address socket)) (port (usocket:get-peer-port socket))) (when (and address port) --- 283,348 ---- #-:lispworks (defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster)) (setf (acceptor-process taskmaster) ! (bt:make-thread ! (lambda () ! (accept-connections (taskmaster-acceptor taskmaster))) ! :name (format nil "hunchentoot-listener-~A:~A" ! (or (acceptor-address (taskmaster-acceptor taskmaster)) "*") ! (acceptor-port (taskmaster-acceptor taskmaster)))))) ! ! #-:lispworks ! (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket) ! ;; Here's the idea, with the stipulations given in ONE-THREAD-PER-CONNECTION-TASKMASTER ! ;; - If MAX-THREAD-COUNT is null, just start a taskmaster ! ;; - If the connection count will exceed MAX-ACCEPT-COUNT or if MAX-ACCEPT-COUNT ! ;; is null and the connection count will exceed MAX-THREAD-COUNT, ! ;; return an HTTP 503 error to the client ! ;; - Otherwise if we're between MAX-THREAD-COUNT and MAX-ACCEPT-COUNT, ! ;; wait until the connection count drops, then handle the request ! ;; - Otherwise, increment REQUEST-COUNT and start a taskmaster ! (cond ((null (taskmaster-max-thread-count taskmaster)) ! ;; No limit on number of requests, just start a taskmaster ! (create-taskmaster-thread taskmaster socket)) ! ((if (taskmaster-max-accept-count taskmaster) ! (>= (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster)) ! (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))) ! ;; Send HTTP 503 to indicate that we can't handle the request right now ! (too-many-taskmaster-requests taskmaster socket) ! (send-http-error-reply taskmaster socket +http-service-unavailable+)) ! ((and (taskmaster-max-accept-count taskmaster) ! (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))) ! ;; Wait for a request to finish, then carry on ! (wait-for-free-connection taskmaster) ! (increment-taskmaster-request-count taskmaster) ! (create-taskmaster-thread taskmaster socket)) ! (t ! ;; We're within both limits, just start a taskmaster ! (increment-taskmaster-request-count taskmaster) ! (create-taskmaster-thread taskmaster socket)))) ! ! (defun send-http-error-reply (taskmaster socket error-code) ! "A helper function to send out a quick error reply, ! before any state is set up via PROCESS-REQUEST." ! (let* ((acceptor (taskmaster-acceptor taskmaster)) ! (stream (initialize-connection-stream acceptor (make-socket-stream socket acceptor))) ! (reason-phrase (reason-phrase error-code)) ! (first-line (format nil "HTTP/1.1 ~D ~A" ! error-code reason-phrase)) ! (content (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~A</body></html>" ! error-code reason-phrase reason-phrase))) ! (write-sequence (map 'list #'char-code first-line) stream) ! (write-sequence +crlf+ stream) ;end of first line ! (write-header-line "Content-Type" "text/html; charset=iso-8859-1" stream) ! (write-header-line "Content-Length" (length content) stream) ! (write-sequence +crlf+ stream) ;end of headers ! (write-sequence (map 'list #'char-code content) stream) ! (write-sequence +crlf+ stream) ;end of content ! (force-output stream)))
#-:lispworks (defun client-as-string (socket) "A helper function which returns the client's address and port as a ! string and tries to act robustly in the presence of network problems." (let ((address (usocket:get-peer-address socket)) (port (usocket:get-peer-port socket))) (when (and address port) *************** *** 126,149 **** port))))
#-:lispworks ! (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket) ;; we are handling all conditions here as we want to make sure that ;; the acceptor process never crashes while trying to create a ;; worker thread; one such problem exists in ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on ;; some platforms in certain situations. (handler-case* ! (bt:make-thread (lambda () ! (process-connection (taskmaster-acceptor taskmaster) socket)) ! :name (format nil "Hunchentoot worker (client: ~A)" (client-as-string socket))) ! ! (error (cond) ! ;; need to bind *ACCEPTOR* so that LOG-MESSAGE can do its work. ! (let ((*acceptor* (taskmaster-acceptor taskmaster))) ! (log-message *lisp-errors-log-level* ! "Error while creating worker thread for new incoming connection: ~A" cond)))))
! ;; LispWorks implementation
#+:lispworks (defmethod shutdown ((taskmaster taskmaster)) --- 351,377 ---- port))))
#-:lispworks ! (defmethod create-taskmaster-thread ((taskmaster one-thread-per-connection-taskmaster) socket) ! "Create a thread for handling a single request" ;; we are handling all conditions here as we want to make sure that ;; the acceptor process never crashes while trying to create a ;; worker thread; one such problem exists in ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on ;; some platforms in certain situations. (handler-case* ! (bt:make-thread ! (lambda () ! (unwind-protect ! (process-connection (taskmaster-acceptor taskmaster) socket) ! (decrement-taskmaster-request-count taskmaster))) ! :name (format nil (taskmaster-worker-thread-name-format taskmaster) (client-as-string socket))) ! (error (cond) ! ;; need to bind *ACCEPTOR* so that LOG-MESSAGE can do its work. ! (let ((*acceptor* (taskmaster-acceptor taskmaster))) ! (log-message *lisp-errors-log-level* ! "Error while creating worker thread for new incoming connection: ~A" cond)))))
! ;;; LispWorks implementation
#+:lispworks (defmethod shutdown ((taskmaster taskmaster)) *************** *** 158,172 **** (accept-connections (taskmaster-acceptor taskmaster)))
#+:lispworks ! (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) handle) (incf *worker-counter*) ;; check if we need to perform a global GC (when (and *cleanup-interval* (zerop (mod *worker-counter* *cleanup-interval*))) (when *cleanup-function* (funcall *cleanup-function*))) ! (mp:process-run-function (format nil "Hunchentoot worker (client: ~{~A:~A~})" ! (multiple-value-list ! (get-peer-address-and-port handle))) ! nil #'process-connection ! (taskmaster-acceptor taskmaster) handle)) --- 386,424 ---- (accept-connections (taskmaster-acceptor taskmaster)))
#+:lispworks ! (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket) (incf *worker-counter*) ;; check if we need to perform a global GC (when (and *cleanup-interval* (zerop (mod *worker-counter* *cleanup-interval*))) (when *cleanup-function* (funcall *cleanup-function*))) ! (cond ((null (taskmaster-max-thread-count taskmaster)) ! ;; No limit on number of requests, just start a taskmaster ! (create-taskmaster-thread taskmaster socket)) ! ((if (taskmaster-max-accept-count taskmaster) ! (>= (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster)) ! (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))) ! ;; Send HTTP 503 to indicate that we can't handle the request right now ! (too-many-taskmaster-requests taskmaster socket) ! (send-http-error-reply taskmaster socket +http-service-unavailable+)) ! ((and (taskmaster-max-accept-count taskmaster) ! (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))) ! ;; Lispworks doesn't have condition variables, so punt ! (too-many-taskmaster-requests taskmaster socket) ! (send-http-error-reply taskmaster socket +http-service-unavailable+)) ! (t ! ;; We're within both limits, just start a taskmaster ! (increment-taskmaster-request-count taskmaster) ! (create-taskmaster-thread taskmaster socket)))) ! ! #+:lispworks ! (defmethod create-taskmaster-thread ((taskmaster one-thread-per-connection-taskmaster) socket) ! (flet ((process (taskmaster sock) ! (unwind-protect ! (process-connection (taskmaster-acceptor taskmaster) socket) ! (decrement-taskmaster-request-count taskmaster)))) ! (mp:process-run-function (format nil "hunchentoot-worker~{-~A:~A~})" ! (multiple-value-list ! (get-peer-address-and-port socket))) ! nil #'process taskmaster socket)))