diff --git a/thot.lisp b/thot.lisp
index bb7b1dd..60069a7 100644
--- a/thot.lisp
+++ b/thot.lisp
@@ -108,8 +108,14 @@
`(labels ,(mapcar #'reader definitions)
,@body)))
-(defun request-reader (stream cont)
- (let ((request (make-instance 'request :stream stream))
+(defun request-reader (request reply cont)
+ "Returns a HTTP request reader function which itself returns either :
+ :EOF if end of stream was reached, or
+ a closure if read would block, or
+ the return value of CONT, which should be either :
+ :KEEP-ALIVE if the connection is to be kept alive for next request, or
+ NIL if the request stream is to be closed after reply."
+ (let ((stream (request-stream request))
(buffer (string-output-stream))
(name "")
(value ""))
@@ -172,7 +178,7 @@
(next-header))
(t (error "Missing header LF"))))
(end-of-headers (char)
- (cond ((char= #\Newline char) (funcall cont request))
+ (cond ((char= #\Newline char) (funcall cont request reply))
(t (error "Missing end of headers LF")))))
#'method))))
@@ -185,7 +191,12 @@
:accessor reply-headers%)
(headers-sent :initform nil
:accessor reply-headers-sent%
- :type boolean)))
+ :type boolean)
+ (cont-queue :initform (make-instance 'queue
+ :element-type 'function
+ :size 40)
+ :accessor reply-cont-queue%
+ :type queue)))
(defvar *reply*)
@@ -203,8 +214,7 @@
(defsetf reply-headers (&optional (reply '*reply*)) (value)
`(setf (reply-headers% ,reply) ,value))
-(defun reply-header (name &optional (reply *reply*))
- (declare (type reply reply))
+(defun reply-header (name &optional (reply *reply*)) (declare (type reply reply))
(let ((header (assoc name (reply-headers reply) :test #'string-equal)))
(when header
(rest header))))
@@ -216,20 +226,64 @@
(defsetf reply-headers-sent (&optional (reply '*reply*)) (value)
`(setf (reply-headers-sent% ,reply) ,value))
+(defun reply-cont-queue (&optional (reply *reply*))
+ (declare (type reply reply))
+ (reply-cont-queue% reply))
+
+(defsetf reply-cont-queue (&optional (reply '*reply*)) (value)
+ `(setf (reply-cont-queue% ,reply) ,value))
+
(defun reply-content-length (&optional (reply *reply*))
(declare (type reply reply))
(parse-integer (reply-header 'content-length reply)))
+(defun reply-stream ()
+ (request-stream))
+
(defun status (line)
(let ((status (reply-status)))
(when status
(error 'status-already-sent status line)))
(setf (reply-status) line)
- (let ((stream (request-stream)))
- (write-sequence stream (request-http-version))
- (write stream #\Space)
- (write-sequence stream line)
- (write-sequence stream +crlf+)))
+ (let ((stream (reply-stream)))
+ (labels ((version (&optional (start 0))
+ (multiple-value-bind (count state)
+ (write-sequence stream (request-http-version) :start start)
+ (case state
+ ((nil) (space))
+ ((:eof) (error 'stream-end-error :stream stream))
+ ((:non-blocking) (write (reply-cont-queue)
+ (lambda ()
+ (version (+ start count)))))
+ (otherwise (error 'stream-output-error :stream stream)))))
+ (space ()
+ (case (write stream #\Space)
+ ((nil) (line))
+ ((:eof) (error 'stream-end-error :stream stream))
+ ((:non-blocking) (write (reply-cont-queue) #'space))
+ (otherwise (error 'stream-output-error :stream stream))))
+ (line (&optional (start 0))
+ (multiple-value-bind (count state)
+ (write-sequence stream line :start start)
+ (case state
+ ((nil) (crlf))
+ ((:eof) (error 'stream-end-error :stream stream))
+ ((:non-blocking) (write (reply-cont-queue)
+ (lambda () (line (+ start count)))))
+ (otherwise (error 'stream-output-error :stream stream)))))
+ (crlf (&optional (start 0))
+ (multiple-value-bind (count state)
+ (write-sequence stream +crlf+)
+ (case state
+ ((nil) nil)
+ ((:eof) (error 'stream-end-error :stream stream))
+ ((:non-blocking) (write (reply-cont-queue)
+ (lambda () (crlf (+ start count)))))
+ (otherwise (error 'stream-output-error
+ :stream stream))))))
+ (if (= 0 (queue-length (reply-cont-queue)))
+ (version)
+ (write (reply-cont-queue) #'version)))))
(defun header (line)
(unless (reply-status)
@@ -243,8 +297,29 @@
(return))
(pop headers))))
(let ((stream (request-stream)))
- (write-sequence stream line)
- (write-sequence stream +crlf+)))
+ (labels ((line (&optional (start 0))
+ (multiple-value-bind (count state)
+ (write-sequence stream line)
+ (case state
+ ((nil) (crlf))
+ ((:eof) (error 'stream-end-error :stream stream))
+ ((:non-blocking) (write (reply-cont-queue)
+ (lambda () (line (+ start count)))))
+ (otherwise (error 'stream-output-error
+ :stream stream)))))
+ (crlf (&optional (start 0))
+ (multiple-value-bind (count state)
+ (write-sequence stream +crlf+)
+ (case state
+ ((nil) nil)
+ ((:eof) (error 'stream-end-error :stream stream))
+ ((:non-blocking) (write (reply-cont-queue)
+ (lambda () (crlf (+ start count)))))
+ (otherwise (error 'stream-output-error
+ :stream stream))))))
+ (if (= 0 (queue-length (reply-cont-queue)))
+ (line)
+ (write (reply-cont-queue) #'line)))))
(defun end-headers ()
(unless (reply-headers-sent)
@@ -253,13 +328,27 @@
(defun content (string)
(end-headers)
- (write-sequence (request-stream) string))
+ (let ((stream (reply-stream)))
+ (labels ((content-string (&optional (start 0))
+ (multiple-value-bind (count state)
+ (write-sequence (request-stream) string)
+ (case state
+ ((nil) nil)
+ (:eof) (error 'stream-end-error :stream stream)
+ ((:non-blocking) (write (reply-cont-queue)
+ (lambda ()
+ (content-string (+ start count)))))
+ (otherwise (error 'stream-output-error
+ :stream stream))))))
+ (if (= 0 (queue-length (reply-cont-queue)))
+ (content-string)
+ (write (reply-cont-queue) #'content-string)))))
(defun 404-not-found ()
(status "404 Not found")
(header "Content-Type: text/plain")
(content (format nil "404 Not found
-
+
The requested url ~S was not found on this server."
(request-target))))
@@ -269,10 +358,10 @@ The requested url ~S was not found on this server."
(defvar *url-handlers*
'(404-not-found-handler))
-(defun request-cont (request)
+(defun request-cont (request reply)
(let ((handlers *url-handlers*)
(*request* request)
- (*reply* (make-instance 'reply)))
+ (*reply* reply))
(loop
(when (endp handlers)
(return))
@@ -294,9 +383,11 @@ The requested url ~S was not found on this server."
(loop
(when *stop*
(return))
- (unless (eq :keep-alive
- (funcall (request-reader stream #'request-cont)))
- (return))))
+ (let* ((request (make-instance 'request :stream stream))
+ (reply (make-instance 'reply))
+ (result (funcall (request-reader request reply #'request-cont))))
+ (unless (eq :keep-alive result)
+ (return)))))
(defvar *acceptor-loop*)