;;; HTTP request objects
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; 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
(define-module (web request)
#:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
+ #:use-module (ice-9 binary-ports)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-9)
#:use-module (web uri)
request-uri
request-version
request-headers
+ request-meta
request-port
read-request
build-request
write-request
- read-request-body/latin-1
- write-request-body/latin-1
-
- read-request-body/bytevector
- write-request-body/bytevector
+ read-request-body
+ write-request-body
;; General headers
;;
;;;
(define-record-type <request>
- (make-request method uri version headers port)
+ (make-request method uri version headers meta port)
request?
(method request-method)
(uri request-uri)
(version request-version)
(headers request-headers)
+ (meta request-meta)
(port request-port))
(define (bad-request message . args)
(throw 'bad-request message args))
+(define (bad-request-printer port key args default-printer)
+ (apply (case-lambda
+ ((msg args)
+ (display "Bad request: " port)
+ (apply format port msg args)
+ (newline port))
+ (_ (default-printer)))
+ args))
+
+(set-exception-printer! 'bad-request bad-request-printer)
+
(define (non-negative-integer? n)
(and (number? n) (>= n 0) (exact? n) (integer? n)))
(let ((h (car headers)))
(if (pair? h)
(let ((k (car h)) (v (cdr h)))
- (if (symbol? k)
- (if (not (valid-header? k v))
- (bad-request "Bad value for header ~a: ~s" k v))
- (if (not (and (string? k) (string? v)))
- (bad-request "Unknown header not a pair of strings: ~s"
- h)))
- (validate-headers (cdr headers)))
+ (if (valid-header? k v)
+ (validate-headers (cdr headers))
+ (bad-request "Bad value for header ~a: ~s" k v)))
(bad-request "Header not a pair: ~a" h)))
(if (not (null? headers))
(bad-request "Headers not a list: ~a" headers))))
-(define* (build-request #:key (method 'GET) uri (version '(1 . 1))
- (headers '()) port (validate-headers? #t))
- (cond
- ((not (and (pair? version)
- (non-negative-integer? (car version))
- (non-negative-integer? (cdr version))))
- (bad-request "Bad version: ~a" version))
- ((not (uri? uri))
- (bad-request "Bad uri: ~a" uri))
- ((and (not port) (memq method '(POST PUT)))
- (bad-request "Missing port for message ~a" method))
- (else
- (if validate-headers?
- (validate-headers headers))))
- (make-request method uri version headers port))
+(define* (build-request uri #:key (method 'GET) (version '(1 . 1))
+ (headers '()) port (meta '())
+ (validate-headers? #t))
+ "Construct an HTTP request object. If VALIDATE-HEADERS? is true,
+the headers are each run through their respective validators."
+ (let ((needs-host? (and (equal? version '(1 . 1))
+ (not (assq-ref headers 'host)))))
+ (cond
+ ((not (and (pair? version)
+ (non-negative-integer? (car version))
+ (non-negative-integer? (cdr version))))
+ (bad-request "Bad version: ~a" version))
+ ((not (uri? uri))
+ (bad-request "Bad uri: ~a" uri))
+ ((and (not port) (memq method '(POST PUT)))
+ (bad-request "Missing port for message ~a" method))
+ ((not (list? meta))
+ (bad-request "Bad metadata alist" meta))
+ ((and needs-host? (not (uri-host uri)))
+ (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a"
+ uri))
+ (else
+ (if validate-headers?
+ (validate-headers headers))))
+ (make-request method uri version
+ (if needs-host?
+ (acons 'host (cons (uri-host uri) (uri-port uri))
+ headers)
+ headers)
+ meta port)))
-(define (read-request port)
+(define* (read-request port #:optional (meta '()))
+ "Read an HTTP request from PORT, optionally attaching the given
+metadata, META.
+
+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 Requests\" in the manual, for
+more information.
+
+Note that the body is not part of the request. Once you have read a
+request, you may read the body separately, and likewise for writing
+requests."
(set-port-encoding! port "ISO-8859-1")
(call-with-values (lambda () (read-request-line port))
(lambda (method uri version)
- (make-request method uri version (read-headers port) port))))
+ (make-request method uri version (read-headers port) meta port))))
+;; FIXME: really return a new request?
(define (write-request r port)
+ "Write the given HTTP request to PORT.
+
+Return a new request, whose ‘request-port’ will continue writing
+on PORT, perhaps using some transfer encoding."
(write-request-line (request-method r) (request-uri r)
(request-version r) port)
(write-headers (request-headers r) port)
(if (eq? port (request-port r))
r
(make-request (request-method r) (request-uri r) (request-version r)
- (request-headers r) port)))
-
-;; Probably not what you want to use "in production". Relies on one byte
-;; per char because we are in latin-1 encoding.
-;;
-(define (read-request-body/latin-1 r)
- (let ((nbytes (request-content-length r)))
- (and nbytes
- (let ((buf (make-string nbytes)))
- (read-delimited! "" buf (request-port r))
- buf))))
-
-;; Likewise, assumes that body can be written in the latin-1 encoding,
-;; and that the latin-1 encoding is what is expected by the server.
-;;
-(define (write-request-body/latin-1 r body)
- (display body (request-port r)))
+ (request-headers r) (request-meta r) port)))
-(define (read-request-body/bytevector r)
+(define (read-request-body r)
+ "Reads the request body from R, as a bytevector. Return ‘#f’
+if there was no request body."
(let ((nbytes (request-content-length r)))
(and nbytes
(let ((bv (get-bytevector-n (request-port r) nbytes)))
(bad-request "EOF while reading request body: ~a bytes of ~a"
(bytevector-length bv) nbytes))))))
-(define (write-request-body/bytevector r bv)
+(define (write-request-body r bv)
+ "Write BV, a bytevector, to the port corresponding to the HTTP
+request R."
(put-bytevector (request-port r) bv))
(define-syntax define-request-accessor
(define-request-accessor user-agent #f)
;; Misc accessors
-(define* (request-absolute-uri r #:optional default-host default-port)
+(define* (request-absolute-uri r #:optional default-host default-port
+ default-scheme)
+ "A helper routine to determine the absolute URI of a request, using the
+‘host’ header and the default host and port."
(let ((uri (request-uri r)))
(if (uri-host uri)
uri
(bad-request
"URI not absolute, no Host header, and no default: ~s"
uri)))))
- (build-uri (uri-scheme uri)
+ (build-uri (or (uri-scheme uri)
+ default-scheme
+ (bad-request "URI not absolute and no default-port"
+ uri))
#:host (car host)
#:port (cdr host)
#:path (uri-path uri)
HCoop / bpt / guile.git / blobdiff