checkpoint

examples.cl

@@ -153,7 +153,10 @@
 	      :mime-type "text/plain"
 	      :preload t)
 
-
+(publish-file :url "/foo.txt"
+	      :file "foo.txt"
+	      :mime-type "text/plain"
+	      :preload nil)
 
 
 

loadonly.cl

@@ -0,0 +1 @@
+(defparameter *loadswitch* :load)

neo.cl

@@ -17,22 +17,50 @@
 (eval-when (compile load eval)
   ;; these are the common headers and are stored in slots in 
   ;; the objects
+  ;; the list consists of  ("name" . name)
+  ;; where name is symbol naming the accessor function
   (defparameter *fast-headers*
-      '("connection" 
-	"date" 
-	"transfer-encoding"
-	"accept"
-	"host"
-	"user-agent"
-	"content-length")))
+      (let (res)
+	(dolist (name '("connection" 
+			"date" 
+			"transfer-encoding"
+			"accept"
+			"host"
+			"user-agent"
+			"content-length"))
+	  (push (cons name (read-from-string name)) res))
+	res)))
+
+
+
 
 
 (defmacro header-slot-value (name obj)
   ;; name is a string naming the header value (all lower case)
   ;; retrive the slot's value from the http-request obj obj.
-  (if* (assoc name *fast-headers* :test #'equal)
-	  then ; has as
-  )
+  (let (ent)
+    (if* (setq ent (assoc name *fast-headers* :test #'equal))
+       then ; has a fast accesor
+	    `(,(cdr ent) ,obj)
+       else ; must get it from the alist
+	    `(cdr (assoc ,name (alist ,obj) :test #'equal)))))
+
+(defsetf header-slot-value (name obj) (newval)
+  ;; set the header value regardless of where it is stored
+  (let (ent)
+    (if* (setq ent (assoc name *fast-headers* :test #'equal))
+       then `(setf (,(cdr ent) ,obj) ,newval)
+       else (let ((genvar (gensym))
+		  (nobj (gensym)))
+	      `(let* ((,nobj ,obj)
+		      (,genvar (assoc ,name (alist ,nobj) 
+				      :test #'equal)))
+		 (if* (null ,genvar)
+		    then (push (setq ,genvar (cons ,name nil))
+			       (alist ,nobj)))
+		 (setf (cdr ,genvar) ,newval))))))
+
+
 
 
 
@@ -45,11 +73,11 @@
       ;; generate a list of slot descriptors for all of the 
       ;; fast header slots
       (dolist (head *fast-headers*)
-	(let ((name (read-from-string head))) ; use read for case mode compat
-	  (push `(,name :accessor ,name :initform nil
-			:initarg
-			,(intern (symbol-name name) :keyword))
-		res)))
+	(push `(,(cdr head) :accessor ,(cdr head) 
+			    :initform nil
+			    :initarg
+			    ,(intern (symbol-name (cdr head)) :keyword))
+	      res))
       res))
 
 
@@ -131,7 +159,7 @@
     :reader protocol-string)
    (alist ;; alist of headers not stored in slots
     :initform nil
-    :accessor alist)
+r    :accessor alist)
    (socket ;; the socket we're communicating throgh
     :initarg :socket
     :reader socket)
@@ -175,6 +203,7 @@
 (defparameter *response-created* (make-resp 201 "Created"))
 (defparameter *response-accepted* (make-resp 202 "Accepted"))
 
+(defparameter *response-not-modified* (make-resp 304 "Not Modified"))
 (defparameter *response-bad-request* (make-resp 400 "Bad Request"))
 (defparameter *response-unauthorized* (make-resp 401 "Unauthorized"))
 (defparameter *response-not-found* (make-resp 404 "Not Found"))

parse.cl

@@ -166,8 +166,8 @@
     '#.(let (res)
 	(dolist (head *fast-headers*)
 	  (push (cons
-		 (dual-caseify (concatenate 'string head ":"))
-		 (read-from-string head))
+		 (dual-caseify (concatenate 'string (car head) ":"))
+		 (cdr head))
 		res))
 	res))
 

publish.cl

@@ -18,7 +18,7 @@
 	   :initform nil
 	   :reader prefix)
    (last-modified :initarg :last-modified
-		  :reader last-modified
+		  :accessor last-modified
 		  :initform nil ; means always considered new
 		  ))
   )
@@ -280,16 +280,16 @@
 
 
 (defmethod process-entity ((req xhttp-request) (ent file-entity))
-  (with-http-response2 (req ent)
 
-    (let ((contents (contents ent)))
-      (if* contents
-	 then ;(preloaded)
-	      ; set the response code and 
-	      ; and header fields then dump the value
+  (let ((contents (contents ent)))
+    (if* contents
+       then ;(preloaded)
+	    ; set the response code and 
+	    ; and header fields then dump the value
 
-	      ; * should check for range here
-	      ; for now we'll send it all
+	    ; * should check for range here
+	    ; for now we'll send it all
+	    (with-http-response2 (req ent)
 	      (setf (resp-code req) *response-ok*)
 	      (push (cons "Content-Length" (length contents))
 		    (resp-headers req))
@@ -304,9 +304,57 @@
 		;; at this point the header are out and we have a stream
 		;; to write to 
 		(write-sequence contents (resp-stream req))
-		)
-	 else ; 
-	      (error "this side not done yet")))))
+		))
+       else ; the non-preloaded case
+	    (let (p)
+
+	      (setf (last-modified ent) nil) ; forget previous cached value
+
+	      (if* (null (errorset 
+			  (setq p (open (file ent) 
+					:direction :input
+					:element-type '(unsigned-byte 8)))))
+		 then ; file not readable
+		      (with-http-response2 (req ent)
+			(setf (resp-code req) *response-not-found*)
+			(with-http-body (req ent)))
+		      (return-from process-entity nil))
+
+	      (unwind-protect 
+		  (progn
+		    (let ((size (excl::filesys-size (stream-input-fn p)))
+			  (lastmod (excl::filesys-write-date 
+				    (stream-input-fn p)))
+			  (buffer (make-array 1024 
+					      :element-type '(unsigned-byte 8))))
+		      (declare (dynamic-extent buffer))
+
+		      (setf (last-modified ent) lastmod)
+		      (with-http-response2 (req ent)
+
+			(setf (resp-code req) *response-ok*)
+			(push (cons "Content-Length" size) (resp-headers req))
+			(push (cons "Last-Modified"
+				    (universal-time-to-date 
+				     (min (resp-date req) lastmod)))
+			      (resp-headers req))
+			(setf (resp-content-type req) (mime-type ent))
+
+			(with-http-body (req ent :format :binary)
+			  (loop
+			    (if* (<= size 0) then (return))
+			    (let ((got (read-sequence buffer 
+						      p :end 
+						      (min size 1024))))
+			      (if* (<= got 0) then (return))
+			      (write-sequence buffer (resp-stream req)
+					      :end got)
+			      (decf size got)))))))
+
+
+		(close p))))))
+
+
 
 
 
@@ -318,16 +366,33 @@
   ;; throw to abort the rest of the body being run
 
   ; to be done
-  (declare (ignore doit req ent))
 
   (if* (not doit)
      then ; we dont' even care
 	  (return-from up-to-date-check nil))
 
-
-
-
-  nil)
+  (let ((if-modified-since (header-slot-value "if-modified-since" req)))
+    (if* if-modified-since
+       then (setq if-modified-since
+	      (date-to-universal-time if-modified-since)))
+
+    (if* if-modified-since
+       then ; valid date, do the check
+	    (if* (and (last-modified ent) 
+		      (<= (last-modified ent) if-modified-since))
+	       then ; send back a message that it is already
+		    ; up to date
+		    (setf (resp-code req) *response-not-modified*)
+		    (with-http-body (req ent)
+		      ;; force out the header
+		      )
+		    (throw 'with-http-response nil) ; and quick exit
+		    ))))
+
+
+
+
+
 
 
 
@@ -350,7 +415,7 @@
   ;;	we we started to run out of free threads.
   (setf (resp-keep-alive req) 
     (and *enable-keep-alive*
-	 (equalp "keep-alive" (connection req)))))
+	 (equalp "keep-alive" (header-slot-value "connection" req)))))
 
 
 (defvar *enable-chunking* t) ; until we can figure it out