module/web/response.scm

   1 ;;; HTTP response objects
   2
   3 ;; Copyright (C)  2010 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 (rnrs io 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             write-response
  37
  38             read-response-body/latin-1
  39             write-response-body/latin-1
  40
  41             read-response-body/bytevector
  42             write-response-body/bytevector
  43
  44             ;; General headers
  45             ;;
  46             response-cache-control
  47             response-connection
  48             response-date
  49             response-pragma
  50             response-trailer
  51             response-transfer-encoding
  52             response-upgrade
  53             response-via
  54             response-warning
  55
  56             ;; Entity headers
  57             ;;
  58             response-allow
  59             response-content-encoding
  60             response-content-language
  61             response-content-length
  62             response-content-location
  63             response-content-md5
  64             response-content-range
  65             response-content-type
  66             response-expires
  67             response-last-modified
  68
  69             ;; Response headers
  70             ;;
  71             response-accept-ranges
  72             response-age
  73             response-etag
  74             response-location
  75             response-proxy-authenticate
  76             response-retry-after
  77             response-server
  78             response-vary
  79             response-www-authenticate))
  80
  81
  82 (define-record-type <response>
  83   (make-response version code reason-phrase headers port)
  84   response?
  85   (version response-version)
  86   (code response-code)
  87   (reason-phrase %response-reason-phrase)
  88   (headers response-headers)
  89   (port response-port))
  90
  91 (define (bad-response message . args)
  92   (throw 'bad-response message args))
  93
  94 (define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase
  95                          (headers '()) port)
  96   (make-response version code reason-phrase headers port))
  97
  98 (define *reason-phrases*
  99   '((100 . "Continue")
 100     (101 . "Switching Protocols")
 101     (200 . "OK")
 102     (201 . "Created")
 103     (202 . "Accepted")
 104     (203 . "Non-Authoritative Information")
 105     (204 . "No Content")
 106     (205 . "Reset Content")
 107     (206 . "Partial Content")
 108     (300 . "Multiple Choices")
 109     (301 . "Moved Permanently")
 110     (302 . "Found")
 111     (303 . "See Other")
 112     (304 . "Not Modified")
 113     (305 . "Use Proxy")
 114     (307 . "Temporary Redirect")
 115     (400 . "Bad Request")
 116     (401 . "Unauthorized")
 117     (402 . "Payment Required")
 118     (403 . "Forbidden")
 119     (404 . "Not Found")
 120     (405 . "Method Not Allowed")
 121     (406 . "Not Acceptable")
 122     (407 . "Proxy Authentication Required")
 123     (408 . "Request Timeout")
 124     (409 . "Conflict")
 125     (410 . "Gone")
 126     (411 . "Length Required")
 127     (412 . "Precondition Failed")
 128     (413 . "Request Entity Too Large")
 129     (414 . "Request-URI Too Long")
 130     (415 . "Unsupported Media Type")
 131     (416 . "Requested Range Not Satisfiable")
 132     (417 . "Expectation Failed")
 133     (500 . "Internal Server Error")
 134     (501 . "Not Implemented")
 135     (502 . "Bad Gateway")
 136     (503 . "Service Unavailable")
 137     (504 . "Gateway Timeout")
 138     (505 . "HTTP Version Not Supported")))
 139
 140 (define (code->reason-phrase code)
 141   (or (assv-ref *reason-phrases* code)
 142       "(Unknown)"))
 143
 144 (define (response-reason-phrase response)
 145   (or (%response-reason-phrase response)
 146       (code->reason-phrase (response-code response))))
 147
 148 (define (read-response port)
 149   (set-port-encoding! port "ISO-8859-1")
 150   (call-with-values (lambda () (read-response-line port))
 151     (lambda (version code reason-phrase)
 152       (make-response version code reason-phrase (read-headers port) port))))
 153
 154 (define (write-response r port)
 155   (write-response-line (response-version r) (response-code r)
 156                        (response-reason-phrase r) port)
 157   (write-headers (response-headers r) port)
 158   (display "\r\n" port)
 159   (if (eq? port (response-port r))
 160       r
 161       (make-response (response-version r) (response-code r)
 162                      (response-reason-phrase r) (response-headers r) port)))
 163
 164 ;; Probably not what you want to use "in production". Relies on one byte
 165 ;; per char because we are in latin-1 encoding.
 166 ;;
 167 (define (read-response-body/latin-1 r)
 168   (let ((nbytes (response-content-length r)))
 169     (and nbytes
 170          (let ((buf (make-string nbytes)))
 171            (read-delimited! "" buf (response-port r))
 172            buf))))
 173
 174 ;; Likewise, assumes that body can be written in the latin-1 encoding,
 175 ;; and that the latin-1 encoding is what is expected by the server.
 176 ;;
 177 (define (write-response-body/latin-1 r body)
 178   (display body (response-port r)))
 179
 180 (define (read-response-body/bytevector r)
 181   (let ((nbytes (response-content-length r)))
 182     (and nbytes
 183          (let ((bv (get-bytevector-n (response-port r) nbytes)))
 184            (if (= (bytevector-length bv) nbytes)
 185                bv
 186                (bad-response "EOF while reading response body: ~a bytes of ~a"
 187                             (bytevector-length bv) nbytes))))))
 188
 189 (define (write-response-body/bytevector r bv)
 190   (put-bytevector (response-port r) bv))
 191
 192 (define-syntax define-response-accessor
 193   (lambda (x)
 194     (syntax-case x ()
 195       ((_ field)
 196        #'(define-response-accessor field #f))
 197       ((_ field def) (identifier? #'field)
 198        #`(define* (#,(datum->syntax
 199                       #'field
 200                       (symbol-append 'response- (syntax->datum #'field)))
 201                    response
 202                    #:optional (default def))
 203            (cond
 204             ((assq 'field (response-headers response)) => cdr)
 205             (else default)))))))
 206
 207 ;; General headers
 208 ;;
 209 (define-response-accessor cache-control '())
 210 (define-response-accessor connection '())
 211 (define-response-accessor date #f)
 212 (define-response-accessor pragma '())
 213 (define-response-accessor trailer '())
 214 (define-response-accessor transfer-encoding '())
 215 (define-response-accessor upgrade '())
 216 (define-response-accessor via '())
 217 (define-response-accessor warning '())
 218
 219 ;; Entity headers
 220 ;;
 221 (define-response-accessor allow '())
 222 (define-response-accessor content-encoding '())
 223 (define-response-accessor content-language '())
 224 (define-response-accessor content-length #f)
 225 (define-response-accessor content-location #f)
 226 (define-response-accessor content-md5 #f)
 227 (define-response-accessor content-range #f)
 228 (define-response-accessor content-type #f)
 229 (define-response-accessor expires #f)
 230 (define-response-accessor last-modified #f)
 231
 232 ;; Response headers
 233 ;;
 234 (define-response-accessor accept-ranges #f)
 235 (define-response-accessor age #f)
 236 (define-response-accessor etag #f)
 237 (define-response-accessor location #f)
 238 (define-response-accessor proxy-authenticate #f)
 239 (define-response-accessor retry-after #f)
 240 (define-response-accessor server #f)
 241 (define-response-accessor vary '())
 242 (define-response-accessor www-authenticate #f)