diff options
author | Andy Wingo <wingo@pobox.com> | 2010-10-24 12:36:17 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-11-04 22:52:47 +0100 |
commit | 440840c113c744082b7892315049a4704517215a (patch) | |
tree | 3b3a54cfc9f35e7e7708de8b8c042525e17ccef6 /test-suite | |
parent | 5a2f7fb3156bbcba5ee5ac818526bf40ed43cfe1 (diff) | |
download | guile-440840c113c744082b7892315049a4704517215a.tar.gz |
add HTTP module
* module/web/http.scm: New module, declares known HTTP headers, and
their parsers and unparsers.
* test-suite/tests/web-http.test: Add test suite.
* module/Makefile.am:
* test-suite/Makefile.am: Adapt.
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/web-http.test | 202 |
2 files changed, 203 insertions, 0 deletions
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 0fe9c8560..0f352ce38 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -150,6 +150,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/version.test \ tests/vlist.test \ tests/weaks.test \ + tests/web-http.test \ tests/web-uri.test EXTRA_DIST = \ diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test new file mode 100644 index 000000000..dfc181c18 --- /dev/null +++ b/test-suite/tests/web-http.test @@ -0,0 +1,202 @@ +;;;; web-uri.test --- URI library -*- 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-http) + #:use-module (web uri) + #:use-module (web http) + #:use-module (ice-9 regex) + #:use-module (ice-9 control) + #:use-module (srfi srfi-19) + #:use-module (test-suite lib)) + + +(define-syntax pass-if-named-exception + (syntax-rules () + ((_ name k pat exp) + (pass-if name + (catch 'k + (lambda () exp (error "expected exception" 'k)) + (lambda (k message args) + (if (string-match pat message) + #t + (error "unexpected exception" message args)))))))) + +(define-syntax pass-if-parse + (syntax-rules () + ((_ sym str val) + (pass-if (format #f "~a: ~s -> ~s" 'sym str val) + (call-with-values (lambda () (parse-header (symbol->string 'sym) str)) + (lambda (k v) + (equal? v val))))))) + +(define-syntax pass-if-any-error + (syntax-rules () + ((_ sym str) + (pass-if (format #f "~a: ~s -> any error" 'sym str) + (% (catch #t + (lambda () + (parse-header (symbol->string 'sym) str) + (abort (lambda () (error "expected exception")))) + (lambda (k . args) + #t)) + (lambda (k thunk) + (thunk))))))) + +(define-syntax pass-if-parse-error + (syntax-rules () + ((_ sym str expected-component) + (pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component) + (catch 'bad-header + (lambda () + (parse-header (symbol->string 'sym) str) + (error "expected exception" 'expected-component)) + (lambda (k component arg) + (if (or (not 'expected-component) + (eq? 'expected-component component)) + #t + (error "unexpected exception" component arg)))))))) + +(with-test-prefix "general headers" + + (pass-if-parse cache-control "no-transform" '(no-transform)) + (pass-if-parse cache-control "no-transform,foo" '(no-transform "foo")) + (pass-if-parse cache-control "no-cache" '((no-cache . #t))) + (pass-if-parse cache-control "no-cache,max-age=10" + '((no-cache . #t) (max-age . 10))) + + (pass-if-parse connection "close" '("close")) + (pass-if-parse connection "close, foo" '("close" "foo")) + + (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date) + (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST") + + (pass-if-parse pragma "no-cache" '(no-cache)) + (pass-if-parse pragma "no-cache, foo" '(no-cache "foo")) + + (pass-if-parse trailer "foo, bar" '("foo" "bar")) + + (pass-if-parse transfer-encoding "foo, chunked" '(("foo") (chunked))) + + (pass-if-parse upgrade "qux" '("qux")) + + (pass-if-parse via "xyzzy" '("xyzzy")) + + (pass-if-parse warning "123 foo \"core breach imminent\"" + '((123 "foo" "core breach imminent" #f))) + (pass-if-parse + warning + "123 foo \"core breach imminent\" \"Tue, 15 Nov 1994 08:12:31 GMT\"" + `((123 "foo" "core breach imminent" + ,(string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z"))))) + +(with-test-prefix "entity headers" + (pass-if-parse allow "foo, bar" '("foo" "bar")) + (pass-if-parse content-encoding "qux, baz" '("qux" "baz")) + (pass-if-parse content-language "qux, baz" '("qux" "baz")) + (pass-if-parse content-length "100" 100) + (pass-if-parse content-length "0" 0) + (pass-if-parse content-length "010" 10) + (pass-if-parse content-location "http://foo/" + (build-uri 'http #:host "foo" #:path "/")) + (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *)) + (pass-if-parse content-range "bytes */*" '(bytes * *)) + (pass-if-parse content-range "bytes */30" '(bytes * 30)) + (pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse last-modified "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z"))) + +#; +(parse-header "accept" "text/*;q=0.3, text/html;q=0.7, text/html;level=1") + +#; +(parse-header "expect" "100-continue") + +(with-test-prefix "request headers" + (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1" + '(("text/*" (q . 300)) + ("text/html" (q . 700)) + ("text/html" ("level" . "1")))) + (pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8" + '((1000 . "iso-8859-5") (800 . "unicode-1-1"))) + (pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0" + '((1000 . "gzip") + (500 . "identity") + (0 . "*"))) + (pass-if-parse accept-language "da, en-gb;q=0.8, en;q=0.7" + '((1000 . "da") (800 . "en-gb") (700 . "en"))) + (pass-if-parse authorization "foo" "foo") + (pass-if-parse expect "100-continue, foo" '((100-continue) ("foo"))) + (pass-if-parse from "foo@bar" "foo@bar") + (pass-if-parse host "qux" '("qux" . #f)) + (pass-if-parse host "qux:80" '("qux" . 80)) + (pass-if-parse if-match "\"xyzzy\", W/\"qux\"" + '(("xyzzy" . #t) ("qux" . #f))) + (pass-if-parse if-match "*" '*) + (pass-if-parse if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse if-none-match "\"xyzzy\", W/\"qux\"" + '(("xyzzy" . #t) ("qux" . #f))) + (pass-if-parse if-none-match "*" '*) + (pass-if-parse if-range "\"foo\"" '("foo" . #t)) + (pass-if-parse if-range "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse if-unmodified-since "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse max-forwards "10" 10) + (pass-if-parse max-forwards "00" 0) + (pass-if-parse proxy-authorization "foo" "foo") + (pass-if-parse range "bytes=10-20" '(bytes (10 . 20))) + (pass-if-parse range "bytes=10-" '(bytes (10 . #f))) + (pass-if-parse range "bytes=-20" '(bytes (#f . 20))) + (pass-if-parse range "bytes=-20,-30" '(bytes (#f . 20) (#f . 30))) + (pass-if-parse referer "http://foo/bar?baz" + (build-uri 'http #:host "foo" #:path "/bar" #:query "baz")) + (pass-if-parse te "trailers" '((trailers))) + (pass-if-parse te "trailers,foo" '((trailers) ("foo"))) + (pass-if-parse user-agent "guile" "guile")) + + +;; Response headers +;; +(with-test-prefix "response headers" + (pass-if-parse accept-ranges "foo,bar" '("foo" "bar")) + (pass-if-parse age "30" 30) + (pass-if-parse etag "\"foo\"" '("foo" . #t)) + (pass-if-parse etag "W/\"foo\"" '("foo" . #f)) + (pass-if-parse location "http://other-place" + (build-uri 'http #:host "other-place")) + (pass-if-parse proxy-authenticate "ho-hum" "ho-hum") + (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse retry-after "20" 20) + (pass-if-parse server "guile!" "guile!") + (pass-if-parse vary "*" '*) + (pass-if-parse vary "foo, bar" '("foo" "bar")) + (pass-if-parse www-authenticate "secret" "secret")) |