;;; HTTP messages
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 q)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
#:use-module (web uri)
#:export (string->header
header->string
declare-header!
+ declare-opaque-header!
known-header?
header-parser
header-validator
read-request-line
write-request-line
read-response-line
- write-response-line))
+ write-response-line
-
-;;; TODO
-;;;
-;;; Look at quality lists with more insight.
-;;; Think about `accept' a bit more.
-;;;
+ make-chunked-input-port
+ make-chunked-output-port))
(define (string->header name)
- "Parse @var{name} to a symbolic header name."
+ "Parse NAME to a symbolic header name."
(string->symbol (string-downcase name)))
(define-record-type <header-decl>
validator
writer
#:key multiple?)
- "Define a parser, validator, and writer for the HTTP header, @var{name}.
-
-@var{parser} should be a procedure that takes a string and returns a
-Scheme value. @var{validator} is a predicate for whether the given
-Scheme value is valid for this header. @var{writer} takes a value and a
-port, and writes the value to the port."
+ "Declare a parser, validator, and writer for a given header."
(if (and (string? name) parser validator writer)
(let ((decl (make-header-decl name parser validator writer multiple?)))
(hashq-set! *declared-headers* (string->header name) decl)
(error "bad header decl" name parser validator writer multiple?)))
(define (header->string sym)
- "Return the string form for the header named @var{sym}."
+ "Return the string form for the header named SYM."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-name decl)
(string-titlecase (symbol->string sym)))))
(define (known-header? sym)
- "Return @code{#t} if there are parsers and writers registered for this
-header, otherwise @code{#f}."
+ "Return ‘#t’ iff SYM is a known header, with associated
+parsers and serialization procedures."
(and (lookup-header-decl sym) #t))
(define (header-parser sym)
- "Returns a procedure to parse values for the given header."
+ "Return the value parser for headers named SYM. The result is a
+procedure that takes one argument, a string, and returns the parsed
+value. If the header isn't known to Guile, a default parser is returned
+that passes through the string unchanged."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-parser decl)
(lambda (x) x))))
(define (header-validator sym)
- "Returns a procedure to validate values for the given header."
+ "Return a predicate which returns ‘#t’ if the given value is valid
+for headers named SYM. The default validator for unknown headers
+is ‘string?’."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-validator decl)
string?)))
(define (header-writer sym)
- "Returns a procedure to write values for the given header to a given
-port."
+ "Return a procedure that writes values for headers named SYM to a
+port. The resulting procedure takes two arguments: a value and a port.
+The default writer is ‘display’."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-writer decl)
(define *eof* (call-with-input-string "" read))
(define (read-header port)
- "Reads one HTTP header from @var{port}. Returns two values: the header
+ "Reads one HTTP header from PORT. Returns two values: the header
name and the parsed Scheme value. May raise an exception if the header
was known but the value was invalid.
sym
(read-continuation-line
port
- (string-trim-both line char-whitespace? (1+ delim)))))))))
+ (string-trim-both line char-set:whitespace (1+ delim)))))))))
(define (parse-header sym val)
- "Parse @var{val}, a string, with the parser registered for the header
-named @var{sym}.
-
-Returns the parsed value. If a parser was not found, the value is
-returned as a string."
+ "Parse VAL, a string, with the parser registered for the header
+named SYM. Returns the parsed value."
((header-parser sym) val))
(define (valid-header? sym val)
- "Returns a true value iff @var{val} is a valid Scheme value for the
-header with name @var{sym}."
+ "Returns a true value iff VAL is a valid Scheme value for the
+header with name SYM."
(if (symbol? sym)
((header-validator sym) val)
(error "header name not a symbol" sym)))
(define (write-header sym val port)
- "Writes the given header name and value to @var{port}. If @var{sym}
-is a known header, uses the specific writer registered for that header.
-Otherwise the value is written using @var{display}."
+ "Write the given header name and value to PORT, using the writer
+from ‘header-writer’."
(display (header->string sym) port)
(display ": " port)
((header-writer sym) val port)
(display "\r\n" port))
(define (read-headers port)
- "Read an HTTP message from @var{port}, returning the headers as an
-ordered alist."
+ "Read the headers of an HTTP message from PORT, returning them
+as an ordered alist."
(let lp ((headers '()))
(call-with-values (lambda () (read-header port))
(lambda (k v)
(lp (acons k v headers)))))))
(define (write-headers headers port)
- "Write the given header alist to @var{port}. Doesn't write the final
-\\r\\n, as the user might want to add another header."
+ "Write the given header alist to PORT. Doesn't write the final
+@samp{\\r\\n}, as the user might want to add another header."
(let lp ((headers headers))
(if (pair? headers)
(begin
(define (bad-header sym val)
(throw 'bad-header sym val))
(define (bad-header-component sym val)
- (throw 'bad-header sym val))
+ (throw 'bad-header-component sym val))
+
+(define (bad-header-printer port key args default-printer)
+ (apply (case-lambda
+ ((sym val)
+ (format port "Bad ~a header: ~a\n" (header->string sym) val))
+ (_ (default-printer)))
+ args))
+(define (bad-header-component-printer port key args default-printer)
+ (apply (case-lambda
+ ((sym val)
+ (format port "Bad ~a header component: ~a\n" sym val))
+ (_ (default-printer)))
+ args))
+(set-exception-printer! 'bad-header bad-header-printer)
+(set-exception-printer! 'bad-header-component bad-header-component-printer)
(define (parse-opaque-string str)
str)
(let lp ((i start))
(if (< i end)
(let* ((idx (string-index str delim i end))
- (tok (string-trim-both str char-whitespace? i (or idx end))))
+ (tok (string-trim-both str char-set:whitespace i (or idx end))))
(cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
'())))
(cond
((string-rindex part #\;)
=> (lambda (idx)
- (let ((qpart (string-trim-both part char-whitespace? (1+ idx))))
+ (let ((qpart (string-trim-both part char-set:whitespace (1+ idx))))
(if (string-prefix? "q=" qpart)
(cons (parse-quality qpart 2)
- (string-trim-both part char-whitespace? 0 idx))
+ (string-trim-both part char-set:whitespace 0 idx))
(bad-header-component 'quality qpart)))))
(else
- (cons 1000 (string-trim-both part char-whitespace?)))))
+ (cons 1000 (string-trim-both part char-set:whitespace)))))
(string-split str #\,)))
(define (validate-quality-list l)
;; param-component = token [ "=" (token | quoted-string) ] \
;; *(";" token [ "=" (token | quoted-string) ])
;;
+(define param-delimiters (char-set #\, #\; #\=))
+(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;))
(define* (parse-param-component str #:optional
(val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(if (not (< i end))
(values (reverse! out) end)
- (let ((delim (string-index str
- (lambda (c) (memq c '(#\, #\; #\=)))
- i)))
+ (let ((delim (string-index str param-delimiters i)))
(let ((k (string->symbol
(substring str i (trim-whitespace str i (or delim end)))))
(delimc (and delim (string-ref str delim))))
(if (and (< i end) (eqv? (string-ref str i) #\"))
(parse-qstring str i end #:incremental? #t)
(let ((delim
- (or (string-index
- str
- (lambda (c)
- (or (eqv? c #\;)
- (eqv? c #\,)
- (char-whitespace? c)))
- i end)
+ (or (string-index str param-value-delimiters
+ i end)
end)))
(values (substring str i delim)
delim)))))
port)
(display-digits (date-day date) 2 port)
(display (case (date-month date)
- ((1) " Jan ") ((2) " Feb ") ((3) " Ma ")
+ ((1) " Jan ") ((2) " Feb ") ((3) " Mar ")
((4) " Apr ") ((5) " May ") ((6) " Jun ")
((7) " Jul ") ((8) " Aug ") ((9) " Sep ")
((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
(define* (parse-credentials str #:optional (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let* ((start (skip-whitespace str start end))
- (delim (or (string-index str char-whitespace? start end) end)))
+ (delim (or (string-index str char-set:whitespace start end) end)))
(if (= start end)
(bad-header-component 'authorization str))
(let ((scheme (string->symbol
(define *known-versions* '())
(define* (parse-http-version str #:optional (start 0) (end (string-length str)))
- "Parse an HTTP version from @var{str}, returning it as a major-minor
-pair. For example, @code{HTTP/1.1} parses as the pair of integers,
-@code{(1 . 1)}."
+ "Parse an HTTP version from STR, returning it as a major-minor
+pair. For example, ‘HTTP/1.1’ parses as the pair of integers,
+‘(1 . 1)’."
(or (let lp ((known *known-versions*))
(and (pair? known)
(if (string= str (caar known) start end)
(bad-header-component 'http-version (substring str start end))))))
(define (write-http-version val port)
- "Write the given major-minor version pair to @var{port}."
+ "Write the given major-minor version pair to PORT."
(display "HTTP/" port)
(display (car val) port)
(display #\. port)
;; ourselves the trouble of that case, and disallow the CONNECT method.
;;
(define* (parse-http-method str #:optional (start 0) (end (string-length str)))
- "Parse an HTTP method from @var{str}. The result is an upper-case
-symbol, like @code{GET}."
+ "Parse an HTTP method from STR. The result is an upper-case
+symbol, like ‘GET’."
(cond
((string= str "GET" start end) 'GET)
((string= str "HEAD" start end) 'HEAD)
(bad-request "Invalid URI: ~a" (substring str start end))))))
(define (read-request-line port)
- "Read the first line of an HTTP request from @var{port}, returning
+ "Read the first line of an HTTP request from PORT, returning
three values: the method, the URI, and the version."
(let* ((line (read-line* port))
- (d0 (string-index line char-whitespace?)) ; "delimiter zero"
- (d1 (string-rindex line char-whitespace?)))
+ (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+ (d1 (string-rindex line char-set:whitespace)))
(if (and d0 d1 (< d0 d1))
(values (parse-http-method line 0 d0)
(parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
(display (uri-query uri) port))))
(define (write-request-line method uri version port)
- "Write the first line of an HTTP request to @var{port}."
+ "Write the first line of an HTTP request to PORT."
(display method port)
(display #\space port)
(let ((path (uri-path uri))
(display "\r\n" port))
(define (read-response-line port)
- "Read the first line of an HTTP response from @var{port}, returning
+ "Read the first line of an HTTP response from PORT, returning
three values: the HTTP version, the response code, and the \"reason
phrase\"."
(let* ((line (read-line* port))
- (d0 (string-index line char-whitespace?)) ; "delimiter zero"
- (d1 (and d0 (string-index line char-whitespace?
+ (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+ (d1 (and d0 (string-index line char-set:whitespace
(skip-whitespace line d0)))))
(if (and d0 d1)
(values (parse-http-version line 0 d0)
(parse-non-negative-integer line (skip-whitespace line d0 d1)
d1)
- (string-trim-both line char-whitespace? d1))
+ (string-trim-both line char-set:whitespace d1))
(bad-response "Bad Response-Line: ~s" line))))
(define (write-response-line version code reason-phrase port)
- "Write the first line of an HTTP response to @var{port}."
+ "Write the first line of an HTTP response to PORT."
(write-http-version version port)
(display #\space port)
(display code port)
;; emacs: (put 'declare-header! 'scheme-indent-function 1)
;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
(define (declare-opaque-header! name)
+ "Declares a given header as \"opaque\", meaning that its value is not
+treated specially, and is just returned as a plain string."
(declare-header! name
parse-opaque-string validate-opaque-string write-opaque-string))
(define (declare-uri-header! name)
(declare-header! name
(lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
+ (@@ (web uri) absolute-uri?)
+ write-uri))
+
+;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
+(define (declare-relative-uri-header! name)
+ (declare-header! name
+ (lambda (str)
+ (or ((@@ (web uri) string->uri*) str)
+ (bad-header-component 'uri str)))
uri?
write-uri))
;; Connection = "Connection" ":" 1#(connection-token)
;; connection-token = token
;; e.g.
-;; Connection: close, foo-header
+;; Connection: close, Foo-Header
;;
-(declare-header-list-header! "Connection")
+(declare-header! "Connection"
+ split-header-names
+ list-of-header-names?
+ (lambda (val port)
+ (write-list val port
+ (lambda (x port)
+ (display (if (eq? x 'close)
+ "close"
+ (header->string x))
+ port))
+ ", ")))
;; Date = "Date" ":" HTTP-date
;; e.g.
;; Content-Location = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Content-Location")
+(declare-relative-uri-header! "Content-Location")
;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;;
(map (lambda (x)
(let ((eq (string-index x #\=)))
(if (and eq (= eq (string-rindex x #\=)))
- (cons (string->symbol
- (string-trim x char-whitespace? 0 eq))
- (string-trim-right x char-whitespace? (1+ eq)))
+ (cons
+ (string->symbol
+ (string-trim x char-set:whitespace 0 eq))
+ (string-trim-right x char-set:whitespace (1+ eq)))
(bad-header 'content-type str))))
(cdr parts)))))
(lambda (val)
;; Expires = HTTP-date
;;
-(declare-date-header! "Expires")
+(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))
+
+(declare-header! "Expires"
+ (lambda (str)
+ (if (member str '("0" "-1"))
+ *date-in-the-past*
+ (parse-date str)))
+ date?
+ write-date)
;; Last-Modified = HTTP-date
;;
;; Referer = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Referer")
+(declare-relative-uri-header! "Referer")
;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
;; WWW-Authenticate = 1#challenge
;;
(declare-challenge-list-header! "WWW-Authenticate")
+
+
+;; Chunked Responses
+(define (read-chunk-header port)
+ (let* ((str (read-line port))
+ (extension-start (string-index str (lambda (c) (or (char=? c #\;)
+ (char=? c #\return)))))
+ (size (string->number (if extension-start ; unnecessary?
+ (substring str 0 extension-start)
+ str)
+ 16)))
+ size))
+
+(define (read-chunk port)
+ (let ((size (read-chunk-header port)))
+ (read-chunk-body port size)))
+
+(define (read-chunk-body port size)
+ (let ((bv (get-bytevector-n port size)))
+ (get-u8 port) ; CR
+ (get-u8 port) ; LF
+ bv))
+
+(define* (make-chunked-input-port port #:key (keep-alive? #f))
+ "Returns a new port which translates HTTP chunked transfer encoded
+data from PORT into a non-encoded format. Returns eof when it has
+read the final chunk from PORT. This does not necessarily mean
+that there is no more data on PORT. When the returned port is
+closed it will also close PORT, unless the KEEP-ALIVE? is true."
+ (define (next-chunk)
+ (read-chunk port))
+ (define finished? #f)
+ (define (close)
+ (unless keep-alive?
+ (close-port port)))
+ (define buffer #vu8())
+ (define buffer-size 0)
+ (define buffer-pointer 0)
+ (define (read! bv idx to-read)
+ (define (loop to-read num-read)
+ (cond ((or finished? (zero? to-read))
+ num-read)
+ ((<= to-read (- buffer-size buffer-pointer))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ to-read)
+ (set! buffer-pointer (+ buffer-pointer to-read))
+ (loop 0 (+ num-read to-read)))
+ (else
+ (let ((n (- buffer-size buffer-pointer)))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ n)
+ (set! buffer (next-chunk))
+ (set! buffer-pointer 0)
+ (set! buffer-size (bytevector-length buffer))
+ (set! finished? (= buffer-size 0))
+ (loop (- to-read n)
+ (+ num-read n))))))
+ (loop to-read 0))
+ (make-custom-binary-input-port "chunked input port" read! #f #f close))
+
+(define* (make-chunked-output-port port #:key (keep-alive? #f))
+ "Returns a new port which translates non-encoded data into a HTTP
+chunked transfer encoded data and writes this to PORT. Data
+written to this port is buffered until the port is flushed, at which
+point it is all sent as one chunk. Take care to close the port when
+done, as it will output the remaining data, and encode the final zero
+chunk. When the port is closed it will also close PORT, unless
+KEEP-ALIVE? is true."
+ (define (q-for-each f q)
+ (while (not (q-empty? q))
+ (f (deq! q))))
+ (define queue (make-q))
+ (define (put-char c)
+ (enq! queue c))
+ (define (put-string s)
+ (string-for-each (lambda (c) (enq! queue c))
+ s))
+ (define (flush)
+ ;; It is important that we do _not_ write a chunk if the queue is
+ ;; empty, since it will be treated as the final chunk.
+ (unless (q-empty? queue)
+ (let ((len (q-length queue)))
+ (display (number->string len 16) port)
+ (display "\r\n" port)
+ (q-for-each (lambda (elem) (write-char elem port))
+ queue)
+ (display "\r\n" port))))
+ (define (close)
+ (flush)
+ (display "0\r\n" port)
+ (force-output port)
+ (unless keep-alive?
+ (close-port port)))
+ (make-soft-port (vector put-char put-string flush #f close) "w"))