[hunchentoot-devel] per server easy-handler-alist
Mac Chan
emailmac at gmail.com
Fri May 18 22:45:21 UTC 2007
On 5/18/07, Edi Weitz <edi at agharta.de> wrote:
> Edit. Hmm... You're not the first one. Maybe I should change my
> name... :)
I have an excuse - google didn't flag any spelling errors :-)
> > Attached is a patch that introduce a slot :name to the server class
> > and a global variable *servers* which is an a-list mapping names to
> > server instances.
>
> I think you forgot the patch.
Oops.
> > I'd appreciate any suggestions.
>
> At a first glance, this seems like a useful change to me. I have to
> think about it a bit more.
Of course it would be best if you do the refactoring (provided that
you have time), the result is probably optimal.
Anyway, you can take a look at the patch and see if it is useful.
Thanks!
-- Mac
-------------- next part --------------
Index: doc/index.html
===================================================================
--- doc/index.html (revision 1242)
+++ doc/index.html (working copy)
@@ -316,10 +316,11 @@
several servers in one image, each one listening to a different port.
<p><br>[Function]
-<br><a class=none name="start-server"><b>start-server</b> <i><tt>&key</tt> port address dispatch-table mod-lisp-p use-apache-log-p input-chunking-p read-timeout write-timeout setuid setgid ssl-certificate-file ssl-privatekey-file ssl-privatekey-password</i> => <i>server</i></a>
+<br><a class=none name="start-server"><b>start-server</b> <i><tt>&key</tt>name port address dispatch-table mod-lisp-p use-apache-log-p input-chunking-p read-timeout write-timeout setuid setgid ssl-certificate-file ssl-privatekey-file ssl-privatekey-password</i> => <i>server</i></a>
-<blockquote><br> Starts a Hunchentoot server instance and returns it.
-<code><i>port</i></code> ist the port the server will be listening on
+<blockquote><br> Starts a Hunchentoot server instance named
+<code><i>name</i></code> and returns it.
+<code><i>port</i></code> is the port the server will be listening on
- the default is 80 (or 443 if SSL information is provided).
If <code><i>address</i></code> is a string denoting an IP address,
then the server only receives connections for that address. This must
@@ -636,7 +637,7 @@
<a href="http://www.lispworks.com/documentation/HyperSpec/Body/03_de.htm">destructuring lambda list</a>
<pre>
- (name &key uri default-parameter-type default-request-type).
+ (name &key uri default-parameter-type default-request-type server-names).
</pre>
<code><i>lambda-list</i></code> is a list the elements of which are either a symbol
@@ -670,6 +671,9 @@
<code><i>default-request-type</i></code> (the default of which
is <code>:BOTH</code>) will be used.
<p>
+If <code><i>server-names</i></code> is provided, it should be a list of names
+indicating which servers that this handler will apply. See <a href="#start-server"><code>START-SERVER</code></a>
+<p>
The value of <code><i>var</i></code> will usually be a string (unless
it resulted from a <a href="#upload">file upload</a> in which case it won't be converted at
all), but if <code><i>parameter-type</i></code> (which is evaluated)
Index: easy-handlers.lisp
===================================================================
--- easy-handlers.lisp (revision 1242)
+++ easy-handlers.lisp (working copy)
@@ -155,6 +155,24 @@
,(or request-type default-request-type)))
,init-form))))
+(defun replace-easy-handler-entry (uri name &optional server-names)
+ "Replace an entry in the easy-handler-alist, given an uri and a
+function name. If server-names is not provided, *easy-handler-alist*
+is modified. Otherwise, change the easy-handler-alist slot of the
+named server instances."
+ (macrolet ((do-it (place)
+ `(progn
+ (setf ,place
+ (delete-if (lambda (cons)
+ (or (equal uri (car cons))
+ (eq name (cdr cons))))
+ ,place))
+ (push (cons uri name) ,place))))
+ (if server-names
+ (dolist (server (mapcar 'make-server server-names))
+ (do-it (server-easy-handler-alist server)))
+ (do-it *easy-handler-alist*))))
+
(defmacro define-easy-handler (description lambda-list &body body)
"Defines a handler with the body BODY and optionally registers
it with a URI so that it will be found by DISPATCH-EASY-HANDLERS.
@@ -188,6 +206,9 @@
DEFAULT-REQUEST-TYPE \(the default of which is :BOTH) will be
used.
+If server-names is provided, it should be a list of names indicating
+which servers that this handler will apply. See START-SERVER
+
The value of VAR will usually be a string \(unless it resulted from a
file upload in which case it won't be converted at all), but if
PARAMETER-TYPE \(which is evaluated) is provided, the string will be
@@ -273,23 +294,19 @@
(setq description (list description)))
(destructuring-bind (name &key uri
(default-parameter-type ''string)
- (default-request-type :both))
- description
- (with-unique-names (cons uri%)
+ (default-request-type :both)
+ server-names)
+ description
+ (with-unique-names (uri%)
`(progn
- ,@(when uri
- `((let ((,uri% ,uri))
- (setq *easy-handler-alist*
- (delete-if (lambda (,cons)
- (or (equal ,uri% (car ,cons))
- (eq ',name (cdr ,cons))))
- *easy-handler-alist*))
- (push (cons ,uri% ',name) *easy-handler-alist*))))
- (defun ,name (&key ,@(loop for part in lambda-list
- collect (make-defun-parameter part
- default-parameter-type
- default-request-type)))
- , at body)))))
+ (let ((,uri% ,uri))
+ (when ,uri%
+ (replace-easy-handler-entry ,uri% ',name ,server-names)))
+ (defun ,name (&key ,@(loop for part in lambda-list
+ collect (make-defun-parameter part
+ default-parameter-type
+ default-request-type)))
+ , at body)))))
;; help the LispWorks IDE to find these definitions
#+:lispworks
Index: server.lisp
===================================================================
--- server.lisp (revision 1242)
+++ server.lisp (working copy)
@@ -30,14 +30,17 @@
(in-package :hunchentoot)
(defclass server ()
- ((socket :accessor server-socket
+ ((name :initarg :name :initform nil :accessor server-instance-name
+ :documentation "A name to identify a server
+instance. e.g. :https or :http")
+ (socket :accessor server-socket
:documentation "The socket the server is listening on.")
(port :initarg :port
- :reader server-local-port
+ :accessor server-local-port
:documentation "The port the server is listening on.
See START-SERVER.")
(address :initarg :address
- :reader server-address
+ :accessor server-address
:documentation "The address the server is listening
on. See START-SERVER.")
(dispatch-table :initarg :dispatch-table
@@ -45,17 +48,23 @@
:documentation "The dispatch-table used by this
server. Can be NIL to denote that *META-DISPATCHER* should be called
instead.")
+ (easy-handler-alist :initarg :easy-handler-alist
+ :initform nil
+ :accessor server-easy-handler-alist
+ :documentation "The easy-handler-alist used by
+this server. Can be NIL to denote that the *easy-handler-alist*
+should be used instead")
(output-chunking-p :initarg :output-chunking-p
- :reader server-output-chunking-p
+ :accessor server-output-chunking-p
:documentation "Whether the server may use output chunking.")
(input-chunking-p :initarg :input-chunking-p
- :reader server-input-chunking-p
+ :accessor server-input-chunking-p
:documentation "Whether the server may use input chunking.")
(read-timeout :initarg :read-timeout
- :reader server-read-timeout
+ :accessor server-read-timeout
:documentation "The read-timeout of the server.")
(write-timeout :initarg :write-timeout
- :reader server-write-timeout
+ :accessor server-write-timeout
:documentation "The write-timeout of the server.")
(listener :accessor server-listener
:documentation "The Lisp process which listens for
@@ -66,26 +75,26 @@
:documentation "A list of currently active worker threads.")
(mod-lisp-p :initform nil
:initarg :mod-lisp-p
- :reader server-mod-lisp-p
+ :accessor server-mod-lisp-p
:documentation "Whether this is a genuine
Hunchentoot server or \"just\" infrastructure for mod_lisp.")
(use-apache-log-p :initarg :use-apache-log-p
- :reader server-use-apache-log-p
+ :accessor server-use-apache-log-p
:documentation "Whether the server should use
Apache's log file. Only applicable if MOD-LISP-P is true.")
#-:hunchentoot-no-ssl
(ssl-certificate-file :initarg :ssl-certificate-file
- :reader server-ssl-certificate-file
+ :accessor server-ssl-certificate-file
:documentation "The namestring of a
certificate file if SSL is used, NIL otherwise.")
#-:hunchentoot-no-ssl
(ssl-privatekey-file :initarg :ssl-privatekey-file
- :reader server-ssl-privatekey-file
+ :accessor server-ssl-privatekey-file
:documentation "The namestring of a
private key file if SSL is used, NIL otherwise.")
#-:hunchentoot-no-ssl
(ssl-privatekey-password :initarg :ssl-privatekey-password
- :reader server-ssl-privatekey-password
+ :accessor server-ssl-privatekey-password
:documentation "The password for the
private key file or NIL.")
(lock :initform (make-lock (format nil "hunchentoot-lock-~A"
@@ -96,7 +105,19 @@
(:documentation "An object of this class contains all relevant
information about a running Hunchentoot server instance."))
-(defun start-server (&key (port 80 port-provided-p)
+(defun make-server (&optional name)
+ "Return a named server if one is already created. Otherwise create a
+new instance and insert it into the named-server alist if name is
+provided."
+ (let ((server (cdr (assoc name *servers* :test #'equalp))))
+ (unless server
+ (setq server (make-instance 'server :name name))
+ (when name
+ (setq *servers* (acons name server *servers*))))
+ (values server)))
+
+(defun initialize-server (&key name
+ (port 80 port-provided-p)
address
dispatch-table
(mod-lisp-p nil)
@@ -104,11 +125,55 @@
(input-chunking-p t)
(read-timeout *default-read-timeout*)
(write-timeout *default-write-timeout*)
- #+(and :unix (not :win32)) setuid
- #+(and :unix (not :win32)) setgid
#-:hunchentoot-no-ssl ssl-certificate-file
#-:hunchentoot-no-ssl (ssl-privatekey-file ssl-certificate-file)
- #-:hunchentoot-no-ssl ssl-privatekey-password)
+ #-:hunchentoot-no-ssl ssl-privatekey-password
+ &allow-other-keys)
+ "Return a server instance with the various slots initialized properly."
+ (let ((server (make-server name))
+ (output-chunking-p t))
+ #-:hunchentoot-no-ssl
+ (when ssl-certificate-file
+ ;; disable output chunking for SSL connections
+ (setq output-chunking-p nil)
+ (unless port-provided-p (setq port 443)))
+ ;; no timeouts if behind mod_lisp
+ (when mod-lisp-p
+ (setq read-timeout nil
+ write-timeout nil))
+ (setf (server-local-port server) port
+ (server-address server) address
+ (server-dispatch-table server) dispatch-table
+ (server-mod-lisp-p server) mod-lisp-p
+ (server-use-apache-log-p server) (and mod-lisp-p use-apache-log-p)
+ (server-input-chunking-p server) input-chunking-p
+ (server-output-chunking-p server) (and output-chunking-p (not mod-lisp-p))
+ (server-read-timeout server) read-timeout
+ (server-write-timeout server) write-timeout)
+ #-:hunchentoot-no-ssl
+ (setf (server-ssl-certificate-file server)
+ (and ssl-certificate-file (namestring ssl-certificate-file))
+ (server-ssl-privatekey-file server)
+ (and ssl-privatekey-file (namestring ssl-privatekey-file))
+ (server-ssl-privatekey-password server)
+ ssl-privatekey-password)
+ (values server)))
+
+(defun start-server (&rest args
+ &key name
+ (port 80 port-provided-p)
+ address
+ dispatch-table
+ (mod-lisp-p nil)
+ (use-apache-log-p mod-lisp-p)
+ (input-chunking-p t)
+ (read-timeout *default-read-timeout*)
+ (write-timeout *default-write-timeout*)
+ #+(and :unix (not :win32)) setuid
+ #+(and :unix (not :win32)) setgid
+ #-:hunchentoot-no-ssl ssl-certificate-file
+ #-:hunchentoot-no-ssl (ssl-privatekey-file ssl-certificate-file)
+ #-:hunchentoot-no-ssl ssl-privatekey-password)
"Starts a Hunchentoot server and returns the SERVER object \(which
can be stopped with STOP-SERVER). PORT is the port the server will be
listening on - the default is 80 \(or 443 if SSL information is
@@ -160,104 +225,80 @@
associated with a password."
;; initialize the session secret if needed
(unless (boundp '*session-secret*)
- (reset-session-secret))
- (let ((output-chunking-p t))
- #-:hunchentoot-no-ssl
- (when ssl-certificate-file
- ;; disable output chunking for SSL connections
- (setq output-chunking-p nil)
- (unless port-provided-p (setq port 443)))
- ;; no timeouts if behind mod_lisp
- (when mod-lisp-p
- (setq read-timeout nil
- write-timeout nil))
- ;; use a new process/lock name for each server
- (atomic-incf *server-counter*)
- ;; create the SERVER object
- (let ((server (make-instance 'server
- :port port
- :address address
- :dispatch-table dispatch-table
- :output-chunking-p (and output-chunking-p (not mod-lisp-p))
- :input-chunking-p input-chunking-p
- #-:hunchentoot-no-ssl #-:hunchentoot-no-ssl
- :ssl-certificate-file (and ssl-certificate-file
- (namestring ssl-certificate-file))
- #-:hunchentoot-no-ssl #-:hunchentoot-no-ssl
- :ssl-privatekey-file (and ssl-privatekey-file
- (namestring ssl-privatekey-file))
- #-:hunchentoot-no-ssl #-:hunchentoot-no-ssl
- :ssl-privatekey-password ssl-privatekey-password
- :mod-lisp-p mod-lisp-p
- :use-apache-log-p (and mod-lisp-p use-apache-log-p)
- :read-timeout read-timeout
- :write-timeout write-timeout)))
- (multiple-value-bind (process condition)
- ;; start up the actual server
- (start-up-server :service port
- :address address
- :process-name (format nil "hunchentoot-listener-~A" *server-counter*)
- ;; this function is called once on
- ;; startup - we use it to record the
- ;; socket
- :announce (lambda (socket &optional condition)
- (cond (socket
- (setf (server-socket server) socket))
- (condition
- (error condition))))
- ;; this function is called whenever a
- ;; connection is made
- :function (lambda (handle)
- (with-lock ((server-lock server))
- (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*)))
- ;; start a worker thread
- ;; for this connection
- ;; and remember it
- (push (process-run-function (format nil "hunchentoot-worker-~A"
- *worker-counter*)
- #'process-connection
- server handle)
- (server-workers server))))
- ;; wait until the server was
- ;; successfully started or an error
- ;; condition is returned
- :wait t)
- (cond (process
- ;; remember the listener so we can kill it later
- (setf (server-listener server) process))
- (condition
- (error condition))))
- #+(and :unix (not :win32))
- (when setgid
- ;; we must make sure to call setgid before we call setuid or
- ;; suddenly we aren't root anymore...
- (etypecase setgid
- (integer (setgid setgid))
- (string (setgid (get-gid-from-name setgid)))))
- #+(and :unix (not :win32))
- (when setuid
- (etypecase setuid
- (integer (setuid setuid))
- (string (setuid (get-uid-from-name setuid)))))
- server)))
+ (reset-session-secret))
+ ;; use a new process/lock name for each server
+ (atomic-incf *server-counter*)
+ ;; create the SERVER object
+ (let ((server (apply #'initialize-server args)))
+ (multiple-value-bind (process condition)
+ ;; start up the actual server
+ (start-up-server :service (server-local-port server)
+ :address (server-address server)
+ :process-name (format nil "hunchentoot-listener-~A" *server-counter*)
+ ;; this function is called once on
+ ;; startup - we use it to record the
+ ;; socket
+ :announce (lambda (socket &optional condition)
+ (cond (socket
+ (setf (server-socket server) socket))
+ (condition
+ (error condition))))
+ ;; this function is called whenever a
+ ;; connection is made
+ :function (lambda (handle)
+ (with-lock ((server-lock server))
+ (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*)))
+ ;; start a worker thread
+ ;; for this connection
+ ;; and remember it
+ (push (process-run-function (format nil "hunchentoot-worker-~A"
+ *worker-counter*)
+ #'process-connection
+ server handle)
+ (server-workers server))))
+ ;; wait until the server was
+ ;; successfully started or an error
+ ;; condition is returned
+ :wait t)
+ (cond (process
+ ;; remember the listener so we can kill it later
+ (setf (server-listener server) process))
+ (condition
+ (error condition))))
+ #+(and :unix (not :win32))
+ (when setgid
+ ;; we must make sure to call setgid before we call setuid or
+ ;; suddenly we aren't root anymore...
+ (etypecase setgid
+ (integer (setgid setgid))
+ (string (setgid (get-gid-from-name setgid)))))
+ #+(and :unix (not :win32))
+ (when setuid
+ (etypecase setuid
+ (integer (setuid setuid))
+ (string (setuid (get-uid-from-name setuid)))))
+ server))
(defun stop-server (server)
"Stops the Hunchentoot server SERVER."
- ;; use lock so that the listener can't start new workers
- (with-lock ((server-lock server))
- ;; kill all worker threads
- (dolist (worker (server-workers server))
- (ignore-errors (process-kill worker))
- (process-allow-scheduling))
- ;; finally, kill main listener
- (when-let (listener (server-listener server))
- (process-kill listener)))
+ (let ((server (if (typep server 'server)
+ server
+ (cdr (assoc server *servers* :test #'equalp)))))
+ ;; use lock so that the listener can't start new workers
+ (with-lock ((server-lock server))
+ ;; kill all worker threads
+ (dolist (worker (server-workers server))
+ (ignore-errors (process-kill worker))
+ (process-allow-scheduling))
+ ;; finally, kill main listener
+ (when-let (listener (server-listener server))
+ (process-kill listener))))
(values))
(defun process-connection (server handle)
@@ -372,6 +413,8 @@
:server-protocol server-protocol))
(*dispatch-table* (or (server-dispatch-table *server*)
(funcall *meta-dispatcher* *server*)))
+ (*easy-handler-alist* (or (server-easy-handler-alist *server*)
+ *easy-handler-alist*))
backtrace)
(multiple-value-bind (body error)
(catch 'handler-done
Index: specials.lisp
===================================================================
--- specials.lisp (revision 1242)
+++ specials.lisp (working copy)
@@ -319,6 +319,9 @@
"During the execution of dispatchers and handlers this variable
is bound to the SERVER object which processes the request.")
+(defvar *servers* nil
+ "Alist mapping server-name to \(named) server instance.")
+
(defvar *meta-dispatcher* (lambda (server)
(declare (ignore server))
*dispatch-table*)
Index: test/test.lisp
===================================================================
--- test/test.lisp (revision 1242)
+++ test/test.lisp (working copy)
@@ -471,6 +471,22 @@
(loop :for choice :being :the :hash-keys :of meal :collect choice)
(gethash "Yellow snow" meal)
team)))))
+
+(define-easy-handler (home-page :uri "/hunchentoot/test/easy-home.html"
+ :server-names '(:http))
+ ()
+ (with-html (:html (:body "Home page"))))
+
+(define-easy-handler (login-page :uri "/hunchentoot/test/easy-login.html"
+ :server-names '(:https))
+ ()
+ (with-html (:html (:body "Secure login"))))
+
+(define-easy-handler (common-page :uri "/hunchentoot/test/easy-common.html"
+ :server-names '(:https :http))
+ ()
+ (with-html (:html (:body "Common page"))))
+
(defun menu ()
@@ -512,6 +528,12 @@
" \(same picture)"))
(:tr (:td (:a :href "/hunchentoot/test/easy-demo.html"
"\"Easy\" handler example")))
+ (:tr (:td (:a :href "/hunchentoot/test/easy-home.html"
+ "\"Easy\" handler example - mockup home page (`http' server instance only)")))
+ (:tr (:td (:a :href "/hunchentoot/test/easy-login.html"
+ "\"Easy\" handler example - mockup login page (`https' server instance only)")))
+ (:tr (:td (:a :href "/hunchentoot/test/easy-common.html"
+ "\"Easy\" handler example - mockup common page (http & https)")))
(:tr (:td (:a :href "/hunchentoot/test/utf8-binary.txt"
"UTF-8 demo")
" \(writing octets directly to the stream)"))
@@ -580,3 +602,12 @@
("/hunchentoot/test/files/" send-file)
("/hunchentoot/test" menu)))
(list #'default-dispatcher)))
+
+;; (defparameter *server-instance* (start-server :port 8080))
+;; (stop-server *server-instance*)
+
+;; (start-server :name :http :port 8000)
+;; (stop-server :http)
+
+;; (start-server :name :https :port 4443)
+;; (stop-server :https)
More information about the Tbnl-devel
mailing list