mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
61fe8eafc2
* module/web/http.scm ("Cache-Control"): Write string values using the
default val writer, to get quoting correct.
* test-suite/tests/web-http.test (pass-if-round-trip): New helper.
("general headers"): Check that cache-extensions round trip properly.
234 lines
10 KiB
Scheme
234 lines
10 KiB
Scheme
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2010, 2011 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)
|
|
(and (equal? (parse-header 'sym str)
|
|
val)
|
|
(valid-header? 'sym val))))))
|
|
|
|
(define-syntax pass-if-round-trip
|
|
(syntax-rules ()
|
|
((_ str)
|
|
(pass-if (format #f "~s round trip" str)
|
|
(equal? (call-with-output-string
|
|
(lambda (port)
|
|
(call-with-values
|
|
(lambda () (read-header (open-input-string str)))
|
|
(lambda (sym val)
|
|
(write-header sym val port)))))
|
|
str)))))
|
|
|
|
(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 '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 '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))
|
|
(pass-if-parse cache-control "no-cache=\"Authorization, Date\""
|
|
'((no-cache . (authorization date))))
|
|
(pass-if-parse cache-control "private=\"Foo\""
|
|
'((private . (foo))))
|
|
(pass-if-parse cache-control "no-cache,max-age=10"
|
|
'(no-cache (max-age . 10)))
|
|
(pass-if-parse cache-control "max-stale" '(max-stale))
|
|
(pass-if-parse cache-control "max-stale=10" '((max-stale . 10)))
|
|
(pass-if-round-trip "Cache-Control: acme-cache-extension\r\n")
|
|
(pass-if-round-trip "Cache-Control: acme-cache-extension=20\r\n")
|
|
(pass-if-round-trip "Cache-Control: acme-cache-extension=100 quux\r\n")
|
|
(pass-if-round-trip "Cache-Control: acme-cache-extension=\"100, quux\"\r\n")
|
|
|
|
(pass-if-parse connection "close" '(close))
|
|
(pass-if-parse connection "Content-Encoding" '(content-encoding))
|
|
|
|
(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 date "Wed, 7 Sep 2011 11:25:00 GMT"
|
|
(string->date "Wed, 7 Sep 2011 11:25:00 +0000"
|
|
"~a,~e ~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 trailer "connection, bar" '(connection 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 content-type "foo/bar" '(foo/bar))
|
|
(pass-if-parse content-type "foo/bar; baz=qux" '(foo/bar (baz . "qux")))
|
|
(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")))
|
|
|
|
(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")))
|
|
;; Allow nonstandard .2 to mean 0.2
|
|
(pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
|
|
(pass-if-parse authorization "Basic foooo" '(basic . "foooo"))
|
|
(pass-if-parse authorization "Digest foooo" '(digest foooo))
|
|
(pass-if-parse authorization "Digest foo=bar,baz=qux"
|
|
'(digest (foo . "bar") (baz . "qux")))
|
|
(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 "Basic foooo" '(basic . "foooo"))
|
|
(pass-if-parse proxy-authorization "Digest foooo" '(digest foooo))
|
|
(pass-if-parse proxy-authorization "Digest foo=bar,baz=qux"
|
|
'(digest (foo . "bar") (baz . "qux")))
|
|
(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 "Basic realm=\"guile\""
|
|
'((basic (realm . "guile"))))
|
|
(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 "Basic realm=\"guile\""
|
|
'((basic (realm . "guile")))))
|