fix bad-request-printer

[bpt/guile.git] / module / web / request.scm

;;; HTTP request 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 request)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-9)
  #:use-module (web uri)
  #:use-module (web http)
  #:export (request?
            request-method
            request-uri
            request-version
            request-headers
            request-meta
            request-port
            
            read-request
            build-request
            write-request

            read-request-body
            write-request-body

            ;; General headers
            ;;
            request-cache-control
            request-connection
            request-date
            request-pragma
            request-trailer
            request-transfer-encoding
            request-upgrade
            request-via
            request-warning
            
            ;; Entity headers
            ;;
            request-allow
            request-content-encoding
            request-content-language
            request-content-length
            request-content-location
            request-content-md5
            request-content-range
            request-content-type
            request-expires
            request-last-modified
            
            ;; Request headers
            ;;
            request-accept
            request-accept-charset
            request-accept-encoding
            request-accept-language
            request-authorization
            request-expect
            request-from
            request-host
            request-if-match
            request-if-modified-since
            request-if-none-match
            request-if-range
            request-if-unmodified-since
            request-max-forwards
            request-proxy-authorization
            request-range
            request-referer
            request-te
            request-user-agent

            ;; Misc
            request-absolute-uri))


;;; {Character Encodings, Strings, and Bytevectors}
;;; 
;;; Requests are read from over the wire, and as such have to be treated
;;; very carefully.
;;;
;;; The header portion of the message is defined to be in a subset of
;;; ASCII, and may be processed either byte-wise (using bytevectors and
;;; binary I/O) or as characters in a single-byte ASCII-compatible
;;; encoding.
;;;
;;; We choose the latter, processing as strings in the latin-1
;;; encoding. This allows us to use all the read-delimited machinery,
;;; character sets, and regular expressions, shared substrings, etc.
;;;
;;; The characters in the header values may themselves encode other
;;; bytes or characters -- basically each header has its own parser. We
;;; leave that as a header-specific topic.
;;;
;;; The body is present if the content-length header is present. Its
;;; format and, if textual, encoding is determined by the headers, but
;;; its length is encoded in bytes. So we just slurp that number of
;;; characters in latin-1, knowing that the number of characters
;;; corresponds to the number of bytes, and then convert to a
;;; bytevector, perhaps for later decoding.
;;;

(define-record-type <request>
  (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)))
                                    
(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-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 uri #:key (method 'GET) (version '(1 . 1))
                        (headers '()) port (meta '())
                        (validate-headers? #t))
  "Construct an HTTP request object. If @var{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 #:optional (meta '()))
  "Read an HTTP request from @var{port}, optionally attaching the given
metadata, @var{meta}.

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 Requests\" in the manual, for
more information."
  (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) meta port))))

;; FIXME: really return a new request?
(define (write-request r port)
  "Write the given HTTP request to @var{port}.

Returns a new request, whose @code{request-port} will continue writing
on @var{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)
  (display "\r\n" port)
  (if (eq? port (request-port r))
      r
      (make-request (request-method r) (request-uri r) (request-version r)
                    (request-headers r) (request-meta r) port)))

(define (read-request-body r)
  "Reads the request body from @var{r}, as a bytevector.  Returns
@code{#f} if there was no request body."
  (let ((nbytes (request-content-length r)))
    (and nbytes
         (let ((bv (get-bytevector-n (request-port r) nbytes)))
           (if (= (bytevector-length bv) nbytes)
               bv
               (bad-request "EOF while reading request body: ~a bytes of ~a"
                            (bytevector-length bv) nbytes))))))

(define (write-request-body r bv)
  "Write @var{bv}, a bytevector, to the port corresponding to the HTTP
request @var{r}."
  (put-bytevector (request-port r) bv))

(define-syntax define-request-accessor
  (lambda (x)
    (syntax-case x ()
      ((_ field)
       #'(define-request-accessor field #f))
      ((_ field def) (identifier? #'field)
       #`(define* (#,(datum->syntax
                      #'field
                      (symbol-append 'request- (syntax->datum #'field)))
                   request
                   #:optional (default def))
           (cond
            ((assq 'field (request-headers request)) => cdr)
            (else default)))))))

;; General headers
;;
(define-request-accessor cache-control '())
(define-request-accessor connection '())
(define-request-accessor date #f)
(define-request-accessor pragma '())
(define-request-accessor trailer '())
(define-request-accessor transfer-encoding '())
(define-request-accessor upgrade '())
(define-request-accessor via '())
(define-request-accessor warning '())

;; Entity headers
;;
(define-request-accessor allow '())
(define-request-accessor content-encoding '())
(define-request-accessor content-language '())
(define-request-accessor content-length #f)
(define-request-accessor content-location #f)
(define-request-accessor content-md5 #f)
(define-request-accessor content-range #f)
(define-request-accessor content-type #f)
(define-request-accessor expires #f)
(define-request-accessor last-modified #f)

;; Request headers
;;
(define-request-accessor accept '())
(define-request-accessor accept-charset '())
(define-request-accessor accept-encoding '())
(define-request-accessor accept-language '())
(define-request-accessor authorization #f)
(define-request-accessor expect '())
(define-request-accessor from #f)
(define-request-accessor host #f)
;; Absence of an if-directive appears to be different from `*'.
(define-request-accessor if-match #f)
(define-request-accessor if-modified-since #f)
(define-request-accessor if-none-match #f)
(define-request-accessor if-range #f)
(define-request-accessor if-unmodified-since #f)
(define-request-accessor max-forwards #f)
(define-request-accessor proxy-authorization #f)
(define-request-accessor range #f)
(define-request-accessor referer #f)
(define-request-accessor te '())
(define-request-accessor user-agent #f)

;; Misc accessors
(define* (request-absolute-uri r #:optional default-host default-port)
  (let ((uri (request-uri r)))
    (if (uri-host uri)
        uri
        (let ((host
               (or (request-host r)
                   (if default-host
                       (cons default-host default-port)
                       (bad-request
                        "URI not absolute, no Host header, and no default: ~s"
                        uri)))))
          (build-uri (uri-scheme uri)
                     #:host (car host)
                     #:port (cdr host)
                     #:path (uri-path uri)
                     #:query (uri-query uri)
                     #:fragment (uri-fragment uri))))))