[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Tue Feb 10 14:46:11 UTC 2009
Revision: 4230
Author: edi
URL: http://bknr.net/trac/changeset/4230
Checkpoint
U trunk/thirdparty/hunchentoot/acceptor.lisp
U trunk/thirdparty/hunchentoot/connection-dispatcher.lisp
U trunk/thirdparty/hunchentoot/packages.lisp
Modified: trunk/thirdparty/hunchentoot/acceptor.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-10 14:25:30 UTC (rev 4229)
+++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-10 14:46:11 UTC (rev 4230)
@@ -32,12 +32,10 @@
(defclass acceptor ()
((port :initarg :port
:reader acceptor-port
- :documentation "The port the acceptor is listening on.
-See START-SERVER.")
+ :documentation "The port the acceptor is listening on.")
(address :initarg :address
:reader acceptor-address
- :documentation "The address the acceptor is listening
-on. See START-SERVER.")
+ :documentation "The address the acceptor is listening on.")
(name :initarg :name
:accessor acceptor-name
:documentation "The optional name of the acceptor, a symbol.")
@@ -46,10 +44,10 @@
:documentation "Determines which class of request
objects is created when a request comes in and should be \(a symbol
naming) a class which inherits from REQUEST.")
- (dispatch-table :initarg :dispatch-table
- :accessor acceptor-dispatch-table
- :documentation "The dispatch-table used by this
-acceptor. Can be NIL to denote that *DISPATCH-TABLE* should be used.")
+ (request-dispatcher :initarg :request-dispatcher
+ :accessor acceptor-request-dispatcher
+ :documentation "The dispatcher function used by
+this acceptor.")
(output-chunking-p :initarg :output-chunking-p
:reader acceptor-output-chunking-p
:documentation "Whether the acceptor may use output chunking.")
@@ -71,28 +69,28 @@
semantics of this parameter is determined by the underlying Lisp's
implementation of socket timeouts.")
(write-timeout :initarg :write-timeout
- :reader acceptor-write-timeout
- :documentation "The connection timeout of the acceptor,
+ :reader acceptor-write-timeout
+ :documentation "The connection timeout of the acceptor,
specified in (fractional) seconds. The precise semantics of this
parameter is determined by the underlying Lisp's implementation of
socket timeouts.")
(connection-dispatcher :initarg :connection-dispatcher
- :initform nil
- :reader acceptor-connection-dispatcher
- :documentation "The connection dispatcher that is
+ :initform nil
+ :reader acceptor-connection-dispatcher
+ :documentation "The connection dispatcher that is
responsible for listening to new connections and scheduling them for
execution.")
#+:lispworks
- (acceptor :accessor acceptor-acceptor
- :documentation "The Lisp process which accepts incoming
+ (process :accessor acceptor-process
+ :documentation "The Lisp process which accepts incoming
requests.")
#-:lispworks
(listen-socket :accessor acceptor-listen-socket
:documentation "The listen socket for incoming
connections.")
(acceptor-shutdown-p :initform nil
- :accessor acceptor-shutdown-p
- :documentation "Flag that makes the acceptor
+ :accessor acceptor-shutdown-p
+ :documentation "Flag that makes the acceptor
shutdown itself when set to something other than NIL.")
(access-logger :initarg :access-logger
:accessor acceptor-access-logger
@@ -120,66 +118,12 @@
:request-class 'request
:output-chunking-p t
:input-chunking-p t
- :dispatch-table nil
+ :request-dispatcher 'dispatch-request
:access-logger 'log-access
:message-logger 'log-message)
(:documentation "An object of this class contains all relevant
information about a running Hunchentoot acceptor instance."))
-(defmethod initialize-instance :after ((acceptor acceptor)
- &key connection-dispatcher-class
- connection-dispatcher-arguments
- (threaded *supports-threads-p* threaded-specified-p)
- (persistent-connections-p
- threaded
- persistent-connections-specified-p)
- (connection-timeout
- *default-connection-timeout*
- connection-timeout-provided-p)
- (read-timeout nil read-timeout-provided-p)
- (write-timeout nil write-timeout-provided-p))
- "The CONNECTION-DISPATCHER-CLASS and CONNECTION-DISPATCHER-ARGUMENTS
-arguments to the creation of a acceptor instance determine the
-connection dispatcher instance that is created. THREADED is the user
-friendly version of the CONNECTION-DISPATCHER-CLASS option. If it is
-NIL, an unthreaded connection dispatcher is used. It is an error to
-specify both THREADED and a CONNECTION-DISPATCHER-CLASS argument.
-
-The PERSISTENT-CONNECTIONS-P keyword argument defaults to the value of
-the THREADED keyword argument but can be overridden.
-
-If a neither READ-TIMEOUT nor WRITE-TIMEOUT are specified by the user,
-the acceptor's read and write timeouts default to the CONNECTION-TIMEOUT
-value. If either of READ-TIMEOUT or WRITE-TIMEOUT is specified,
-CONNECTION-TIMEOUT is not used and may not be supplied."
- (declare (ignore read-timeout write-timeout))
- (when (and threaded-specified-p connection-dispatcher-class)
- (parameter-error "Can't use both THREADED and CONNECTION-DISPATCHER-CLASS arguments."))
- (unless persistent-connections-specified-p
- (setf (acceptor-persistent-connections-p acceptor) persistent-connections-p))
- (unless (acceptor-connection-dispatcher acceptor)
- (setf (slot-value acceptor 'connection-dispatcher)
- (apply #'make-instance
- (or connection-dispatcher-class
- (if threaded
- 'one-thread-per-connection-dispatcher
- 'single-threaded-connection-dispatcher))
- :acceptor acceptor
- connection-dispatcher-arguments)))
- (if (or read-timeout-provided-p write-timeout-provided-p)
- (when connection-timeout-provided-p
- (parameter-error "Can't have both CONNECTION-TIMEOUT and either of READ-TIMEOUT and WRITE-TIMEOUT."))
- (setf (slot-value acceptor 'read-timeout) connection-timeout
- (slot-value acceptor 'write-timeout) connection-timeout)))
-
-(defgeneric acceptor-ssl-p (acceptor)
- (:documentation "Returns a true value if ACCEPTOR is an SSL acceptor.")
- (:method ((acceptor t))
- nil))
-
-(defun ssl-p (&optional (acceptor *acceptor*))
- (acceptor-ssl-p acceptor))
-
(defmethod print-object ((acceptor acceptor) stream)
(print-unreadable-object (acceptor stream :type t)
(format stream "\(host ~A, port ~A)"
@@ -347,7 +291,7 @@
(when startup-condition
(error startup-condition))
(mp:process-stop listener-process)
- (setf (acceptor-acceptor acceptor) listener-process))
+ (setf (acceptor-process acceptor) listener-process))
#-:lispworks
(setf (acceptor-listen-socket acceptor)
(usocket:socket-listen (or (acceptor-address acceptor)
@@ -362,7 +306,7 @@
using HANDLE-INCOMING-CONNECTION.")
(:method ((acceptor acceptor))
#+:lispworks
- (mp:process-unstop (acceptor-acceptor acceptor))
+ (mp:process-unstop (acceptor-process acceptor))
#-:lispworks
(usocket:with-acceptor-socket (listener (acceptor-listen-socket acceptor))
(loop
@@ -405,6 +349,7 @@
(chunked-stream-stream stream))
(t stream))))
+;;; TODO
(defgeneric dispatch-request (acceptor request reply)
(:documentation "")
(:method (acceptor request reply)
Modified: trunk/thirdparty/hunchentoot/connection-dispatcher.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/connection-dispatcher.lisp 2009-02-10 14:25:30 UTC (rev 4229)
+++ trunk/thirdparty/hunchentoot/connection-dispatcher.lisp 2009-02-10 14:46:11 UTC (rev 4230)
@@ -65,13 +65,7 @@
(defgeneric shutdown (connection-dispatcher)
(:documentation "Terminate all threads that are currently associated
-with the connection dispatcher, if any.")
- (:method ((dispatcher t))
- #+:lispworks
- (when-let (acceptor (acceptor-acceptor (acceptor dispatcher)))
- ;; kill the main acceptor process, see LW documentation for
- ;; COMM:START-UP-SERVER
- (mp:process-kill acceptor))))
+with the connection dispatcher, if any."))
(defclass single-threaded-connection-dispatcher (connection-dispatcher)
()
@@ -87,16 +81,27 @@
(defclass one-thread-per-connection-dispatcher (connection-dispatcher)
((acceptor-process :accessor acceptor-process
:documentation "Process that accepts incoming
- connections and dispatches them to new processes
- for request execution."))
+connections and dispatches them to new processes for request
+execution."))
(:documentation "Connection Dispatcher that starts one thread for
listening to incoming requests and one thread for each incoming
connection."))
+;; usocket implementation
+
+#-:lispworks
+(defmethod shutdown ((dispatcher connection-dispatcher)))
+
+#-:lispworks
+(defmethod shutdown ((dispatcher one-thread-per-connection-dispatcher))
+ ;; just wait until the acceptor process has finished, then return
+ (loop
+ (unless (bt:thread-alive-p (acceptor-process dispatcher))
+ (return))
+ (sleep 1)))
+
+#-:lispworks
(defmethod execute-acceptor ((dispatcher one-thread-per-connection-dispatcher))
- #+:lispworks
- (accept-connections (acceptor dispatcher))
- #-:lispworks
(setf (acceptor-process dispatcher)
(bt:make-thread (lambda ()
(accept-connections (acceptor dispatcher)))
@@ -105,12 +110,34 @@
(acceptor-port (acceptor dispatcher))))))
#-:lispworks
-(defmethod shutdown ((dispatcher one-thread-per-connection-dispatcher))
- (loop
- while (bt:thread-alive-p (acceptor-process dispatcher))
- do (sleep 1)))
+(defun client-as-string (socket)
+ (let ((address (usocket:get-peer-address socket))
+ (port (usocket:get-peer-port socket)))
+ (when (and address port)
+ (format nil "~A:~A"
+ (usocket:vector-quad-to-dotted-quad address)
+ port))))
+#-:lispworks
+(defmethod handle-incoming-connection ((dispatcher one-thread-per-connection-dispatcher) socket)
+ (bt:make-thread (lambda ()
+ (process-connection (acceptor dispatcher) socket))
+ :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))))
+
+;; LispWorks implementation
+
#+:lispworks
+(defmethod shutdown ((dispatcher connection-dispatcher))
+ (when-let (process (acceptor-process (acceptor dispatcher)))
+ ;; kill the main acceptor process, see LW documentation for
+ ;; COMM:START-UP-SERVER
+ (mp:process-kill process)))
+
+#+:lispworks
+(defmethod execute-acceptor ((dispatcher one-thread-per-connection-dispatcher))
+ (accept-connections (acceptor dispatcher)))
+
+#+:lispworks
(defmethod handle-incoming-connection ((dispatcher one-thread-per-connection-dispatcher) handle)
(incf *worker-counter*)
;; check if we need to perform a global GC
@@ -123,18 +150,3 @@
(get-peer-address-and-port handle)))
nil #'process-connection
(acceptor dispatcher) handle))
-
-#-:lispworks
-(defun client-as-string (socket)
- (let ((address (usocket:get-peer-address socket))
- (port (usocket:get-peer-port socket)))
- (when (and address port)
- (format nil "~A:~A"
- (usocket:vector-quad-to-dotted-quad address)
- port))))
-
-#-:lispworks
-(defmethod handle-incoming-connection ((dispatcher one-thread-per-connection-dispatcher) socket)
- (bt:make-thread (lambda ()
- (process-connection (acceptor dispatcher) socket))
- :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))))
Modified: trunk/thirdparty/hunchentoot/packages.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-10 14:25:30 UTC (rev 4229)
+++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-10 14:46:11 UTC (rev 4230)
@@ -143,9 +143,11 @@
"DISPATCH-REQUEST"
"DO-SESSIONS"
"ESCAPE-FOR-HTML"
+ "EXECUTE-ACCEPTOR"
"GET-PARAMETER"
"GET-PARAMETERS"
"GET-PARAMETERS*"
+ "HANDLE-INCOMING-CONNECTION"
"HANDLE-IF-MODIFIED-SINCE"
"HANDLE-STATIC-FILE"
"HANDLER-DONE"
@@ -194,7 +196,7 @@
"SCRIPT-NAME*"
"SEND-HEADERS"
"ACCEPTOR-ADDRESS"
- "ACCEPTOR-DISPATCH-TABLE"
+ "ACCEPTOR-REQUEST-DISPATCHER"
"ACCEPTOR-NAME"
"ACCEPTOR-PORT"
"SERVER-PROTOCOL"
@@ -209,10 +211,10 @@
"SESSION-VALUE"
"SET-COOKIE"
"SET-COOKIE*"
- "SSL-P"
- "START-SERVER"
+ "SHUTDOWN"
+ "START"
"START-SESSION"
- "STOP-SERVER"
+ "STOP"
"URL-DECODE"
"URL-ENCODE"
"USER-AGENT"))
More information about the Bknr-cvs
mailing list