Permalink
Browse files

checkpoint

  • Loading branch information...
1 parent 05e616f commit e2999f387eadea9549035349a4092e671a2ffc72 jkf committed Jun 29, 1999
Showing with 135 additions and 37 deletions.
  1. +4 −1 examples.cl
  2. +1 −0 loadonly.cl
  3. +45 −16 neo.cl
  4. +2 −2 parse.cl
  5. +83 −18 publish.cl
View
@@ -153,7 +153,10 @@
:mime-type "text/plain"
:preload t)
-
+(publish-file :url "/foo.txt"
+ :file "foo.txt"
+ :mime-type "text/plain"
+ :preload nil)
View
@@ -0,0 +1 @@
+(defparameter *loadswitch* :load)
View
61 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"))
View
@@ -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))
View
@@ -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

0 comments on commit e2999f3

Please sign in to comment.