[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Thu Jul 17 12:57:00 UTC 2008
Revision: 3487
Author: hans
URL: http://bknr.net/trac/changeset/3487
Split up setting up the socket to listen for connections and accepting
connections into two steps. The reason for this change is that listening
is better done in the thread/process that invokes START-SERVER, as errors
will then be reported directly (EADDRINUSE comes to mind) and that the
caller of START-SERVER can be sure that the server will be ready enough
to accept connections once START-SERVER returns.
"listeners" are now called "acceptors" to reflect the new world.
For Lispworks, the TCP server process will be stopped after it has been
and then unstopped to actually begin serving requests. This is not strictly
needed, but this way the behaviour of Lispworks and non-Lispworks is
similar.
U trunk/thirdparty/hunchentoot/connection-manager.lisp
U trunk/thirdparty/hunchentoot/doc/index.xml
U trunk/thirdparty/hunchentoot/packages.lisp
U trunk/thirdparty/hunchentoot/server.lisp
Modified: trunk/thirdparty/hunchentoot/connection-manager.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/connection-manager.lisp 2008-07-17 12:50:50 UTC (rev 3486)
+++ trunk/thirdparty/hunchentoot/connection-manager.lisp 2008-07-17 12:57:00 UTC (rev 3487)
@@ -40,11 +40,11 @@
(:documentation "Base class for all connection managers classes.
Its purpose is to carry the back pointer to the server instance."))
-(defgeneric execute-listener (connection-manager)
+(defgeneric execute-acceptor (connection-manager)
(:documentation
"This function is called once Hunchentoot has performed all initial
processing to start listening for incoming connections. It does so by
-calling the LISTEN-FOR-CONNECTIONS functions of the server, taken from
+calling the ACCEPT-CONNECTIONS functions of the server, taken from
the SERVER slot of the connection manager instance.
In a multi-threaded environment, the connection manager starts a new
@@ -70,7 +70,6 @@
(:documentation "Terminate all threads that are currently associated
with the connection manager, if any.")
(:method (manager)
- (declare (ignore manager))
#+:lispworks
(when-let (listener (server-listener (server manager)))
;; kill the main listener process, see LW documentation for
@@ -82,28 +81,38 @@
(:documentation "Connection manager that runs synchronously in the
thread that invoked the START-SERVER function."))
-(defmethod execute-listener ((manager single-threaded-connection-manager))
- (listen-for-connections (server manager)))
+(defmethod execute-acceptor ((manager single-threaded-connection-manager))
+ (accept-connections (server manager)))
(defmethod handle-incoming-connection ((manager single-threaded-connection-manager) socket)
(process-connection (server manager) socket))
(defclass one-thread-per-connection-manager (connection-manager)
- ()
+ ((acceptor-process :accessor acceptor-process
+ :documentation "Process that accepts incoming
+ connections and dispatches them to new processes
+ for request execution."))
(:documentation "Connection manager that starts one thread for
listening to incoming requests and one thread for each incoming
connection."))
-(defmethod execute-listener ((manager one-thread-per-connection-manager))
+(defmethod execute-acceptor ((manager one-thread-per-connection-manager))
#+:lispworks
- (listen-for-connections (server manager))
+ (accept-connections (server manager))
#-:lispworks
- (bt:make-thread (lambda ()
- (listen-for-connections (server manager)))
- :name (format nil "Hunchentoot listener \(~A:~A)"
- (or (server-address (server manager)) "*")
- (server-port (server manager)))))
+ (setf (acceptor-process manager)
+ (bt:make-thread (lambda ()
+ (accept-connections (server manager)))
+ :name (format nil "Hunchentoot acceptor \(~A:~A)"
+ (or (server-address (server manager)) "*")
+ (server-port (server manager))))))
+#-:lispworks
+(defmethod shutdown ((manager one-thread-per-connection-manager))
+ (loop
+ while (bt:thread-alive-p (acceptor-process manager))
+ do (sleep 1)))
+
#+:lispworks
(defmethod handle-incoming-connection ((manager one-thread-per-connection-manager) handle)
(incf *worker-counter*)
Modified: trunk/thirdparty/hunchentoot/doc/index.xml
===================================================================
--- trunk/thirdparty/hunchentoot/doc/index.xml 2008-07-17 12:50:50 UTC (rev 3486)
+++ trunk/thirdparty/hunchentoot/doc/index.xml 2008-07-17 12:57:00 UTC (rev 3487)
@@ -531,6 +531,7 @@
<clix:special-variable name="*cleanup-interval*">
<clix:description>
+ (Lispworks only)
Should be <code>NIL</code> or a positive integer. The system
calls <clix:ref>*CLEANUP-FUNCTION*</clix:ref>
whenever <clix:ref>*CLEANUP-INTERVAL*</clix:ref> new worker
@@ -541,13 +542,13 @@
<clix:special-variable name="*cleanup-function*">
<clix:description>
+ (Lispworks only)
The function (with no arguments) which is called
if <clix:ref>*CLEANUP-INTERVAL*</clix:ref> is
not <code>NIL</code>. The initial value is a function which
calls
<code>(<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-166.htm">HCL</a>:<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-212.htm">
- <code>MARK-AND-SWEEP</code> </a> 2)</code> on LispWorks and
- does nothing on other Lisps.
+ <code>MARK-AND-SWEEP</code> </a> 2)</code>.
<p>
On LispWorks this is necessary because each <em>worker</em>
(which is created to handle an incoming http request and
Modified: trunk/thirdparty/hunchentoot/packages.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/packages.lisp 2008-07-17 12:50:50 UTC (rev 3486)
+++ trunk/thirdparty/hunchentoot/packages.lisp 2008-07-17 12:57:00 UTC (rev 3487)
@@ -40,7 +40,9 @@
(:import-from :lw "WITH-UNIQUE-NAMES" "WHEN-LET")
(:export "*APPROVED-RETURN-CODES*"
"*CATCH-ERRORS-P*"
+ #+:lispworks
"*CLEANUP-FUNCTION*"
+ #+:lispworks
"*CLEANUP-INTERVAL*"
"*CONTENT-TYPES-FOR-URL-REWRITE*"
"*DEFAULT-CONNECTION-TIMEOUT*"
Modified: trunk/thirdparty/hunchentoot/server.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/server.lisp 2008-07-17 12:50:50 UTC (rev 3486)
+++ trunk/thirdparty/hunchentoot/server.lisp 2008-07-17 12:57:00 UTC (rev 3487)
@@ -81,9 +81,13 @@
responsible for listening to new connections and scheduling them for
execution.")
#+:lispworks
- (listener :accessor server-listener
- :documentation "The Lisp process which listens for
-incoming requests.")
+ (acceptor :accessor server-acceptor
+ :documentation "The Lisp process which accepts incoming
+ requests.")
+ #-:lispworks
+ (listen-socket :accessor server-listen-socket
+ :documentation "The listen socket for incoming
+ connections.")
(server-shutdown-p :initform nil
:accessor server-shutdown-p
:documentation "Flag that makes the server
@@ -191,13 +195,16 @@
(:documentation "Start the SERVER so that it begins accepting
connections.")
(:method ((server server))
- (execute-listener (server-connection-manager server))))
+ (start-listening server)
+ (execute-acceptor (server-connection-manager server))))
(defgeneric stop (server)
(:documentation "Stop the SERVER so that it does no longer accept requests.")
(:method ((server server))
(setf (server-shutdown-p server) t)
- (shutdown (server-connection-manager server))))
+ (shutdown (server-connection-manager server))
+ #-:lispworks
+ (usocket:socket-close (server-listen-socket server))))
(defun start-server (&rest args
&key port address dispatch-table name
@@ -339,51 +346,66 @@
"Time in seconds to wait for a new connection to arrive before
performing a cleanup run.")
-(defgeneric listen-for-connections (server)
+(defgeneric start-listening (server)
(:documentation "Sets up a listen socket for the given SERVER and
-listens for incoming connections. In a loop, accepts a connection and
+enables it to listen for incoming connections. This function is
+called from the thread that starts the server initially and may return
+errors resulting from the listening operation. (like 'address in use'
+or similar).")
+ (:method ((server server))
+ #+:lispworks
+ (multiple-value-bind (listener-process startup-condition)
+ (comm:start-up-server :service (server-port server)
+ :address (server-address server)
+ :process-name (format nil "Hunchentoot listener \(~A:~A)"
+ (or (server-address server) "*") (server-port server))
+ ;; this function is called once on startup - we
+ ;; use it to check for errors
+ :announce (lambda (socket &optional condition)
+ (declare (ignore socket))
+ (when condition
+ (error condition)))
+ ;; this function is called whenever a connection
+ ;; is made
+ :function (lambda (handle)
+ (unless (server-shutdown-p server)
+ (handle-incoming-connection
+ (server-connection-manager server) handle)))
+ ;; wait until the server was successfully started
+ ;; or an error condition is returned
+ :wait t)
+ (when startup-condition
+ (error startup-condition))
+ (process-stop listener-process)
+ (setf (server-acceptor server) listener-process))
+ #-:lispworks
+ (setf (server-listen-socket server)
+ (usocket:socket-listen (or (server-address server)
+ usocket:*wildcard-host*)
+ (server-port server)
+ :reuseaddress t
+ :element-type '(unsigned-byte 8)))))
+
+(defgeneric accept-connections (server)
+ (:documentation "In a loop, accepts a connection and
dispatches it to the server's connection manager object for processing
using HANDLE-INCOMING-CONNECTION.")
(:method ((server server))
- #+:lispworks
- (setf (server-listener server)
- (comm:start-up-server :service (server-port server)
- :address (server-address server)
- :process-name (format nil "Hunchentoot listener \(~A:~A)"
- (or (server-address server) "*") (server-port server))
- ;; this function is called once on startup - we
- ;; use it to check for errors
- :announce (lambda (socket &optional condition)
- (declare (ignore socket))
- (when condition
- (error condition)))
- ;; this function is called whenever a connection
- ;; is made
- :function (lambda (handle)
- (unless (server-shutdown-p server)
- (handle-incoming-connection
- (server-connection-manager server) handle)))
- ;; wait until the server was successfully started
- ;; or an error condition is returned
- :wait t))
- #-:lispworks
- (usocket:with-socket-listener (listener
- (or (server-address server)
- usocket:*wildcard-host*)
- (server-port server)
- :reuseaddress t
- :element-type '(unsigned-byte 8))
- (do ((new-connection-p (usocket:wait-for-input listener :timeout +new-connection-wait-time+)
- (usocket:wait-for-input listener :timeout +new-connection-wait-time+)))
- ((server-shutdown-p server))
- (when new-connection-p
- (let ((client-connection (usocket:socket-accept listener)))
- (when client-connection
- (set-timeouts client-connection
- (server-read-timeout server)
- (server-write-timeout server))
- (handle-incoming-connection (server-connection-manager server)
- client-connection))))))))
+ #+:lispworks
+ (process-unstop (server-acceptor server))
+ #-:lispworks
+ (usocket:with-server-socket (listener (server-listen-socket server))
+ (do ((new-connection-p (usocket:wait-for-input listener :timeout +new-connection-wait-time+)
+ (usocket:wait-for-input listener :timeout +new-connection-wait-time+)))
+ ((server-shutdown-p server))
+ (when new-connection-p
+ (let ((client-connection (usocket:socket-accept listener)))
+ (when client-connection
+ (set-timeouts client-connection
+ (server-read-timeout server)
+ (server-write-timeout server))
+ (handle-incoming-connection (server-connection-manager server)
+ client-connection))))))))
(defgeneric initialize-connection-stream (server stream)
(:documentation "Wraps the given STREAM with all the additional
More information about the Bknr-cvs
mailing list