summaryrefslogtreecommitdiff
path: root/module/web/response.scm
blob: 07e1245398db36ba94c5a710c696ae313aa0680f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
;;; HTTP response objects

;; 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
;; 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 rdelim)
  #: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?
            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
            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 @var{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 @var{response}, or the standard
reason phrase for the response's code."
  (or (%response-reason-phrase response)
      (code->reason-phrase (response-code response))))

(define (read-response port)
  "Read an HTTP response from @var{port}.

As a side effect, sets the encoding on @var{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 @var{port}.

Returns a new response, whose @code{response-port} will continue writing
on @var{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)
  (display "\r\n" port)
  (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 @code{#t} if the response @var{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 (read-response-body r)
  "Reads the response body from @var{r}, as a bytevector.  Returns
@code{#f} if there was no response body."
  (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 r bv)
  "Write @var{bv}, a bytevector, to the port corresponding to the HTTP
response @var{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)