;;; ;;; Intarweb is an improved HTTP library for Chicken ;;; ;; Copyright (c) 2008-2018, Peter Bex ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the author nor the names of its ;; contributors may be used to endorse or promote products derived ;; from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;; TODO: Support RFC5987? Seems awfully messy though (need to pull in iconv?) ;; We could use http://www.greenbytes.de/tech/tc2231/ in the testsuite. ;; Look at that URI's toplevel directory for more HTTP/URI-related testcases! (module intarweb (http-line-limit http-header-limit http-urlencoded-request-data-limit replace-header-contents replace-header-contents! remove-header remove-header! update-header-contents update-header-contents! headers single-headers headers? headers->list http-name->symbol symbol->http-name header-parsers header-unparsers unparse-header unparse-headers read-headers safe-methods safe? idempotent-methods idempotent? keep-alive? response-class etag=? etag=-weakly? etag-matches? etag-matches-weakly? make-request request? request-major request-major-set! request-minor request-minor-set! request-method request-method-set! request-uri request-uri-set! request-headers request-headers-set! request-port request-port-set! update-request set-request! request-has-message-body? request-parsers read-request request-unparsers write-request finish-request-body http-0.9-request-parser http-1.x-request-parser http-0.9-request-unparser http-1.0-request-unparser http-1.x-request-unparser header-parse-error-handler read-urlencoded-request-data make-response response? response-major response-major-set! response-minor response-minor-set! response-code response-code-set! response-reason response-reason-set! response-status response-status-set! response-headers response-headers-set! response-port response-port-set! update-response set-response! response-has-message-body-for-request? write-response response-parsers response-unparsers read-response finish-response-body http-0.9-response-parser http-0.9-response-unparser http-1.0-response-parser http-1.0-response-unparser http-1.x-response-parser http-1.x-response-unparser http-status-codes http-status->code&reason ;; http-header-parsers header-contents header-values header-value header-params header-param get-value get-params get-param split-multi-header parse-token parse-comment parse-params parse-value+params unparse-params multiple single make-key/value-subparser rfc1123-string->time rfc850-string->time asctime-string->time http-date-string->time rfc1123-subparser rfc850-subparser asctime-subparser http-date-subparser product-subparser quality-subparser unknown-header-parser filename-subparser symbol-subparser symbol-subparser-ci natnum-subparser host/port-subparser base64-subparser range-subparser filename-subparser etag-parser software-parser mailbox-subparser if-range-parser retry-after-subparser via-parser warning-parser key/value-subparser set-cookie-parser cache-control-parser pragma-parser te-parser cookie-parser strict-transport-security-parser must-be-quoted-chars quote-string unparse-token default-header-unparser etag-unparser host/port-unparser product-unparser software-unparser rfc1123-unparser cookie-unparser strict-transport-security-unparser ;; Subparsers/subunparsers authorization-param-subparsers basic-auth-param-subparser digest-auth-param-subparser authorization-param-subunparsers basic-auth-param-subunparser digest-auth-param-subunparser ) (import scheme (chicken base) (chicken foreign) (chicken irregex) (chicken format) (chicken io) (chicken string) (chicken time posix) (chicken pathname) (chicken fixnum) (chicken condition) (chicken port) (chicken syntax) srfi-1 srfi-13 srfi-14 base64 uri-common defstruct) ;; The below can all be #f if you want no limit (not recommended!) (define http-line-limit (make-parameter 4096)) (define http-header-limit (make-parameter 64)) (define http-urlencoded-request-data-limit (make-parameter (* 4 1024 1024))) (define (read-urlencoded-request-data request #!optional (max-length (http-urlencoded-request-data-limit))) (let* ((p (request-port request)) (len (header-value 'content-length (request-headers request))) ;; For simplicity's sake, we don't allow exactly the max request limit (limit (if (and len max-length) (min len max-length) (or max-length len))) (data (read-string limit (request-port request)))) (if (and (not (eof-object? data)) max-length (= max-length (string-length data))) (signal-http-condition 'read-urlencoded-request-data "Max allowed URLencoded request size exceeded" (list request max-length) 'urlencoded-request-data-limit-exceeded 'contents data 'limit limit) (form-urldecode data)))) (define (raise-line-limit-exceeded-error line limit port) (let ((safe-line-prefix (if (< limit 128) (sprintf "~A[..and more (was limited to ~A)..]" line limit) (sprintf "~A[..~A+ more chars (was limited to ~A)..]" (substring line 0 128) (- limit 128) limit)))) (signal-http-condition 'safe-read-line "Max allowed line length exceeded" (list port safe-line-prefix) 'line-limit-exceeded 'contents line 'limit limit))) (define (safe-read-line p) (let* ((limit (http-line-limit)) (line (read-line p (http-line-limit)))) (if (and (not (eof-object? line)) limit (= limit (string-length line))) (raise-line-limit-exceeded-error line limit p) line))) ;; Make headers a new type, to force the use of the HEADERS procedure ;; and ensure only proper header values are passed to all procedures ;; that deal with headers. (define-record headers v) (define-record-printer (headers h out) (fprintf out "#(headers: ~S)" (headers-v h))) (define headers->list headers-v) (define (remove-header! name headers) (let loop ((h (headers-v headers))) (cond ((null? h) headers) ((eq? name (caar h)) (set-cdr! h (cdr h)) headers) (else (loop (cdr h)))))) (define (remove-header name headers) (make-headers (let loop ((h (headers-v headers))) (cond ((null? h) h) ((eq? name (caar h)) (loop (cdr h))) (else (cons (car h) (loop (cdr h)))))))) ;; Check that the header values are valid vectors, and that if there ;; is a raw value, there is only one value at all. (define (check-header-values loc name contents) (let lp ((mode 'unknown) (todo contents)) (let ((head (car todo))) (if (not (and (vector? head) (= 2 (vector-length head)))) (signal-http-condition loc "header values must be vectors of length 2" (list name contents) 'header-value) (let ((type (if (eq? (get-params head) 'raw) 'raw 'cooked))) (unless (or (eq? mode 'unknown) (eq? mode type)) (signal-http-condition loc "When using raw headers, all values must be raw" (list name contents) 'header-value) (lp type (cdr todo)))))))) ;; XXX: Do we need these replace procedures in the exports list? It ;; looks like we can use update everywhere. (define (replace-header-contents! name contents headers) (check-header-values 'replace-header-contents! name contents) (let loop ((h (headers-v headers))) (cond ((null? h) (headers-v-set! headers (cons (cons name contents) (headers-v headers))) headers) ((eq? name (caar h)) (set-cdr! (car h) contents) headers) (else (loop (cdr h)))))) (define (replace-header-contents name contents headers) (check-header-values 'replace-header-contents! name contents) (make-headers (let loop ((h (headers-v headers))) (cond ((null? h) (cons (cons name contents) h)) ((eq? name (caar h)) (cons (cons (caar h) contents) (cdr h))) (else (cons (car h) (loop (cdr h)))))))) (define (make-updater replacer) (lambda (name contents headers) (let ((old (header-contents name headers '()))) (replacer name (if (member name (single-headers)) (list (last contents)) (append old contents)) headers)))) (define update-header-contents (make-updater replace-header-contents)) (define update-header-contents! (make-updater replace-header-contents!)) (define http-name->symbol (compose string->symbol string-downcase!)) (define symbol->http-name (compose string-titlecase symbol->string)) ;; Make a header set from a literal expression by folding in the headers ;; with any previous ones (define (headers headers-to-be #!optional (old-headers (make-headers '()))) (fold (lambda (h new-headers) (update-header-contents (car h) (map (lambda (v) (if (vector? v) v (vector v '()))) ; normalize to vector (cdr h)) new-headers)) old-headers headers-to-be)) (define (normalized-uri str) (and-let* ((uri (uri-reference str))) (uri-normalize-path-segments uri))) (include "header-parsers") ; Also includes header unparsers ;; Any unknown headers are considered to be multi-headers, always (define single-headers (make-parameter '(accept-ranges age authorization content-disposition content-length content-location content-md5 content-type date etag expect expires host if-modified-since if-unmodified-since last-modified location max-forwards proxy-authorization range referer retry-after server transfer-encoding user-agent www-authenticate))) (define string->http-method string->symbol) (define http-method->string symbol->string) ;; Make an output port automatically "chunked" (define (chunked-output-port port) (let ((chunked-port (make-output-port (lambda (s) ; write (let ((len (string-length s))) (unless (zero? len) (fprintf port "~X\r\n~A\r\n" len s)))) (lambda () ; close (close-output-port port)) (lambda () ; flush (flush-output port))))) ;; first "reserved" slot ;; Slot 7 should probably stay 'custom (##sys#setslot chunked-port 10 'chunked-output-port) ;; second "reserved" slot (##sys#setslot chunked-port 11 port) chunked-port)) ;; Make an input port automatically "chunked" (define (chunked-input-port port) (let* ((chunk-length 0) (position 0) (check-position (lambda () (when (and position (>= position chunk-length)) (unless (eq? chunk-length 0) (safe-read-line port)) ; Read \r\n data trailer (let ((line (safe-read-line port))) (if (eof-object? line) (set! position #f) (begin (set! chunk-length (string->number line 16)) (cond ((not chunk-length) (set! position #f)) ((zero? chunk-length) ; Read final data trailer (safe-read-line port) (set! position #f)) (else (set! position 0)))))))))) (make-input-port (lambda () ; read-char (check-position) (if position (let ((char (read-char port))) (unless (eof-object? char) (set! position (add1 position))) char) #!eof)) (lambda () ; ready? (check-position) (or (not position) (char-ready? port))) (lambda () ; close (close-input-port port)) (lambda () ; peek-char (check-position) (if position (peek-char port) #!eof)) (lambda (p bytes buf off) ; read-string! (let lp ((todo bytes) (total-bytes-read 0) (off off)) (check-position) (if (or (not position) (= todo 0)) total-bytes-read (let* ((n (min todo (- chunk-length position))) (bytes-read (read-string! n buf port off))) (set! position (+ position bytes-read)) (lp (- todo bytes-read) (+ total-bytes-read bytes-read) (+ off bytes-read))))))))) ;; TODO: Note that in the above, read-line is not currently ;; implemented. It is *extremely* tricky to correctly maintain the ;; port position when all \r *AND/OR* \n characters get chopped off ;; the line-string. It can be done by maintaining our own extra ;; buffer, but that complicates all the procedures here enormously, ;; including read-line itself. ;; RFC2616, Section 4.3: "The presence of a message-body in a request ;; is signaled by the inclusion of a Content-Length or Transfer-Encoding ;; header field in the request's message-headers." ;; We don't check the method since "a server SHOULD read and forward the ;; a message-body on any request", even it shouldn't be sent for that method. ;; ;; Because HTTP/1.0 has no official definition of when a message body ;; is present, we'll assume it's always present, unless there is no ;; content-length and we have a keep-alive connection. (define request-has-message-body? (make-parameter (lambda (req) (let ((headers (request-headers req))) (if (and (= 1 (request-major req)) (= 0 (request-minor req))) (not (eq? 'keep-alive (header-contents 'connection headers))) (or (header-contents 'content-length headers) (header-contents 'transfer-encoding headers))))))) ;; RFC2616, Section 4.3: "For response messages, whether or not a ;; message-body is included with a message is dependent on both the ;; request method and the response status code (section 6.1.1)." (define response-has-message-body-for-request? (make-parameter (lambda (resp req) (not (or (= (response-class resp) 100) (memv (response-code resp) '(204 304)) (eq? 'HEAD (request-method req))))))) ;; OPTIONS and TRACE are not explicitly mentioned in section 9.1.1, ;; but section 9.1.2 says they SHOULD NOT have side-effects by ;; definition, which means they are safe, as well. (define safe-methods (make-parameter '(GET HEAD OPTIONS TRACE))) ;; RFC2616, Section 9.1.1 (define (safe? obj) (let ((method (if (request? obj) (request-method obj) obj))) (not (not (member method (safe-methods)))))) (define idempotent-methods (make-parameter '(GET HEAD PUT DELETE OPTIONS TRACE))) ;; RFC2616, Section 9.1.2 (define (idempotent? obj) (let ((method (if (request? obj) (request-method obj) obj))) (not (not (member method (idempotent-methods)))))) (define (keep-alive? obj) (let ((major (if (request? obj) (request-major obj) (response-major obj))) (minor (if (request? obj) (request-minor obj) (response-minor obj))) (con (header-value 'connection (if (request? obj) (request-headers obj) (response-headers obj))))) (if (and (= major 1) (> minor 0)) (not (eq? con 'close)) ;; RFC 2068, section 19.7.1 (see also RFC 2616, section 19.6.2) (eq? con 'keep-alive)))) (define (etag=? a b) (and (not (eq? 'weak (car a))) (eq? (car a) (car b)) (string=? (cdr a) (cdr b)))) (define (etag=-weakly? a b) (and (eq? (car a) (car b)) (string=? (cdr a) (cdr b)))) (define (etag-matches? etag matchlist) (any (lambda (m) (or (eq? m '*) (etag=? etag m))) matchlist)) (define (etag-matches-weakly? etag matchlist) (any (lambda (m) (or (eq? m '*) (etag=-weakly? etag m))) matchlist)) ;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Request parsing ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;; ;; This includes parsers for all RFC-defined headers (define header-parsers (make-parameter `((accept . ,(multiple symbol-subparser-ci `((q . ,quality-subparser)))) (accept-charset . ,(multiple symbol-subparser-ci `((q . ,quality-subparser)))) (accept-encoding . ,(multiple symbol-subparser-ci `((q . ,quality-subparser)))) (accept-language . ,(multiple symbol-subparser-ci `((q . ,quality-subparser)))) (accept-ranges . ,(single symbol-subparser-ci)) (age . ,(single natnum-subparser)) (allow . ,(multiple symbol-subparser)) (authorization . ,authorization-parser) (cache-control . ,cache-control-parser) (connection . ,(multiple symbol-subparser-ci)) (content-encoding . ,(multiple symbol-subparser-ci)) (content-language . ,(multiple symbol-subparser-ci)) (content-length . ,(single natnum-subparser)) (content-location . ,(single normalized-uri)) (content-md5 . ,(single base64-subparser)) (content-range . ,(single range-subparser)) (content-type . ,(single symbol-subparser-ci `((charset . ,symbol-subparser-ci)))) (date . ,(single http-date-subparser)) (etag . ,etag-parser) (expect . ,(single (make-key/value-subparser '()))) (expires . ,(single http-date-subparser)) (from . ,(multiple mailbox-subparser)) (host . ,(single host/port-subparser)) (if-match . ,if-match-parser) (if-modified-since . ,(single http-date-subparser)) (if-none-match . ,if-match-parser) (if-range . ,if-range-parser) (if-unmodified-since . ,(single http-date-subparser)) (last-modified . ,(single http-date-subparser)) (location . ,(single normalized-uri)) (max-forwards . ,(single natnum-subparser)) (pragma . ,pragma-parser) (proxy-authenticate . ,authenticate-parser) (proxy-authorization . ,authorization-parser) (range . ,(multiple range-subparser)) (referer . ,(single normalized-uri)) (retry-after . ,(single retry-after-subparser)) (server . ,software-parser) (te . ,te-parser) (trailer . ,(multiple symbol-subparser-ci)) (transfer-encoding . ,(single symbol-subparser-ci)) (upgrade . ,(multiple product-subparser)) (user-agent . ,software-parser) (vary . ,(multiple symbol-subparser-ci)) (via . ,via-parser) (warning . ,warning-parser) (www-authenticate . ,authenticate-parser) ;; RFC 2183 (content-disposition . ,(single symbol-subparser-ci `((filename . ,filename-subparser) (creation-date . ,rfc1123-subparser) (modification-date . ,rfc1123-subparser) (read-date . ,rfc1123-subparser) (size . ,natnum-subparser)))) ;; RFC 2109 (set-cookie . ,set-cookie-parser) (cookie . ,cookie-parser) ;; ;; TODO: RFC 2965? ;; ;; RFC 6797 (strict-transport-security . ,strict-transport-security-parser) ;; Nonstandard but common headers (x-forwarded-for . ,(multiple identity)) ))) (define header-parse-error-handler ;; ignore errors (make-parameter (lambda (header-name contents headers exn) headers))) ;; The parser is supposed to return a list of header values for its header (define (parse-header name contents) (let* ((default unknown-header-parser) (parser (alist-ref name (header-parsers) eq? default))) (parser contents))) (define (parse-header-line line headers) (or (and-let* ((colon-idx (string-index line #\:)) (header-name (http-name->symbol (string-take line colon-idx))) (contents (string-trim-both (string-drop line (add1 colon-idx))))) (handle-exceptions exn ((header-parse-error-handler) header-name contents headers exn) (update-header-contents! header-name (parse-header header-name contents) headers))) (signal-http-condition 'parse-header-line "Bad header line" (list line) 'header-error 'contents line))) ;; XXXX: Bottleneck? (define (read-headers port) (if (eof-object? (peek-char port)) ; Yeah, so sue me (make-headers '()) (let ((header-limit (http-header-limit)) (line-limit (http-line-limit))) (let lp ((c (read-char port)) (ln '()) (headers (make-headers '())) (hc 0) (len 0)) (cond ((eqv? len line-limit) (raise-line-limit-exceeded-error (reverse-list->string ln) line-limit port)) ((eof-object? c) (if (null? ln) headers (parse-header-line (reverse-list->string ln) headers))) ;; Only accept CRLF (we're not this strict everywhere...) ((and (eqv? c #\return) (eqv? (peek-char port) #\newline)) (read-char port) ; Consume and discard NL (if (null? ln) ; Nothing came before: end of headers headers (let ((pc (peek-char port))) (if (and (not (eof-object? pc)) (or (eqv? pc #\space) (eqv? pc #\tab))) ;; If the next line starts with whitespace, ;; it's a continuation line of the same ;; header. See section 2.2 of RFC 2616. (let skip ((pc (read-char port)) (len len) (ln ln)) (if (and (not (eqv? len line-limit)) (or (eqv? pc #\space) (eqv? pc #\tab))) (skip (read-char port) (add1 len) (cons pc ln)) (lp pc ln headers hc len))) (let* ((ln (reverse-list->string ln)) (headers (parse-header-line ln headers)) (hc (add1 hc))) (when (eqv? hc header-limit) (signal-http-condition 'read-headers "Max allowed header count exceeded" (list port) 'header-limit-exceeded 'contents ln 'headers headers 'limit header-limit)) (lp (read-char port) '() headers hc 0)))))) ((eqv? c #\") (let lp2 ((c2 (read-char port)) (ln (cons c ln)) (len len)) (cond ((or (eqv? 0 len) (eof-object? c2)) (lp c2 ln headers hc len)) ((eqv? c2 #\") (lp (read-char port) (cons c2 ln) headers hc (add1 len))) ((eqv? c2 #\\) (let ((c3 (read-char port)) (len len)) (if (or (eof-object? c3) (eqv? 0 len)) (lp c3 (cons c2 ln) headers hc len) (lp2 (read-char port) (cons c3 (cons c2 ln)) (add1 len))))) (else (lp2 (read-char port) (cons c2 ln) (add1 len)))))) (else (lp (read-char port) (cons c ln) headers hc (add1 len)))))))) (define (signal-http-condition loc msg args type . more-info) (signal (make-composite-condition (make-property-condition 'http) (apply make-property-condition type more-info) (make-property-condition 'exn 'location loc 'message msg 'arguments args)))) (defstruct request (method 'GET) uri (major 1) (minor 1) (headers (make-headers '())) port) ;; Perhaps we should have header parsers indexed by version or ;; something like that, so you can define the maximum version. Useful ;; for when expecting a response. Then we group request/response parsers ;; together, as with request/response unparsers. (define http-0.9-request-parser (let ((req (irregex '(seq (w/nocase "GET") (+ space) (=> uri (* any)))))) (lambda (line in) (and-let* ((m (irregex-match req line)) (uri (normalized-uri (irregex-match-substring m 'uri)))) (make-request method: 'GET uri: uri major: 0 minor: 9 port: in))))) ;; Might want to reuse this elsewhere (define token-sre '(+ (~ "()<>@,;:\\\"/[]?={}\t "))) ;; XXX This actually parses anything >= HTTP/1.0 (define http-1.x-request-parser (let ((req (irregex `(seq (=> method ,token-sre) (+ space) (=> uri (+ (~ blank))) ; uri-common handles details (+ space) (w/nocase "HTTP/") (=> major (+ digit)) "." (=> minor (+ digit)))))) (lambda (line in) (and-let* ((m (irregex-match req line)) (uri-string (irregex-match-substring m 'uri)) (major (string->number (irregex-match-substring m 'major))) (minor (string->number (irregex-match-substring m 'minor))) (method (string->http-method (irregex-match-substring m 'method))) (headers (read-headers in))) (let* ((wildcard (string=? uri-string "*")) (uri (and (not wildcard) (normalized-uri uri-string))) ;; HTTP/1.0 has no chunking (port (if (and (or (> major 1) (>= minor 1)) (memq 'chunked (header-values 'transfer-encoding headers))) (chunked-input-port in) in))) ;; HTTP/1.1 allows several "things" as "URI" (RFC2616, 5.1.2): ;; Request-URI = "*" | absoluteURI | abs_path | authority ;; ;; HTTP/1.0, URIs are more limited (RFC1945, 5.1.2): ;; Request-URI = absoluteURI | abs_path ;; ;; Currently, a plain authority is not accepted. This would ;; require deep changes in the representation of request ;; objects. It is only used in CONNECT requests, so ;; currently not much of a problem. If we want to support ;; this, we'd need a separate object type and expose a ;; parser from uri-generic/uri-common for just authority. (and (or (and wildcard (or (> major 1) (>= minor 1))) (and uri (or (absolute-uri? uri) (and (uri-path-absolute? uri) (not (uri-host uri)))))) (make-request method: method uri: uri major: major minor: minor headers: headers port: port))))))) (define request-parsers ; order matters here (make-parameter (list http-1.x-request-parser))) (define (read-request inport) (let ((line (safe-read-line inport))) (and (not (eof-object? line)) ;; Try each parser in turn to process the request-line. ;; A parser returns either #f or a request object (let loop ((parsers (request-parsers))) (if (null? parsers) (signal-http-condition 'read-request "Unknown protocol line" (list line) 'unknown-protocol-line 'line line) (or ((car parsers) line inport) (loop (cdr parsers)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Request unparsing ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;; (define header-unparsers (make-parameter `((content-disposition . ,content-disposition-unparser) (date . ,rfc1123-unparser) (etag . ,etag-unparser) (expires . ,rfc1123-unparser) (host . ,host/port-unparser) (if-match . ,if-match-unparser) (if-modified-since . ,rfc1123-unparser) (if-none-match . ,if-match-unparser) (if-unmodified-since . ,rfc1123-unparser) (last-modified . ,rfc1123-unparser) (user-agent . ,software-unparser) (server . ,software-unparser) (upgrade . ,product-unparser) (cookie . ,cookie-unparser) (set-cookie . ,set-cookie-unparser) (authorization . ,authorization-unparser) (www-authenticate . ,authenticate-unparser) (proxy-authorization . ,authorization-unparser) (proxy-authenticate . ,authenticate-unparser) (via . ,via-unparser) ;; RFC 6797 (strict-transport-security . ,strict-transport-security-unparser)))) (define (unparse-header header-name header-value) (cond ((and (not (null? header-value)) (eq? 'raw (get-params (car header-value)))) (map get-no-newline-value header-value)) ((assq header-name (header-unparsers)) => (lambda (unparser) ((cdr unparser) header-value))) (else (default-header-unparser header-value)))) (define (unparse-headers headers out) (let ((unparsers (header-unparsers))) ; Don't access parameter for each header (for-each (lambda (h) (let* ((name (car h)) (name-s (symbol->http-name name)) (contents (cdr h)) (unparse (cond ((assq name unparsers) => cdr) ; inlined for perf (else default-header-unparser)))) (handle-exceptions exn (if ((condition-predicate 'http) exn) (signal exn) ;; Do not tamper with our own custom errors (let* ((none "(no error message provided in original exn)") (msg ((condition-property-accessor 'exn 'message none) exn)) (loc ((condition-property-accessor 'exn 'location #f) exn)) (args ((condition-property-accessor 'exn 'arguments '()) exn))) (signal-http-condition 'unparse-headers (sprintf "could not unparse ~S header ~S: ~A~A" name-s contents (if loc (sprintf "(~A) " loc) "") msg) args 'unparse-error 'header-name name 'header-value contents 'unparser unparse 'original-exn exn))) (let ((lines (if (and (not (null? contents)) (eq? 'raw (get-params (car contents)))) (map get-no-newline-value contents) (unparse contents)))) (for-each (lambda (value) ;; Verify there's no \r\n or \r or \n in value? (display (string-append name-s ": " value "\r\n") out)) lines))))) (headers-v headers)))) ;; Use string-append and display rather than fprintf so the line gets ;; written in one burst. This supposedly avoids a strange race ;; condition, see #800. We use string-append instead of sprintf for ;; performance reasons. This is not exported, and our callers compare ;; request-major and request-minor so we can assume they're numbers. (define (write-request-line request) (let ((uri (request-uri request))) (display (string-append (http-method->string (request-method request)) " " (if uri (uri->string uri) "*") " HTTP/" (number->string (request-major request)) "." (number->string (request-minor request)) "\r\n") (request-port request)))) (define (http-0.9-request-unparser request) (display (string-append "GET " (uri->string (request-uri request)) "\r\n") (request-port request)) request) (define (http-1.0-request-unparser request) (and-let* (((= (request-major request) 1)) ((= (request-minor request) 0)) (o (request-port request))) (write-request-line request) (unparse-headers (request-headers request) o) (display "\r\n" o) request)) ;; XXX This actually unparses anything >= HTTP/1.1 (define (http-1.x-request-unparser request) (and-let* (((or (> (request-major request) 1) (and (= (request-major request) 1) (> (request-minor request) 0)))) (o (request-port request))) (write-request-line request) (unparse-headers (request-headers request) o) (display "\r\n" o) (if (memq 'chunked (header-values 'transfer-encoding (request-headers request))) (update-request request port: (chunked-output-port (request-port request))) request))) (define request-unparsers ; order matters here (make-parameter (list http-1.x-request-unparser http-1.0-request-unparser))) (define (write-request request) ;; Try each unparser in turn to write the request-line. ;; An unparser returns either #f or a new request object. (let loop ((unparsers (request-unparsers))) (if (null? unparsers) (let ((major (request-major request)) (minor (request-minor request))) (signal-http-condition 'write-request "Unknown protocol" (list (conc major "." minor)) 'unknown-protocol 'major major 'minor minor)) (or ((car unparsers) request) (loop (cdr unparsers)))))) ;; Required for chunked requests. This is a bit of a hack! (define (finish-request-body request) (when (and (memq 'chunked (header-values 'transfer-encoding (request-headers request))) (eq? (##sys#slot (request-port request) 10) 'chunked-output-port)) (display "0\r\n\r\n" (##sys#slot (request-port request) 11))) request) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Response unparsing ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct response (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port) (define make-response (let ((old-make-response make-response)) (lambda (#!rest args #!key status code reason) (let ((resp (apply old-make-response args))) (when (and status (not code) (not reason)) (response-status-set! resp status)) resp)))) (define update-response (let ((old-update-response update-response)) (lambda (resp #!rest args #!key status code reason) (let ((resp (apply old-update-response resp args))) (when (and status (not code) (not reason)) (response-status-set! resp status)) resp)))) (define (response-status-set! resp status) (receive (code reason) (http-status->code&reason status) (response-code-set! resp code) (response-reason-set! resp reason) resp)) (define (response-class obj) (let ((code (if (response? obj) (response-code obj) obj))) (- code (modulo code 100)))) (define (response-status obj) (let* ((c (if (response? obj) (response-code obj) obj)) (s (find (lambda (x) (= (cadr x) c)) (http-status-codes)))) (if s (car s) (signal-http-condition 'response-status "Unknown status code" (list c) 'unknown-code 'code c)))) (define (http-status->code&reason status) (let ((s (alist-ref status (http-status-codes)))) (unless s (signal-http-condition 'http-status->code&reason ;; haha, status symbol ;) "Unknown response status symbol" (list status) 'unknown-status 'status status)) (values (car s) (cdr s)))) ;; List of HTTP status codes based on: ;; http://www.iana.org/assignments/http-status-codes/http-status-codes.xml (define http-status-codes (make-parameter `((continue . (100 . "Continue")) (switching-protocols . (101 . "Switching Protocols")) (processing . (102 . "Processing")) (ok . (200 . "OK")) (created . (201 . "Created")) (accepted . (202 . "Accepted")) (non-authoritative-information . (203 . "Non-Authoritative Information")) (no-content . (204 . "No Content")) (reset-content . (205 . "Reset Content")) (partial-content . (206 . "Partial Content")) (multi-status . (207 . "Multi-Status")) (already-reported . (208 . "Already Reported")) (im-used . (226 . "IM Used")) (multiple-choices . (300 . "Multiple Choices")) (moved-permanently . (301 . "Moved Permanently")) (found . (302 . "Found")) (see-other . (303 . "See Other")) (not-modified . (304 . "Not Modified")) (use-proxy . (305 . "Use Proxy")) (temporary-redirect . (307 . "Temporary Redirect")) (bad-request . (400 . "Bad Request")) (unauthorized . (401 . "Unauthorized")) (payment-required . (402 . "Payment Required")) (forbidden . (403 . "Forbidden")) (not-found . (404 . "Not Found")) (method-not-allowed . (405 . "Method Not Allowed")) (not-acceptable . (406 . "Not Acceptable")) (proxy-authentication-required . (407 . "Proxy Authentication Required")) (request-time-out . (408 . "Request Time-out")) (conflict . (409 . "Conflict")) (gone . (410 . "Gone")) (length-required . (411 . "Length Required")) (precondition-failed . (412 . "Precondition Failed")) (request-entity-too-large . (413 . "Request Entity Too Large")) (request-uri-too-large . (414 . "Request-URI Too Large")) (unsupported-media-type . (415 . "Unsupported Media Type")) (requested-range-not-satisfiable . (416 . "Requested Range Not Satisfiable")) (expectation-failed . (417 . "Expectation Failed")) (unprocessable-entity . (422 . "Unprocessable Entity")) (locked . (423 . "Locked")) (failed-dependency . (424 . "Failed Dependency")) (upgrade-required . (426 . "Upgrade Required")) (precondition-required . (428 . "Precondition Required")) (too-many-requests . (429 . "Too Many Requests")) (request-header-fields-too-large . (431 . "Request Header Fields Too Large")) (internal-server-error . (500 . "Internal Server Error")) (not-implemented . (501 . "Not Implemented")) (bad-gateway . (502 . "Bad Gateway")) (service-unavailable . (503 . "Service Unavailable")) (gateway-time-out . (504 . "Gateway Time-out")) (http-version-not-supported . (505 . "HTTP Version Not Supported")) (insufficient-storage . (507 . "Insufficient Storage")) (loop-detected . (508 . "Loop Detected")) (not-extended . (510 . "Not Extended")) (network-authentication-required . (511 . "Network Authentication Required"))))) (define (http-0.9-response-unparser response) response) ;; The response-body will just follow ;; See notes at write-request-line (define (write-response-line response) (display (string-append "HTTP/" (number->string (response-major response)) "." (number->string (response-minor response)) " " (->string (response-code response)) " " (->string (response-reason response)) "\r\n") (response-port response))) (define (http-1.0-response-unparser response) (and-let* (((= (response-major response) 1)) ((= (response-minor response) 0)) (o (response-port response))) (write-response-line response) (unparse-headers (response-headers response) o) (display "\r\n" o) response)) ;; XXX This actually unparses anything >= HTTP/1.1 (define (http-1.x-response-unparser response) (and-let* (((or (> (response-major response) 1) (and (= (response-major response) 1) (> (response-minor response) 0)))) (o (response-port response))) (write-response-line response) (unparse-headers (response-headers response) o) (display "\r\n" o) (if (memq 'chunked (header-values 'transfer-encoding (response-headers response))) (update-response response port: (chunked-output-port (response-port response))) response))) (define response-unparsers (make-parameter (list http-1.x-response-unparser http-1.0-response-unparser))) (define (write-response response) ;; Try each unparser in turn to write the response-line. ;; An unparser returns either #f or a new response object. (let loop ((unparsers (response-unparsers))) (if (null? unparsers) (let ((major (response-major response)) (minor (response-minor response))) (signal-http-condition 'write-response "Unknown protocol" (list (conc major "." minor)) 'unknown-protocol 'major major 'minor minor)) (or ((car unparsers) response) (loop (cdr unparsers)))))) ;; Required for chunked requests. This is a bit of a hack! (define (finish-response-body response) (when (and (memq 'chunked (header-values 'transfer-encoding (response-headers response))) (eq? (##sys#slot (response-port response) 10) 'chunked-output-port)) (display "0\r\n\r\n" (##sys#slot (response-port response) 11))) response) ;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Response parsing ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;; (define http-1.x-response-parser (let ((resp (irregex '(seq (w/nocase "HTTP/") (=> major (+ digit)) "." (=> minor (+ digit)) ;; Could use '(= 3 digit) for status-code, but ;; that's currently not compilable (+ space) (=> status-code digit digit digit) (+ space) (=> reason-phrase (* nonl)))))) (lambda (line in) (and-let* ((m (irregex-match resp line)) (code (string->number (irregex-match-substring m 'status-code))) (major (string->number (irregex-match-substring m 'major))) (minor (string->number (irregex-match-substring m 'minor))) ((or (> major 1) (and (= major 1) (> minor 0)))) (reason (irregex-match-substring m 'reason-phrase)) (h (read-headers in)) (port (if (memq 'chunked (header-values 'transfer-encoding h)) (chunked-input-port in) in))) (make-response code: code reason: reason major: major minor: minor headers: h port: port))))) (define http-1.0-response-parser (let ((resp (irregex '(seq (w/nocase "HTTP/1.0") ;; Could use '(= 3 digit) for status-code, but ;; that's currently not compilable (+ space) (=> status-code digit digit digit) (+ space) (=> reason-phrase (* nonl)))))) (lambda (line in) (and-let* ((m (irregex-match resp line)) (code (string->number (irregex-match-substring m 'status-code))) (reason (irregex-match-substring m 'reason-phrase)) (h (read-headers in))) ;; HTTP/1.0 has no chunking (make-response code: code reason: reason major: 1 minor: 0 headers: h port: in))))) ;; You can't "detect" a 0.9 response, because there is no response line. ;; It will simply output the body directly, so we will just assume that ;; if we can't recognise the output string, we just got a 0.9 response. (define (http-0.9-response-parser line in) (make-response code: 200 reason: "OK" major: 0 minor: 9 ;; XXX This is wrong, it re-inserts \r\n, while it may have ;; been a \n only. To work around this, we'd have to write ;; a custom (safe-)read-line procedure. ;; However, it does not matter much because HTTP 0.9 is only ;; defined to ever return text/html, no binary or any other ;; content type. port: (call-with-input-string (string-append line "\r\n") (lambda (str) (make-concatenated-port str in))))) (define response-parsers ;; order matters here (make-parameter (list http-1.x-response-parser http-1.0-response-parser))) (define (read-response inport) (let ((line (safe-read-line inport))) (and (not (eof-object? line)) (let loop ((parsers (response-parsers))) (if (null? parsers) (signal-http-condition 'read-response "Unknown protocol line" (list line) 'unknown-protocol-line 'line line) (or ((car parsers) line inport) (loop (cdr parsers)))))))) )