;;; HTTP messages
-;; Copyright (C) 2010, 2011, 2012 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.
(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 @code{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 *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-set:whitespace)) ; "delimiter zero"
(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))
(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>
;;
;; 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"))