module/web/response.scm

   1 ;;; HTTP response objects
   2
   3 ;; Copyright (C)  2010, 2011, 2012 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18 ;; 02110-1301 USA
  19
  20 ;;; Code:
  21
  22 (define-module (web response)
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (ice-9 binary-ports)
  25   #:use-module (ice-9 rdelim)
  26   #:use-module (srfi srfi-9)
  27   #:use-module (web http)
  28   #:export (response?
  29             response-version
  30             response-code
  31             response-reason-phrase
  32             response-headers
  33             response-port
  34             read-response
  35             build-response
  36             adapt-response-version
  37             write-response
  38
  39             response-must-not-include-body?
  40             read-response-body
  41             write-response-body
  42
  43             ;; General headers
  44             ;;
  45             response-cache-control
  46             response-connection
  47             response-date
  48             response-pragma
  49             response-trailer
  50             response-transfer-encoding
  51             response-upgrade
  52             response-via
  53             response-warning
  54
  55             ;; Entity headers
  56             ;;
  57             response-allow
  58             response-content-encoding
  59             response-content-language
  60             response-content-length
  61             response-content-location
  62             response-content-md5
  63             response-content-range
  64             response-content-type
  65             response-expires
  66             response-last-modified
  67
  68             ;; Response headers
  69             ;;
  70             response-accept-ranges
  71             response-age
  72             response-etag
  73             response-location
  74             response-proxy-authenticate
  75             response-retry-after
  76             response-server
  77             response-vary
  78             response-www-authenticate))
  79
  80
  81 (define-record-type <response>
  82   (make-response version code reason-phrase headers port)
  83   response?
  84   (version response-version)
  85   (code response-code)
  86   (reason-phrase %response-reason-phrase)
  87   (headers response-headers)
  88   (port response-port))
  89
  90 (define (bad-response message . args)
  91   (throw 'bad-response message args))
  92
  93 (define (non-negative-integer? n)
  94   (and (number? n) (>= n 0) (exact? n) (integer? n)))
  95
  96 (define (validate-headers headers)
  97   (if (pair? headers)
  98       (let ((h (car headers)))
  99         (if (pair? h)
 100             (let ((k (car h)) (v (cdr h)))
 101               (if (valid-header? k v)
 102                   (validate-headers (cdr headers))
 103                   (bad-response "Bad value for header ~a: ~s" k v)))
 104             (bad-response "Header not a pair: ~a" h)))
 105       (if (not (null? headers))
 106           (bad-response "Headers not a list: ~a" headers))))
 107
 108 (define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase
 109                          (headers '()) port (validate-headers? #t))
 110   "Construct an HTTP response object. If @var{validate-headers?} is true,
 111 the headers are each run through their respective validators."
 112   (cond
 113    ((not (and (pair? version)
 114               (non-negative-integer? (car version))
 115               (non-negative-integer? (cdr version))))
 116     (bad-response "Bad version: ~a" version))
 117    ((not (and (non-negative-integer? code) (< code 600)))
 118     (bad-response "Bad code: ~a" code))
 119    ((and reason-phrase (not (string? reason-phrase)))
 120     (bad-response "Bad reason phrase" reason-phrase))
 121    (else
 122     (if validate-headers?
 123         (validate-headers headers))))
 124   (make-response version code reason-phrase headers port))
 125
 126 (define *reason-phrases*
 127   '((100 . "Continue")
 128     (101 . "Switching Protocols")
 129     (200 . "OK")
 130     (201 . "Created")
 131     (202 . "Accepted")
 132     (203 . "Non-Authoritative Information")
 133     (204 . "No Content")
 134     (205 . "Reset Content")
 135     (206 . "Partial Content")
 136     (300 . "Multiple Choices")
 137     (301 . "Moved Permanently")
 138     (302 . "Found")
 139     (303 . "See Other")
 140     (304 . "Not Modified")
 141     (305 . "Use Proxy")
 142     (307 . "Temporary Redirect")
 143     (400 . "Bad Request")
 144     (401 . "Unauthorized")
 145     (402 . "Payment Required")
 146     (403 . "Forbidden")
 147     (404 . "Not Found")
 148     (405 . "Method Not Allowed")
 149     (406 . "Not Acceptable")
 150     (407 . "Proxy Authentication Required")
 151     (408 . "Request Timeout")
 152     (409 . "Conflict")
 153     (410 . "Gone")
 154     (411 . "Length Required")
 155     (412 . "Precondition Failed")
 156     (413 . "Request Entity Too Large")
 157     (414 . "Request-URI Too Long")
 158     (415 . "Unsupported Media Type")
 159     (416 . "Requested Range Not Satisfiable")
 160     (417 . "Expectation Failed")
 161     (500 . "Internal Server Error")
 162     (501 . "Not Implemented")
 163     (502 . "Bad Gateway")
 164     (503 . "Service Unavailable")
 165     (504 . "Gateway Timeout")
 166     (505 . "HTTP Version Not Supported")))
 167
 168 (define (code->reason-phrase code)
 169   (or (assv-ref *reason-phrases* code)
 170       "(Unknown)"))
 171
 172 (define (response-reason-phrase response)
 173   "Return the reason phrase given in @var{response}, or the standard
 174 reason phrase for the response's code."
 175   (or (%response-reason-phrase response)
 176       (code->reason-phrase (response-code response))))
 177
 178 (define (read-response port)
 179   "Read an HTTP response from @var{port}.
 180
 181 As a side effect, sets the encoding on @var{port} to
 182 ISO-8859-1 (latin-1), so that reading one character reads one byte.  See
 183 the discussion of character sets in \"HTTP Responses\" in the manual,
 184 for more information."
 185   (set-port-encoding! port "ISO-8859-1")
 186   (call-with-values (lambda () (read-response-line port))
 187     (lambda (version code reason-phrase)
 188       (make-response version code reason-phrase (read-headers port) port))))
 189
 190 (define (adapt-response-version response version)
 191   "Adapt the given response to a different HTTP version.  Returns a new
 192 HTTP response.
 193
 194 The idea is that many applications might just build a response for the
 195 default HTTP version, and this method could handle a number of
 196 programmatic transformations to respond to older HTTP versions (0.9 and
 197 1.0).  But currently this function is a bit heavy-handed, just updating
 198 the version field."
 199   (build-response #:code (response-code response)
 200                   #:version version
 201                   #:headers (response-headers response)
 202                   #:port (response-port response)))
 203
 204 (define (write-response r port)
 205   "Write the given HTTP response to @var{port}.
 206
 207 Returns a new response, whose @code{response-port} will continue writing
 208 on @var{port}, perhaps using some transfer encoding."
 209   (write-response-line (response-version r) (response-code r)
 210                        (response-reason-phrase r) port)
 211   (write-headers (response-headers r) port)
 212   (display "\r\n" port)
 213   (if (eq? port (response-port r))
 214       r
 215       (make-response (response-version r) (response-code r)
 216                      (response-reason-phrase r) (response-headers r) port)))
 217
 218 (define (response-must-not-include-body? r)
 219   "Returns @code{#t} if the response @var{r} is not permitted to have a body.
 220
 221 This is true for some response types, like those with code 304."
 222   ;; RFC 2616, section 4.3.
 223   (or (<= 100 (response-code r) 199)
 224       (= (response-code r) 204)
 225       (= (response-code r) 304)))
 226
 227 (define (read-response-body r)
 228   "Reads the response body from @var{r}, as a bytevector.  Returns
 229 @code{#f} if there was no response body."
 230   (let ((nbytes (response-content-length r)))
 231     (and nbytes
 232          (let ((bv (get-bytevector-n (response-port r) nbytes)))
 233            (if (= (bytevector-length bv) nbytes)
 234                bv
 235                (bad-response "EOF while reading response body: ~a bytes of ~a"
 236                             (bytevector-length bv) nbytes))))))
 237
 238 (define (write-response-body r bv)
 239   "Write @var{bv}, a bytevector, to the port corresponding to the HTTP
 240 response @var{r}."
 241   (put-bytevector (response-port r) bv))
 242
 243 (define-syntax define-response-accessor
 244   (lambda (x)
 245     (syntax-case x ()
 246       ((_ field)
 247        #'(define-response-accessor field #f))
 248       ((_ field def) (identifier? #'field)
 249        #`(define* (#,(datum->syntax
 250                       #'field
 251                       (symbol-append 'response- (syntax->datum #'field)))
 252                    response
 253                    #:optional (default def))
 254            (cond
 255             ((assq 'field (response-headers response)) => cdr)
 256             (else default)))))))
 257
 258 ;; General headers
 259 ;;
 260 (define-response-accessor cache-control '())
 261 (define-response-accessor connection '())
 262 (define-response-accessor date #f)
 263 (define-response-accessor pragma '())
 264 (define-response-accessor trailer '())
 265 (define-response-accessor transfer-encoding '())
 266 (define-response-accessor upgrade '())
 267 (define-response-accessor via '())
 268 (define-response-accessor warning '())
 269
 270 ;; Entity headers
 271 ;;
 272 (define-response-accessor allow '())
 273 (define-response-accessor content-encoding '())
 274 (define-response-accessor content-language '())
 275 (define-response-accessor content-length #f)
 276 (define-response-accessor content-location #f)
 277 (define-response-accessor content-md5 #f)
 278 (define-response-accessor content-range #f)
 279 (define-response-accessor content-type #f)
 280 (define-response-accessor expires #f)
 281 (define-response-accessor last-modified #f)
 282
 283 ;; Response headers
 284 ;;
 285 (define-response-accessor accept-ranges #f)
 286 (define-response-accessor age #f)
 287 (define-response-accessor etag #f)
 288 (define-response-accessor location #f)
 289 (define-response-accessor proxy-authenticate #f)
 290 (define-response-accessor retry-after #f)
 291 (define-response-accessor server #f)
 292 (define-response-accessor vary '())
 293 (define-response-accessor www-authenticate #f)