Initial CHICKEN 5 port of intarweb 1.72.0

1 files changed, 1055 insertions, 0 deletions

diff --git a/intarweb.scm b/intarweb.scm
new file mode 100644
index 0000000..3df4690
--- /dev/null
+++ b/intarweb.scm
@@ -0,0 +1,1055 @@
+;;;
+;;; 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))))))))
+
+)