;;; ;;; Intarweb is an improved HTTP library for Chicken ;;; ;; Copyright (c) 2008-2012, 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 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 read-headers http-0.9-request-parser http-1.x-request-parser http-0.9-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 http-0.9-response-parser http-1.x-response-parser http-0.9-response-unparser 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 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 product-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 must-be-quoted-chars quote-string unparse-token default-header-unparser etag-unparser host/port-unparser product-unparser rfc1123-unparser cookie-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 foreign) (use extras ports data-structures srfi-1 srfi-13 srfi-14 irregex posix base64 defstruct uri-common files) ;; The below can all be #f if you want no limit (define http-line-limit (make-parameter 1024)) (define http-header-limit (make-parameter 256)) (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 "Max allowed URLencoded request size exceeded" (list request max-length) 'urlencoded-request-data-limit-exceeded 'contents data 'limit limit) (form-urldecode data)))) (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))) (signal-http-condition "Max allowed line length exceeded" (list p) 'line-limit-exceeded 'contents line 'limit limit) 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)))))))) ;; 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) (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) (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) ;; Hack to insert trailer in chunked ports (define *end-of-transfer-object* (list 'eot)) ;; Make an output port automatically "chunked" (define (chunked-output-port port) (make-output-port (lambda (s) ; write (if (eq? *end-of-transfer-object* s) (fprintf port "0\r\n\r\n") ; trailer? (fprintf port "~X\r\n~A\r\n" (string-length s) s))) (lambda () ; close (close-output-port port)) (lambda () ; flush (flush-output 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 (zero? chunk-length) (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)) (if chunk-length (set! position 0) (set! position #f))))))))) (make-input-port (lambda () ; read (check-position) (if position (let ((char (read-char port))) (if (not (eof-object? char)) (set! position (add1 position))) char) #!eof)) (lambda () ; ready? (check-position) (and position (char-ready? port))) (lambda () ; close (close-input-port port)) (lambda () ; peek (check-position) (if position (peek-char port) #!eof))))) ;; 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. (define request-has-message-body? (make-parameter (lambda (req) (let ((headers (request-headers req))) (or (header-contents headers 'content-length) (header-contents headers 'transfer-encoding)))))) ;; 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 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 . ,product-parser) (te . ,te-parser) (trailer . ,(multiple symbol-subparser-ci)) (transfer-encoding . ,(single symbol-subparser-ci)) (upgrade . ,(multiple update-header-contents!)) (user-agent . ,product-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) ;; RFC 2965? ;; 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 "Bad header line" (list line) 'header-error 'contents line))) (define (read-headers port) (let ((first-line (safe-read-line port)) (limit (http-header-limit))) (if (or (eof-object? first-line) (string-null? first-line)) (make-headers '()) (let loop ((num-lines 2) (prev-line first-line) (line (safe-read-line port)) (headers (make-headers '()))) (cond ((or (eof-object? line) (string-null? line)) (if (string-null? prev-line) headers (parse-header-line prev-line headers))) ((and limit (> num-lines limit)) (signal-http-condition "Max allowed header count exceeded" (list port) 'header-limit-exceeded 'contents line 'limit limit)) ((char-whitespace? (string-ref line 0)) ; Continuation char? ;; This shouldn't count a new header line but add to the read-limit (loop (add1 num-lines) (string-append prev-line line) (safe-read-line port) headers)) ((string=? (string-take-right prev-line 1) "\\") ; escaped? ;; XXX Test if this works with all combinations of \r\n ;; with prepended backslashes. We don't care about ;; malformed stuff like "foo\\\\\n" or \ with missing " (loop (add1 num-lines) (string-append prev-line "\n" line) (safe-read-line port) headers)) (else (loop (add1 num-lines) line (safe-read-line port) (parse-header-line prev-line headers)))))))) (define (signal-http-condition msg args type . more-info) (signal (make-composite-condition (make-property-condition 'http) (apply make-property-condition type more-info) (make-property-condition 'exn '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 (normalized-uri (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))) (make-request method: method uri: uri major: major minor: minor headers: headers port: in))))) (define request-parsers ; order matters here (make-parameter (list http-1.x-request-parser http-0.9-request-parser))) (define (read-request inport) (let* ((line (safe-read-line inport)) ;; A bit ugly, but simpler than the alternatives (line (if (eof-object? line) "" 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 "Unknown protocol line" 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 . ,product-unparser) (server . ,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)))) (define (unparse-header header-name header-value) (let* ((def default-header-unparser) (unparser (alist-ref header-name (header-unparsers) eq? def))) (unparser header-value))) (define (unparse-headers headers out) (for-each (lambda (h) (let* ((name (car h)) (name-s (symbol->http-name name)) (contents (cdr h))) (for-each (lambda (value) ;; Verify there's no \r\n or \r or \n in value? (fprintf out "~A: ~A\r\n" name-s value)) (unparse-header name contents)))) (headers-v headers))) (define (write-request-line request) (fprintf (request-port request) "~A ~A HTTP/~A.~A\r\n" (http-method->string (request-method request)) (uri->string (request-uri request)) (request-major request) (request-minor request))) (define (http-0.9-request-unparser request) (fprintf (request-port request) "GET ~A\r\n" (uri->string (request-uri 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 http-0.9-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 "Unknown protocol" (list (conc major "." minor)) 'unknown-protocol 'major major 'minor minor)) (or ((car unparsers) request) (loop (cdr unparsers)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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 "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 "Unknown response status symbol" (list status) 'unknown-status 'status status)) (values (car s) (cdr s)))) (define http-status-codes (make-parameter `((continue . (100 . "Continue")) (switching-protocols . (101 . "Switching Protocols")) (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")) (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")) (request-range-not-satisfiable . (416 . "Requested range not satisfiable")) (expectation-failed . (417 . "Expectation Failed")) (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"))))) (define (http-0.9-response-unparser response) response) ;; The response-body will just follow (define (write-response-line response) (fprintf (response-port response) "HTTP/~A.~A ~A ~A\r\n" (response-major response) (response-minor response) (response-code response) (response-reason 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 http-0.9-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 "Unknown protocol" (list (conc major "." minor)) 'unknown-protocol 'major major 'minor minor)) (or ((car unparsers) response) (loop (cdr unparsers)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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. ;; If this is not desired, just change response-parsers to exclude this one. (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 http-0.9-response-parser))) (define (read-response inport) (let* ((line (safe-read-line inport)) (line (if (eof-object? line) "" line))) (let loop ((parsers (response-parsers))) (if (null? parsers) (signal-http-condition "Unknown protocol" (list line) 'unknown-protocol-line 'line line) (or ((car parsers) line inport) (loop (cdr parsers))))))) )