<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
</head>
<body bgcolor="#ffffff" text="#000000">
<div class="moz-text-flowed"
style="font-family: -moz-fixed; font-size: 12px;" lang="x-western">The
following patch adds a feature to Hunchentoot
<br>
called "soft shutdown" or "soft stop". It provides
<br>
a way to shut down the Hunchentoot server, but
<br>
only after any pending requests have been
<br>
processed (including sending back the reply).
<br>
<br>
Is this OK to add to the official Hunchentoot?
<br>
<br>
Thanks.
<br>
<br>
-- Dan
<br>
<br>
</div>
<div class="moz-text-plain" wrap="true" graphical-quote="true"
style="font-family: -moz-fixed; font-size: 12px;" lang="x-western">
<pre wrap="">
<hr size="4" width="90%">
*** /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 <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b>)
! :acceptor <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b>
! :remote-addr remote-addr
! :remote-port remote-port
! :headers-in headers-in
! :content-stream <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>hunchentoot-stream<span
class="moz-txt-tag">*</span></b>
! :method method
! :uri url-string
! :server-protocol protocol))))
(force-output <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>hunchentoot-stream<span class="moz-txt-tag">*</span></b>)
(setq <b class="moz-txt-star"><span class="moz-txt-tag">*</span>hunchentoot-stream<span
class="moz-txt-tag">*</span></b> (reset-connection-stream <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b> <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>hunchentoot-stream<span class="moz-txt-tag">*</span></b>))
(when <b class="moz-txt-star"><span class="moz-txt-tag">*</span>close-hunchentoot-stream<span
class="moz-txt-tag">*</span></b>
(return)))))
(when <b class="moz-txt-star"><span class="moz-txt-tag">*</span>hunchentoot-stream<span
class="moz-txt-tag">*</span></b>
;; 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 <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b>))
+ (incf (accessor-requests-in-progress <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b>)))
(process-request (make-instance (acceptor-request-class <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b>)
! :acceptor <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>acceptor<span class="moz-txt-tag">*</span></b>
! :remote-addr remote-addr
! :remote-port remote-port
! :headers-in headers-in
! :content-stream <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>hunchentoot-stream<span
class="moz-txt-tag">*</span></b>
! :method method
! :uri url-string
! :server-protocol protocol)))
! )
(force-output <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>hunchentoot-stream<span class="moz-txt-tag">*</span></b>)
(setq <b class="moz-txt-star"><span class="moz-txt-tag">*</span>hunchentoot-stream<span
class="moz-txt-tag">*</span></b> (reset-connection-stream <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b> <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>hunchentoot-stream<span class="moz-txt-tag">*</span></b>))
(when <b class="moz-txt-star"><span class="moz-txt-tag">*</span>close-hunchentoot-stream<span
class="moz-txt-tag">*</span></b>
(return)))))
+
+ ;; When we are finished processing the request:
+ (with-lock-held ((acceptor-shutdown-lock <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>acceptor<span class="moz-txt-tag">*</span></b>))
+ (decf (accessor-requests-in-progress <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>acceptor<span class="moz-txt-tag">*</span></b>))
+ (when (acceptor-shutdown-p <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>acceptor<span class="moz-txt-tag">*</span></b>)
+ (condition-variable-signal (acceptor-shutdown-queue <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b>))))
+
(when <b class="moz-txt-star"><span class="moz-txt-tag">*</span>hunchentoot-stream<span
class="moz-txt-tag">*</span></b>
;; 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 <b class="moz-txt-star"><span class="moz-txt-tag">*</span>default-max-thread-count<span
class="moz-txt-tag">*</span></b> 100)
+ (defvar <b class="moz-txt-star"><span class="moz-txt-tag">*</span>default-max-accept-count<span
class="moz-txt-tag">*</span></b> (+ <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>default-max-thread-count<span
class="moz-txt-tag">*</span></b> 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 <b class="moz-txt-star"><span class="moz-txt-tag">*</span>default-max-thread-count<span
class="moz-txt-tag">*</span></b>
! :max-accept-count <b class="moz-txt-star"><span class="moz-txt-tag">*</span>default-max-accept-count<span
class="moz-txt-tag">*</span></b>)
(: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 <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>ACCEPTOR<span class="moz-txt-tag">*</span></b> so that LOG-MESSAGE can do its work.
! (let ((<b class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b> (taskmaster-acceptor taskmaster)))
! (log-message <b class="moz-txt-star"><span class="moz-txt-tag">*</span>lisp-errors-log-level<span
class="moz-txt-tag">*</span></b>
! "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 <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>ACCEPTOR<span class="moz-txt-tag">*</span></b> so that LOG-MESSAGE can do its work.
! (let ((<b class="moz-txt-star"><span class="moz-txt-tag">*</span>acceptor<span
class="moz-txt-tag">*</span></b> (taskmaster-acceptor taskmaster)))
! (log-message <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>lisp-errors-log-level<span
class="moz-txt-tag">*</span></b>
! "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 <b class="moz-txt-star"><span class="moz-txt-tag">*</span>worker-counter<span
class="moz-txt-tag">*</span></b>)
;; check if we need to perform a global GC
(when (and <b class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-interval<span
class="moz-txt-tag">*</span></b>
(zerop (mod <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>worker-counter<span class="moz-txt-tag">*</span></b> <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-interval<span
class="moz-txt-tag">*</span></b>)))
(when <b class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-function<span
class="moz-txt-tag">*</span></b>
(funcall <b class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-function<span
class="moz-txt-tag">*</span></b>)))
! (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 <b class="moz-txt-star"><span class="moz-txt-tag">*</span>worker-counter<span
class="moz-txt-tag">*</span></b>)
;; check if we need to perform a global GC
(when (and <b class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-interval<span
class="moz-txt-tag">*</span></b>
(zerop (mod <b class="moz-txt-star"><span
class="moz-txt-tag">*</span>worker-counter<span class="moz-txt-tag">*</span></b> <b
class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-interval<span
class="moz-txt-tag">*</span></b>)))
(when <b class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-function<span
class="moz-txt-tag">*</span></b>
(funcall <b class="moz-txt-star"><span class="moz-txt-tag">*</span>cleanup-function<span
class="moz-txt-tag">*</span></b>)))
! (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)))
</pre>
</div>
</body>
</html>