- bknr-cvs@lists.common-lisp.net - mailman3.common-lisp.net

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

12 Feb '09

Revision: 4245 Author: hans URL: http://bknr.net/trac/changeset/4245 Only try to set timeout if not NIL. Only try to rewrite when a session has been set up. U trunk/thirdparty/hunchentoot/headers.lisp U trunk/thirdparty/hunchentoot/set-timeouts.lisp Modified: trunk/thirdparty/hunchentoot/headers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/headers.lisp 2009-02-12 09:04:52 UTC (rev 4244) +++ trunk/thirdparty/hunchentoot/headers.lisp 2009-02-12 17:00:04 UTC (rev 4245) @@ -177,6 +177,7 @@ (write-sequence +crlf+ *hunchentoot-stream*) (maybe-write-to-header-stream first-line)) (when (and (stringp content) + (session *request*) (not content-modified-p) (starts-with-one-of-p (or (content-type) "") *content-types-for-url-rewrite*)) Modified: trunk/thirdparty/hunchentoot/set-timeouts.lisp =================================================================== --- trunk/thirdparty/hunchentoot/set-timeouts.lisp 2009-02-12 09:04:52 UTC (rev 4244) +++ trunk/thirdparty/hunchentoot/set-timeouts.lisp 2009-02-12 17:00:04 UTC (rev 4245) @@ -61,8 +61,9 @@ (setf (ccl:stream-output-timeout (usocket:socket usocket)) write-timeout)) #+:sbcl - (setf (sb-impl::fd-stream-timeout (usocket:socket-stream usocket)) - (coerce read-timeout 'single-float)) + (when read-timeout + (setf (sb-impl::fd-stream-timeout (usocket:socket-stream usocket)) + (coerce read-timeout 'single-float))) #+:cmu (setf (lisp::fd-stream-timeout (usocket:socket-stream usocket)) (coerce read-timeout 'integer))

1 0

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

12 Feb '09

Revision: 4244 Author: hans URL: http://bknr.net/trac/changeset/4244 Compilation fixes for non-Lispworks. Compiles, but does not run yet. A trunk/thirdparty/hunchentoot/compat.lisp U trunk/thirdparty/hunchentoot/hunchentoot.asd U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/util.lisp Added: trunk/thirdparty/hunchentoot/compat.lisp =================================================================== --- trunk/thirdparty/hunchentoot/compat.lisp (rev 0) +++ trunk/thirdparty/hunchentoot/compat.lisp 2009-02-12 09:04:52 UTC (rev 4244) @@ -0,0 +1,114 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/util.lisp,v 1.35 2008/04/08 14:39:18 edi Exp $ + +;;; Copyright (c) 2004-2009, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :hunchentoot) + +(defmacro when-let ((var form) &body body) + "Evaluates FORM and binds VAR to the result, then executes BODY +if VAR has a true value." + `(let ((,var ,form)) + (when ,var ,@body))) + +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + ,@body)) + +(defmacro with-rebinding (bindings &body body) + "Syntax: WITH-REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,,@temps) + ,,@body)))))) + +(defun get-peer-address-and-port (socket) + "Returns the peer address and port of the socket SOCKET as two +values. The address is returned as a string in dotted IP address +notation." + (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 +ignored." + (declare (ignore server)) + (usocket:socket-stream socket)) + +(defun make-lock (name) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + (bt:make-lock name)) + +(defmacro with-lock-held ((lock) &body body) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + `(bt:with-lock-held (,lock) ,@body)) \ No newline at end of file Modified: trunk/thirdparty/hunchentoot/hunchentoot.asd =================================================================== --- trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-11 23:54:40 UTC (rev 4243) +++ trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-12 09:04:52 UTC (rev 4244) @@ -63,6 +63,8 @@ (:file "packages") #+:lispworks (:file "lispworks") + #-:lispworks + (:file "compat") (:file "specials") (:file "conditions") (:file "mime-types") Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 23:54:40 UTC (rev 4243) +++ trunk/thirdparty/hunchentoot/session.lisp 2009-02-12 09:04:52 UTC (rev 4244) @@ -29,7 +29,7 @@ (in-package :hunchentoot) -(defgeneric session-db-lock (acceptor &key (whole-db-p t)) +(defgeneric session-db-lock (acceptor &key whole-db-p) (:documentation "A function which returns a lock that will be used to prevent concurrent access to sessions. The first argument will be the acceptor that handles the current request, the second argument is Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2009-02-11 23:54:40 UTC (rev 4243) +++ trunk/thirdparty/hunchentoot/util.lisp 2009-02-12 09:04:52 UTC (rev 4244) @@ -29,72 +29,7 @@ (in-package :hunchentoot) -#-:lispworks -(defmacro when-let ((var form) &body body) - "Evaluates FORM and binds VAR to the result, then executes BODY -if VAR has a true value." - `(let ((,var ,form)) - (when ,var ,@body))) -#-:lispworks -(defmacro with-unique-names ((&rest bindings) &body body) - "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* - -Executes a series of forms with each VAR bound to a fresh, -uninterned symbol. The uninterned symbol is as if returned by a call -to GENSYM with the string denoted by X - or, if X is not supplied, the -string denoted by VAR - as argument. - -The variable bindings created are lexical unless special declarations -are specified. The scopes of the name bindings and declarations do not -include the Xs. - -The forms are evaluated in order, and the values of all but the last -are discarded \(that is, the body is an implicit PROGN)." - ;; reference implementation posted to comp.lang.lisp as - ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also - ;; <http://www.cliki.net/Common%20Lisp%20Utilities> - `(let ,(mapcar #'(lambda (binding) - (check-type binding (or cons symbol)) - (if (consp binding) - (destructuring-bind (var x) binding - (check-type var symbol) - `(,var (gensym ,(etypecase x - (symbol (symbol-name x)) - (character (string x)) - (string x))))) - `(,binding (gensym ,(symbol-name binding))))) - bindings) - ,@body)) - -#-:lispworks -(defmacro with-rebinding (bindings &body body) - "Syntax: WITH-REBINDING ( { var | (var prefix) }* ) form* - -Evaluates a series of forms in the lexical environment that is -formed by adding the binding of each VAR to a fresh, uninterned -symbol, and the binding of that fresh, uninterned symbol to VAR's -original value, i.e., its value in the current lexical environment. - -The uninterned symbol is created as if by a call to GENSYM with the -string denoted by PREFIX - or, if PREFIX is not supplied, the string -denoted by VAR - as argument. - -The forms are evaluated in order, and the values of all but the last -are discarded \(that is, the body is an implicit PROGN)." - ;; reference implementation posted to comp.lang.lisp as - ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also - ;; <http://www.cliki.net/Common%20Lisp%20Utilities> - (loop for binding in bindings - for var = (if (consp binding) (car binding) binding) - for name = (gensym) - collect `(,name ,var) into renames - collect ``(,,var ,,name) into temps - finally (return `(let ,renames - (with-unique-names ,bindings - `(let (,,@temps) - ,,@body)))))) - (defun starts-with-p (seq subseq &key (test 'eql)) "Tests whether the sequence SEQ starts with the sequence SUBSEQ. Individual elements are compared with TEST." @@ -385,27 +320,3 @@ "Whether the current connection to the client is secure." (acceptor-ssl-p acceptor)) -#-:lispworks -(defun get-peer-address-and-port (socket) - "Returns the peer address and port of the socket SOCKET as two -values. The address is returned as a string in dotted IP address -notation." - (values (usocket:vector-quad-to-dotted-quad (usocket:get-peer-address socket)) - (usocket:get-peer-port socket))) - -#-:lispworks -(defun make-socket-stream (socket server) - "Returns a stream for the socket SOCKET. The SERVER argument is -ignored." - (declare (ignore server)) - (usocket:socket-stream socket)) - -#-:lispworks -(defun make-lock (name) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - (bt:make-lock name)) - -#-:lispworks -(defmacro with-lock-held ((lock) &body body) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - `(bt:with-lock-held (,lock) ,@body)) \ No newline at end of file

1 0

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

11 Feb '09

Revision: 4243 Author: edi URL: http://bknr.net/trac/changeset/4243 Integrate url-rewrite U trunk/thirdparty/hunchentoot/doc/index.xml U trunk/thirdparty/hunchentoot/hunchentoot.asd A trunk/thirdparty/hunchentoot/url-rewrite/ A trunk/thirdparty/hunchentoot/url-rewrite/packages.lisp A trunk/thirdparty/hunchentoot/url-rewrite/primitives.lisp A trunk/thirdparty/hunchentoot/url-rewrite/specials.lisp A trunk/thirdparty/hunchentoot/url-rewrite/url-rewrite.lisp A trunk/thirdparty/hunchentoot/url-rewrite/util.lisp Change set too large, please see URL above

1 0

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

11 Feb '09

Revision: 4242 Author: edi URL: http://bknr.net/trac/changeset/4242 More session changes U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/request.lisp U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/specials.lisp Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 23:10:20 UTC (rev 4241) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 23:42:18 UTC (rev 4242) @@ -179,6 +179,7 @@ "LOG-FILE" "LOG-MESSAGE" "MIME-TYPE" + "NEXT-SESSION-ID" "NO-CACHE" "PARAMETER" "POST-PARAMETER" @@ -199,6 +200,7 @@ "REMOVE-SESSION" "REPLY-EXTERNAL-FORMAT" "REQUEST" + "REQUEST-ACCEPTOR" "REQUEST-METHOD" "REQUEST-METHOD*" "REQUEST-URI" @@ -216,6 +218,7 @@ "SERVER-PROTOCOL*" "SESSION-COOKIE-NAME" "SESSION-COOKIE-VALUE" + "SESSION-CREATED" "SESSION-DB" "SESSION-DB-LOCK" "SESSION-GC" Modified: trunk/thirdparty/hunchentoot/request.lisp =================================================================== --- trunk/thirdparty/hunchentoot/request.lisp 2009-02-11 23:10:20 UTC (rev 4241) +++ trunk/thirdparty/hunchentoot/request.lisp 2009-02-11 23:42:18 UTC (rev 4242) @@ -30,7 +30,10 @@ (in-package :hunchentoot) (defclass request () - ((headers-in :initarg :headers-in + ((acceptor :initarg :acceptor + :documentation "The acceptor which created this request object." + :reader request-acceptor) + (headers-in :initarg :headers-in :documentation "An alist of the incoming headers." :reader headers-in) (method :initarg :method Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 23:10:20 UTC (rev 4241) +++ trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 23:42:18 UTC (rev 4242) @@ -69,21 +69,19 @@ (defmethod (setf session-db) (new-value (acceptor t)) (setq *session-db* new-value)) +(defgeneric next-session-id (acceptor) + (:documentation "Returns the next sequential session ID, an integer, +which should be unique per session. The default method uses a simple +global counter and isn't guarded by a lock. For a high-performance +production environment you might consider to use a more robust +method.")) + (let ((session-id-counter 0)) - (defun get-next-session-id () - "Returns the next sequential session id." + (defmethod next-session-id ((acceptor t)) (incf session-id-counter))) -(let ((global-session-usage-counter 0)) - (defun count-session-usage () - "Counts session usage globally and triggers session gc if necessary." - (when (and *session-gc-frequency* - (zerop (mod (incf global-session-usage-counter) - *session-gc-frequency*))) - (session-gc)))) - (defclass session () - ((session-id :initform (get-next-session-id) + ((session-id :initform (next-session-id (request-acceptor *request*)) :reader session-id :type integer :documentation "The unique ID \(an INTEGER) of the session.") @@ -118,12 +116,10 @@ session expires if it's not used.")) (:documentation "SESSION objects are automatically maintained by Hunchentoot. They should not be created explicitly with MAKE-INSTANCE -but implicitly with START-SESSION. Note that SESSION objects can only -be created when the special variable *REQUEST* is bound to a REQUEST -object.")) +but implicitly with START-SESSION.")) (defun encode-session-string (id user-agent remote-addr start) - "Create a uniquely encoded session string based on the values ID, + "Creates a uniquely encoded session string based on the values ID, USER-AGENT, REMOTE-ADDR, and START" ;; *SESSION-SECRET* is used twice due to known theoretical ;; vulnerabilities of MD5 encoding @@ -223,11 +219,24 @@ (defmethod session-cookie-name ((acceptor t)) "hunchentoot-session") +(defgeneric session-created (acceptor new-session) + (:documentation "This function is called whenever a new session has +been created. There's a default method which might trigger a session +GC based on the value of *SESSION-GC-FREQUENCY*.")) + +(let ((global-session-usage-counter 0)) + (defmethod session-created ((acceptor t) (session t)) + "Counts session usage globally and triggers session GC if +necessary." + (when (and *session-gc-frequency* + (zerop (mod (incf global-session-usage-counter) + *session-gc-frequency*))) + (session-gc)))) + (defun start-session () "Returns the current SESSION object. If there is no current session, creates one and updates the corresponding data structures. In this case the function will also send a session cookie to the browser." - (count-session-usage) (let ((session (session *request*))) (when session (return-from start-session session)) @@ -239,6 +248,7 @@ (set-cookie (session-cookie-name *acceptor*) :value (session-cookie-value session) :path "/") + (session-created *acceptor* session) (setq *session* session))) (defun remove-session (session) @@ -303,22 +313,22 @@ user-agent (real-remote-addr request) (session-start session)))) - ;; The session key presented by the client is valid. + ;; the session key presented by the client is valid (setf (slot-value session 'last-click) (get-universal-time)) session) (session - ;; The session ID pointed to an existing session, but the - ;; session string did not match the expected session - ;; string. Report to the log file, remove the session to - ;; make sure that it can't be used again. The original - ;; legitimate user will be required to log in again. + ;; the session ID pointed to an existing session, but the + ;; session string did not match the expected session string (log-message* :warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')" session-identifier user-agent remote-addr) + ;; remove the session to make sure that it can't be used + ;; again; the original legitimate user will be required to + ;; log in again (remove-session session) nil) (t - ;; No session was found under the ID given, presumably + ;; no session was found under the ID given, presumably ;; because it has expired. (log-message* :info "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')" Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 23:10:20 UTC (rev 4241) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 23:42:18 UTC (rev 4242) @@ -165,8 +165,8 @@ (defvar *session-gc-frequency* 50 "A session GC \(see function SESSION-GC) will happen every -*SESSION-GC-FREQUENCY* requests \(counting only requests which -use a session) if this variable is not NIL.") +*SESSION-GC-FREQUENCY* requests \(counting only requests which create +a new session) if this variable is not NIL. See SESSION-CREATED.") (defvar *use-user-agent-for-sessions* t "Whether the 'User-Agent' header should be encoded into the session

1 0

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

11 Feb '09

Revision: 4241 Author: edi URL: http://bknr.net/trac/changeset/4241 Checkpoint session changes U trunk/thirdparty/hunchentoot/misc.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/specials.lisp U trunk/thirdparty/hunchentoot/test/test-handlers.lisp Modified: trunk/thirdparty/hunchentoot/misc.lisp =================================================================== --- trunk/thirdparty/hunchentoot/misc.lisp 2009-02-11 21:44:43 UTC (rev 4240) +++ trunk/thirdparty/hunchentoot/misc.lisp 2009-02-11 23:10:20 UTC (rev 4241) @@ -51,8 +51,8 @@ #\= (:greedy-repetition 0 nil (:inverted-char-class #\&)) #\&)))))) - (defun add-cookie-value-to-url (url &key (cookie-name *session-cookie-name*) - (value (session-cookie-value)) + (defun add-cookie-value-to-url (url &key (cookie-name (session-cookie-name *acceptor*)) + (value (session-cookie-value (session *request*))) (replace-ampersands-p t)) "Removes all GET parameters named COOKIE-NAME from URL and then adds a new GET parameter with the name COOKIE-NAME and the value @@ -72,8 +72,8 @@ (setq url (regex-replace-all "&" url "&"))) url)) -(defun maybe-rewrite-urls-for-session (html &key (cookie-name *session-cookie-name*) - (value (session-cookie-value))) +(defun maybe-rewrite-urls-for-session (html &key (cookie-name (session-cookie-name *acceptor*)) + (value (session-cookie-value (session *request*)))) "Rewrites the HTML page HTML such that the name/value pair COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is @@ -220,7 +220,7 @@ (protocol (if (ssl-p) :https :http)) (add-session-id (not (or host-provided-p (starts-with-scheme-p target) - (cookie-in *session-cookie-name*)))) + (cookie-in (session-cookie-name *acceptor*))))) (code +http-moved-temporarily+)) "Redirects the browser to TARGET which should be a string. If TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 21:44:43 UTC (rev 4240) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 23:10:20 UTC (rev 4241) @@ -64,7 +64,6 @@ "*REQUEST*" "*REWRITE-FOR-SESSION-URLS*" "*SESSION*" - "*SESSION-COOKIE-NAME*" "*SESSION-GC-FREQUENCY*" "*SESSION-MAX-TIME*" "*SESSION-REMOVAL-HOOK*" @@ -157,7 +156,6 @@ "DELETE-SESSION-VALUE" "DISPATCH-EASY-HANDLERS" "DISPATCH-REQUEST" - "DO-SESSIONS" "ESCAPE-FOR-HTML" "EXECUTE-ACCEPTOR" "GET-PARAMETER" @@ -216,14 +214,17 @@ "SEND-HEADERS" "SERVER-PROTOCOL" "SERVER-PROTOCOL*" + "SESSION-COOKIE-NAME" "SESSION-COOKIE-VALUE" - "SESSION-COUNTER" + "SESSION-DB" + "SESSION-DB-LOCK" "SESSION-GC" "SESSION-MAX-TIME" "SESSION-REMOTE-ADDR" "SESSION-TOO-OLD-P" "SESSION-USER-AGENT" "SESSION-VALUE" + "SESSION-VERIFY" "SET-COOKIE" "SET-COOKIE*" "SHUTDOWN" Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 21:44:43 UTC (rev 4240) +++ trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 23:10:20 UTC (rev 4241) @@ -29,10 +29,46 @@ (in-package :hunchentoot) -(defvar *session-data-lock* (make-lock "session-data-lock") - "A lock to prevent two threads from modifying *SESSION-DATA* at the -same time.") +(defgeneric session-db-lock (acceptor &key (whole-db-p t)) + (:documentation "A function which returns a lock that will be used +to prevent concurrent access to sessions. The first argument will be +the acceptor that handles the current request, the second argument is +true if the whole \(current) session database is modified. If it is +NIL, only one existing session in the database is modified. +This function can return NIL which means that sessions or session +databases will be modified without a lock held. The default is to +always return a global lock for Lisps that support threads and NIL +otherwise.")) + +(defmethod session-db-lock ((acceptor t) &key (whole-db-p t)) + (declare (ignore whole-db-p)) + *global-session-db-lock*) + +(defmacro with-session-lock-held ((lock) &body body) + "This is like WITH-LOCK-HELD except that it will accept NIL as a +\"lock\" and just execute BODY in this case." + (with-unique-names (thunk) + (with-rebinding (lock) + `(flet ((,thunk () ,@body)) + (cond (,lock (with-lock-held (,lock) (,thunk))) + (t (,thunk))))))) + +(defgeneric session-db (acceptor) + (:documentation "Returns the current session database which is an +alist where each car is a session's ID and the cdr is the +corresponding SESSION object itself. The default is to use a global +list for all acceptors.")) + +(defmethod session-db ((acceptor t)) + *session-db*) + +(defgeneric (setf session-db) (new-value acceptor) + (:documentation "Modifies the current session database. See SESSION-DB.")) + +(defmethod (setf session-db) (new-value (acceptor t)) + (setq *session-db* new-value)) + (let ((session-id-counter 0)) (defun get-next-session-id () "Returns the next sequential session id." @@ -46,7 +82,6 @@ *session-gc-frequency*))) (session-gc)))) - (defclass session () ((session-id :initform (get-next-session-id) :reader session-id @@ -75,21 +110,17 @@ :reader session-data :documentation "Data associated with this session - see SESSION-VALUE.") - (session-counter :initform 0 - :reader session-counter - :documentation "The number of times this session -has been used.") (max-time :initarg :max-time :initform *session-max-time* :accessor session-max-time :type fixnum :documentation "The time \(in seconds) after which this session expires if it's not used.")) - (:documentation "SESSION objects are automatically maintained -by Hunchentoot. They should not be created explicitly with -MAKE-INSTANCE but implicitly with START-SESSION. Note that -SESSION objects can only be created when the special variable -*REQUEST* is bound to a REQUEST object.")) + (:documentation "SESSION objects are automatically maintained by +Hunchentoot. They should not be created explicitly with MAKE-INSTANCE +but implicitly with START-SESSION. Note that SESSION objects can only +be created when the special variable *REQUEST* is bound to a REQUEST +object.")) (defun encode-session-string (id user-agent remote-addr start) "Create a uniquely encoded session string based on the values ID, @@ -121,16 +152,16 @@ (setf (slot-value session 'session-string) (stringify-session session))) (defun session-gc () - "Removes sessions from *session-data* which are too old - see -SESSION-TOO-OLD-P." - (with-lock-held (*session-data-lock*) - (setq *session-data* - (loop for id-session-pair in *session-data* - for (nil . session) = id-session-pair - when (session-too-old-p session) - do (funcall *session-removal-hook* session) - else - collect id-session-pair))) + "Removes sessions from the current session database which are too +old - see SESSION-TOO-OLD-P." + (with-session-lock-held ((session-db-lock *acceptor*)) + (setf (session-db *acceptor*) + (loop for id-session-pair in (session-db *acceptor*) + for (nil . session) = id-session-pair + when (session-too-old-p session) + do (funcall *session-removal-hook* session) + else + collect id-session-pair))) (values)) (defun session-value (symbol &optional (session *session*)) @@ -149,7 +180,7 @@ (with-rebinding (symbol) (with-unique-names (place %session) `(let ((,%session (or ,session (start-session)))) - (with-lock-held (*session-data-lock*) + (with-session-lock-held ((session-db-lock *acceptor* :whole-db-p nil)) (let* ((,place (assoc ,symbol (session-data ,%session) :test #'eq))) (cond (,place @@ -168,17 +199,30 @@ :key #'car :test #'eq))) (values)) -(defun session-cookie-value (&optional (session (session *request*))) - "Returns a string which can be used to safely restore the -session if as session has already been established. This is used -as the value stored in the session cookie or in the corresponding -GET parameter." +(defgeneric session-cookie-value (session) + (:documentation "Returns a string which can be used to safely +restore the session SESSION if as session has already been +established. This is used as the value stored in the session cookie +or in the corresponding GET parameter. A default method is provided +and there's no reason to change it unless you want to use your own +session objects.")) + +(defmethod session-cookie-value ((session session)) (and session (format nil "~A:~A" (session-id session) (session-string session)))) +(defgeneric session-cookie-name (acceptor) + (:documentation "Returns the name \(a string) of the cookie \(or the +GET parameter) which is used to store a session on the client side. +The default is to use the string \"hunchentoot-session\", but you can +specialize this function if you want another name.")) + +(defmethod session-cookie-name ((acceptor t)) + "hunchentoot-session") + (defun start-session () "Returns the current SESSION object. If there is no current session, creates one and updates the corresponding data structures. In this @@ -189,9 +233,10 @@ (return-from start-session session)) (setf session (make-instance 'session) (session *request*) session) - (with-lock-held (*session-data-lock*) - (setq *session-data* (acons (session-id session) session *session-data*))) - (set-cookie *session-cookie-name* + (with-session-lock-held ((session-db-lock *acceptor*)) + (setf (session-db *acceptor*) + (acons (session-id session) session (session-db *acceptor*)))) + (set-cookie (session-cookie-name *acceptor*) :value (session-cookie-value session) :path "/") (setq *session* session))) @@ -199,11 +244,11 @@ (defun remove-session (session) "Completely removes the SESSION object SESSION from Hunchentoot's internal session database." - (with-lock-held (*session-data-lock*) + (with-session-lock-held ((session-db-lock *acceptor*)) (funcall *session-removal-hook* session) - (setq *session-data* - (delete (session-id session) *session-data* - :key #'car :test #'=))) + (setf (session-db *acceptor*) + (delete (session-id session) (session-db *acceptor*) + :key #'car :test #'=))) (values)) (defun session-too-old-p (session) @@ -217,7 +262,7 @@ session has not expired. Will remove the session if it has expired but will not create a new one." (let ((session - (cdr (assoc id *session-data* :test #'=)))) + (cdr (assoc id (session-db *acceptor*) :test #'=)))) (when (and session (session-too-old-p session)) (when *reply* @@ -226,14 +271,19 @@ (setq session nil)) session)) -(defun session-verify (request) - "Tries to get a session identifier from the cookies \(or -alternatively from the GET parameters) sent by the client. This +(defgeneric session-verify (request) + (:documentation "Tries to get a session identifier from the cookies +\(or alternatively from the GET parameters) sent by the client. This identifier is then checked for validity against the REQUEST object -REQUEST. On success the corresponding session object \(if not too old) -is returned \(and updated). Otherwise NIL is returned." - (let ((session-identifier (or (cookie-in *session-cookie-name* request) - (get-parameter *session-cookie-name* request)))) +REQUEST. On success the corresponding session object \(if not too +old) is returned \(and updated). Otherwise NIL is returned. + +A default method is provided and you only need to write your own one +if you want to maintain your own sessions.")) + +(defmethod session-verify ((request request)) + (let ((session-identifier (or (cookie-in (session-cookie-name *acceptor*) request) + (get-parameter (session-cookie-name *acceptor*) request)))) (unless (and session-identifier (stringp session-identifier) (plusp (length session-identifier))) @@ -245,36 +295,35 @@ (user-agent (user-agent request)) (remote-addr (remote-addr request))) (cond - ((and session - (string= session-string - (session-string session)) - (string= session-string - (encode-session-string id - user-agent - (real-remote-addr request) - (session-start session)))) - ;; The session key presented by the client is valid. - (incf (slot-value session 'session-counter)) - (setf (slot-value session 'last-click) (get-universal-time)) - session) - (session - ;; The session ID pointed to an existing session, but the - ;; session string did not match the expected session - ;; string. Report to the log file, remove the session to - ;; make sure that it can't be used again. The original - ;; legitimate user will be required to log in again. - (log-message* :warning - "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')" - session-identifier user-agent remote-addr) - (remove-session session) - nil) - (t - ;; No session was found under the ID given, presumably - ;; because it has expired. - (log-message* :info - "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')" - session-identifier user-agent remote-addr) - nil)))))) + ((and session + (string= session-string + (session-string session)) + (string= session-string + (encode-session-string id + user-agent + (real-remote-addr request) + (session-start session)))) + ;; The session key presented by the client is valid. + (setf (slot-value session 'last-click) (get-universal-time)) + session) + (session + ;; The session ID pointed to an existing session, but the + ;; session string did not match the expected session + ;; string. Report to the log file, remove the session to + ;; make sure that it can't be used again. The original + ;; legitimate user will be required to log in again. + (log-message* :warning + "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')" + session-identifier user-agent remote-addr) + (remove-session session) + nil) + (t + ;; No session was found under the ID given, presumably + ;; because it has expired. + (log-message* :info + "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')" + session-identifier user-agent remote-addr) + nil)))))) (defun reset-session-secret () "Sets *SESSION-SECRET* to a new random value. All old sessions will @@ -283,18 +332,8 @@ (defun reset-sessions () "Removes ALL stored sessions." - (with-lock-held (*session-data-lock*) - (loop for (nil . session) in *session-data* + (with-session-lock-held ((session-db-lock *acceptor*)) + (loop for (nil . session) in (session-db *acceptor*) do (funcall *session-removal-hook* session)) - (setq *session-data* nil)) - (values)) - -(defmacro do-sessions ((var &optional result-form) &body body) - "Executes BODY with VAR bound to each existing SESSION object -consecutively. Returns the values returned by RESULT-FORM unless -RETURN is executed. The scope of the binding of VAR does not include -RESULT-FORM." - (let ((=temp= (gensym))) - `(dolist (,=temp= *session-data* ,result-form) - (let ((,var (cdr ,=temp=))) - ,@body)))) \ No newline at end of file + (setq *session-db* nil)) + (values)) \ No newline at end of file Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 21:44:43 UTC (rev 4240) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 23:10:20 UTC (rev 4241) @@ -120,10 +120,6 @@ "The three-character names of the twelve months - needed for cookie date format.") -(defvar *session-cookie-name* "hunchentoot-session" - "The name of the cookie \(or the GET parameter) which is used to -store the session on the client side.") - (defvar *rewrite-for-session-urls* t "Whether HTML pages should possibly be rewritten for cookie-less session-management.") @@ -161,10 +157,8 @@ the uploaded file is written. The hook is called directly before the file is created.") -(defvar *session-data* nil - "All sessions of all users currently using Hunchentoot. An -alist where the car is the session's ID and the cdr is the -SESSION object itself.") +(defvar *session-db* nil + "The default \(global) session database.") (defvar *session-max-time* #.(* 30 60) "The default time \(in seconds) after which a session times out.") @@ -313,6 +307,11 @@ #+:lispworks t #-:lispworks bt:*supports-threads-p*) +(defvar *global-session-db-lock* + (load-time-value (and *supports-threads-p* (make-lock "global-session-db-lock"))) + "A global lock to prevent two threads from modifying *session-db* at +the same time \(or NIL for Lisps which don't have threads).") + (defconstant +new-connection-wait-time+ 2 "Time in seconds to wait for a new connection to arrive before performing a cleanup run.") Modified: trunk/thirdparty/hunchentoot/test/test-handlers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-11 21:44:43 UTC (rev 4240) +++ trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-11 23:10:20 UTC (rev 4241) @@ -198,8 +198,8 @@ (:input :type :text :name "new-bar-value" :value (or (session-value 'bar) "")))) - (info-table *session-cookie-name* - (cookie-in *session-cookie-name*) + (info-table (session-cookie-name *acceptor*) + (cookie-in (session-cookie-name *acceptor*)) (mapcar #'car (cookies-in*)) (session-value 'foo) (session-value 'bar))))))

1 0

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

11 Feb '09

Revision: 4240 Author: edi URL: http://bknr.net/trac/changeset/4240 Take care of session secret U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/specials.lisp U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-11 21:19:33 UTC (rev 4239) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-11 21:44:43 UTC (rev 4240) @@ -182,6 +182,11 @@ ;; general implementation +(defmethod start :before ((acceptor acceptor)) + (unless (boundp '*session-secret*) + (hunchentoot-warn "Session secret is unbound. Using Lisp's RANDOM function to initialize it.") + (reset-session-secret))) + (defmethod start ((acceptor acceptor)) (start-listening acceptor) (let ((connection-dispatcher (acceptor-connection-dispatcher acceptor))) Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 21:19:33 UTC (rev 4239) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 21:44:43 UTC (rev 4240) @@ -38,7 +38,8 @@ (:import-from :hunchentoot-asd :*hunchentoot-version*) #+:lispworks (:import-from :lw "WITH-UNIQUE-NAMES" "WHEN-LET") - (:export "*APPROVED-RETURN-CODES*" + (:export "*ACCEPTOR*" + "*APPROVED-RETURN-CODES*" #+:lispworks "*CLEANUP-FUNCTION*" #+:lispworks @@ -62,12 +63,12 @@ "*REPLY*" "*REQUEST*" "*REWRITE-FOR-SESSION-URLS*" - "*ACCEPTOR*" "*SESSION*" "*SESSION-COOKIE-NAME*" "*SESSION-GC-FREQUENCY*" "*SESSION-MAX-TIME*" "*SESSION-REMOVAL-HOOK*" + "*SESSION-SECRET*" "*SHOW-LISP-ERRORS-P*" "*TMP-DIRECTORY*" "*USE-REMOTE-ADDR-FOR-SESSIONS*" @@ -207,6 +208,7 @@ "REQUIRE-AUTHORIZATION" "RESET-CONNECTION-STREAM" "RESET-SESSIONS" + "RESET-SESSION-SECRET" "RETURN-CODE" "RFC-1123-DATE" "SCRIPT-NAME" Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 21:19:33 UTC (rev 4239) +++ trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 21:44:43 UTC (rev 4240) @@ -276,9 +276,13 @@ session-identifier user-agent remote-addr) nil)))))) +(defun reset-session-secret () + "Sets *SESSION-SECRET* to a new random value. All old sessions will +cease to be valid." + (setq *session-secret* (create-random-string 10 36))) + (defun reset-sessions () - "Removes ALL stored sessions and creates a new session secret." - (reset-session-secret) + "Removes ALL stored sessions." (with-lock-held (*session-data-lock*) (loop for (nil . session) in *session-data* do (funcall *session-removal-hook* session)) Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 21:19:33 UTC (rev 4239) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 21:44:43 UTC (rev 4240) @@ -137,7 +137,11 @@ "A fresh random state.") (defvar-unbound *session-secret* - "A random value that's used to encode the public session data.") + "A random ASCII string that's used to encode the public session +data. This variable is initially unbound and will be set \(using +RESET-SESSION-SECRET) by the first acceptor which is started. You can +prevent this from happening if you set the value yourself before +starting acceptors.") (defvar-unbound *hunchentoot-stream* "The stream representing the socket Hunchentoot is listening on.") Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2009-02-11 21:19:33 UTC (rev 4239) +++ trunk/thirdparty/hunchentoot/util.lisp 2009-02-11 21:44:43 UTC (rev 4240) @@ -120,11 +120,6 @@ (format s "~VR" base (random base *the-random-state*))))) -(defun reset-session-secret () - "Sets *SESSION-SECRET* to a new random value. All old sessions will -cease to be valid." - (setq *session-secret* (create-random-string 10 36))) - (defun reason-phrase (return-code) "Returns a reason phrase for the HTTP return code RETURN-CODE \(which should be an integer) or NIL for return codes Hunchentoot

1 0

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

11 Feb '09

Revision: 4239 Author: edi URL: http://bknr.net/trac/changeset/4239 Some fixes U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/lispworks.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/specials.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-10 19:56:25 UTC (rev 4238) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-11 21:19:33 UTC (rev 4239) @@ -40,7 +40,7 @@ :accessor acceptor-name :documentation "The optional name of the acceptor, a symbol.") (request-class :initarg :request-class - :reader acceptor-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.") @@ -54,10 +54,10 @@ responsible for listening to new connections and scheduling them for execution.") (output-chunking-p :initarg :output-chunking-p - :reader acceptor-output-chunking-p + :accessor acceptor-output-chunking-p :documentation "Whether the acceptor may use output chunking.") (input-chunking-p :initarg :input-chunking-p - :reader acceptor-input-chunking-p + :accessor acceptor-input-chunking-p :documentation "Whether the acceptor may use input chunking.") (persistent-connections-p :initarg :persistent-connections-p :accessor acceptor-persistent-connections-p @@ -68,17 +68,17 @@ 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 + :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.") +implementation of socket timeouts. NIL 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.") + :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.") #+:lispworks (process :accessor acceptor-process :documentation "The Lisp process which accepts incoming @@ -116,9 +116,13 @@ :name (gensym) :request-class 'request :request-dispatcher 'dispatch-request - :connection-dispatcher (make-instance 'one-thread-per-connection-dispatcher) + :connection-dispatcher (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-dispatcher) + (t 'single-threaded-connection-dispatcher))) :output-chunking-p t :input-chunking-p t + :persistent-connections-p t + :read-timeout nil + :write-timeout nil :access-logger 'log-access :message-logger 'log-message) (:documentation "An object of this class contains all relevant @@ -131,7 +135,7 @@ (defgeneric start (acceptor) (:documentation "Starts the ACCEPTOR so that it begins accepting -connections.")) +connections. Returns the acceptor.")) (defgeneric stop (acceptor) (:documentation "Stops the ACCEPTOR so that it no longer accepts @@ -141,7 +145,7 @@ (: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 +return errors resulting from the listening operation \(like 'address in use' or similar).")) (defgeneric accept-connections (acceptor) @@ -182,7 +186,8 @@ (start-listening acceptor) (let ((connection-dispatcher (acceptor-connection-dispatcher acceptor))) (setf (acceptor connection-dispatcher) acceptor) - (execute-acceptor connection-dispatcher))) + (execute-acceptor connection-dispatcher)) + acceptor) (defmethod stop ((acceptor acceptor)) (setf (acceptor-shutdown-p acceptor) t) @@ -191,8 +196,8 @@ (usocket:socket-close (acceptor-listen-socket acceptor))) (defmethod initialize-connection-stream (acceptor stream) + (declare (ignore acceptor)) ;; default method does nothing - (declare (ignore acceptor)) stream) (defmethod reset-connection-stream (acceptor stream) Modified: trunk/thirdparty/hunchentoot/lispworks.lisp =================================================================== --- trunk/thirdparty/hunchentoot/lispworks.lisp 2009-02-10 19:56:25 UTC (rev 4238) +++ trunk/thirdparty/hunchentoot/lispworks.lisp 2009-02-11 21:19:33 UTC (rev 4239) @@ -62,8 +62,7 @@ "The function which is called if *CLEANUP-INTERVAL* is not NIL.") (defvar *worker-counter* 0 - "Internal counter used to generate meaningful names for worker -threads.") + "Internal counter used to count worker threads.") (defun cleanup-function () "The default for *CLEANUP-FUNCTION*. Invokes a GC on 32-bit Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-10 19:56:25 UTC (rev 4238) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 21:19:33 UTC (rev 4239) @@ -115,6 +115,19 @@ "+HTTP-USE-PROXY+" "+HTTP-VERSION-NOT-SUPPORTED+" "ACCEPTOR" + "ACCEPTOR-ACCESS-LOGGER" + "ACCEPTOR-ADDRESS" + "ACCEPTOR-INPUT-CHUNKING-P" + "ACCEPTOR-MESSAGE-LOGGER" + "ACCEPTOR-NAME" + "ACCEPTOR-OUTPUT-CHUNKING-P" + "ACCEPTOR-PERSISTENT-CONNECTIONS-P" + "ACCEPTOR-PORT" + "ACCEPTOR-READ-TIMEOUT" + "ACCEPTOR-REQUEST-CLASS" + "ACCEPTOR-REQUEST-DISPATCHER" + "ACCEPTOR-SSL-P" + "ACCEPTOR-WRITE-TIMEOUT" "ACCESS-LOG-FILE" "AUTHORIZATION" "AUX-REQUEST-VALUE" @@ -166,7 +179,6 @@ "INITIALIZE-CONNECTION-STREAM" "LOG-FILE" "LOG-MESSAGE" - "MAYBE-INVOKE-DEBUGGER" "MIME-TYPE" "NO-CACHE" "PARAMETER" @@ -200,11 +212,6 @@ "SCRIPT-NAME" "SCRIPT-NAME*" "SEND-HEADERS" - "ACCEPTOR-ADDRESS" - "ACCEPTOR-REQUEST-DISPATCHER" - "ACCEPTOR-NAME" - "ACCEPTOR-PORT" - "ACCEPTOR-SSL-P" "SERVER-PROTOCOL" "SERVER-PROTOCOL*" "SESSION-COOKIE-VALUE" Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-10 19:56:25 UTC (rev 4238) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 21:19:33 UTC (rev 4239) @@ -289,10 +289,6 @@ "During the execution of dispatchers and handlers this variable is bound to the SERVER object which processes the request.") -(defvar *worker-counter* 0 - "Internal counter used to generate meaningful names for worker -threads.") - (defvar *default-connection-timeout* 20 "The default connection timeout used when a Hunchentoot server is reading from and writing to a socket stream.")

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/test/test-handlers.lisp
by BKNR Commits 10 Feb '09

10 Feb '09

Revision: 4238 Author: edi URL: http://bknr.net/trac/changeset/4238 Re-apply changes that were overwritten U trunk/thirdparty/hunchentoot/test/test-handlers.lisp Modified: trunk/thirdparty/hunchentoot/test/test-handlers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-10 17:35:21 UTC (rev 4237) +++ trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-10 19:56:25 UTC (rev 4238) @@ -118,8 +118,8 @@ (fmt "~[~;once~;twice~:;~:*~R times~]" (incf count))) " since its handler was compiled.") (info-table (host) - (server-address *server*) - (server-port) + (acceptor-address *acceptor*) + (acceptor-port *acceptor*) (remote-addr*) (remote-port*) (real-remote-addr) @@ -513,14 +513,10 @@ "Forbidden \(403) page"))) (:tr (:td (:a :href "/hunchentoot/test/oops.html" "Error handling") - " \(output depends on settings like " + " \(output depends on " (:a :href "http://weitz.de/hunchentoot/#*show-lisp-errors-p*" (:code "*SHOW-LISP-ERRORS-P*")) - (fmt " \(currently ~S) and " *show-lisp-errors-p*) - (:a :href "http://weitz.de/hunchentoot/#*show-lisp-backtraces-p*" - (:code "*SHOW-LISP-BACKTRACES-P*")) - (fmt " \(currently ~S)" *show-lisp-backtraces-p*) - ")")) + (fmt " \(currently ~S))" *show-lisp-errors-p*))) (:tr (:td (:a :href "/hunchentoot/foo" "URI handled by") " "

1 0

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

10 Feb '09

Revision: 4237 Author: edi URL: http://bknr.net/trac/changeset/4237 Replace literal characters with portable code U trunk/thirdparty/hunchentoot/test/script.lisp Modified: trunk/thirdparty/hunchentoot/test/script.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/script.lisp 2009-02-10 16:37:27 UTC (rev 4236) +++ trunk/thirdparty/hunchentoot/test/script.lisp 2009-02-10 17:35:21 UTC (rev 4237) @@ -64,7 +64,7 @@ (format t "Test POST parameters with foreign characters (Latin-1)~%") (http-request "parameter_latin1_post.html" - :method :post :parameters (list (cons "foo" (format nil "H~Chner" #\Latin_Small_Letter_U_With_Diaeresis)))) + :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"") @@ -79,7 +79,7 @@ (http-request "parameter_utf8_post.html" :method :post :external-format-out :utf-8 - :parameters (list (cons "foo" (format nil "H~Chner" #\Latin_Small_Letter_U_With_Diaeresis)))) + :parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252))))) (http-assert-header :content-type "text/html; charset=UTF-8") (http-assert-body "(72 252 104 110 101 114)") (http-assert-body ""Hühner"")

1 0

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

10 Feb '09

Revision: 4236 Author: edi URL: http://bknr.net/trac/changeset/4236 More name fixes U trunk/thirdparty/hunchentoot/ssl.lisp Modified: trunk/thirdparty/hunchentoot/ssl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-10 16:36:06 UTC (rev 4235) +++ trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-10 16:37:27 UTC (rev 4236) @@ -60,7 +60,7 @@ args)) #+lispworks -(defun make-ssl-acceptor-stream (socket-stream &key certificate-file privatekey-file privatekey-password) +(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 stream using the certificate file CERTIFICATE-FILE and the private key file PRIVATEKEY-FILE. Both of these values must be namestrings @@ -88,11 +88,11 @@ ;; attach SSL to the stream if necessary (call-next-method acceptor #+:lispworks - (make-ssl-acceptor-stream stream + (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)) #-:lispworks - (cl+ssl:make-ssl-acceptor-stream stream + (cl+ssl:make-ssl-server-stream stream :certificate (acceptor-ssl-certificate-file acceptor) :key (acceptor-ssl-privatekey-file acceptor)))) \ No newline at end of file

1 0