summaryrefslogtreecommitdiff
path: root/module/web/response.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/web/response.scm')
-rw-r--r--module/web/response.scm379
1 files changed, 379 insertions, 0 deletions
diff --git a/module/web/response.scm b/module/web/response.scm
new file mode 100644
index 000000000..06e1c6dc1
--- /dev/null
+++ b/module/web/response.scm
@@ -0,0 +1,379 @@
+;;; HTTP response objects
+
+;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (web response)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module (web http)
+ #:export (response?
+ response-version
+ response-code
+ response-reason-phrase
+ response-headers
+ response-port
+ read-response
+ build-response
+ adapt-response-version
+ write-response
+
+ response-must-not-include-body?
+ response-body-port
+ read-response-body
+ write-response-body
+
+ ;; General headers
+ ;;
+ response-cache-control
+ response-connection
+ response-date
+ response-pragma
+ response-trailer
+ response-transfer-encoding
+ response-upgrade
+ response-via
+ response-warning
+
+ ;; Entity headers
+ ;;
+ response-allow
+ response-content-encoding
+ response-content-language
+ response-content-length
+ response-content-location
+ response-content-md5
+ response-content-range
+ response-content-type
+ text-content-type?
+ response-expires
+ response-last-modified
+
+ ;; Response headers
+ ;;
+ response-accept-ranges
+ response-age
+ response-etag
+ response-location
+ response-proxy-authenticate
+ response-retry-after
+ response-server
+ response-vary
+ response-www-authenticate))
+
+
+(define-record-type <response>
+ (make-response version code reason-phrase headers port)
+ response?
+ (version response-version)
+ (code response-code)
+ (reason-phrase %response-reason-phrase)
+ (headers response-headers)
+ (port response-port))
+
+(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 (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 *reason-phrases*
+ '((100 . "Continue")
+ (101 . "Switching Protocols")
+ (200 . "OK")
+ (201 . "Created")
+ (202 . "Accepted")
+ (203 . "Non-Authoritative Information")
+ (204 . "No Content")
+ (205 . "Reset Content")
+ (206 . "Partial Content")
+ (300 . "Multiple Choices")
+ (301 . "Moved Permanently")
+ (302 . "Found")
+ (303 . "See Other")
+ (304 . "Not Modified")
+ (305 . "Use Proxy")
+ (307 . "Temporary Redirect")
+ (400 . "Bad Request")
+ (401 . "Unauthorized")
+ (402 . "Payment Required")
+ (403 . "Forbidden")
+ (404 . "Not Found")
+ (405 . "Method Not Allowed")
+ (406 . "Not Acceptable")
+ (407 . "Proxy Authentication Required")
+ (408 . "Request Timeout")
+ (409 . "Conflict")
+ (410 . "Gone")
+ (411 . "Length Required")
+ (412 . "Precondition Failed")
+ (413 . "Request Entity Too Large")
+ (414 . "Request-URI Too Long")
+ (415 . "Unsupported Media Type")
+ (416 . "Requested Range Not Satisfiable")
+ (417 . "Expectation Failed")
+ (500 . "Internal Server Error")
+ (501 . "Not Implemented")
+ (502 . "Bad Gateway")
+ (503 . "Service Unavailable")
+ (504 . "Gateway Timeout")
+ (505 . "HTTP Version Not Supported")))
+
+(define (code->reason-phrase code)
+ (or (assv-ref *reason-phrases* code)
+ "(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)
+ (put-string port "\r\n")
+ (if (eq? port (response-port r))
+ r
+ (make-response (response-version r) (response-code r)
+ (response-reason-phrase r) (response-headers r) port)))
+
+(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)
+ ;; Read at most LEN bytes in total. HTTP/1.1 doesn't say what to do
+ ;; when a server provides more than the Content-Length, but it seems
+ ;; wise to just stop reading at LEN.
+ (let ((count (min count (- len bytes-read))))
+ (let loop ((ret (get-bytevector-n! port bv start count)))
+ (cond ((eof-object? ret)
+ (if (= bytes-read len)
+ 0 ; EOF
+ (fail)))
+ ((and (zero? ret) (> count 0))
+ ;; Do not return zero since zero means EOF, so try again.
+ (loop (get-bytevector-n! port bv start count)))
+ (else
+ (set! bytes-read (+ bytes-read ret))
+ ret)))))
+
+ (define close
+ (and (not keep-alive?)
+ (lambda ()
+ (close-port 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
+ (cond
+ ((member '(chunked) (response-transfer-encoding r))
+ (make-chunked-input-port (response-port r)
+ #:keep-alive? keep-alive?))
+ ((response-content-length r)
+ => (lambda (len)
+ (make-delimited-input-port (response-port r)
+ len keep-alive?)))
+ ((response-must-not-include-body? r)
+ #f)
+ ((or (memq 'close (response-connection r))
+ (and (equal? (response-version r) '(1 . 0))
+ (not (memq 'keep-alive (response-connection r)))))
+ (response-port r))
+ (else
+ ;; Here we have a message with no transfer encoding, no
+ ;; content-length, and a response that won't necessarily be closed
+ ;; by the server. Not much we can do; assume that the client
+ ;; knows how to handle it.
+ (response-port r))))
+
+ (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."
+ (let ((body (and=> (response-body-port r #:decode? #f)
+ get-bytevector-all)))
+ ;; Reading a body of length 0 will result in get-bytevector-all
+ ;; returning the EOF object.
+ (if (eof-object? body)
+ #vu8()
+ body)))
+
+(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
+ (lambda (x)
+ (syntax-case x ()
+ ((_ field)
+ #'(define-response-accessor field #f))
+ ((_ field def) (identifier? #'field)
+ #`(define* (#,(datum->syntax
+ #'field
+ (symbol-append 'response- (syntax->datum #'field)))
+ response
+ #:optional (default def))
+ (cond
+ ((assq 'field (response-headers response)) => cdr)
+ (else default)))))))
+
+;; General headers
+;;
+(define-response-accessor cache-control '())
+(define-response-accessor connection '())
+(define-response-accessor date #f)
+(define-response-accessor pragma '())
+(define-response-accessor trailer '())
+(define-response-accessor transfer-encoding '())
+(define-response-accessor upgrade '())
+(define-response-accessor via '())
+(define-response-accessor warning '())
+
+;; Entity headers
+;;
+(define-response-accessor allow '())
+(define-response-accessor content-encoding '())
+(define-response-accessor content-language '())
+(define-response-accessor content-length #f)
+(define-response-accessor content-location #f)
+(define-response-accessor content-md5 #f)
+(define-response-accessor content-range #f)
+(define-response-accessor content-type #f)
+(define-response-accessor expires #f)
+(define-response-accessor last-modified #f)
+
+;; Response headers
+;;
+(define-response-accessor accept-ranges #f)
+(define-response-accessor age #f)
+(define-response-accessor etag #f)
+(define-response-accessor location #f)
+(define-response-accessor proxy-authenticate #f)
+(define-response-accessor retry-after #f)
+(define-response-accessor server #f)
+(define-response-accessor vary '())
+(define-response-accessor www-authenticate #f)