;;; HTTP response objects
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012 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
(define-module (web response)
#:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
+ #:use-module (ice-9 binary-ports)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (web http)
#:export (response?
response-port
read-response
build-response
- extend-response
adapt-response-version
write-response
- read-response-body/latin-1
- write-response-body/latin-1
-
- read-response-body/bytevector
- write-response-body/bytevector
+ response-must-not-include-body?
+ response-body-port
+ read-response-body
+ write-response-body
;; General headers
;;
response-content-md5
response-content-range
response-content-type
+ text-content-type?
response-expires
response-last-modified
(define (bad-response message . args)
(throw 'bad-response message args))
+(define (non-negative-integer? n)
+ (and (number? n) (>= n 0) (exact? n) (integer? n)))
+
+(define (validate-headers headers)
+ (if (pair? headers)
+ (let ((h (car headers)))
+ (if (pair? h)
+ (let ((k (car h)) (v (cdr h)))
+ (if (valid-header? k v)
+ (validate-headers (cdr headers))
+ (bad-response "Bad value for header ~a: ~s" k v)))
+ (bad-response "Header not a pair: ~a" h)))
+ (if (not (null? headers))
+ (bad-response "Headers not a list: ~a" headers))))
+
(define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase
- (headers '()) port)
+ (headers '()) port (validate-headers? #t))
+ "Construct an HTTP response object. If VALIDATE-HEADERS? is true,
+the headers are each run through their respective validators."
+ (cond
+ ((not (and (pair? version)
+ (non-negative-integer? (car version))
+ (non-negative-integer? (cdr version))))
+ (bad-response "Bad version: ~a" version))
+ ((not (and (non-negative-integer? code) (< code 600)))
+ (bad-response "Bad code: ~a" code))
+ ((and reason-phrase (not (string? reason-phrase)))
+ (bad-response "Bad reason phrase" reason-phrase))
+ (else
+ (if validate-headers?
+ (validate-headers headers))))
(make-response version code reason-phrase headers port))
-(define (extend-response r k v . additional)
- (let ((r (build-response #:version (response-version r)
- #:code (response-code r)
- #:reason-phrase (%response-reason-phrase r)
- #:headers
- (assoc-set! (copy-tree (response-headers r))
- k v)
- #:port (response-port r))))
- (if (null? additional)
- r
- (apply extend-response r additional))))
-
(define *reason-phrases*
'((100 . "Continue")
(101 . "Switching Protocols")
"(Unknown)"))
(define (response-reason-phrase response)
+ "Return the reason phrase given in RESPONSE, or the standard
+reason phrase for the response's code."
(or (%response-reason-phrase response)
(code->reason-phrase (response-code response))))
+(define (text-content-type? type)
+ "Return #t if TYPE, a symbol as returned by `response-content-type',
+represents a textual type such as `text/plain'."
+ (let ((type (symbol->string type)))
+ (or (string-prefix? "text/" type)
+ (string-suffix? "/xml" type)
+ (string-suffix? "+xml" type))))
+
(define (read-response port)
+ "Read an HTTP response from PORT.
+
+As a side effect, sets the encoding on PORT to
+ISO-8859-1 (latin-1), so that reading one character reads one byte. See
+the discussion of character sets in \"HTTP Responses\" in the manual,
+for more information."
(set-port-encoding! port "ISO-8859-1")
(call-with-values (lambda () (read-response-line port))
(lambda (version code reason-phrase)
(make-response version code reason-phrase (read-headers port) port))))
(define (adapt-response-version response version)
+ "Adapt the given response to a different HTTP version. Returns a new
+HTTP response.
+
+The idea is that many applications might just build a response for the
+default HTTP version, and this method could handle a number of
+programmatic transformations to respond to older HTTP versions (0.9 and
+1.0). But currently this function is a bit heavy-handed, just updating
+the version field."
(build-response #:code (response-code response)
#:version version
#:headers (response-headers response)
#:port (response-port response)))
(define (write-response r port)
+ "Write the given HTTP response to PORT.
+
+Returns a new response, whose ‘response-port’ will continue writing
+on PORT, perhaps using some transfer encoding."
(write-response-line (response-version r) (response-code r)
(response-reason-phrase r) port)
(write-headers (response-headers r) port)
(make-response (response-version r) (response-code r)
(response-reason-phrase r) (response-headers r) port)))
-;; Probably not what you want to use "in production". Relies on one byte
-;; per char because we are in latin-1 encoding.
-;;
-(define (read-response-body/latin-1 r)
- (let ((nbytes (response-content-length r)))
- (and nbytes
- (let ((buf (make-string nbytes)))
- (read-delimited! "" buf (response-port r))
- buf))))
-
-;; Likewise, assumes that body can be written in the latin-1 encoding,
-;; and that the latin-1 encoding is what is expected by the server.
-;;
-(define (write-response-body/latin-1 r body)
- (display body (response-port r)))
-
-(define (read-response-body/bytevector r)
- (let ((nbytes (response-content-length r)))
- (and nbytes
- (let ((bv (get-bytevector-n (response-port r) nbytes)))
- (if (= (bytevector-length bv) nbytes)
- bv
- (bad-response "EOF while reading response body: ~a bytes of ~a"
- (bytevector-length bv) nbytes))))))
-
-(define (write-response-body/bytevector r bv)
+(define (response-must-not-include-body? r)
+ "Returns ‘#t’ if the response R is not permitted to have a body.
+
+This is true for some response types, like those with code 304."
+ ;; RFC 2616, section 4.3.
+ (or (<= 100 (response-code r) 199)
+ (= (response-code r) 204)
+ (= (response-code r) 304)))
+
+(define (make-delimited-input-port port len keep-alive?)
+ "Return an input port that reads from PORT, and makes sure that
+exactly LEN bytes are available from PORT. Closing the returned port
+closes PORT, unless KEEP-ALIVE? is true."
+ (define bytes-read 0)
+
+ (define (fail)
+ (bad-response "EOF while reading response body: ~a bytes of ~a"
+ bytes-read len))
+
+ (define (read! bv start count)
+ (let ((ret (get-bytevector-n! port bv start count)))
+ (if (eof-object? ret)
+ (if (= bytes-read len)
+ 0
+ (fail))
+ (begin
+ (set! bytes-read (+ bytes-read ret))
+ (if (> bytes-read len)
+ (fail)
+ ret)))))
+
+ (define close
+ (and (not keep-alive?)
+ (lambda ()
+ (close port))))
+
+ (make-custom-binary-input-port "delimited input port" read! #f #f close))
+
+(define* (response-body-port r #:key (decode? #t) (keep-alive? #t))
+ "Return an input port from which the body of R can be read. The
+encoding of the returned port is set according to R's ‘content-type’
+header, when it's textual, except if DECODE? is #f. Return #f when no
+body is available.
+
+When KEEP-ALIVE? is #f, closing the returned port also closes R's
+response port."
+ (define port
+ (if (member '(chunked) (response-transfer-encoding r))
+ (make-chunked-input-port (response-port r)
+ #:keep-alive? keep-alive?)
+ (let ((len (response-content-length r)))
+ (and len
+ (make-delimited-input-port (response-port r)
+ len keep-alive?)))))
+
+ (when (and decode? port)
+ (match (response-content-type r)
+ (((? text-content-type?) . props)
+ (set-port-encoding! port
+ (or (assq-ref props 'charset)
+ "ISO-8859-1")))
+ (_ #f)))
+
+ port)
+
+(define (read-response-body r)
+ "Reads the response body from R, as a bytevector. Returns
+‘#f’ if there was no response body."
+ (and=> (response-body-port r #:decode? #f) get-bytevector-all))
+
+(define (write-response-body r bv)
+ "Write BV, a bytevector, to the port corresponding to the HTTP
+response R."
(put-bytevector (response-port r) bv))
(define-syntax define-response-accessor
HCoop / bpt / guile.git / blobdiff