*** /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)))