module/web/request.scm

   1 ;;; HTTP request 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 request)
  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 uri)
  28   #:use-module (web http)
  29   #:export (request?
  30             request-method
  31             request-uri
  32             request-version
  33             request-headers
  34             request-meta
  35             request-port
  36
  37             read-request
  38             build-request
  39             write-request
  40
  41             read-request-body
  42             write-request-body
  43
  44             ;; General headers
  45             ;;
  46             request-cache-control
  47             request-connection
  48             request-date
  49             request-pragma
  50             request-trailer
  51             request-transfer-encoding
  52             request-upgrade
  53             request-via
  54             request-warning
  55
  56             ;; Entity headers
  57             ;;
  58             request-allow
  59             request-content-encoding
  60             request-content-language
  61             request-content-length
  62             request-content-location
  63             request-content-md5
  64             request-content-range
  65             request-content-type
  66             request-expires
  67             request-last-modified
  68
  69             ;; Request headers
  70             ;;
  71             request-accept
  72             request-accept-charset
  73             request-accept-encoding
  74             request-accept-language
  75             request-authorization
  76             request-expect
  77             request-from
  78             request-host
  79             request-if-match
  80             request-if-modified-since
  81             request-if-none-match
  82             request-if-range
  83             request-if-unmodified-since
  84             request-max-forwards
  85             request-proxy-authorization
  86             request-range
  87             request-referer
  88             request-te
  89             request-user-agent
  90
  91             ;; Misc
  92             request-absolute-uri))
  93
  94
  95 ;;; {Character Encodings, Strings, and Bytevectors}
  96 ;;;
  97 ;;; Requests are read from over the wire, and as such have to be treated
  98 ;;; very carefully.
  99 ;;;
 100 ;;; The header portion of the message is defined to be in a subset of
 101 ;;; ASCII, and may be processed either byte-wise (using bytevectors and
 102 ;;; binary I/O) or as characters in a single-byte ASCII-compatible
 103 ;;; encoding.
 104 ;;;
 105 ;;; We choose the latter, processing as strings in the latin-1
 106 ;;; encoding. This allows us to use all the read-delimited machinery,
 107 ;;; character sets, and regular expressions, shared substrings, etc.
 108 ;;;
 109 ;;; The characters in the header values may themselves encode other
 110 ;;; bytes or characters -- basically each header has its own parser. We
 111 ;;; leave that as a header-specific topic.
 112 ;;;
 113 ;;; The body is present if the content-length header is present. Its
 114 ;;; format and, if textual, encoding is determined by the headers, but
 115 ;;; its length is encoded in bytes. So we just slurp that number of
 116 ;;; characters in latin-1, knowing that the number of characters
 117 ;;; corresponds to the number of bytes, and then convert to a
 118 ;;; bytevector, perhaps for later decoding.
 119 ;;;
 120
 121 (define-record-type <request>
 122   (make-request method uri version headers meta port)
 123   request?
 124   (method request-method)
 125   (uri request-uri)
 126   (version request-version)
 127   (headers request-headers)
 128   (meta request-meta)
 129   (port request-port))
 130
 131 (define (bad-request message . args)
 132   (throw 'bad-request message args))
 133
 134 (define (bad-request-printer port key args default-printer)
 135   (apply (case-lambda
 136            ((msg args)
 137             (display "Bad request: " port)
 138             (apply format port msg args)
 139             (newline port))
 140            (_ (default-printer)))
 141          args))
 142
 143 (set-exception-printer! 'bad-request bad-request-printer)
 144
 145 (define (non-negative-integer? n)
 146   (and (number? n) (>= n 0) (exact? n) (integer? n)))
 147
 148 (define (validate-headers headers)
 149   (if (pair? headers)
 150       (let ((h (car headers)))
 151         (if (pair? h)
 152             (let ((k (car h)) (v (cdr h)))
 153               (if (valid-header? k v)
 154                   (validate-headers (cdr headers))
 155                   (bad-request "Bad value for header ~a: ~s" k v)))
 156             (bad-request "Header not a pair: ~a" h)))
 157       (if (not (null? headers))
 158           (bad-request "Headers not a list: ~a" headers))))
 159
 160 (define* (build-request uri #:key (method 'GET) (version '(1 . 1))
 161                         (headers '()) port (meta '())
 162                         (validate-headers? #t))
 163   "Construct an HTTP request object. If VALIDATE-HEADERS? is true,
 164 the headers are each run through their respective validators."
 165   (let ((needs-host? (and (equal? version '(1 . 1))
 166                           (not (assq-ref headers 'host)))))
 167     (cond
 168      ((not (and (pair? version)
 169                 (non-negative-integer? (car version))
 170                 (non-negative-integer? (cdr version))))
 171       (bad-request "Bad version: ~a" version))
 172      ((not (uri? uri))
 173       (bad-request "Bad uri: ~a" uri))
 174      ((and (not port) (memq method '(POST PUT)))
 175       (bad-request "Missing port for message ~a" method))
 176      ((not (list? meta))
 177       (bad-request "Bad metadata alist" meta))
 178      ((and needs-host? (not (uri-host uri)))
 179       (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a"
 180                    uri))
 181      (else
 182       (if validate-headers?
 183           (validate-headers headers))))
 184     (make-request method uri version
 185                   (if needs-host?
 186                       (acons 'host (cons (uri-host uri) (uri-port uri))
 187                              headers)
 188                       headers)
 189                   meta port)))
 190
 191 (define* (read-request port #:optional (meta '()))
 192   "Read an HTTP request from PORT, optionally attaching the given
 193 metadata, META.
 194
 195 As a side effect, sets the encoding on PORT to
 196 ISO-8859-1 (latin-1), so that reading one character reads one byte.  See
 197 the discussion of character sets in \"HTTP Requests\" in the manual, for
 198 more information.
 199
 200 Note that the body is not part of the request.  Once you have read a
 201 request, you may read the body separately, and likewise for writing
 202 requests."
 203   (set-port-encoding! port "ISO-8859-1")
 204   (call-with-values (lambda () (read-request-line port))
 205     (lambda (method uri version)
 206       (make-request method uri version (read-headers port) meta port))))
 207
 208 ;; FIXME: really return a new request?
 209 (define (write-request r port)
 210   "Write the given HTTP request to PORT.
 211
 212 Return a new request, whose ‘request-port’ will continue writing
 213 on PORT, perhaps using some transfer encoding."
 214   (write-request-line (request-method r) (request-uri r)
 215                       (request-version r) port)
 216   (write-headers (request-headers r) port)
 217   (display "\r\n" port)
 218   (if (eq? port (request-port r))
 219       r
 220       (make-request (request-method r) (request-uri r) (request-version r)
 221                     (request-headers r) (request-meta r) port)))
 222
 223 (define (read-request-body r)
 224   "Reads the request body from R, as a bytevector.  Return ‘#f’
 225 if there was no request body."
 226   (let ((nbytes (request-content-length r)))
 227     (and nbytes
 228          (let ((bv (get-bytevector-n (request-port r) nbytes)))
 229            (if (= (bytevector-length bv) nbytes)
 230                bv
 231                (bad-request "EOF while reading request body: ~a bytes of ~a"
 232                             (bytevector-length bv) nbytes))))))
 233
 234 (define (write-request-body r bv)
 235   "Write BV, a bytevector, to the port corresponding to the HTTP
 236 request R."
 237   (put-bytevector (request-port r) bv))
 238
 239 (define-syntax define-request-accessor
 240   (lambda (x)
 241     (syntax-case x ()
 242       ((_ field)
 243        #'(define-request-accessor field #f))
 244       ((_ field def) (identifier? #'field)
 245        #`(define* (#,(datum->syntax
 246                       #'field
 247                       (symbol-append 'request- (syntax->datum #'field)))
 248                    request
 249                    #:optional (default def))
 250            (cond
 251             ((assq 'field (request-headers request)) => cdr)
 252             (else default)))))))
 253
 254 ;; General headers
 255 ;;
 256 (define-request-accessor cache-control '())
 257 (define-request-accessor connection '())
 258 (define-request-accessor date #f)
 259 (define-request-accessor pragma '())
 260 (define-request-accessor trailer '())
 261 (define-request-accessor transfer-encoding '())
 262 (define-request-accessor upgrade '())
 263 (define-request-accessor via '())
 264 (define-request-accessor warning '())
 265
 266 ;; Entity headers
 267 ;;
 268 (define-request-accessor allow '())
 269 (define-request-accessor content-encoding '())
 270 (define-request-accessor content-language '())
 271 (define-request-accessor content-length #f)
 272 (define-request-accessor content-location #f)
 273 (define-request-accessor content-md5 #f)
 274 (define-request-accessor content-range #f)
 275 (define-request-accessor content-type #f)
 276 (define-request-accessor expires #f)
 277 (define-request-accessor last-modified #f)
 278
 279 ;; Request headers
 280 ;;
 281 (define-request-accessor accept '())
 282 (define-request-accessor accept-charset '())
 283 (define-request-accessor accept-encoding '())
 284 (define-request-accessor accept-language '())
 285 (define-request-accessor authorization #f)
 286 (define-request-accessor expect '())
 287 (define-request-accessor from #f)
 288 (define-request-accessor host #f)
 289 ;; Absence of an if-directive appears to be different from `*'.
 290 (define-request-accessor if-match #f)
 291 (define-request-accessor if-modified-since #f)
 292 (define-request-accessor if-none-match #f)
 293 (define-request-accessor if-range #f)
 294 (define-request-accessor if-unmodified-since #f)
 295 (define-request-accessor max-forwards #f)
 296 (define-request-accessor proxy-authorization #f)
 297 (define-request-accessor range #f)
 298 (define-request-accessor referer #f)
 299 (define-request-accessor te '())
 300 (define-request-accessor user-agent #f)
 301
 302 ;; Misc accessors
 303 (define* (request-absolute-uri r #:optional default-host default-port
 304                                default-scheme)
 305   "A helper routine to determine the absolute URI of a request, using the
 306 ‘host’ header and the default host and port."
 307   (let ((uri (request-uri r)))
 308     (if (uri-host uri)
 309         uri
 310         (let ((host
 311                (or (request-host r)
 312                    (if default-host
 313                        (cons default-host default-port)
 314                        (bad-request
 315                         "URI not absolute, no Host header, and no default: ~s"
 316                         uri)))))
 317           (build-uri (or (uri-scheme uri)
 318                          default-scheme
 319                          (bad-request "URI not absolute and no default-port"
 320                                       uri))
 321                      #:host (car host)
 322                      #:port (cdr host)
 323                      #:path (uri-path uri)
 324                      #:query (uri-query uri)
 325                      #:fragment (uri-fragment uri))))))