mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-13 23:20:32 +02:00
Code Activity

add HTTP request module

Browse source 
* module/web/request.scm: Add HTTP request module.
* test-suite/tests/web-request.test: Test cases.

* module/Makefile.am:
* test-suite/Makefile.am: Adapt.
This commit is contained in:
Andy Wingo 2010-10-22 00:06:32 +02:00
parent 440840c113
commit ad05d4e8c6
4 changed files with 380 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

1
module/Makefile.am
View file

@ -350,6 +350,7 @@ LIB_SOURCES = \
WEB_SOURCES = \ WEB_SOURCES = \
web/http.scm \ web/http.scm \
web/request.scm \
web/uri.scm web/uri.scm
EXTRA_DIST += oop/ChangeLog-2008 EXTRA_DIST += oop/ChangeLog-2008

294
module/web/request.scm Normal file
View file

@ -0,0 +1,294 @@
;;; HTTP request objects
;; Copyright (C) 2010 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 (rnrs io 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-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
;; 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 port)
request?
(method request-method)
(uri request-uri)
(version request-version)
(headers request-headers)
(port request-port))
(define (bad-request message . args)
(throw 'bad-request 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 (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)))
(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 (read-request port)
(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))))
(define (write-request r port)
(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) 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)))
(define (read-request-body/bytevector r)
(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/bytevector r bv)
(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))))))

1
test-suite/Makefile.am
View file

@ -151,6 +151,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/vlist.test \ tests/vlist.test \
tests/weaks.test \ tests/weaks.test \
tests/web-http.test \ tests/web-http.test \
tests/web-request.test \
tests/web-uri.test tests/web-uri.test
EXTRA_DIST = \ EXTRA_DIST = \

84
test-suite/tests/web-request.test Normal file
View file

@ -0,0 +1,84 @@
;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010 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
(define-module (test-suite web-request)
#:use-module (web uri)
#:use-module (web request)
#:use-module (test-suite lib))
;; The newlines are equivalent to \n.
(define example-1
"GET /qux HTTP/1.1\r
Host: localhost:8080\r
User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2\r
Accept: application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r
Accept-Encoding: gzip\r
Accept-Language: en-gb, en;q=0.9\r
\r
")
(define (requests-equal? r1 r2)
(and (equal? (request-method r1) (request-method r2))
(equal? (request-uri r1) (request-uri r2))
(equal? (request-version r1) (request-version r2))
(equal? (request-headers r1) (request-headers r2))))
(with-test-prefix "example-1"
(let ((r #f))
(pass-if "read-request"
(begin
(set! r (read-request (open-input-string example-1)))
(request? r)))
(pass-if (equal? (request-method r) 'GET))
(pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux")))
(pass-if (equal? (read-request-body/latin-1 r) #f))
;; Since it's #f, should be an idempotent read, so we can try
;; bytevectors too
(pass-if (equal? (read-request-body/bytevector r) #f))
(pass-if "checking all headers"
(equal?
(request-headers r)
'((host . ("localhost" . 8080))
(user-agent . "Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2")
(accept . (("application/xml")
("application/xhtml+xml")
("text/html" (q . 900))
("text/plain" (q . 800))
("image/png")
("*/*" (q . 500))))
(accept-encoding . ((1000 . "gzip")))
(accept-language . ((1000 . "en-gb") (900 . "en"))))))
;; works because there is no body
(pass-if "write then read"
(requests-equal? (with-input-from-string
(with-output-to-string
(lambda ()
(write-request r (current-output-port))))
(lambda ()
(read-request (current-input-port))))
r))
(pass-if "by accessor"
(equal? (request-accept-encoding r) '((1000 . "gzip"))))))