http.lisp (18851B)
1 ;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 ;; TODO remove all those coerce list<->string? 24 ;; TODO !!! post parsing with multiline textarea 25 ;; TODO !!! file(s) upload 26 27 (defpackage :rw.http 28 (:use :cl) 29 (:export :*default-mime-type* 30 :*http-codes* 31 :*mime-types* 32 :client 33 :server)) 34 35 (in-package :rw.http) 36 37 (defparameter *mime-types* 38 '(("css" . "text/css;charset=UTF-8") 39 ("gif" . "image/gif") 40 ("html" . "text/html;charset=UTF-8") 41 ("js" . "application/javascript;charset=UTF-8") 42 ("png" . "image/png") 43 ("txt" . "text/plain;charset=UTF-8"))) 44 45 (defparameter *default-mime-type* "application/octet-stream") 46 47 (defparameter *http-codes* 48 ;; https://en.wikipedia.org/wiki/List_of_HTTP_status_codes 49 '((200 . "OK") 50 (201 . "Created") 51 (202 . "Accepted") 52 (203 . "Non-Authoritative Information (since HTTP/1.1)") 53 (204 . "No Content") 54 (205 . "Reset Content") 55 (206 . "Partial Content") 56 (207 . "Multi-Status (WebDAV; RFC 4918)") 57 (208 . "Already Reported (WebDAV; RFC 5842)") 58 (226 . "IM Used (RFC 3229)") 59 (300 . "Multiple Choices") 60 (301 . "Moved Permanently") 61 (302 . "Found") 62 (303 . "See Other (since HTTP/1.1)") 63 (304 . "Not Modified") 64 (305 . "Use Proxy (since HTTP/1.1)") 65 (306 . "Switch Proxy") 66 (307 . "Temporary Redirect (since HTTP/1.1)") 67 (308 . "Permanent Redirect (approved as experimental RFC)[12]") 68 (400 . "Bad Request") 69 (401 . "Unauthorized") 70 (402 . "Payment Required") 71 (403 . "Forbidden") 72 (404 . "Not Found") 73 (405 . "Method Not Allowed") 74 (406 . "Not Acceptable") 75 (407 . "Proxy Authentication Required") 76 (408 . "Request Timeout") 77 (409 . "Conflict") 78 (410 . "Gone") 79 (411 . "Length Required") 80 (412 . "Precondition Failed") 81 (413 . "Request Entity Too Large") 82 (414 . "Request-URI Too Long") 83 (415 . "Unsupported Media Type") 84 (416 . "Requested Range Not Satisfiable") 85 (417 . "Expectation Failed") 86 (418 . "I'm a teapot (RFC 2324)") 87 (419 . "Authentication Timeout (not in RFC 2616)") 88 ;;(420 . "Method Failure (Spring Framework)") 89 ;;(420 . "Enhance Your Calm (Twitter)") 90 (422 . "Unprocessable Entity (WebDAV; RFC 4918)") 91 (423 . "Locked (WebDAV; RFC 4918)") 92 ;;(424 . "Failed Dependency (WebDAV; RFC 4918)") 93 ;;(424 . "Method Failure (WebDAV)[14]") 94 (425 . "Unordered Collection (Internet draft)") 95 (426 . "Upgrade Required (RFC 2817)") 96 (428 . "Precondition Required (RFC 6585)") 97 (429 . "Too Many Requests (RFC 6585)") 98 (431 . "Request Header Fields Too Large (RFC 6585)") 99 (444 . "No Response (Nginx)") 100 (449 . "Retry With (Microsoft)") 101 (450 . "Blocked by Windows Parental Controls (Microsoft)") 102 ;;(451 . "Unavailable For Legal Reasons (Internet draft)") 103 ;;(451 . "Redirect (Microsoft)") 104 (494 . "Request Header Too Large (Nginx)") 105 (495 . "Cert Error (Nginx)") 106 (496 . "No Cert (Nginx)") 107 (497 . "HTTP to HTTPS (Nginx)") 108 (499 . "Client Closed Request (Nginx)") 109 (500 . "Internal Server Error") 110 (501 . "Not Implemented") 111 (502 . "Bad Gateway") 112 (503 . "Service Unavailable") 113 (504 . "Gateway Timeout") 114 (505 . "HTTP Version Not Supported") 115 (506 . "Variant Also Negotiates (RFC 2295)") 116 (507 . "Insufficient Storage (WebDAV; RFC 4918)") 117 (508 . "Loop Detected (WebDAV; RFC 5842)") 118 (509 . "Bandwidth Limit Exceeded (Apache bw/limited extension)") 119 (510 . "Not Extended (RFC 2774)") 120 (511 . "Network Authentication Required (RFC 6585)") 121 (598 . "Network read timeout error (Unknown)") 122 (599 . "Network connect timeout error (Unknown)"))) 123 124 (defun next-eol (reader) 125 (ecase (rw:next reader) 126 (#\newline :lf) 127 (#\return (case (rw:peek reader) 128 (#\newline (rw:next reader) :crlf) 129 (t :lf))))) 130 131 (defun next-protocol (reader) 132 (let ((x (cdr (assoc (rw:till reader '(#\H #\T #\P #\/ #\1 #\. #\0) t) 133 '(((#\H #\T #\T #\P #\/ #\1 #\. #\0) . :http-1.0) 134 ((#\H #\T #\T #\P #\/ #\1 #\. #\1) . :http-1.1)) 135 :test #'equal)))) 136 (assert x) 137 x)) 138 139 (defun next-status (reader) 140 (unless (member (rw:peek reader) '(#\return #\newline)) 141 (values (prog1 (next-protocol reader) 142 (rw:skip reader)) 143 (prog1 (rw:next-z0 reader) 144 (rw:skip reader)) 145 (prog1 (coerce (rw:till reader '(#\return #\newline)) 'string) 146 (next-eol reader))))) 147 148 (defun header-part-reader (reader) 149 (lambda () 150 (rw:skip reader) 151 (when (rw:peek reader) 152 (flet ((str (y) 153 (when y 154 (coerce y 'string)))) 155 (cons (str (rw:till reader '(#\= #\;))) 156 (ecase (rw:next reader) 157 ((nil #\;) nil) 158 (#\= 159 (rw:skip reader) 160 (let ((q (when (eql #\" (rw:peek reader)) 161 (rw:next reader) 162 t))) 163 (prog1 (str (rw:till reader '(#\"))) 164 (when q 165 (assert (eql #\" (rw:next reader)))) 166 (rw:skip reader) 167 (assert (member (rw:next reader) '(#\; nil)))))))))))) 168 169 (defun parse-header (k v) 170 (case (cdr (assoc k '(("Content-Length" . :z0) 171 ("Content-Disposition" . :header-parts) 172 ("Content-Type" . :header-parts)) 173 :test #'equal)) 174 (:z0 (rw:next-z0 (rw:peek-reader (rw:reader v)))) 175 (:header-parts (rw:till (rw:peek-reader 176 (header-part-reader 177 (rw:peek-reader (rw:reader v)))))) 178 (t (coerce v 'string)))) 179 180 ;;(parse-header "Content-Disposition" "form-data; name=\"z7\"; filename=\"\"") 181 ;;(parse-header "Content-Type" "multipart/form-data; boundary=---------------------------333499860151468491119738773") 182 183 (defun header-reader (reader) 184 (lambda () 185 (let ((k (rw:till reader '(#\: #\return #\newline)))) 186 (when k 187 (assert (eql #\: (rw:next reader))) 188 (rw:skip reader) 189 (let* ((kk (coerce k 'string)) 190 (v (rw:till reader '(#\return #\newline)))) 191 (next-eol reader) 192 (cons kk (parse-header kk v))))))) 193 194 (defun next-headers (reader) 195 (prog1 (rw:till (rw:peek-reader (header-reader reader))) 196 (next-eol reader))) 197 198 (defun next-body (reader) ;; TODO better, respect content-length! 199 (coerce (rw:till reader) '(vector (unsigned-byte 8)))) 200 201 (defun write-crlf (writer) 202 (rw:write-octets writer '(13 10))) 203 204 (defun write-header (writer k v) 205 (when v 206 (rw:write-utf8-string writer k) 207 (rw:write-octets writer #.(rw.string:string-to-octets ": " :utf-8)) 208 (etypecase v 209 (string (rw:write-utf8-string writer v)) 210 (integer (rw:write-utf8-string writer (princ-to-string v))) 211 (cons 212 (loop 213 for part in v 214 for i from 0 215 do (progn 216 (when (plusp i) 217 (rw:write-octets writer #.(rw.string:string-to-octets ";" :utf-8))) 218 (etypecase part 219 (string (rw:write-utf8-string writer part)) 220 (cons 221 (rw:write-utf8-string writer (car part)) 222 (when (cdr part) 223 (rw:write-octets writer #.(rw.string:string-to-octets "=" :utf-8)) 224 (rw:write-utf8-string writer (cdr part))))))))) 225 (write-crlf writer))) 226 227 (defun write-headers (writer headers) 228 (dolist (x headers) 229 (write-header writer (car x) (cdr x)))) 230 231 (defun write-protocol (writer protocol) 232 (rw:write-octets 233 writer 234 (ecase protocol 235 (:http-1.0 #.(rw.string:string-to-octets "HTTP/1.0" :utf-8)) 236 (:http-1.1 #.(rw.string:string-to-octets "HTTP/1.1" :utf-8))))) 237 238 (defun write-query (writer method protocol path query-string) 239 (rw:write-utf8-string writer (ecase method 240 (:get "GET") 241 (:head "HEAD") 242 (:post "POST") 243 (:put "PUT"))) 244 (rw:write-utf8-char writer #\space) 245 (rw:write-utf8-string writer (or path "/")) 246 (when query-string 247 (rw:write-utf8-char writer #\?) 248 (rw:write-utf8-string writer query-string)) 249 (rw:write-utf8-char writer #\space) 250 (write-protocol writer protocol) 251 (write-crlf writer)) 252 253 (defun %client1 (stream host port method protocol path query-string headers) 254 (let ((w (rw:byte-writer stream))) 255 (write-query w method protocol path query-string) 256 (write-headers w (or headers 257 `(("Host" . ,(if port 258 (format nil "~a:~a" host port) 259 host))))) 260 (write-crlf w)) 261 (finish-output stream) 262 (assert (eq :http-1.0 protocol)) ;; TODO chunked encoding with http-1.1 263 (let* ((rb (rw:peek-reader (rw:byte-reader stream))) 264 (rc (rw:peek-reader (rw:utf8-reader rb :charp t)))) 265 (multiple-value-bind (protocol code message) (next-status rc) 266 (values protocol code message (next-headers rc) (next-body rb))))) 267 268 (defun client1 (url headers) 269 (destructuring-bind (&key scheme host port path query-string fragment) 270 (etypecase url 271 (list url) 272 (string (rw.uri:parse url))) 273 (declare (ignore fragment)) 274 (assert (equal "http" scheme)) 275 (with-open-stream (s (rw.socket:make-tcp-client-socket host (or port 80))) 276 (%client1 s host port :get :http-1.0 path query-string headers)))) 277 278 (defun client (url &key headers (redirect 5)) 279 (do (protocol code message headers2 body) 280 ((< (decf redirect) 0)) 281 (multiple-value-setq (protocol code message headers2 body) 282 (client1 url headers)) 283 (if (member code '(301 302)) 284 (setq url (cdr (assoc "Location" headers2 :test #'equalp))) ;; TODO update "Host" header 285 (return-from client (values protocol code message headers2 body))))) 286 287 ;;(client "http://127.0.0.1:2341") 288 ;;(client "http://logand.com") 289 290 291 292 293 ;; HTTP/1.1 302 Moved Temporarily^M 294 ;; Content-Length: 369 295 ;; Date: Sat, 21 Sep 2013 13:41:11 GMT 296 ;; Server: Hunchentoot 1.2.3 297 ;; Connection: Close 298 ;; Location: http://NIL/?s=24rb7pccnd&a=0&c= 299 ;; Content-Type: text/html; charset=iso-8859-1 300 301 ;; <html><head><title>302 Moved Temporarily</title></head><body><h1>Moved Temporarily</h1>The document has moved <a href='http://NIL/?s=24rb7pccnd&a=0&c='>here</a><p><hr><address><a href='http://weitz.de/hunchentoot/'>Hunchentoot 1.2.3</a> <a href='http://openmcl.clozure.com/'>(Clozure Common Lisp Version 1.9-r15767 (LinuxARM32))</a></address></p></body></html>Connection closed by foreign host. 302 303 (defun next-method (reader allowed-methods) 304 (let ((x (cdr (assoc (rw:till (rw:peek-reader (rw:shorter-reader reader 5)) 305 '(#\G #\E #\T 306 #\H #\A #\D 307 #\P #\O #\S) 308 t) 309 '(((#\G #\E #\T) . :get) 310 ((#\H #\E #\A #\D) . :head) 311 ((#\P #\O #\S #\T) . :post)) 312 :test #'equal)))) 313 (assert (member x allowed-methods)) 314 x)) 315 316 (defun next-query (reader allowed-methods) 317 (unless (member (rw:peek reader) '(#\return #\newline)) 318 (flet ((str (y) 319 (when y 320 (coerce y 'string)))) 321 (values (prog1 (next-method reader allowed-methods) 322 (rw:skip reader)) 323 (prog1 (str (rw:till reader '(#\space #\return #\newline))) 324 (unless (member (rw:peek reader) '(#\return #\newline)) 325 (rw:skip reader '(#\space)))) 326 (prog1 (next-protocol reader) 327 (next-eol reader)))))) 328 329 (defun write-status (writer protocol code message) 330 (write-protocol writer protocol) 331 (rw:write-u8 writer #.(char-code #\space)) 332 (rw:write-utf8-string writer (princ-to-string code)) 333 (rw:write-u8 writer #.(char-code #\space)) 334 (rw:write-utf8-string writer 335 (or message 336 (cdr (assoc code *http-codes*)) 337 (error "unknown http code ~s" code))) 338 (write-crlf writer)) 339 340 (defun multipart-reader (breader creader boundary) 341 (let* ((cb `(#\return #\newline #\- #\- ,@(coerce boundary 'list))) 342 (bb (rw.string:string-to-octets (coerce cb 'string) :utf-8)) 343 (cr (rw:peek-reader creader)) 344 done) 345 (assert (not (rw:slurp (rw:search-reader creader (cddr cb))))) 346 (lambda () 347 (unless done 348 (cond 349 ((eql #\- (rw:peek cr)) 350 (assert (eql #\- (rw:next cr))) 351 (assert (eql #\- (rw:next cr))) 352 (next-eol cr) 353 (setq done t) 354 nil) 355 (t 356 (next-eol cr) 357 (let ((headers (next-headers cr))) 358 (list :part 359 :headers headers 360 :body (if (cdr (assoc "Content-Type" headers :test #'equal)) 361 ;; TODO callback instead of slurp? 362 ;;(cdr (assoc "filename" y :test #'equal)) 363 ;;("Content-Type" ("application/octet-stream")) 364 (rw:slurp (rw:search-reader breader bb)) 365 (let ((x (rw:slurp (rw:search-reader creader cb)))) 366 (when x 367 (coerce x 'string)))))))))))) 368 369 (defun post-parameters (method multipart/form-data) 370 (when (eq :post method) 371 (loop 372 for x in multipart/form-data 373 collect (destructuring-bind (tag &key headers body) x 374 (assert (eq :part tag)) 375 (cons (let ((y (cdr (assoc "Content-Disposition" headers 376 :test #'equal)))) 377 (assert (equal '("form-data") 378 (assoc "form-data" y :test #'equal))) 379 (cdr (assoc "name" y :test #'equal))) 380 body))))) 381 382 (defun server-read (breader creader method) 383 (let ((headers (next-headers creader))) 384 (values 385 headers 386 (when (eq :post method) 387 (rw:slurp 388 (let ((br (rw:shorter-reader 389 breader 390 (cdr (assoc "Content-Length" headers :test #'equal))))) 391 (multipart-reader 392 br 393 (rw:utf8-reader br :charp t) 394 (cdr (assoc "boundary" 395 (cdr (assoc "Content-Type" headers :test #'equal)) 396 :test #'equal))))))))) 397 398 (defun server-write (form writer) 399 (ecase (car form) 400 (:http-1.0 401 (destructuring-bind (&key code message headers body) (cdr form) 402 (write-status writer :http-1.0 code message) 403 (write-headers writer 404 (or headers 405 '(("Connection" . "close") 406 ;;("Date" . "") 407 ;;("Last-Modified" . "") 408 #+nil("Server" . "CL-RW")))) 409 (write-crlf writer) 410 (etypecase body 411 (null) 412 (string (rw:write-utf8-string writer body)) 413 (pathname 414 (with-open-file (s body :element-type '(unsigned-byte 8)) 415 (rw:copy (rw:byte-reader s) writer))) 416 ((vector (unsigned-byte 8)) 417 (rw:copy (rw:reader body) writer)) 418 (cons 419 (rw:write-utf8-string writer 420 (with-output-to-string (*standard-output*) 421 (rw.html:html body))) 422 #+nil(let ((*standard-output* stream)) (rw.html:html body))) ;; TODO xml, css... 423 (function (funcall body writer))))))) 424 425 (defun server-handler (stream handler allowed-methods ignore-errors-p) 426 (flet ((body () 427 (with-open-stream (stream stream) 428 (let* ((br (rw:byte-reader stream)) 429 (cr (rw:peek-reader (rw:utf8-reader br :charp t)))) 430 (multiple-value-bind (method query protocol) 431 (next-query cr allowed-methods) 432 (server-write 433 (multiple-value-bind (headers body) 434 (server-read br cr method) 435 (funcall handler :write stream method query protocol headers 436 body)) 437 (rw:byte-writer stream))))))) 438 (if ignore-errors-p 439 (ignore-errors (body)) 440 (body)))) 441 442 (defun accept-loop (socket quit handler host port allowed-methods ignore-errors-p) 443 (do ((q (or quit (rw:reader '(nil t))))) 444 ((funcall q)) 445 (let ((c (rw.socket:accept socket))) 446 (rw.concurrency:make-thread 447 (format nil "RW.HTTP:SERVER-HANDLER ~s ~s" host port) 448 (lambda () 449 (server-handler c handler allowed-methods ignore-errors-p)))))) 450 451 ;; TODO also without threads 452 ;; TODO also thread limit 453 ;; TODO also thread pool 454 (defun server (host port handler &key quit allowed-methods ignore-errors-p) 455 (let ((s (rw.socket:make-tcp-server-socket host port))) 456 (flet ((accept () 457 (with-open-stream (s s) 458 (accept-loop s quit handler host port allowed-methods 459 ignore-errors-p)))) 460 (if (rw.concurrency:threads-supported-p) 461 (rw.concurrency:make-thread 462 (format nil "RW.HTTP:ACCEPT-LOOP ~s ~s" host port) 463 #'accept) 464 (accept))))) 465 466 (defun my-handler (msg stream method query protocol headers &optional body) 467 (ecase msg 468 (:read (rw:till (rw:peek-reader stream))) 469 (:write `(:http-1.0 470 :code 200 471 :body ,(prin1-to-string 472 (list method query protocol headers body)))))) 473 474 ;;(server "0.0.0.0" 1567 'my-handler :quit (lambda () nil))