Commit f9063e5baa9b30b82626f1670d116fffda90a7a9
2019-01-16T17:30:35
bufferize reply status and headers; remote-addr; support RailsOnLisp
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
diff --git a/thot.lisp b/thot.lisp
index 9989ae2..af52893 100644
--- a/thot.lisp
+++ b/thot.lisp
@@ -27,6 +27,8 @@
((stream :initarg :stream
:reader request-stream%
:type stream)
+ (remote-addr :initarg :remote-addr
+ :accessor request-remote-addr%)
(method :initarg :method
:accessor request-method%
:type (or null symbol))
@@ -39,6 +41,9 @@
(headers :initform (make-hash-table :test 'equalp :size 32)
:reader request-headers%
:type hash-table)
+ (data :initform nil
+ :accessor request-data%
+ :type (or null string))
(uri :accessor request-uri%
:type (or null string))
(scheme :type (or null string))
@@ -54,6 +59,7 @@
(setf (request-method% request) nil
(request-target% request) nil
(request-http-version% request) nil
+ (request-data% request) nil
(request-uri% request) nil
(request-query% request) nil)
(clrhash (request-headers% request))
@@ -63,6 +69,10 @@
(declare (type request request))
(request-stream% request))
+(defun request-remote-addr (&optional (request *request*))
+ (declare (type request request))
+ (request-remote-addr% request))
+
(defun request-method (&optional (request *request*))
(declare (type request request))
(request-method% request))
@@ -146,16 +156,23 @@
(defun request-header (header-name &optional (request *request*))
(declare (type request request))
- (gethash header-name (request-headers% request)))
+ (gethash (string-downcase header-name)
+ (request-headers% request)))
-(defsetf request-header (header-name &optional (request '*request*)) (value)
- `(setf (gethash ,header-name (request-headers ,request)) ,value))
+(defsetf request-header (header-name &optional (request '*request*))
+ (value)
+ `(setf (gethash (string-downcase ,header-name)
+ (request-headers% ,request)) ,value))
(defun request-content-length (&optional (request *request*))
- (let ((header (request-header "Content-Length" request)))
+ (let ((header (request-header "content-length" request)))
(when header
(parse-integer header))))
+(defun request-data (&optional (request *request*))
+ (declare (type request request))
+ (request-data% request))
+
;; HTTP parser
(defmacro with-readers-for (stream definitions &body body)
@@ -186,7 +203,8 @@
(let ((stream (request-stream request))
(buffer (string-output-stream))
(name "")
- (value ""))
+ (value "")
+ (length nil))
(flet ((get-buffer ()
(prog1 (sequence-output-stream-sequence buffer)
(sequence-output-stream-reset buffer))))
@@ -223,7 +241,7 @@
(header-name))))
(header-name (char)
(cond ((char= #\: char)
- (setq name (get-buffer))
+ (setq name (string-downcase (get-buffer)))
(header-spaces))
(t (stream-write buffer char)
(header-name))))
@@ -233,21 +251,32 @@
(header-value))))
(header-value (char)
(cond ((char= #\Return char)
- (setq value (get-buffer))
+ (setf value (get-buffer))
(header-lf))
(t (stream-write buffer char)
(header-value))))
(header-lf (char)
- (cond ((char= #\Newline char)
- (when (debug-p (or :thot :http))
- (msg debug name ": " value))
- (setf (request-header name request) value)
- (next-header))
- (t (error "Missing header LF"))))
+ (unless (char= #\Newline char)
+ (error "Missing header LF"))
+ (when (debug-p (or :thot :http))
+ (msg debug name " <- " value))
+ (setf (request-header name request) value
+ value "")
+ (next-header))
(end-of-headers (char)
- (cond ((char= #\Newline char)
- (request-handler request reply))
- (t (error "Missing end of headers LF")))))
+ (unless (char= #\Newline char)
+ (error "Missing end of headers LF"))
+ (setf length (request-content-length request))
+ (if (and length (< 0 length))
+ (data)
+ (request-handler request reply)))
+ (data (char)
+ (stream-write buffer char)
+ (cond ((= 0 (decf length))
+ (setf (request-data% request) (get-buffer))
+ (request-handler request reply))
+ (t
+ (data)))))
#'method))))
;; Reply
@@ -308,15 +337,7 @@
(parse-integer (reply-header 'content-length reply)))
(defun status (line)
- (let ((status (reply-status)))
- (when status
- (error 'status-already-sent status line)))
- (setf (reply-status) line)
- (let ((stream (reply-stream)))
- (stream-write-sequence stream (request-http-version))
- (stream-write stream #\Space)
- (stream-write-sequence stream line)
- (stream-write-sequence stream +crlf+)))
+ (setf (reply-status) line))
(defun header (&rest parts)
(unless (reply-status)
@@ -329,15 +350,20 @@
(when (endp (rest headers))
(setf (rest headers) (list line))
(return))
- (pop headers)))
- (let ((stream (reply-stream)))
- (stream-write-sequence stream line)
- (stream-write-sequence stream +crlf+))))
+ (pop headers)))))
(defun end-headers ()
(unless (reply-headers-sent)
(setf (reply-headers-sent) t)
- (header "")))
+ (header "")
+ (let ((stream (reply-stream)))
+ (stream-write-sequence stream (request-http-version))
+ (stream-write stream #\Space)
+ (stream-write-sequence stream (reply-status))
+ (stream-write-sequence stream +crlf+)
+ (dolist (header (reply-headers))
+ (stream-write-sequence stream header)
+ (stream-write-sequence stream +crlf+)))))
(defun content (&rest parts)
(end-headers)
@@ -470,7 +496,7 @@ The requested url "
(msg debug "path " path " ext " ext " type " type))
(header "Content-Type: " (string-downcase (symbol-name type)))
(with-stream (in (unistd-stream-open path :read t))
- (let ((size (stream-file-size in)))
+ (let ((size (the integer (stream-file-size in))))
(header "Content-Length: " size)
(end-headers)
(unless (= 0 size)