X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/ad05d4e8c6ccd17a826af3a4df38f055eb3fc9b9..b89432ffbf2990b2f0ca86e848dc7695a0622dba:/module/web/request.scm diff --git a/module/web/request.scm b/module/web/request.scm index 8e29589b3..0a206cf35 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -21,7 +21,7 @@ (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) @@ -31,17 +31,15 @@ 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 ;; @@ -121,17 +119,29 @@ ;;; (define-record-type - (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))) @@ -140,40 +150,67 @@ (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) @@ -181,25 +218,11 @@ (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))) @@ -208,7 +231,9 @@ (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 @@ -275,7 +300,10 @@ (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 @@ -286,7 +314,10 @@ (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)