summaryrefslogtreecommitdiff
path: root/test-suite
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-10-24 12:36:17 +0200
committerAndy Wingo <wingo@pobox.com>2010-11-04 22:52:47 +0100
commit440840c113c744082b7892315049a4704517215a (patch)
tree3b3a54cfc9f35e7e7708de8b8c042525e17ccef6 /test-suite
parent5a2f7fb3156bbcba5ee5ac818526bf40ed43cfe1 (diff)
downloadguile-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.am1
-rw-r--r--test-suite/tests/web-http.test202
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"))