February 2009 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4263 Author: edi URL: http://bknr.net/trac/changeset/4263 Do to REPLY what we did to REQUEST U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/headers.lisp U trunk/thirdparty/hunchentoot/misc.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/reply.lisp U trunk/thirdparty/hunchentoot/request.lisp U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/test/test-handlers.lisp Change set too large, please see URL above

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4262 Author: edi URL: http://bknr.net/trac/changeset/4262 More... U trunk/thirdparty/hunchentoot/easy-handlers.lisp U trunk/thirdparty/hunchentoot/headers.lisp U trunk/thirdparty/hunchentoot/misc.lisp Modified: trunk/thirdparty/hunchentoot/easy-handlers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/easy-handlers.lisp 2009-02-16 22:16:31 UTC (rev 4261) +++ trunk/thirdparty/hunchentoot/easy-handlers.lisp 2009-02-16 22:33:22 UTC (rev 4262) @@ -161,7 +161,7 @@ DESCRIPTION is either a symbol NAME or a list matching the destructuring lambda list - (name &key uri server-names default-parameter-type default-request-type). + (name &key uri acceptor-names default-parameter-type default-request-type). LAMBDA-LIST is a list the elements of which are either a symbol VAR or a list matching the destructuring lambda list @@ -182,11 +182,11 @@ function and applying this function to the current request object returns a true value. -SERVER-NAMES \(which is evaluated) can be a list of symbols which +ACCEPTOR-NAMES \(which is evaluated) can be a list of symbols which means that the handler will be returned by DISPATCH-EASY-HANDLERS in -servers which have one of these names \(see SERVER-NAME). -SERVER-NAMES can also be the symbol T which means that the handler -will be returned by DISPATCH-EASY-HANDLERS in every server. +acceptor which have one of these names \(see ACCEPTOR-NAME). +ACCEPTOR-NAMES can also be the symbol T which means that the handler +will be returned by DISPATCH-EASY-HANDLERS in every acceptor. Whether the GET or POST parameter \(or both) will be taken into consideration, depends on REQUEST-TYPE which can @@ -277,7 +277,7 @@ argument is provided." (when (atom description) (setq description (list description))) - (destructuring-bind (name &key uri (server-names t) + (destructuring-bind (name &key uri (acceptor-names t) (default-parameter-type ''string) (default-request-type :both)) description @@ -291,7 +291,7 @@ (or (equal ,uri (first list)) (eq ',name (third list)))) *easy-handler-alist*)) - (push (list ,uri ,server-names ',name) *easy-handler-alist*))))) + (push (list ,uri ,acceptor-names ',name) *easy-handler-alist*))))) (defun ,name (&key ,@(loop for part in lambda-list collect (make-defun-parameter part default-parameter-type @@ -310,9 +310,9 @@ (defun dispatch-easy-handlers (request) "This is a dispatcher which returns the appropriate handler defined with DEFINE-EASY-HANDLER, if there is one." - (loop for (uri server-names easy-handler) in *easy-handler-alist* - when (and (or (eq server-names t) - (find (acceptor-name *acceptor*) server-names :test #'eq)) + (loop for (uri acceptor-names easy-handler) in *easy-handler-alist* + when (and (or (eq acceptor-names t) + (find (acceptor-name *acceptor*) acceptor-names :test #'eq)) (cond ((stringp uri) (string= (script-name request) uri)) (t (funcall uri request)))) Modified: trunk/thirdparty/hunchentoot/headers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/headers.lisp 2009-02-16 22:16:31 UTC (rev 4261) +++ trunk/thirdparty/hunchentoot/headers.lisp 2009-02-16 22:33:22 UTC (rev 4262) @@ -189,9 +189,8 @@ (setf content (string-to-octets content :external-format (reply-external-format)))) (when content ;; whenever we know what we're going to send out as content, set - ;; the content-length header properly. It may be that the user - ;; specified a different Content-Length, but that will not be - ;; right. We might want to warn the user. + ;; the Content-Length header properly; maybe the user specified + ;; a different content length, but that will wrong anyway (setf (header-out :content-length) (length content))) ;; write all headers from the REPLY object (loop for (key . value) in (headers-out) @@ -233,7 +232,7 @@ (defun read-initial-request-line (stream) "Reads and returns the initial HTTP request line, catching permitted errors and handling *BREAK-EVEN-WHILE-READING-REQUEST-TYPE-P*. If no -request could be read, return NIL." +request could be read, returns NIL." (let ((*break-on-signals* (and *break-even-while-reading-request-type-p* *break-on-signals*))) (handler-case Modified: trunk/thirdparty/hunchentoot/misc.lisp =================================================================== --- trunk/thirdparty/hunchentoot/misc.lisp 2009-02-16 22:16:31 UTC (rev 4261) +++ trunk/thirdparty/hunchentoot/misc.lisp 2009-02-16 22:33:22 UTC (rev 4262) @@ -109,9 +109,9 @@ (address-string))) (defun create-prefix-dispatcher (prefix handler) - "Creates a dispatch function which will dispatch to the -function denoted by HANDLER if the file name of the current -request starts with the string PREFIX." + "Creates a request dispatch function which will dispatch to the +function denoted by HANDLER if the file name of the current request +starts with the string PREFIX." (lambda (request) (let ((mismatch (mismatch (script-name request) prefix :test #'char=))) @@ -120,9 +120,9 @@ handler)))) (defun create-regex-dispatcher (regex handler) - "Creates a dispatch function which will dispatch to the -function denoted by HANDLER if the file name of the current -request matches the CL-PPCRE regular expression REGEX." + "Creates a request dispatch function which will dispatch to the +function denoted by HANDLER if the file name of the current request +matches the CL-PPCRE regular expression REGEX." (let ((scanner (create-scanner regex))) (lambda (request) (and (scan scanner (script-name request)) @@ -136,13 +136,13 @@ (defun handle-static-file (path &optional content-type) "A function which acts like a Hunchentoot handler for the file -denoted by PATH. Send a content type header corresponding to -CONTENT-TYPE or \(if that is NIL) tries to determine the content -type via the file's suffix." +denoted by PATH. Sends a content type header corresponding to +CONTENT-TYPE or \(if that is NIL) tries to determine the content type +via the file's suffix." (when (or (wild-pathname-p path) (not (fad:file-exists-p path)) (fad:directory-exists-p path)) - ;; does not exist + ;; file does not exist (setf (return-code) +http-not-found+) (abort-request-handler)) (let ((time (or (file-write-date path) (get-universal-time)))) @@ -166,10 +166,10 @@ (finish-output out)))))) (defun create-static-file-dispatcher-and-handler (uri path &optional content-type) - "Creates and returns a dispatch function which will dispatch to a -handler function which emits the file denoted by the pathname + "Creates and returns a request dispatch function which will dispatch +to a handler function which emits the file denoted by the pathname designator PATH with content type CONTENT-TYPE if the SCRIPT-NAME of -the request matches the string URI. If CONTENT-TYPE is NIL tries to +the request matches the string URI. If CONTENT-TYPE is NIL, tries to determine the content type via the file's suffix." ;; the dispatcher (lambda (request)

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4261 Author: edi URL: http://bknr.net/trac/changeset/4261 More documentation U trunk/thirdparty/hunchentoot/compat.lisp U trunk/thirdparty/hunchentoot/lispworks.lisp U trunk/thirdparty/hunchentoot/set-timeouts.lisp U trunk/thirdparty/hunchentoot/taskmaster.lisp Modified: trunk/thirdparty/hunchentoot/compat.lisp =================================================================== --- trunk/thirdparty/hunchentoot/compat.lisp 2009-02-16 21:53:06 UTC (rev 4260) +++ trunk/thirdparty/hunchentoot/compat.lisp 2009-02-16 22:16:31 UTC (rev 4261) @@ -99,10 +99,10 @@ (values (usocket:vector-quad-to-dotted-quad (usocket:get-peer-address socket)) (usocket:get-peer-port socket))) -(defun make-socket-stream (socket server) - "Returns a stream for the socket SOCKET. The SERVER argument is +(defun make-socket-stream (socket acceptor) + "Returns a stream for the socket SOCKET. The ACCEPTOR argument is ignored." - (declare (ignore server)) + (declare (ignore acceptor)) (usocket:socket-stream socket)) (defun make-lock (name) Modified: trunk/thirdparty/hunchentoot/lispworks.lisp =================================================================== --- trunk/thirdparty/hunchentoot/lispworks.lisp 2009-02-16 21:53:06 UTC (rev 4260) +++ trunk/thirdparty/hunchentoot/lispworks.lisp 2009-02-16 22:16:31 UTC (rev 4261) @@ -55,14 +55,23 @@ (defvar *cleanup-interval* 100 "Should be NIL or a positive integer. The system calls -*CLEANUP-FUNCTION* whenever *CLEANUP-INTERVAL* new worker threads have -been created unless the value is NIL.") +*CLEANUP-FUNCTION* whenever *CLEANUP-INTERVAL* new worker threads +\(counted globally across all acceptors) have been created unless the +value is NIL. The initial value is 100. +This variable is only available on LispWorks.") + (defvar *cleanup-function* 'cleanup-function - "The function which is called if *CLEANUP-INTERVAL* is not NIL.") + "A designator for a function without arguments which is called on a +regular basis if *CLEANUP-INTERVAL* is not NIL. The initial value is +the name of a function which invokes a garbage collection on 32-bit +versions of LispWorks. +This variable is only available on LispWorks.") + (defvar *worker-counter* 0 - "Internal counter used to count worker threads.") + "Internal counter used to count worker threads. Needed for +*CLEANUP-FUNCTION*.") (defun cleanup-function () "The default for *CLEANUP-FUNCTION*. Invokes a GC on 32-bit Modified: trunk/thirdparty/hunchentoot/set-timeouts.lisp =================================================================== --- trunk/thirdparty/hunchentoot/set-timeouts.lisp 2009-02-16 21:53:06 UTC (rev 4260) +++ trunk/thirdparty/hunchentoot/set-timeouts.lisp 2009-02-16 22:16:31 UTC (rev 4261) @@ -29,21 +29,19 @@ (in-package :hunchentoot) -;;; system specific implementation of the function that sets up -;;; connection timeouts - (defun set-timeouts (usocket read-timeout write-timeout) "Sets up timeouts on the given USOCKET object. READ-TIMEOUT is the read timeout period, WRITE-TIMEOUT is the write timeout, specified in -seconds. The timeouts can either be implemented using the low-level -socket options SO_RCVTIMEO and SO_SNDTIMEO or some other, -implementation specific mechanism. On platforms that do not support -separate read and write timeouts, both must be equal or an error will -be signaled. READ-TIMEOUT and WRITE-TIMEOUT may be NIL, which means -that the corresponding socket timeout value will not be set." +\(fractional) seconds. The timeouts can either be implemented using +the low-level socket options SO_RCVTIMEO and SO_SNDTIMEO or some +other, implementation specific mechanism. On platforms that do not +support separate read and write timeouts, both must be equal or an +error will be signaled. READ-TIMEOUT and WRITE-TIMEOUT may be NIL, +which means that the corresponding socket timeout value will not be +set." (declare (ignorable usocket read-timeout write-timeout)) - #+:sbcl ;; add other Lisps here if necessary + #+(or :sbcl :cmu) (unless (eql read-timeout write-timeout) (parameter-error "Read and write timeouts for socket must be equal.")) #+:clisp Modified: trunk/thirdparty/hunchentoot/taskmaster.lisp =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-02-16 21:53:06 UTC (rev 4260) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-02-16 22:16:31 UTC (rev 4261) @@ -114,6 +114,8 @@ #-: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)

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4260 Author: edi URL: http://bknr.net/trac/changeset/4260 More documentation U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/taskmaster.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 21:24:05 UTC (rev 4259) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 21:53:06 UTC (rev 4260) @@ -105,7 +105,9 @@ #+:lispworks (process :accessor acceptor-process :documentation "The Lisp process which accepts incoming -requests.") +requests. This is the process started by COMM:START-UP-SERVER and no +matter what kind of taskmaster you are using this will always be a new +process different from the one where START was called.") #-:lispworks (listen-socket :accessor acceptor-listen-socket :documentation "The socket listening for incoming Modified: trunk/thirdparty/hunchentoot/taskmaster.lisp =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-02-16 21:24:05 UTC (rev 4259) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-02-16 21:53:06 UTC (rev 4260) @@ -31,22 +31,18 @@ (defclass taskmaster () ((acceptor :accessor taskmaster-acceptor - :documentation "The acceptor instance that this -taskmaster works for.")) - (:documentation "Base class for all taskmaster classes. Its purpose -is to carry the back pointer to the acceptor instance.")) + :documentation "A backpointer to the acceptor instance +this taskmaster works for.")) + (:documentation "An instance of this class is responsible for +distributing the work of handling requests when its acceptor ")) (defgeneric execute-acceptor (taskmaster) - (:documentation - "This function is called once Hunchentoot has performed all initial -processing to start listening for incoming connections. It does so by -calling the ACCEPT-CONNECTIONS functions of the acceptor, taken from -the ACCEPTOR slot of the taskmaster instance. + (:documentation "This is a callback called by the acceptor once it +has performed all initial processing to start listening for incoming +connections \(see START-LISTENING). It usually calls the +ACCEPT-CONNECTIONS method of the acceptor, but depending on the +taskmaster instance the method might be called from a new thread.")) -In a multi-threaded environment, the taskmaster starts a new -thread and calls THUNK in that thread. In a single-threaded -environment, the thunk will be called directly.")) - (defgeneric handle-incoming-connection (taskmaster socket) (:documentation "This function is called by Hunchentoot to start processing of @@ -63,28 +59,36 @@ is called directly.")) (defgeneric shutdown (taskmaster) - (:documentation "Terminate all threads that are currently associated -with the taskmaster, if any.")) + (:documentation "Shuts down the taskmaster, i.e. frees all resources +that were set up by it. For example, a multi-threaded taskmaster +might terminate all threads that are currently associated with it.")) (defclass single-threaded-taskmaster (taskmaster) () - (:documentation "Taskmaster that runs synchronously in the -thread that invoked the START-SERVER function.")) + (:documentation "A taskmaster that runs synchronously in the thread +where the START function was invoked \(or in the case of LispWorks in +the thread started by COMM:START-UP-SERVER). This is the simplest +possible taskmaster implementation in that its methods do nothing but +calling their acceptor \"sister\" methods - EXECUTE-ACCEPTOR calls +ACCEPT-CONNECTIONS, HANDLE-INCOMING-CONNECTION calls +PROCESS-CONNECTION.")) (defmethod execute-acceptor ((taskmaster single-threaded-taskmaster)) + ;; in a single-threaded environment we just call ACCEPT-CONNECTIONS (accept-connections (taskmaster-acceptor taskmaster))) (defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket) + ;; in a single-threaded environment we just call PROCESS-CONNECTION (process-connection (taskmaster-acceptor taskmaster) socket)) (defclass one-thread-per-connection-taskmaster (taskmaster) - ((acceptor-process :accessor acceptor-process - :documentation "Process that accepts incoming + (#-:lispworks + (acceptor-process :accessor acceptor-process + :documentation "A process that accepts incoming connections and hands them off to new processes for request handling.")) - (:documentation "Taskmaster that starts one thread for -listening to incoming requests and one thread for each incoming -connection.")) + (:documentation "A taskmaster that starts one thread for listening +to incoming requests and one thread for each incoming connection.")) ;; usocket implementation @@ -104,7 +108,7 @@ (setf (acceptor-process taskmaster) (bt:make-thread (lambda () (accept-connections (taskmaster-acceptor taskmaster))) - :name (format nil "Hunchentoot acceptor \(~A:~A)" + :name (format nil "Hunchentoot listener \(~A:~A)" (or (acceptor-address (taskmaster-acceptor taskmaster)) "*") (acceptor-port (taskmaster-acceptor taskmaster))))))

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4259 Author: edi URL: http://bknr.net/trac/changeset/4259 Add documentation U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/ssl.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 20:17:51 UTC (rev 4258) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 21:24:05 UTC (rev 4259) @@ -32,65 +32,87 @@ (defclass acceptor () ((port :initarg :port :reader acceptor-port - :documentation "The port the acceptor is listening on.") + :documentation "The port the acceptor is listening on. The +default is 80. Note that depending on your operating system you might +need special privileges to listen on port 80.") (address :initarg :address :reader acceptor-address - :documentation "The address the acceptor is listening on.") + :documentation "The address the acceptor is listening on. +If address is a string denoting an IP address, then the server only +receives connections for that address. This must be one of the +addresses associated with the machine and allowed values are host +names such as \"www.zappa.com\" and address strings such as +\"72.3.247.29\". If address is NIL, then the server will receive +connections to all IP addresses on the machine. This is the default.") (name :initarg :name :accessor acceptor-name - :documentation "The optional name of the acceptor, a symbol.") + :documentation "The optional name of the acceptor, a symbol. +This name can be utilized when defining \"easy handlers\" - see +DEFINE-EASY-HANDLER. The default name is an uninterned symbol as +returned by GENSYM.") (request-class :initarg :request-class :accessor acceptor-request-class :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.") +naming) a class which inherits from REQUEST. The default is the +symbol REQUEST.") (handler-selector :initarg :handler-selector :accessor acceptor-handler-selector - :documentation "The handler selector function -used by this acceptor. A function which accepts a REQUEST object and -calls a request handler of its choice \(and returns its return -value).") + :documentation "A designator for the handler +selector function used by this acceptor. A function which accepts a +REQUEST object and calls a request handler of its choice \(and returns +its return value). The default is the unexported symbol +LIST-HANDLER-SELECTOR which works through the list *DISPATCH-TABLE*.") (taskmaster :initarg :taskmaster :reader acceptor-taskmaster - :documentation "The taskmaster that is responsible for -scheduling the work for this acceptor.") + :documentation "The taskmaster \(i.e. an instance of a +subclass of TASKMASTER) that is responsible for scheduling the work +for this acceptor. The default depends on the MP capabilities of the +underlying Lisp.") (output-chunking-p :initarg :output-chunking-p :accessor acceptor-output-chunking-p - :documentation "Whether the acceptor may use output chunking.") + :documentation "A generalized boolean denoting +whether the acceptor may use chunked encoding for output, i.e. when +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 "Whether the acceptor may use input chunking.") + :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.") (persistent-connections-p :initarg :persistent-connections-p :accessor acceptor-persistent-connections-p - :documentation "Whether the acceptor -supports persistent connections, which is the default for threaded -acceptors. If this property is false, Hunchentoot closes incoming -connections after having processed one request. This is the default -for non-threaded acceptors.") + :documentation "A generalized boolean +denoting whether the acceptor supports persistent connections, which +is the default for threaded acceptors. If this property is NIL, +Hunchentoot closes each incoming connection after having processed one +request. This is the default for non-threaded acceptors.") (read-timeout :initarg :read-timeout :reader acceptor-read-timeout - :documentation "The connection timeout of the -acceptor, specified in \(fractional) seconds. Connections that are -idle for longer than this time are closed by Hunchentoot. The precise -semantics of this parameter is determined by the underlying Lisp's -implementation of socket timeouts. NIL means no timeout.") + :documentation "The read 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. NIL \(which is the default that you might want to +change for production environments) means no timeout.") (write-timeout :initarg :write-timeout :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. NIL means no timeout.") + :documentation "The write 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. NIL \(which is the default that you might want to +change for production environments) means no timeout.") #+:lispworks (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.") + :documentation "The socket listening for incoming +connections.") (acceptor-shutdown-p :initform nil :accessor acceptor-shutdown-p - :documentation "Flag that makes the acceptor + :documentation "A flag that makes the acceptor shutdown itself when set to something other than NIL.") (access-logger :initarg :access-logger :accessor acceptor-access-logger @@ -132,9 +154,17 @@ :write-timeout nil :access-logger 'log-access-to-file :message-logger 'log-message-to-file) - (:documentation "An object of this class contains all relevant -information about a running Hunchentoot acceptor instance.")) + (:documentation "To create a Hunchentoot webserver, you make an +instance of this class and use the generic function START to start it +\(and STOP to stop it). Use the :PORT initarg if you don't want to +listen on the default http port 80. There are other initargs most of +which you probably won't need very often. They are explained in +detail in the docstrings of the slot definitions for this class. +Unless you are in a Lisp without MP capabilities, you can have several +active instances of ACCEPTOR \(listening on different ports) at the +same time.")) + (defmethod print-object ((acceptor acceptor) stream) (print-unreadable-object (acceptor stream :type t) (format stream "\(host ~A, port ~A)" @@ -150,41 +180,44 @@ (defgeneric start-listening (acceptor) (:documentation "Sets up a listen socket for the given ACCEPTOR and -enables it to listen for incoming connections. This function is -called from the thread that starts the acceptor initially and may -return errors resulting from the listening operation \(like 'address -in use' or similar).")) +enables it to listen to incoming connections. This function is called +from the thread that starts the acceptor initially and may return +errors resulting from the listening operation \(like 'address in use' +or similar).")) (defgeneric accept-connections (acceptor) - (:documentation "In a loop, accepts a connection and dispatches it + (:documentation "In a loop, accepts a connection and hands it over to the acceptor's taskmaster for processing using HANDLE-INCOMING-CONNECTION.")) (defgeneric initialize-connection-stream (acceptor stream) - (:documentation "Wraps the given STREAM with all the additional -stream classes to support the functionality required by ACCEPTOR. The -methods of this generic function must return the stream to use.")) + (:documentation "Can be used to modify the stream which is used to +communicate between client and server before the request is read. The +default method of ACCEPTOR does nothing, but see for example the +method defined for SSL-ACCEPTOR. All methods of this generic function +must return the stream to use.")) (defgeneric reset-connection-stream (acceptor stream) - (:documentation "Resets the given STREAM so that it can be used to -process the next request, ACCEPTOR is the acceptor that this stream -belongs to, which determines what to do to reset. This generic -function is called after a request has been processed and must return -the stream.")) + (:documentation "Resets the stream which is used to communicate +between client and server after one request has been served so that it +can be used to process the next request. This generic function is +called after a request has been processed and must return the +stream.")) (defgeneric process-connection (acceptor socket) (:documentation "This function is called by the taskmaster when a -new client connection has been established. Arguments are the -ACCEPTOR object and a usocket socket stream object \(or a LispWorks -socket handle) in SOCKET. It reads the request headers and hands over -to PROCESS-REQUEST. This is done in a loop until the stream has to be -closed or until a connection timeout occurs.")) +new client connection has been established. Its arguments are the +ACCEPTOR object and a LispWorks socket handle or a usocket socket +stream object in SOCKET. It reads the request headers, sets up the +request and reply objects, and hands over to PROCESS-REQUEST. This is +done in a loop until the stream has to be closed or until a connection +timeout occurs.")) (defgeneric acceptor-ssl-p (acceptor) (:documentation "Returns a true value if ACCEPTOR uses SSL connections. The default is to unconditionally return NIL and subclasses of ACCEPTOR must specialize this method to signal that -they're using secure connections.")) +they're using secure connections - see the SSL-ACCEPTOR class.")) ;; general implementation @@ -224,7 +257,7 @@ (t stream))) (defmethod process-connection :around ((*acceptor* acceptor) (socket t)) - "The around method is responsible for error handling." + ;; this around method is used for error handling (declare (ignore socket)) ;; note that this method also binds *ACCEPTOR* (handler-bind ((error @@ -247,7 +280,7 @@ (unwind-protect ;; process requests until either the acceptor is shut down, ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the - ;; handler or the peer fails to send a request. + ;; handler, or the peer fails to send a request (loop (let ((*close-hunchentoot-stream* t)) (when (acceptor-shutdown-p *acceptor*) @@ -297,10 +330,11 @@ (defun process-request (request) "This function is called by PROCESS-CONNECTION after the incoming -headers have been read. It sets up the REQUEST and REPLY objects, -selects and calls a handler, and finally sends the output to the -client using START-OUTPUT. If all goes as planned, the function -returns T." +headers have been read. It selects and calls a handler and sends the +output of this handler to the client using START-OUTPUT. It also sets +up simple error handling for the actual request handler. + +The return value of this function is ignored." (let (*tmp-files* *headers-sent*) (unwind-protect (let* ((*request* request)) @@ -333,12 +367,11 @@ (escape-for-html (format nil "~A" error)))) (error "An error has occured.") - (t body)))) - t) + (t body))))) (dolist (path *tmp-files*) (when (and (pathnamep path) (probe-file path)) ;; the handler may have chosen to (re)move the uploaded - ;; file, so ignore errors that happen during deletion. + ;; file, so ignore errors that happen during deletion (ignore-errors (delete-file path))))))) Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-16 20:17:51 UTC (rev 4258) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-16 21:24:05 UTC (rev 4259) @@ -128,11 +128,11 @@ "ACCEPTOR-PERSISTENT-CONNECTIONS-P" "ACCEPTOR-PORT" "ACCEPTOR-READ-TIMEOUT" - "ACCEPTOR-REQUEST-CLASS" + "ACCEPTOR-REQUEST-CLASS" "ACCEPTOR-SSL-P" - "ACCEPTOR-SSL-CERTIFICATE-FILE" - "ACCEPTOR-SSL-PRIVATEKEY-FILE" - "ACCEPTOR-SSL-PRIVATEKEY-PASSWORD" + #-:hunchentoot-no-ssl "ACCEPTOR-SSL-CERTIFICATE-FILE" + #-:hunchentoot-no-ssl "ACCEPTOR-SSL-PRIVATEKEY-FILE" + #-:hunchentoot-no-ssl "ACCEPTOR-SSL-PRIVATEKEY-PASSWORD" "ACCEPTOR-WRITE-TIMEOUT" "AUTHORIZATION" "AUX-REQUEST-VALUE" @@ -234,7 +234,7 @@ "SET-COOKIE*" "SHUTDOWN" "SINGLE-THREADED-TASKMASTER" - "SSL-ACCEPTOR" + #-:hunchentoot-no-ssl "SSL-ACCEPTOR" "SSL-P" "START" "START-LISTENING" Modified: trunk/thirdparty/hunchentoot/ssl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-16 20:17:51 UTC (rev 4258) +++ trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-16 21:24:05 UTC (rev 4259) @@ -47,9 +47,18 @@ private key file or NIL for no password.")) (:default-initargs :port 443) - (:documentation "This class defines additional slots required to -serve requests via SSL.")) + (:documentation "Create and START an instance of this class +\(instead of ACCEPTOR) if you want an https server. There are two +required initargs, :SSL-CERTIFICATE-FILE and :SSL-PRIVATEKEY-FILE, for +pathname designators denoting the certificate file and the key file in +PEM format. On LispWorks, you can have both in one file in which case +the second initarg is optional. On LispWorks, you can also use the +:SSL-PRIVATEKEY-PASSWORD initarg to provide a password \(as a string) +for the key file \(or NIL, the default, for no password). On other +Lisps, the key file must not be password-protected. +The default port for SSL-ACCEPTOR instances is 443 instead of 80")) + ;; general implementation (defmethod acceptor-ssl-p ((acceptor ssl-acceptor)) @@ -85,9 +94,10 @@ "Given the acceptor socket stream SOCKET-STREAM attaches SSL to the stream using the certificate file CERTIFICATE-FILE and the private key file PRIVATEKEY-FILE. Both of these values must be namestrings -denoting the location of the files. If PRIVATEKEY-PASSWORD is not NIL -then it should be the password for the private key file \(if -necessary). Returns the stream" +denoting the location of the files and will be fed directly to +OpenSSL. If PRIVATEKEY-PASSWORD is not NIL then it should be the +password for the private key file \(if necessary). Returns the +stream." (flet ((ctx-configure-callback (ctx) (when privatekey-password (comm:set-ssl-ctx-password-callback ctx :password privatekey-password))

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4258 Author: edi URL: http://bknr.net/trac/changeset/4258 Fix SSL problems (for LispWorks) U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/ssl.lisp A trunk/thirdparty/hunchentoot/test/test-certificate.crt A trunk/thirdparty/hunchentoot/test/test-key-no-password.key Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 14:18:15 UTC (rev 4257) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 20:17:51 UTC (rev 4258) @@ -243,6 +243,7 @@ (defmethod process-connection ((*acceptor* acceptor) (socket t)) (let ((*hunchentoot-stream* (initialize-connection-stream *acceptor* (make-socket-stream socket *acceptor*)))) + (print *hunchentoot-stream*) (unwind-protect ;; process requests until either the acceptor is shut down, ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the Modified: trunk/thirdparty/hunchentoot/ssl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-16 14:18:15 UTC (rev 4257) +++ trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-16 20:17:51 UTC (rev 4258) @@ -32,22 +32,21 @@ (defclass ssl-acceptor (acceptor) ((ssl-certificate-file :initarg :ssl-certificate-file :reader acceptor-ssl-certificate-file - :documentation "The namestring of a -certificate file.") + :documentation "A pathname designator for a +certificate file in PEM format.") (ssl-privatekey-file :initarg :ssl-privatekey-file :reader acceptor-ssl-privatekey-file - :documentation "The namestring of a private -key file, or NIL if the certificate file contains the private key.") - (ssl-privatekey-password #+:lispworks #+:lispworks - :initform nil + :documentation "A pathname designator for a +private key file in PEM format, or \(only on LispWorks) NIL if the +certificate file contains the private key.") + #+:lispworks + (ssl-privatekey-password :initform nil :initarg :ssl-privatekey-password :reader acceptor-ssl-privatekey-password :documentation "The password for the -private key file or NIL.")) +private key file or NIL for no password.")) (:default-initargs - :port 443 - :input-chunking-p nil - :output-chunking-p nil) + :port 443) (:documentation "This class defines additional slots required to serve requests via SSL.")) @@ -56,6 +55,19 @@ (defmethod acceptor-ssl-p ((acceptor ssl-acceptor)) t) +(defmethod initialize-instance :after ((acceptor ssl-acceptor) &rest initargs) + (declare (ignore initargs)) + ;; LispWorks can read both from the same file, so we can default one + #+:lispworks + (unless (slot-boundp acceptor 'ssl-privatekey-file) + (setf (slot-value acceptor 'ssl-privatekey-file) + (acceptor-ssl-certificate-file acceptor))) + ;; OpenSSL doesn't know much about Lisp pathnames... + (setf (slot-value acceptor 'ssl-privatekey-file) + (namestring (truename (acceptor-ssl-privatekey-file acceptor))) + (slot-value acceptor 'ssl-certificate-file) + (namestring (truename (acceptor-ssl-certificate-file acceptor))))) + ;; usocket implementation #-:lispworks @@ -68,14 +80,6 @@ ;; LispWorks implementation -#+:lispworks -(defmethod initialize-instance :after ((acceptor ssl-acceptor) &rest initargs) - (declare (ignore initargs)) - ;; LispWorks can read both from the same file, so we can default one - (unless (slot-boundp acceptor 'ssl-privatekey-file) - (setf (slot-value acceptor 'ssl-privatekey-file) - (acceptor-ssl-certificate-file acceptor)))) - #+lispworks (defun make-ssl-server-stream (socket-stream &key certificate-file privatekey-file privatekey-password) "Given the acceptor socket stream SOCKET-STREAM attaches SSL to the Added: trunk/thirdparty/hunchentoot/test/test-certificate.crt =================================================================== --- trunk/thirdparty/hunchentoot/test/test-certificate.crt (rev 0) +++ trunk/thirdparty/hunchentoot/test/test-certificate.crt 2009-02-16 20:17:51 UTC (rev 4258) @@ -0,0 +1,13 @@ +-----BEGIN CERTIFICATE----- +MIIB3TCCAUYCCQCDg/PAAhv7kjANBgkqhkiG9w0BAQQFADAzMQswCQYDVQQGEwJE +RTEQMA4GA1UECBMHR2VybWFueTESMBAGA1UEAxMJbG9jYWxob3N0MB4XDTA5MDIx +NjEyMTgzMFoXDTEwMDIxNjEyMTgzMFowMzELMAkGA1UEBhMCREUxEDAOBgNVBAgT +B0dlcm1hbnkxEjAQBgNVBAMTCWxvY2FsaG9zdDCBnzANBgkqhkiG9w0BAQEFAAOB +jQAwgYkCgYEAxpUaQISfEDw3c7VSFsW+oKQViarjMmZNJL7ZWaZlsbVgROPohCRj +qmbS1yjQ0DZQWZK4PMyyXqT90OUIXSohGAB9O3M/etMpMYaRlws66o2mNx/R8bTZ +qGDQcXXRg1Ghsq2JnQsyhl4nTQXMn8KM/jLd6iT9XJd+O6AuWfOlticCAwEAATAN +BgkqhkiG9w0BAQQFAAOBgQCUW7a5BvL8Qoy5Mvd9cxUt8jnDm5KRiEgcmBIIlrVi +bLXmEQaRPQDoxGsrzi/LaUuMitT/kaGwhbdhfwZsjXI2QxuqpPYRhLnPBvn6q77u +e0/yXaPp6UnMnQNw2O8xLcUDeLbRrw9IBPeDUYYP0OaTkJvORwFJ4e6rdVyha4o7 +1A== +-----END CERTIFICATE----- Added: trunk/thirdparty/hunchentoot/test/test-key-no-password.key =================================================================== --- trunk/thirdparty/hunchentoot/test/test-key-no-password.key (rev 0) +++ trunk/thirdparty/hunchentoot/test/test-key-no-password.key 2009-02-16 20:17:51 UTC (rev 4258) @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICWwIBAAKBgQDGlRpAhJ8QPDdztVIWxb6gpBWJquMyZk0kvtlZpmWxtWBE4+iE +JGOqZtLXKNDQNlBZkrg8zLJepP3Q5QhdKiEYAH07cz960ykxhpGXCzrqjaY3H9Hx +tNmoYNBxddGDUaGyrYmdCzKGXidNBcyfwoz+Mt3qJP1cl347oC5Z86W2JwIDAQAB +AoGAJoJhneNaCUb0Je8ipSHhzrsjJhhKiMqH6TlNYvI+xFB9A78CpyV7Yl8gQfM7 +UzVFLamjKr8zU+FBC1Ju5co2sl4u3fPgXwuo5X36IVa03WdClXp0PQ7RsOXqi0Rx +d1maRkxPok7AnSMCAWNeLCgxVmCKzIWLKcvB8idK7evjGUkCQQDyoewf7ey1eNy7 +hv87E9E/gUQ/9A9rEhkKcRbwvEicB+OcxpZl6Br0Z6EJH39AlJe1ii81lSqfPd+h +6WE2uU+lAkEA0YXmYnCJdlcYAORLX3ewibVCikOJUIMt7smGVOK23ubmHh49+KUW +HT3xDPDRVmkmiYzqXZOY0pGUG37b4GAE2wJAXRPa1kDanp835kSaYtpuWjNHsFT7 +GTL/Ii9SApXoMNsh6QGRrpREyt96Olq34VlffYf+JksL57y/rogt/+VE9QJAV+vV +YmeQ92zSsMUb7+K83PyIAJcYjwWNB8/fI83DKURBOlA8dxNndTvh5ClF3vne5weP +7VabYXkfam5QfBYu0wJANPeIsAd8yUdZViiMOH6tE8DUlMy/p1N9Rz0eMSc4uUch +EB59djdHmSknY0JgVZJFybWFWKtbxSvcnrJq/hAcMQ== +-----END RSA PRIVATE KEY-----

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4257 Author: edi URL: http://bknr.net/trac/changeset/4257 Some fixes U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/ssl.lisp U trunk/thirdparty/hunchentoot/taskmaster.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 12:05:37 UTC (rev 4256) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-16 14:18:15 UTC (rev 4257) @@ -123,7 +123,7 @@ :name (gensym) :request-class 'request :handler-selector 'list-handler-selector - :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-taskmaster) + :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster) (t 'single-threaded-taskmaster))) :output-chunking-p t :input-chunking-p t @@ -206,12 +206,12 @@ #-:lispworks (usocket:socket-close (acceptor-listen-socket acceptor))) -(defmethod initialize-connection-stream (acceptor stream) +(defmethod initialize-connection-stream ((acceptor acceptor) stream) (declare (ignore acceptor)) ;; default method does nothing stream) -(defmethod reset-connection-stream (acceptor stream) +(defmethod reset-connection-stream ((acceptor acceptor) stream) (declare (ignore acceptor)) ;; turn chunking off at this point (cond ((typep stream 'chunked-stream) Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-16 12:05:37 UTC (rev 4256) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-16 14:18:15 UTC (rev 4257) @@ -182,6 +182,7 @@ "MIME-TYPE" "NEXT-SESSION-ID" "NO-CACHE" + "ONE-THREAD-PER-CONNECTION-TASKMASTER" "PARAMETER" "POST-PARAMETER" "POST-PARAMETERS" @@ -232,6 +233,7 @@ "SET-COOKIE" "SET-COOKIE*" "SHUTDOWN" + "SINGLE-THREADED-TASKMASTER" "SSL-ACCEPTOR" "SSL-P" "START" Modified: trunk/thirdparty/hunchentoot/ssl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-16 12:05:37 UTC (rev 4256) +++ trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-16 14:18:15 UTC (rev 4257) @@ -104,4 +104,4 @@ (make-ssl-server-stream stream :certificate-file (acceptor-ssl-certificate-file acceptor) :privatekey-file (acceptor-ssl-privatekey-file acceptor) - :privatekey-password (acceptor-ssl-privatekey-password acceptor)))) \ No newline at end of file + :privatekey-password (acceptor-ssl-privatekey-password acceptor)))) Modified: trunk/thirdparty/hunchentoot/taskmaster.lisp =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-02-16 12:05:37 UTC (rev 4256) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-02-16 14:18:15 UTC (rev 4257) @@ -77,7 +77,7 @@ (defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket) (process-connection (taskmaster-acceptor taskmaster) socket)) -(defclass one-thread-per-taskmaster (taskmaster) +(defclass one-thread-per-connection-taskmaster (taskmaster) ((acceptor-process :accessor acceptor-process :documentation "Process that accepts incoming connections and hands them off to new processes for request @@ -92,7 +92,7 @@ (defmethod shutdown ((taskmaster taskmaster))) #-:lispworks -(defmethod shutdown ((taskmaster one-thread-per-taskmaster)) +(defmethod shutdown ((taskmaster one-thread-per-connection-taskmaster)) ;; just wait until the acceptor process has finished, then return (loop (unless (bt:thread-alive-p (acceptor-process taskmaster)) @@ -100,7 +100,7 @@ (sleep 1))) #-:lispworks -(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) +(defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster)) (setf (acceptor-process taskmaster) (bt:make-thread (lambda () (accept-connections (taskmaster-acceptor taskmaster))) @@ -118,7 +118,7 @@ port)))) #-:lispworks -(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) socket) +(defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket) (bt:make-thread (lambda () (process-connection (taskmaster-acceptor taskmaster) socket)) :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) @@ -133,11 +133,11 @@ (mp:process-kill process))) #+:lispworks -(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) +(defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster)) (accept-connections (taskmaster-acceptor taskmaster))) #+:lispworks -(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) handle) +(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*

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/test/script.lisp
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4256 Author: hans URL: http://bknr.net/trac/changeset/4256 Forgot to save this. U trunk/thirdparty/hunchentoot/test/script.lisp Modified: trunk/thirdparty/hunchentoot/test/script.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/script.lisp 2009-02-16 12:00:15 UTC (rev 4255) +++ trunk/thirdparty/hunchentoot/test/script.lisp 2009-02-16 12:05:37 UTC (rev 4256) @@ -40,9 +40,15 @@ (defun test-hunchentoot (base-url &key (make-cookie-jar (lambda () (make-instance 'drakma:cookie-jar)))) - "Run the built-in confidence test. The keyword arguments accepted - are for future extension and should not currently be used." + "Run the built-in confidence test. BASE-URL is the base URL to use + for testing, it should not have a trailing slash. The keyword + arguments accepted are for future extension and should not + currently be used. + The script expects the Hunchentoot example test server to be + running at the given BASE-URL and retrieves various pages from that + server, expecting certain responses." + (with-script-context (:base-url (format nil "~A/hunchentoot/test/" base-url)) (say "Request home page")

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
by BKNR Commits 16 Feb '09

16 Feb '09

Revision: 4255 Author: hans URL: http://bknr.net/trac/changeset/4255 add some documentation on the testing facility U trunk/thirdparty/hunchentoot/doc/index.xml U trunk/thirdparty/hunchentoot/test/script-engine.lisp U trunk/thirdparty/hunchentoot/test/script.lisp Modified: trunk/thirdparty/hunchentoot/doc/index.xml =================================================================== --- trunk/thirdparty/hunchentoot/doc/index.xml 2009-02-12 23:38:00 UTC (rev 4254) +++ trunk/thirdparty/hunchentoot/doc/index.xml 2009-02-16 12:00:15 UTC (rev 4255) @@ -2592,12 +2592,51 @@ using <clix:ref>RAW-POST-DATA</clix:ref> instead of reading the request body using a flexi stream. Usually, this is automatically done right by Hunchentoot to read POST data, and - you should only use the <clix:arg>want-stream</clix:arg> keyword argument to the - <clix:ref>RAW-POST-DATA</clix:ref> in rare circumstances. + you should only use the <clix:arg>want-stream</clix:arg> + keyword argument to the <clix:ref>RAW-POST-DATA</clix:ref> in + rare circumstances. </li> </ul> </clix:chapter> + <clix:chapter name="testing" title="Testing"> + Hunchentoot comes with a test script that verifies that the + example web server responds as expected. This test script uses the + <a href="http://weitz.de/drakma/">Drakma</a> HTTP client library + and thus shares a significant amount of its base code with + Hunchentoot itself. Still, running the test script is a useful + confidence test, and it is also possible to run the script across + machines in order to verify a new Hunchentoot (or, for that matter + Drakma) port. + <p> + To run the confidence test, start + the <clix:ref>example</clix:ref> web server. Then, in your Lisp + listener, type +<pre>(hunchentoot-test:test-hunchentoot "http://localhost:4242")</pre> + You will see some diagnostic output and a summary line that + reports whether any tests have failed. + </p> + + <clix:function name="hunchentoot-test:test-hunchentoot"> + <clix:lambda-list>base-url <clix:lkw>key</clix:lkw></clix:lambda-list> + <clix:returns>|</clix:returns> + <clix:description> + Run the built-in confidence + test. <clix:arg>base-url</clix:arg> is the base URL to use + for testing, it should not have a trailing slash. The keyword + arguments accepted are for future extension and should not + currently be used. + <p> + The script expects the Hunchentoot example test server to be + running at the given <clix:arg>base-url</clix:arg> and + retrieves various pages from that server, expecting certain + responses. + </p> + </clix:description> + </clix:function> + + </clix:chapter> + <clix:chapter name="history" title="History"> Hunchentoot's predecessor <a href="http://weitz.de/tbnl/">TBNL</a> Modified: trunk/thirdparty/hunchentoot/test/script-engine.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/script-engine.lisp 2009-02-12 23:38:00 UTC (rev 4254) +++ trunk/thirdparty/hunchentoot/test/script-engine.lisp 2009-02-16 12:00:15 UTC (rev 4255) @@ -47,13 +47,21 @@ (defvar *script-context* nil "Current script context") -(defmacro with-script-context ((&rest args &key (context-class-name 'script-context) &allow-other-keys) &body body) +(defmacro with-script-context ((&rest args &key (context-class-name 'script-context) &allow-other-keys) + &body body) `(let ((*script-context* (make-instance ',context-class-name ,@args)) - (*default-pathname-defaults* *this-file*)) + (*default-pathname-defaults* *this-file*) + failed) (handler-bind ((assertion-failed (lambda (condition) + (push condition failed) (format t "Assertion failed:~%~A~%" condition)))) - (progn ,@body)))) + (prog1 + (progn ,@body + (values)) + (if failed + (format t ";; ~A assertion~:P FAILED~%" (length failed)) + (format t ";; all tests PASSED~%")))))) (defclass http-reply () ((body :initarg :body) Modified: trunk/thirdparty/hunchentoot/test/script.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/script.lisp 2009-02-12 23:38:00 UTC (rev 4254) +++ trunk/thirdparty/hunchentoot/test/script.lisp 2009-02-16 12:00:15 UTC (rev 4255) @@ -33,21 +33,30 @@ (with-open-file (f pathname) (princ-to-string (file-length f)))) +(defun say (fmt &rest args) + (format t "; ") + (apply #'format t fmt args) + (terpri)) + (defun test-hunchentoot (base-url &key (make-cookie-jar (lambda () (make-instance 'drakma:cookie-jar)))) + + "Run the built-in confidence test. The keyword arguments accepted + are for future extension and should not currently be used." + (with-script-context (:base-url (format nil "~A/hunchentoot/test/" base-url)) - (format t "Request home page~%") + (say "Request home page") (http-request "") (http-assert 'status-code 200) (http-assert-header :content-type "^text/html") - (format t "Test cookies~%") + (say "Test cookies") (let ((cookie-jar (funcall make-cookie-jar))) (http-request "cookie.html" :cookie-jar cookie-jar) (http-request "cookie.html" :cookie-jar cookie-jar) (http-assert-body "(?ms)COOKIE-IN "pumpkin".*"barking"")) - (format t "Test session variables~%") + (say "Test session variables") (let ((cookie-jar (funcall make-cookie-jar))) (http-request "session.html" :cookie-jar cookie-jar :method :post :parameters '(("new-foo-value" . "ABC") ("new-bar-value" . "DEF"))) @@ -56,26 +65,26 @@ (http-assert-body "\(HUNCHENTOOT-TEST::FOO . "ABC"\)") (http-assert-body "\(HUNCHENTOOT-TEST::BAR . "DEF"\)")) - (format t "Test GET parameters with foreign characters (Latin-1)~%") + (say "Test GET parameters with foreign characters (Latin-1)") (http-request "parameter_latin1_get.html?foo=H%FChner") (http-assert-header :content-type "text/html; charset=ISO-8859-1") (http-assert-body "(72 252 104 110 101 114)") (http-assert-body ""Hühner"") - (format t "Test POST parameters with foreign characters (Latin-1)~%") + (say "Test POST parameters with foreign characters (Latin-1)") (http-request "parameter_latin1_post.html" :method :post :parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252))))) (http-assert-header :content-type "text/html; charset=ISO-8859-1") (http-assert-body "(72 252 104 110 101 114)") (http-assert-body ""Hühner"") - (format t "Test GET parameters with foreign characters (UTF-8)~%") + (say "Test GET parameters with foreign characters (UTF-8)") (http-request "parameter_utf8_get.html?foo=H%C3%BChner") (http-assert-header :content-type "text/html; charset=UTF-8") (http-assert-body "(72 252 104 110 101 114)") (http-assert-body ""Hühner"") - (format t "Test POST parameters with foreign characters (UTF-8)~%") + (say "Test POST parameters with foreign characters (UTF-8)") (http-request "parameter_utf8_post.html" :method :post :external-format-out :utf-8 @@ -84,31 +93,31 @@ (http-assert-body "(72 252 104 110 101 114)") (http-assert-body ""Hühner"") - (format t "Test redirection~%") + (say "Test redirection") (http-request "redir.html") (http-assert 'uri (lambda (uri) (matches (princ-to-string uri) "info.html\\?redirected=1"))) - (format t "Test authorization~%") + (say "Test authorization") (http-request "authorization.html") (http-assert 'status-code 401) (http-request "authorization.html" :basic-authorization '("nanook" "igloo")) (http-assert 'status-code 200) - (format t "Request the Zappa image~%") + (say "Request the Zappa image") (http-request "image.jpg") (http-assert-header :content-length (file-length-string #P"fz.jpg")) (http-assert-header :content-type "image/jpeg") (http-assert 'body (complement #'mismatch) (file-contents #P"fz.jpg")) - (format t "Request the Zappa image from RAM~%") + (say "Request the Zappa image from RAM") (http-request "image-ram.jpg") (http-assert-header :content-length (file-length-string #P"fz.jpg")) (http-assert-header :content-type "image/jpeg") (http-assert 'body (complement #'mismatch) (file-contents #P"fz.jpg")) - (format t "Upload a file~%") + (say "Upload a file") (http-request "upload.html" :method :post :parameters '(("clean" . "doit"))) (http-request "upload.html"

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/acceptor.lisp
by BKNR Commits 12 Feb '09

12 Feb '09

Revision: 4254 Author: edi URL: http://bknr.net/trac/changeset/4254 Indentation U trunk/thirdparty/hunchentoot/acceptor.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 23:36:48 UTC (rev 4253) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 23:38:00 UTC (rev 4254) @@ -124,7 +124,7 @@ :request-class 'request :handler-selector 'list-handler-selector :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-taskmaster) - (t 'single-threaded-taskmaster))) + (t 'single-threaded-taskmaster))) :output-chunking-p t :input-chunking-p t :persistent-connections-p t

1 0