mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
6fe2803b45
* module/web/uri.scm (uri-encode): the hexadecimal percent-encoding %HH
is now uppercased as suggested by RFC3986:
"For consistency, URI producers and normalizers should use
uppercase hexadecimal digits for all percent-encodings."
* test-suite/tests/web-uri.test ("encode"): update tests.
263 lines
8.1 KiB
Scheme
263 lines
8.1 KiB
Scheme
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2010, 2011, 2012 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-web-uri)
|
|
#:use-module (web uri)
|
|
#:use-module (ice-9 regex)
|
|
#:use-module (test-suite lib))
|
|
|
|
|
|
;; FIXME: need more decode / encode tests
|
|
|
|
|
|
(define* (uri=? uri #:key scheme userinfo host port path query fragment)
|
|
(and (uri? uri)
|
|
(equal? (uri-scheme uri) scheme)
|
|
(equal? (uri-userinfo uri) userinfo)
|
|
(equal? (uri-host uri) host)
|
|
(equal? (uri-port uri) port)
|
|
(equal? (uri-path uri) path)
|
|
(equal? (uri-query uri) query)
|
|
(equal? (uri-fragment uri) fragment)))
|
|
|
|
(define-syntax pass-if-uri-exception
|
|
(syntax-rules ()
|
|
((_ name pat exp)
|
|
(pass-if name
|
|
(catch 'uri-error
|
|
(lambda () exp (error "expected uri-error exception"))
|
|
(lambda (k message args)
|
|
(if (string-match pat message)
|
|
#t
|
|
(error "unexpected uri-error exception" message args))))))))
|
|
|
|
(with-test-prefix "build-uri"
|
|
(pass-if "ftp:"
|
|
(uri=? (build-uri 'ftp)
|
|
#:scheme 'ftp
|
|
#:path ""))
|
|
|
|
(pass-if "ftp:foo"
|
|
(uri=? (build-uri 'ftp #:path "foo")
|
|
#:scheme 'ftp
|
|
#:path "foo"))
|
|
|
|
(pass-if "ftp://foo"
|
|
(uri=? (build-uri 'ftp #:host "foo")
|
|
#:scheme 'ftp
|
|
#:host "foo"
|
|
#:path ""))
|
|
|
|
(pass-if "ftp://foo/bar"
|
|
(uri=? (build-uri 'ftp #:host "foo" #:path "/bar")
|
|
#:scheme 'ftp
|
|
#:host "foo"
|
|
#:path "/bar"))
|
|
|
|
(pass-if "ftp://foo@bar:22/baz"
|
|
(uri=? (build-uri 'ftp #:userinfo "foo" #:host "bar" #:port 22 #:path "/baz")
|
|
#:scheme 'ftp
|
|
#:userinfo "foo"
|
|
#:host "bar"
|
|
#:port 22
|
|
#:path "/baz"))
|
|
|
|
(pass-if-uri-exception "non-symbol scheme"
|
|
"Expected.*symbol"
|
|
(build-uri "nonsym"))
|
|
|
|
(pass-if-uri-exception "http://bad.host.1"
|
|
"Expected.*host"
|
|
(build-uri 'http #:host "bad.host.1"))
|
|
|
|
(pass-if "http://bad.host.1 (no validation)"
|
|
(uri=? (build-uri 'http #:host "bad.host.1" #:validate? #f)
|
|
#:scheme 'http #:host "bad.host.1" #:path ""))
|
|
|
|
(pass-if "http://1.good.host"
|
|
(uri=? (build-uri 'http #:host "1.good.host")
|
|
#:scheme 'http #:host "1.good.host" #:path ""))
|
|
|
|
(when (memq 'socket *features*)
|
|
(pass-if "http://192.0.2.1"
|
|
(uri=? (build-uri 'http #:host "192.0.2.1")
|
|
#:scheme 'http #:host "192.0.2.1" #:path ""))
|
|
|
|
(pass-if "http://[2001:db8::1]"
|
|
(uri=? (build-uri 'http #:host "2001:db8::1")
|
|
#:scheme 'http #:host "2001:db8::1" #:path ""))
|
|
|
|
(pass-if "http://[::ffff:192.0.2.1]"
|
|
(uri=? (build-uri 'http #:host "::ffff:192.0.2.1")
|
|
#:scheme 'http #:host "::ffff:192.0.2.1" #:path "")))
|
|
|
|
(pass-if-uri-exception "http://foo:not-a-port"
|
|
"Expected.*port"
|
|
(build-uri 'http #:host "foo" #:port "not-a-port"))
|
|
|
|
(pass-if-uri-exception "http://foo:10 but port as string"
|
|
"Expected.*port"
|
|
(build-uri 'http #:host "foo" #:port "10"))
|
|
|
|
(pass-if-uri-exception "http://:10"
|
|
"Expected.*host"
|
|
(build-uri 'http #:port 10))
|
|
|
|
(pass-if-uri-exception "http://foo@"
|
|
"Expected.*host"
|
|
(build-uri 'http #:userinfo "foo")))
|
|
|
|
|
|
(with-test-prefix "string->uri"
|
|
(pass-if "ftp:"
|
|
(uri=? (string->uri "ftp:")
|
|
#:scheme 'ftp
|
|
#:path ""))
|
|
|
|
(pass-if "ftp:foo"
|
|
(uri=? (string->uri "ftp:foo")
|
|
#:scheme 'ftp
|
|
#:path "foo"))
|
|
|
|
(pass-if "ftp://foo/bar"
|
|
(uri=? (string->uri "ftp://foo/bar")
|
|
#:scheme 'ftp
|
|
#:host "foo"
|
|
#:path "/bar"))
|
|
|
|
(pass-if "ftp://foo@bar:22/baz"
|
|
(uri=? (string->uri "ftp://foo@bar:22/baz")
|
|
#:scheme 'ftp
|
|
#:userinfo "foo"
|
|
#:host "bar"
|
|
#:port 22
|
|
#:path "/baz"))
|
|
|
|
(pass-if "http://bad.host.1"
|
|
(not (string->uri "http://bad.host.1")))
|
|
|
|
(pass-if "http://1.good.host"
|
|
(uri=? (string->uri "http://1.good.host")
|
|
#:scheme 'http #:host "1.good.host" #:path ""))
|
|
|
|
(when (memq 'socket *features*)
|
|
(pass-if "http://192.0.2.1"
|
|
(uri=? (string->uri "http://192.0.2.1")
|
|
#:scheme 'http #:host "192.0.2.1" #:path ""))
|
|
|
|
(pass-if "http://[2001:db8::1]"
|
|
(uri=? (string->uri "http://[2001:db8::1]")
|
|
#:scheme 'http #:host "2001:db8::1" #:path ""))
|
|
|
|
(pass-if "http://[2001:db8::1]:80"
|
|
(uri=? (string->uri "http://[2001:db8::1]:80")
|
|
#:scheme 'http
|
|
#:host "2001:db8::1"
|
|
#:port 80
|
|
#:path ""))
|
|
|
|
(pass-if "http://[::ffff:192.0.2.1]"
|
|
(uri=? (string->uri "http://[::ffff:192.0.2.1]")
|
|
#:scheme 'http #:host "::ffff:192.0.2.1" #:path "")))
|
|
|
|
(pass-if "http://foo:"
|
|
(uri=? (string->uri "http://foo:")
|
|
#:scheme 'http #:host "foo" #:path ""))
|
|
|
|
(pass-if "http://foo:/"
|
|
(uri=? (string->uri "http://foo:/")
|
|
#:scheme 'http #:host "foo" #:path "/"))
|
|
|
|
(pass-if "http://2012.jsconf.us/"
|
|
(uri=? (string->uri "http://2012.jsconf.us/")
|
|
#:scheme 'http #:host "2012.jsconf.us" #:path "/"))
|
|
|
|
(pass-if "http://foo:not-a-port"
|
|
(not (string->uri "http://foo:not-a-port")))
|
|
|
|
(pass-if "http://:10"
|
|
(not (string->uri "http://:10")))
|
|
|
|
(pass-if "http://foo@"
|
|
(not (string->uri "http://foo@")))
|
|
|
|
(pass-if "file:/"
|
|
(uri=? (string->uri "file:/")
|
|
#:scheme 'file
|
|
#:path "/"))
|
|
|
|
(pass-if "file:/etc/hosts"
|
|
(uri=? (string->uri "file:/etc/hosts")
|
|
#:scheme 'file
|
|
#:path "/etc/hosts"))
|
|
|
|
(pass-if "file:///etc/hosts"
|
|
(uri=? (string->uri "file:///etc/hosts")
|
|
#:scheme 'file
|
|
#:path "/etc/hosts")))
|
|
|
|
(with-test-prefix "uri->string"
|
|
(pass-if "ftp:"
|
|
(equal? "ftp:"
|
|
(uri->string (string->uri "ftp:"))))
|
|
|
|
(pass-if "ftp:foo"
|
|
(equal? "ftp:foo"
|
|
(uri->string (string->uri "ftp:foo"))))
|
|
|
|
(pass-if "ftp://foo/bar"
|
|
(equal? "ftp://foo/bar"
|
|
(uri->string (string->uri "ftp://foo/bar"))))
|
|
|
|
(pass-if "ftp://foo@bar:22/baz"
|
|
(equal? "ftp://foo@bar:22/baz"
|
|
(uri->string (string->uri "ftp://foo@bar:22/baz"))))
|
|
|
|
(when (memq 'socket *features*)
|
|
(pass-if "http://192.0.2.1"
|
|
(equal? "http://192.0.2.1"
|
|
(uri->string (string->uri "http://192.0.2.1"))))
|
|
|
|
(pass-if "http://[2001:db8::1]"
|
|
(equal? "http://[2001:db8::1]"
|
|
(uri->string (string->uri "http://[2001:db8::1]"))))
|
|
|
|
(pass-if "http://[::ffff:192.0.2.1]"
|
|
(equal? "http://[::ffff:192.0.2.1]"
|
|
(uri->string (string->uri "http://[::ffff:192.0.2.1]")))))
|
|
|
|
(pass-if "http://foo:"
|
|
(equal? "http://foo"
|
|
(uri->string (string->uri "http://foo:"))))
|
|
|
|
(pass-if "http://foo:/"
|
|
(equal? "http://foo/"
|
|
(uri->string (string->uri "http://foo:/")))))
|
|
|
|
(with-test-prefix "decode"
|
|
(pass-if "foo%20bar"
|
|
(equal? "foo bar" (uri-decode "foo%20bar")))
|
|
|
|
(pass-if "foo+bar"
|
|
(equal? "foo bar" (uri-decode "foo+bar"))))
|
|
|
|
(with-test-prefix "encode"
|
|
(pass-if (equal? "foo%20bar" (uri-encode "foo bar")))
|
|
(pass-if (equal? "foo%0A%00bar" (uri-encode "foo\n\x00bar")))
|
|
(pass-if (equal? "%3C%3E%5C%5E" (uri-encode "<>\\^"))))
|