#| -*-Scheme-*-
-$Id: http-syntax.scm,v 1.2 2008/09/17 06:31:48 cph Exp $
+$Id: http-syntax.scm,v 1.3 2008/09/21 07:35:03 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define (read-http-headers port)
(let loop ((headers '()))
- (let ((string (%read-http-header port)))
+ (let ((string (read-rfc2822-folded-line port)))
(if string
(loop (cons (parse-header string) headers))
(reverse! headers)))))
-(define (%read-http-header port)
- (let ((line (read-line port)))
- (if (eof-object? line)
- (error "Premature EOF reading header."))
- (if (string-null? line)
- #f
- (let loop ((lines (list (string-trim-right line))))
- (cond ((char-wsp? (peek-char port))
- (loop (cons (string-trim (read-line port)) lines)))
- ((null? (cdr lines))
- (car lines))
- (else
- (decorated-string-append "" " " "" (reverse! lines))))))))
-
(define parse-header
(let ((parser
(*parser
(define-header "Transfer-Encoding"
(tokenized-parser
- (list-parser
- (encapsulate cons
- (seq lp:token
- lp:parameter*))))
+ (lp:comma-list 1
+ (list-parser
+ (encapsulate cons
+ (seq lp:token
+ lp:parameter*)))))
(lambda (value)
- (pair-of-type? value
- http-token?
- http-parameters?))
+ (list-of-type? value
+ (lambda (elt)
+ (pair-of-type? elt
+ http-token?
+ http-parameters?))))
(lambda (value port)
- (write-http-token (car value) port)
- (write-parameter* (cdr value) port)))
+ (write-comma-list (lambda (elt port)
+ (write-http-token (car elt) port)
+ (write-parameter* (cdr elt) port))
+ value
+ port)))
(define-header "Upgrade"
(tokenized-parser (lp:comma-list 1 lp:product))
http-date?
write-http-date)
\f
+;;;; Chunked encoding
+
+(define (parse-http-chunk-leader string)
+ (lp:chunk-leader (string->tokens string)
+ (lambda (tokens vals lose)
+ (if (null? tokens)
+ (structure-parser-values-ref vals 0)
+ (lose)))
+ (lambda ()
+ #f)))
+
+(define lp:chunk-leader
+ (list-parser
+ (encapsulate cons
+ (seq (transform (lambda (s)
+ (let ((n (string->number s 16 #f)))
+ (and n
+ (list n))))
+ lp:token-string)
+ (encapsulate list
+ (* lp:semicolon
+ lp:parameter%))))))
+\f
;;;; Utilities
(define initialize-package!
#| -*-Scheme-*-
-$Id: httpio.scm,v 14.9 2008/09/17 06:31:50 cph Exp $
+$Id: httpio.scm,v 14.10 2008/09/21 07:35:06 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(receive (method uri version)
(parse-line parse-request-line line "HTTP request line")
(let ((headers (read-http-headers port)))
- (make-http-request method uri version headers
- (or (%read-delimited-body headers port)
- (%no-read-body))))))))
+ (let ((b.t
+ (or (%read-chunked-body headers port)
+ (%read-delimited-body headers port)
+ (%no-read-body))))
+ (make-http-request method uri version
+ (append! headers (cdr b.t))
+ (car b.t))))))))
(define (read-http-response request port)
(%text-mode port)
(receive (version status reason)
(parse-line parse-response-line line "HTTP response line")
(let ((headers (read-http-headers port)))
- (make-http-response version status reason headers
- (if (or (non-body-status? status)
- (string=? (http-request-method request)
- "HEAD"))
- #f
- (or (%read-delimited-body headers port)
- (%read-terminal-body headers port)
- (%no-read-body)))))))))
+ (let ((b.t
+ (if (or (non-body-status? status)
+ (string=? (http-request-method request) "HEAD"))
+ (list #f)
+ (or (%read-chunked-body headers port)
+ (%read-delimited-body headers port)
+ (%read-terminal-body headers port)
+ (%no-read-body)))))
+ (make-http-response version status reason
+ (append! headers (cdr b.t))
+ (car b.t))))))))
+\f
+(define (%read-chunked-body headers port)
+ (let ((h (http-header 'TRANSFER-ENCODING headers #f)))
+ (and h
+ (let ((v (http-header-parsed-value h)))
+ (and (not (default-object? v))
+ (assq 'CHUNKED v)))
+ (let ((output (open-output-octets))
+ (buffer (make-vector-8b #x1000)))
+ (let loop ()
+ (let ((n (%read-chunk-leader port)))
+ (if (> n 0)
+ (begin
+ (%read-chunk n buffer port output)
+ (%text-mode port)
+ (let ((line (read-line port)))
+ (if (not (string-null? line))
+ (error "Missing CRLF after chunk data.")))
+ (loop)))))
+ (cons (get-output-string! output)
+ (read-http-headers port))))))
+
+(define (%read-chunk-leader port)
+ (%text-mode port)
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ (error "Premature EOF in HTTP message body."))
+ (let ((v (parse-http-chunk-leader line)))
+ (if (not v)
+ (error "Ill-formed chunk in HTTP message body."))
+ (car v))))
-(define (%read-all port)
+(define (%read-chunk n buffer port output)
(%binary-mode port)
- (call-with-output-octets
- (lambda (output)
- (let ((buffer (make-vector-8b #x1000)))
- (let loop ()
- (let ((n (read-string! buffer port)))
- (if (> n 0)
- (begin
- (write-substring buffer 0 n output)
- (loop)))))))))
+ (let ((len (vector-8b-length buffer)))
+ (let loop ((n n))
+ (if (> n 0)
+ (let ((m (read-substring! buffer 0 (min n len) port)))
+ (if (= m 0)
+ (error "Premature EOF in HTTP message body."))
+ (write-substring buffer 0 m output)
+ (loop (- n m)))))))
(define (%read-delimited-body headers port)
(let ((n (%get-content-length headers)))
(and n
- (begin
- (%binary-mode port)
- (call-with-output-octets
- (lambda (output)
- (let ((buffer (make-vector-8b #x1000)))
- (let loop ((n n))
- (if (> n 0)
- (let ((m (read-string! buffer port)))
- (if (= m 0)
- (error "Premature EOF in HTTP message body."))
- (write-substring buffer 0 m output)
- (loop (- n m))))))))))))
+ (list
+ (call-with-output-octets
+ (lambda (output)
+ (%read-chunk n (make-vector-8b #x1000) port output)))))))
(define (%read-terminal-body headers port)
(and (let ((h (http-header 'CONNECTION headers #f)))
(let ((v (http-header-parsed-value h)))
(and (not (default-object? v))
(memq 'CLOSE v)))))
- (%read-all port)))
+ (list (%read-all port))))
+
+(define (%read-all port)
+ (%binary-mode port)
+ (call-with-output-octets
+ (lambda (output)
+ (let ((buffer (make-vector-8b #x1000)))
+ (let loop ()
+ (let ((n (read-string! buffer port)))
+ (if (> n 0)
+ (begin
+ (write-substring buffer 0 n output)
+ (loop)))))))))
(define (%no-read-body)
(error "Unable to determine HTTP message body length."))
#| -*-Scheme-*-
-$Id: rfc2822-headers.scm,v 14.2 2008/09/15 07:07:51 cph Exp $
+$Id: rfc2822-headers.scm,v 14.3 2008/09/21 07:35:13 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define (read-rfc2822-headers port)
(let loop ((headers '()))
- (let ((line (read-line port)))
- (if (eof-object? line)
- (parse-error port "Premature EOF reading header fields."))
- (let ((end (string-length line)))
- (cond ((fix:= end 0)
- (map (lambda (p)
- (make-rfc2822-header (car p) (cdr p)))
- (reverse! headers)))
- ((char-wsp? (string-ref line 0))
- (if (not (pair? headers))
- (parse-error port
- "Unmatched header continuation in request:"
- line))
- (let ((h (car headers)))
- (set-cdr! h
- (string-append (cdr h)
- " "
- (trim-wsp line 0 end))))
- (loop headers))
- (else
- (loop
- (cons (let ((colon (string-find-next-char line #\:)))
- (if (not colon)
- (parse-error port
- "Missing colon in header field:"
- line))
- (let ((name (intern (string-head line colon))))
- (guarantee-header-name name)
- (cons name
- (trim-wsp line (fix:+ colon 1) end))))
- headers))))))))
-
-(define (trim-wsp string start end)
- (let* ((start*
- (let loop ((i start))
- (if (and (fix:< i end)
- (char-wsp? (string-ref string i)))
- (loop (fix:+ i 1))
- i)))
- (end*
- (let loop ((i end))
- (if (and (fix:> i start*)
- (char-wsp? (string-ref string (fix:- i 1))))
- (loop (fix:- i 1))
- i))))
- (let ((string
- (if (and (fix:= start* 0)
- (fix:= end* (string-length string)))
- string
- (substring string start* end*))))
- (guarantee-header-value string)
- string)))
+ (let ((header (read-rfc2822-header port)))
+ (if header
+ (loop (cons header headers))
+ (reverse! headers)))))
+
+(define (read-rfc2822-header port)
+ (let ((line (read-rfc2822-folded-line port)))
+ (and line
+ (let ((colon (string-find-next-char line #\:)))
+ (if (not colon)
+ (parse-error port "Missing colon in header field:" line))
+ (make-rfc2822-header (intern (string-head line colon))
+ (let ((end (string-length line)))
+ (substring line
+ (skip-wsp-left line
+ (fix:+ colon 1)
+ end)
+ end)))))))
+
+(define (read-rfc2822-folded-line port)
+ (let ((line (read-line port)))
+ (cond ((string-null? line)
+ #f)
+ ((char-wsp? (string-ref line 0))
+ (parse-error port
+ "Unmatched continuation line:"
+ 'READ-RFC2822-FOLDED-LINE))
+ (else
+ (call-with-output-string
+ (lambda (out)
+ (let loop ((line line))
+ (let ((end (skip-wsp-right line 0 (string-length line))))
+ (write-substring line
+ (skip-wsp-left line 0 end)
+ end
+ out))
+ (if (let ((char (peek-char port)))
+ (if (eof-object? char)
+ (parse-error port
+ "Premature EOF:"
+ 'READ-RFC2822-FOLDED-LINE))
+ (char-wsp? char))
+ (begin
+ (write-char #\space out)
+ (loop (read-line port)))))))))))
+
+(define (skip-wsp-left string start end)
+ (let loop ((i start))
+ (if (and (fix:< i end)
+ (char-wsp? (string-ref string i)))
+ (loop (fix:+ i 1))
+ i)))
+
+(define (skip-wsp-right string start end)
+ (let loop ((i end))
+ (if (and (fix:> i start)
+ (char-wsp? (string-ref string (fix:- i 1))))
+ (loop (fix:- i 1))
+ i)))
\f
;;;; Quotation
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.683 2008/09/17 06:31:54 cph Exp $
+$Id: runtime.pkg,v 14.684 2008/09/21 07:35:15 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
make-rfc2822-header
parser:rfc2822-quoted-string
quote-rfc2822-text
+ read-rfc2822-folded-line
read-rfc2822-headers
rfc2822-header-name
rfc2822-header-value
http-version?
make-http-header
make-http-version
+ parse-http-chunk-leader
parse-http-status
parse-http-token
parse-http-version
projects / mit-scheme.git / commitdiff