diff --git a/ChangeLog b/ChangeLog index ed1dd02b..79783149 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2004-01-09 John Foderaro +1.2.35 + * publish.cl, main.cl, test/t-aserve.cl: add a slot to + all entities holding + the extra headers to add to the response. Add a :headers + argument to all publish functions that allows one + to store a value in the new headers slot. + 2003-12-23 John Foderaro 1.2.34 * fix typo in exports wserver-io-timeout diff --git a/main.cl b/main.cl index 54ea4b4d..122bc5e4 100644 --- a/main.cl +++ b/main.cl @@ -23,7 +23,7 @@ ;; Suite 330, Boston, MA 02111-1307 USA ;; ;; -;; $Id: main.cl,v 1.155 2003/12/23 17:53:35 jkf Exp $ +;; $Id: main.cl,v 1.156 2004/01/09 18:36:46 jkf Exp $ ;; Description: ;; aserve's main loop @@ -37,7 +37,7 @@ (in-package :net.aserve) -(defparameter *aserve-version* '(1 2 34)) +(defparameter *aserve-version* '(1 2 35)) (eval-when (eval load) (require :sock) @@ -494,6 +494,8 @@ Problems with protocol may occur." (ef-name ef))))) (declare (ignore-if-unused ,g-req ,g-ent ,g-external-format)) ,(if* body then `(compute-response-stream ,g-req ,g-ent)) + (if* (entity-headers ,g-ent) + then (bulk-set-reply-headers ,g-req (entity-headers ,g-ent))) (if* ,g-headers then (bulk-set-reply-headers ,g-req ,g-headers)) (send-response-headers ,g-req ,g-ent :pre) diff --git a/publish.cl b/publish.cl index be2987a6..e7ac6664 100644 --- a/publish.cl +++ b/publish.cl @@ -23,7 +23,7 @@ ;; Suite 330, Boston, MA 02111-1307 USA ;; ;; -;; $Id: publish.cl,v 1.76 2003/10/31 16:21:37 jkf Exp $ +;; $Id: publish.cl,v 1.77 2004/01/09 18:36:46 jkf Exp $ ;; Description: ;; publishing urls @@ -95,6 +95,11 @@ :initform nil :accessor entity-hook) + ; cons holding extra headers to send with this entity + (headers :initarg :headers + :initform nil + :accessor entity-headers) + ; extra holds random info we need for a particular entity (extra :initarg :extra :reader entity-extra) )) @@ -514,6 +519,7 @@ timeout plist hook + headers ) ;; publish the given url ;; if file is given then it specifies a file to return @@ -543,6 +549,7 @@ :plist plist :timeout timeout :hook hook + :headers headers ))) (publish-entity ent locator path hval))))) @@ -555,6 +562,7 @@ authorizer timeout plist + headers ) ;; publish a handler for all urls with a certain prefix ;; @@ -582,7 +590,9 @@ :content-type content-type :authorizer authorizer :plist plist - :timeout timeout))) + :timeout timeout + :headers headers + ))) (publish-prefix-entity ent prefix locator hval host-p nil) ent)))) @@ -601,6 +611,7 @@ (timeout #+io-timeout #.(* 100 24 60 60) #-io-timeout nil) hook + headers ) ;; return the given file as the value of the url @@ -654,6 +665,7 @@ :timeout timeout :plist plist :hook hook + :headers headers )))) else (setq ent (make-instance (or class 'file-entity) :host hval @@ -666,6 +678,7 @@ :timeout timeout :plist plist :hook hook + :headers headers ))) (publish-entity ent locator path hval))) @@ -692,6 +705,7 @@ access-file plist hook + headers ) ;; make a whole directory available @@ -722,6 +736,7 @@ :access-file access-file :plist plist :hook hook + :headers headers ))) (publish-prefix-entity ent prefix locator host host-p nil) @@ -812,7 +827,8 @@ authorizer timeout plist - hook) + hook + headers) (if* (null locator) then (setq locator (find-locator :exact server))) @@ -868,6 +884,7 @@ :authorizer authorizer :timeout timeout :hook hook + :headers headers ))) (publish-entity ent locator path hval))) @@ -1517,6 +1534,7 @@ :timeout (entity-timeout ent) :plist (list :parent ent) ; who spawned us :hook (entity-hook ent) + :headers (entity-headers ent) ))) diff --git a/test/t-aserve.cl b/test/t-aserve.cl index 711415a4..cbfb4031 100644 --- a/test/t-aserve.cl +++ b/test/t-aserve.cl @@ -22,7 +22,7 @@ ;; Suite 330, Boston, MA 02111-1307 USA ;; ;; -;; $Id: t-aserve.cl,v 1.49 2003/09/10 16:54:14 layer Exp $ +;; $Id: t-aserve.cl,v 1.50 2004/01/09 18:36:46 jkf Exp $ ;; Description: ;; test iserve @@ -238,6 +238,7 @@ (declare (ignore req ent extra)) (setq got-reps (or got-reps 0)) (incf got-reps)) + :headers '((:testhead . "testval")) ))) (test nil (net.aserve::contents ent)) ; nothing cached yet @@ -255,6 +256,11 @@ (test (format nil "text/plain") (cdr (assoc :content-type headers :test #'eq)) :test #'equal) + + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal) + #+ignore (if* (eq protocol :http/1.1) then (test "chunked" (cdr (assoc :transfer-encoding headers @@ -281,7 +287,9 @@ ;; (publish-file :path "/frob2" :file dummy-2-name :content-type "text/plain" - :preload t) + :preload t + :headers '((:testhead . "testval")) + ) ;; publish with no preload and no cache (publish-file :path "/frob2-npl" :file dummy-2-name @@ -302,6 +310,9 @@ (test (format nil "text/plain") (cdr (assoc :content-type headers :test #'eq)) :test #'equal) + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal) #+ignore (if* (eq protocol :http/1.1) then (test "chunked" (cdr (assoc :transfer-encoding headers @@ -485,6 +496,7 @@ ;; to make a separate binding for each function (publish :path (car pair) :content-type "text/plain" + :headers '((:testhead . "testval")) :function #'(lambda (req ent) (with-http-response (req ent) @@ -497,6 +509,9 @@ :protocol protocol :keep-alive keep-alive) (test 200 code) + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal) (test (format nil "text/plain" port) (cdr (assoc :content-type headers :test #'eq)) :test #'equal) @@ -1259,6 +1274,7 @@ (declare (ignore req ent extra)) (setq got-reps (or got-reps 0)) (incf got-reps)) + :headers '(("testvdir" . "testvval")) :filter #'(lambda (req ent filename info) (declare (ignore ent info)) (test t @@ -1280,9 +1296,15 @@ ; in step 1 we have it return the actual file (setq step 1) - (test 200 (values2 - (x-do-http-request (format nil "~a/test-pd/server.pem" - prefix-local)))) + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/test-pd/server.pem" + prefix-local)) + (declare (ignore body)) + (test 200 code) + (test "testvval" + (cdr (assoc "testvdir" headers :test #'equal)) + :test #'equal)) + (test 1 got-reps) ; hook fired ; remove entry so subsequent tests won't see it @@ -1469,7 +1491,9 @@ (incf got-here) (with-http-response (req ent) (with-http-body (req ent) - (html "foo"))))) + (html "foo")))) + :headers '((:testhead . "testval")) + ) (dolist (prefix (list prefix-local prefix-dns)) (setq got-here 0) (test 200 (values2 @@ -1480,9 +1504,14 @@ (x-do-http-request (format nil "~a/pptest/fred" prefix)))) (test 2 got-here) - (test 200 (values2 - (x-do-http-request (format nil "~a/pptest#asdfasdf" - prefix)))) + (multiple-value-bind (body code headers) + (x-do-http-request (format nil "~a/pptest#asdfasdf" + prefix)) + (declare (ignore body)) + (test 200 code) + (test "testval" + (cdr (assoc "testhead" headers :test #'equal)) + :test #'equal)) (test 3 got-here) (test 200 (values2