1.2.35

ChangeLog

@@ -1,3 +1,11 @@
+2004-01-09  John Foderaro  <jkf@tiger.franz.com>
+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  <jkf@tiger.franz.com>
 1.2.34
 	*  fix typo in exports wserver-io-timeout

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)

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)
 		  )))
 
 

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