diff --git a/acceptor.lisp b/acceptor.lisp
index 052a6a5..1d8d1ad 100644
--- a/acceptor.lisp
+++ b/acceptor.lisp
@@ -84,7 +84,7 @@ sending data to the client. The default is T and there's usually no
reason to change this to NIL.")
(input-chunking-p :initarg :input-chunking-p
:accessor acceptor-input-chunking-p
- :documentation "A generalized boolean denoting
+ :documentation "A generalized boolean denoting
whether the acceptor may use chunked encoding for input, i.e. when
accepting request bodies from the client. The default is T and
there's usually no reason to change this to NIL.")
@@ -353,8 +353,9 @@ chunked encoding, but acceptor is configured to not use it.")))))
(defmethod acceptor-ssl-p ((acceptor t))
;; the default is to always answer "no"
nil)
-
-;; usocket implementation
+
+
+;;; usocket implementation
#-:lispworks
(defmethod start-listening ((acceptor acceptor))
@@ -382,10 +383,11 @@ chunked encoding, but acceptor is configured to not use it.")))))
(set-timeouts client-connection
(acceptor-read-timeout acceptor)
(acceptor-write-timeout acceptor))
+ ;; This will bail if the taskmaster has reached its thread limit
(handle-incoming-connection (acceptor-taskmaster acceptor)
client-connection))))))
-;; LispWorks implementation
+;;; LispWorks implementation
#+:lispworks
(defmethod start-listening ((acceptor acceptor))
@@ -421,6 +423,7 @@ chunked encoding, but acceptor is configured to not use it.")))))
(mp:process-unstop (acceptor-process acceptor))
nil)
+
(defun list-request-dispatcher (request)
"The default request dispatcher which selects a request handler
based on a list of individual request dispatchers all of which can
diff --git a/compat.lisp b/compat.lisp
index 0a59af4..27bc754 100644
--- a/compat.lisp
+++ b/compat.lisp
@@ -111,4 +111,4 @@ ignored."
(defmacro with-lock-held ((lock) &body body)
"Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
- `(bt:with-lock-held (,lock) ,@body))
\ No newline at end of file
+ `(bt:with-lock-held (,lock) ,@body))
diff --git a/conditions.lisp b/conditions.lisp
index d291849..965f2f8 100644
--- a/conditions.lisp
+++ b/conditions.lisp
@@ -123,3 +123,4 @@ the \"current\" error."
(trivial-backtrace:print-backtrace-to-stream s))
(error (condition)
(format nil "Could not generate backtrace: ~A." condition))))
+
diff --git a/cookie.lisp b/cookie.lisp
index 4909c56..d4ebd75 100644
--- a/cookie.lisp
+++ b/cookie.lisp
@@ -118,4 +118,4 @@ replaced."
(cookie-path cookie)
(cookie-domain cookie)
(cookie-secure cookie)
- (cookie-http-only cookie)))
\ No newline at end of file
+ (cookie-http-only cookie)))
diff --git a/doc/index.xml b/doc/index.xml
index 136c3fe..b76cf50 100644
--- a/doc/index.xml
+++ b/doc/index.xml
@@ -100,7 +100,7 @@
Chunga (1.0.0 or
higher), and
CL-PPCRE (plus
- CL-WHO for the example code and Drakma for the tests).
+ CL-WHO for the example code and Drakma for the tests).
@@ -561,8 +561,8 @@ eventually call ACCEPT-CONNECTIONS which is
responsible for settings things up to wait for clients to connect.
For each connection which comes
in, HANDLE-INCOMING-CONNECTION is applied to the
-taskmaster which will call PROCESS-CONNECTION.
-PROCESS-CONNECTION
+taskmaster which will call either call PROCESS-CONNECTION
+directly, or will create a thread to call it. PROCESS-CONNECTION
calls INITIALIZE-CONNECTION-STREAM before it does
anything else, then it selects and calls a function which handles
the request, and finally it sends
@@ -669,17 +669,54 @@ each incoming connection and one which handles all requests
sequentially. It should for example be relatively straightforward to
create a taskmaster which allocates threads from a fixed pool instead
of creating a new one for each connection.
+
+
+You can control the resources consumed by a threaded taskmaster via
+two initargs. :max-thread-count lets you set the maximum
+number of request threads that can be processes simultaneously. If
+this is nil, the is no thread limit imposed.
+
+:max-accept-count lets you set the maximum number of requests
+that can be outstanding (i.e. being processed or queued for processing).
+
+If :max-thread-count is supplied and :max-accept-count
+is NIL, then a +HTTP-SERVICE-UNAVAILABLE+
+error will be generated if there are more than the max-thread-count
+threads processing requests. If both :max-thread-count
+and :max-accept-count are supplied, then max-thread-count
+must be less than max-accept-count; if more than max-thread-count
+requests are being processed, then requests up to max-accept-count
+will be queued until a thread becomes available. If more than
+max-accept-count requests are outstanding, then a +HTTP-SERVICE-UNAVAILABLE+
+error will be generated.
+
+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-SERVICE-UNAVAILABLE+ 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-SERVICE-UNAVAILABLE+.
+The default for these values is 100 and 120, respectively.
+
+
If you want to implement your own taskmasters, you should subclass
-TASKMASTER and specialize the generic functions in this section.
+TASKMASTER or one of its subclasses,
+SINGLE-THREADED-TASKMASTER or
+ONE-THREAD-PER-CONNECTION-TASKMASTER, and
+specialize the generic functions in this section.
An instance of this class is responsible for
distributing the work of handling requests for its acceptor.
-This is
-an "abstract" class in the sense that usually only instances of
-subclasses of TASKMASTER will be used.
+This is an "abstract" class in the sense that usually only instances
+of subclasses of TASKMASTER will be used.
@@ -730,6 +767,37 @@ handle on LispWorks). The taskmaster starts processing requests on
the incoming connection by calling the PROCESS-CONNECTION
method of the acceptor instance. The socket argument is passed to
PROCESS-CONNECTION as an argument.
+
+If the taskmaster is a multi-threaded taskmaster, HANDLE-INCOMING-THREAD
+will call CREATE-TASKMASTER-THREAD, which will call
+PROCESS-CONNECTION in a new thread.
+HANDLE-INCOMING-THREAD might issue a
++HTTP-SERVICE-UNAVAILABLE+ error
+if there are too many request threads or it might block waiting for a
+request thread to finish.
+
+
+
+
+ taskmaster socket
+
+ thread
+
+ This function is called by HANDLE-INCOMING-THREAD
+to create a new thread which calls PROCESS-CONNECTION.
+If you specialize this function, you must be careful to have the thread
+call DECREMENT-TASKMASTER-REQUEST-COUNT before
+it exits. A typical method will look like this:
+
+ (defmethod create-taskmaster-thread ((taskmaster monitor-taskmaster) socket)
+ (bt:make-thread
+ (lambda ()
+ (with-monitor-error-handlers
+ (unwind-protect
+ (with-monitor-variable-bindings
+ (process-connection (taskmaster-acceptor taskmaster) socket))
+ (decrement-taskmaster-request-count taskmaster))))))
+
diff --git a/headers.lisp b/headers.lisp
index 3e0faa9..328cdd3 100644
--- a/headers.lisp
+++ b/headers.lisp
@@ -38,37 +38,36 @@ header line \(or as a simple line if VALUE is NIL)."
(and value (regex-replace-all "[\\r\\n]" value " ")))
(force-output *header-stream*)))
-(defgeneric write-header-line (key value)
+(defgeneric write-header-line (key value &optional stream)
(:documentation "Accepts a string KEY and a Lisp object VALUE and
writes them directly to the client as an HTTP header line.")
- (:method (key (string string))
- (let ((stream *hunchentoot-stream*))
- (labels ((write-header-char (char)
- (when *header-stream*
- (write-char char *header-stream*))
- (write-byte (char-code char) stream))
- (write-header-string (string &key (start 0) (end (length string)))
- (loop for i from start below end
- do (write-header-char (aref string i)))))
- (write-header-string key)
- (write-header-char #\:)
- (write-header-char #\Space)
- (let ((start 0))
- (loop
- (let ((end (or (position #\Newline string :start start)
- (length string))))
- ;; skip empty lines, as they confuse certain HTTP clients
- (unless (eql start end)
- (unless (zerop start)
- (write-header-char #\Tab))
- (write-header-string string :start start :end end)
- (write-header-char #\Return)
- (write-header-char #\Linefeed))
- (setf start (1+ end))
- (when (<= (length string) start)
- (return))))))))
- (:method (key value)
- (write-header-line key (princ-to-string value))))
+ (:method (key (string string) &optional (stream *hunchentoot-stream*))
+ (labels ((write-header-char (char)
+ (when *header-stream*
+ (write-char char *header-stream*))
+ (write-byte (char-code char) stream))
+ (write-header-string (string &key (start 0) (end (length string)))
+ (loop for i from start below end
+ do (write-header-char (aref string i)))))
+ (write-header-string key)
+ (write-header-char #\:)
+ (write-header-char #\Space)
+ (let ((start 0))
+ (loop
+ (let ((end (or (position #\Newline string :start start)
+ (length string))))
+ ;; skip empty lines, as they confuse certain HTTP clients
+ (unless (eql start end)
+ (unless (zerop start)
+ (write-header-char #\Tab))
+ (write-header-string string :start start :end end)
+ (write-header-char #\Return)
+ (write-header-char #\Linefeed))
+ (setf start (1+ end))
+ (when (<= (length string) start)
+ (return)))))))
+ (:method (key value &optional (stream *hunchentoot-stream*))
+ (write-header-line key (princ-to-string value) stream)))
(defun start-output (&key (content nil content-provided-p)
(request *request*))
diff --git a/hunchentoot.asd b/hunchentoot.asd
index baeecf2..dcfd723 100644
--- a/hunchentoot.asd
+++ b/hunchentoot.asd
@@ -27,22 +27,13 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-(in-package :cl-user)
+(in-package :asdf)
-(defpackage :hunchentoot-asd
- (:use :cl :asdf))
-
-(in-package :hunchentoot-asd)
-
-(defvar *hunchentoot-version* "1.1.0"
- "A string denoting the current version of Hunchentoot. Used
-for diagnostic output.")
-
-(export '*hunchentoot-version*)
+(load (merge-pathnames "version.lisp" *load-truename*))
(defsystem :hunchentoot
:serial t
- :version #.*hunchentoot-version*
+ :version #.hunchentoot-version:*hunchentoot-version*
:depends-on (:chunga
:cl-base64
:cl-fad
diff --git a/lispworks.lisp b/lispworks.lisp
old mode 100755
new mode 100644
diff --git a/mime-types.lisp b/mime-types.lisp
index 9339b7d..b1ebe79 100644
--- a/mime-types.lisp
+++ b/mime-types.lisp
@@ -360,4 +360,4 @@ of file suffixes for the corresponding type.")
"Given a pathname designator PATHSPEC returns the MIME type
\(as a string) corresponding to the suffix of the file denoted by
PATHSPEC \(or NIL)."
- (gethash (pathname-type pathspec) *mime-type-hash*))
\ No newline at end of file
+ (gethash (pathname-type pathspec) *mime-type-hash*))
diff --git a/packages.lisp b/packages.lisp
index a311e5e..5528dc0 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -31,21 +31,17 @@
(defpackage "HUNCHENTOOT"
(:nicknames "TBNL")
- (:use :cl :cl-ppcre :chunga :flexi-streams :url-rewrite)
+ (:use :cl :cl-ppcre :chunga :flexi-streams :url-rewrite :hunchentoot-version)
(:shadow "DEFCONSTANT"
"URL-ENCODE")
- ;; see ASDF system definition
- (:import-from :hunchentoot-asd :*hunchentoot-version*)
#+:lispworks
(:import-from :lw "WITH-UNIQUE-NAMES" "WHEN-LET")
(:export "*ACCEPTOR*"
"*ACCESS-LOG-PATHNAME*"
"*APPROVED-RETURN-CODES*"
"*CATCH-ERRORS-P*"
- #+:lispworks
- "*CLEANUP-FUNCTION*"
- #+:lispworks
- "*CLEANUP-INTERVAL*"
+ #+:lispworks "*CLEANUP-FUNCTION*"
+ #+:lispworks "*CLEANUP-INTERVAL*"
"*CONTENT-TYPES-FOR-URL-REWRITE*"
"*DEFAULT-CONNECTION-TIMEOUT*"
"*DEFAULT-CONTENT-TYPE*"
@@ -120,11 +116,10 @@
"+HTTP-USE-PROXY+"
"+HTTP-VERSION-NOT-SUPPORTED+"
"ABORT-REQUEST-HANDLER"
+ "ACCEPT-CONNECTIONS"
"ACCEPTOR"
"ACCEPTOR-ACCESS-LOGGER"
"ACCEPTOR-ADDRESS"
- "ACCEPT-CONNECTIONS"
- "ACCEPTOR-REQUEST-DISPATCHER"
"ACCEPTOR-INPUT-CHUNKING-P"
"ACCEPTOR-MESSAGE-LOGGER"
"ACCEPTOR-NAME"
@@ -134,6 +129,7 @@
"ACCEPTOR-READ-TIMEOUT"
"ACCEPTOR-REPLY-CLASS"
"ACCEPTOR-REQUEST-CLASS"
+ "ACCEPTOR-REQUEST-DISPATCHER"
"ACCEPTOR-SSL-P"
#-:hunchentoot-no-ssl "ACCEPTOR-SSL-CERTIFICATE-FILE"
#-:hunchentoot-no-ssl "ACCEPTOR-SSL-PRIVATEKEY-FILE"
@@ -162,6 +158,8 @@
"CREATE-PREFIX-DISPATCHER"
"CREATE-REGEX-DISPATCHER"
"CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER"
+ "CREATE-TASKMASTER-THREAD"
+ "DECREMENT-TASKMASTER-REQUEST-COUNT"
"DEFAULT-DISPATCHER"
"DEFINE-EASY-HANDLER"
"DELETE-AUX-REQUEST-VALUE"
@@ -172,8 +170,8 @@
"GET-PARAMETER"
"GET-PARAMETERS"
"GET-PARAMETERS*"
- "HANDLE-INCOMING-CONNECTION"
"HANDLE-IF-MODIFIED-SINCE"
+ "HANDLE-INCOMING-CONNECTION"
"HANDLE-REQUEST"
"HANDLE-STATIC-FILE"
"HEADER-IN"
@@ -188,6 +186,7 @@
"HUNCHENTOOT-CONDITION"
"HUNCHENTOOT-ERROR"
"HUNCHENTOOT-WARNING"
+ "INCREMENT-TASKMASTER-REQUEST-COUNT"
"INITIALIZE-CONNECTION-STREAM"
"LOG-MESSAGE"
"MAYBE-INVOKE-DEBUGGER"
@@ -226,8 +225,8 @@
"REQUEST-URI*"
"REQUIRE-AUTHORIZATION"
"RESET-CONNECTION-STREAM"
- "RESET-SESSIONS"
"RESET-SESSION-SECRET"
+ "RESET-SESSIONS"
"RETURN-CODE"
"RETURN-CODE*"
"RFC-1123-DATE"
@@ -261,6 +260,10 @@
"STOP"
"TASKMASTER"
"TASKMASTER-ACCEPTOR"
+ "TASKMASTER-MAX-ACCEPT-COUNT"
+ "TASKMASTER-MAX-THREAD-COUNT"
+ "TASKMASTER-REQUEST-COUNT"
+ "TOO-MANY-TASKMASTER-REQUESTS"
"URL-DECODE"
"URL-ENCODE"
"USER-AGENT"
diff --git a/taskmaster.lisp b/taskmaster.lisp
index 6225ee6..cef2baa 100644
--- a/taskmaster.lisp
+++ b/taskmaster.lisp
@@ -60,6 +60,56 @@ that were set up by it. For example, a multi-threaded taskmaster
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,19 +128,143 @@ PROCESS-CONNECTION."))
;; 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."))
+ (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 (bt: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 (bt: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 thread for each incoming connection.
+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."))
-;; usocket implementation
+(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)
+ (bt: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
+ (bt: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"
+ (bt:with-lock-held ((taskmaster-wait-lock taskmaster))
+ (bt:condition-notify (taskmaster-wait-queue taskmaster))))
+
+(defmethod wait-for-free-connection ((taskmaster one-thread-per-connection-taskmaster))
+ "Wait for a connection to be freed up"
+ (bt:with-lock-held ((taskmaster-wait-lock taskmaster))
+ (loop until (< (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))
+ do (bt:condition-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,16 +282,66 @@ implementations."))
#-: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))))))
+ (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 "~D ~A~:*~A
~A"
+ 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."
+ 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,24 +350,27 @@ string and tries to act robustly in the presence of network problems."
port))))
#-:lispworks
-(defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
+(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 ()
- (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
+ (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,15 +385,39 @@ string and tries to act robustly in the presence of network problems."
(accept-connections (taskmaster-acceptor taskmaster)))
#+:lispworks
-(defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) handle)
+(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*)))
- (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))
+ (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)))
diff --git a/test/packages.lisp b/test/packages.lisp
old mode 100755
new mode 100644
index 464be0b..21d0887
--- a/test/packages.lisp
+++ b/test/packages.lisp
@@ -35,4 +35,4 @@
(:export "TEST-HUNCHENTOOT"))
(defpackage "HUNCHENTOOT-TEST-USER"
- (:use :cl :hunchentoot))
\ No newline at end of file
+ (:use :cl :hunchentoot))
diff --git a/url-rewrite/packages.lisp b/url-rewrite/packages.lisp
index 0575570..bded43e 100644
--- a/url-rewrite/packages.lisp
+++ b/url-rewrite/packages.lisp
@@ -36,4 +36,4 @@
"STARTS-WITH-SCHEME-P"
"ADD-GET-PARAM-TO-URL"
"REWRITE-URLS"
- "URL-ENCODE"))
\ No newline at end of file
+ "URL-ENCODE"))
diff --git a/version.lisp b/version.lisp
new file mode 100644
index 0000000..a896ffe
--- /dev/null
+++ b/version.lisp
@@ -0,0 +1,10 @@
+(in-package :cl-user)
+
+(defpackage :hunchentoot-version
+ (:use :cl)
+ (:export #:*hunchentoot-version*))
+
+(in-package :hunchentoot-version)
+
+(defvar *hunchentoot-version* "1.1.0"
+ "Hunchentoot's version number as a string.")