mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
adc91e41bf
* module/web/http.scm (list-of-strings?, write-list-of-strings): Move
definitions up.
(split-header-names, list-of-header-names?, write-header-list): New
helpers.
(declare-header-list-header): New helper.
(cache-control): Use split-header-names for private and no-cache.
(trailer): Use declare-header-list-header to parse known headers to
symbols.
(vary): Likewise, use split-header-names et al.
* test-suite/tests/web-http.test ("general headers"): Add a test.
205 lines
8.6 KiB
Scheme
205 lines
8.6 KiB
Scheme
;;;; 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))
|
|
(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 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 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 "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"))
|