mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity
guile/test-suite/tests/web-uri.test
Andy Wingo 7095a536f3 web: add support for URI-reference 
Based on a patch by Daniel Hartwig <mandyke@gmail.com>.

* NEWS: Update.
* doc/ref/web.texi (URIs): Fragments are properly part of a URI, so
  remove the incorrect note.  Add documentation on URI subtypes.
* module/web/uri.scm (uri-reference?): New base type predicate.
  (uri?, relative-ref?): Specific predicates.
  (validate-uri-reference): Strict validation.
  (validate-uri, validate-relative-ref): Specific validators.
  (build-uri-reference, build-relative-ref): New constructors.
  (string->uri-reference): Rename from string->uri.
  (string->uri, string->relative-ref): Specific constructors.
  (uri->string): Add #:include-fragment? keyword argument.
* module/web/http.scm (parse-request-uri): Use `build-uri-reference',
  and result is a URI-reference, not URI, object.  No longer infer an
  absent `uri-scheme' is `http'.
  (write-uri): Just use `uri->string'.
  (declare-uri-header!): Remove unused function.
  (declare-uri-reference-header!): Update.  Rename from
  `declare-relative-uri-header!'.
* test-suite/tests/web-uri.test ("build-uri-reference"):
  ("string->uri-reference"): Add.
  ("uri->string"): Also tests for relative-refs.
* test-suite/tests/web-http.test ("read-request-line"):
  ("write-request-line"): Update for no scheme in some URIs.
  ("entity headers", "request headers"): Content-location, Referer, and
  Location should also parse relative-URIs.
* test-suite/tests/web-request.test ("example-1"): Expect URI-reference
  with no scheme.
2017-05-21 13:42:29 +02:00

661 lines
19 KiB
Scheme
Raw Permalink Blame History

;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010-2012, 2014, 2017 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-reference? 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 "build-uri-reference"
(pass-if "//host/etc/foo"
(uri=? (build-uri-reference #:host "host"
#:path "/etc/foo")
#:host "host"
#:path "/etc/foo"))
(pass-if "/path/to/some/foo?query"
(uri=? (build-uri-reference #:path "/path/to/some/foo"
#:query "query")
#:path "/path/to/some/foo"
#:query "query"))
(pass-if "nextdoc/foo"
(uri=? (build-uri-reference #:path "nextdoc/foo")
#:path "nextdoc/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"))
(pass-if "http://foo#bar"
(uri=? (string->uri "http://foo#bar")
#:scheme 'http
#:host "foo"
#:path ""
#:fragment "bar"))
(pass-if "http://foo:/#bar"
(uri=? (string->uri "http://foo:/#bar")
#:scheme 'http
#:host "foo"
#:path "/"
#:fragment "bar"))
(pass-if "http://foo:100#bar"
(uri=? (string->uri "http://foo:100#bar")
#:scheme 'http
#:host "foo"
#:port 100
#:path ""
#:fragment "bar"))
(pass-if "http://foo:100/#bar"
(uri=? (string->uri "http://foo:100/#bar")
#:scheme 'http
#:host "foo"
#:port 100
#:path "/"
#:fragment "bar"))
(pass-if "http://foo?q#bar"
(uri=? (string->uri "http://foo?q#bar")
#:scheme 'http
#:host "foo"
#:path ""
#:query "q"
#:fragment "bar"))
(pass-if "http://foo:/?q#bar"
(uri=? (string->uri "http://foo:/?q#bar")
#:scheme 'http
#:host "foo"
#:path "/"
#:query "q"
#:fragment "bar"))
(pass-if "http://foo:100?q#bar"
(uri=? (string->uri "http://foo:100?q#bar")
#:scheme 'http
#:host "foo"
#:port 100
#:path ""
#:query "q"
#:fragment "bar"))
(pass-if "http://foo:100/?q#bar"
(uri=? (string->uri "http://foo:100/?q#bar")
#:scheme 'http
#:host "foo"
#:port 100
#:path "/"
#:query "q"
#:fragment "bar")))
(with-test-prefix "string->uri-reference"
(pass-if "/foo"
(uri=? (string->uri-reference "/foo")
#:path "/foo"))
(pass-if "ftp:/foo"
(uri=? (string->uri-reference "ftp:/foo")
#:scheme 'ftp
#:path "/foo"))
(pass-if "ftp:foo"
(uri=? (string->uri-reference "ftp:foo")
#:scheme 'ftp
#:path "foo"))
(pass-if "//foo/bar"
(uri=? (string->uri-reference "//foo/bar")
#:host "foo"
#:path "/bar"))
(pass-if "ftp://foo@bar:22/baz"
(uri=? (string->uri-reference "ftp://foo@bar:22/baz")
#:scheme 'ftp
#:userinfo "foo"
#:host "bar"
#:port 22
#:path "/baz"))
(pass-if "//foo@bar:22/baz"
(uri=? (string->uri-reference "//foo@bar:22/baz")
#:userinfo "foo"
#:host "bar"
#:port 22
#:path "/baz"))
(pass-if "http://bad.host.1"
(not (string->uri-reference "http://bad.host.1")))
(pass-if "//bad.host.1"
(not (string->uri-reference "//bad.host.1")))
(pass-if "http://1.good.host"
(uri=? (string->uri-reference "http://1.good.host")
#:scheme 'http #:host "1.good.host" #:path ""))
(pass-if "//1.good.host"
(uri=? (string->uri-reference "//1.good.host")
#:host "1.good.host" #:path ""))
(when (memq 'socket *features*)
(pass-if "http://192.0.2.1"
(uri=? (string->uri-reference "http://192.0.2.1")
#:scheme 'http #:host "192.0.2.1" #:path ""))
(pass-if "//192.0.2.1"
(uri=? (string->uri-reference "//192.0.2.1")
#:host "192.0.2.1" #:path ""))
(pass-if "http://[2001:db8::1]"
(uri=? (string->uri-reference "http://[2001:db8::1]")
#:scheme 'http #:host "2001:db8::1" #:path ""))
(pass-if "//[2001:db8::1]"
(uri=? (string->uri-reference "//[2001:db8::1]")
#:host "2001:db8::1" #:path ""))
(pass-if "http://[2001:db8::1]:80"
(uri=? (string->uri-reference "http://[2001:db8::1]:80")
#:scheme 'http
#:host "2001:db8::1"
#:port 80
#:path ""))
(pass-if "//[2001:db8::1]:80"
(uri=? (string->uri-reference "//[2001:db8::1]:80")
#:host "2001:db8::1"
#:port 80
#:path ""))
(pass-if "http://[::ffff:192.0.2.1]"
(uri=? (string->uri-reference "http://[::ffff:192.0.2.1]")
#:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
(pass-if "//[::ffff:192.0.2.1]"
(uri=? (string->uri-reference "//[::ffff:192.0.2.1]")
#:host "::ffff:192.0.2.1" #:path "")))
(pass-if "http://foo:"
(uri=? (string->uri-reference "http://foo:")
#:scheme 'http #:host "foo" #:path ""))
(pass-if "//foo:"
(uri=? (string->uri-reference "//foo:")
#:host "foo" #:path ""))
(pass-if "http://foo:/"
(uri=? (string->uri-reference "http://foo:/")
#:scheme 'http #:host "foo" #:path "/"))
(pass-if "//foo:/"
(uri=? (string->uri-reference "//foo:/")
#:host "foo" #:path "/"))
(pass-if "http://2012.jsconf.us/"
(uri=? (string->uri-reference "http://2012.jsconf.us/")
#:scheme 'http #:host "2012.jsconf.us" #:path "/"))
(pass-if "//2012.jsconf.us/"
(uri=? (string->uri-reference "//2012.jsconf.us/")
#:host "2012.jsconf.us" #:path "/"))
(pass-if "http://foo:not-a-port"
(not (string->uri-reference "http://foo:not-a-port")))
(pass-if "//foo:not-a-port"
(not (string->uri-reference "//foo:not-a-port")))
(pass-if "http://:10"
(not (string->uri-reference "http://:10")))
(pass-if "//:10"
(not (string->uri-reference "//:10")))
(pass-if "http://foo@"
(not (string->uri-reference "http://foo@")))
(pass-if "//foo@"
(not (string->uri-reference "//foo@")))
(pass-if "file:/"
(uri=? (string->uri-reference "file:/")
#:scheme 'file
#:path "/"))
(pass-if "/"
(uri=? (string->uri-reference "/")
#:path "/"))
(pass-if "foo"
(uri=? (string->uri-reference "foo")
#:path "foo"))
(pass-if "file:/etc/hosts"
(uri=? (string->uri-reference "file:/etc/hosts")
#:scheme 'file
#:path "/etc/hosts"))
(pass-if "/etc/hosts"
(uri=? (string->uri-reference "/etc/hosts")
#:path "/etc/hosts"))
(pass-if "file:///etc/hosts"
(uri=? (string->uri-reference "file:///etc/hosts")
#:scheme 'file
#:path "/etc/hosts"))
(pass-if "///etc/hosts"
(uri=? (string->uri-reference "///etc/hosts")
#:path "/etc/hosts"))
(pass-if "/foo#bar"
(uri=? (string->uri-reference "/foo#bar")
#:path "/foo"
#:fragment "bar"))
(pass-if "//foo#bar"
(uri=? (string->uri-reference "//foo#bar")
#:host "foo"
#:path ""
#:fragment "bar"))
(pass-if "//foo:/#bar"
(uri=? (string->uri-reference "//foo:/#bar")
#:host "foo"
#:path "/"
#:fragment "bar"))
(pass-if "//foo:100#bar"
(uri=? (string->uri-reference "//foo:100#bar")
#:host "foo"
#:port 100
#:path ""
#:fragment "bar"))
(pass-if "//foo:100/#bar"
(uri=? (string->uri-reference "//foo:100/#bar")
#:host "foo"
#:port 100
#:path "/"
#:fragment "bar"))
(pass-if "/foo?q#bar"
(uri=? (string->uri-reference "/foo?q#bar")
#:path "/foo"
#:query "q"
#:fragment "bar"))
(pass-if "//foo?q#bar"
(uri=? (string->uri-reference "//foo?q#bar")
#:host "foo"
#:path ""
#:query "q"
#:fragment "bar"))
(pass-if "//foo:/?q#bar"
(uri=? (string->uri-reference "//foo:/?q#bar")
#:host "foo"
#:path "/"
#:query "q"
#:fragment "bar"))
(pass-if "//foo:100?q#bar"
(uri=? (string->uri-reference "//foo:100?q#bar")
#:host "foo"
#:port 100
#:path ""
#:query "q"
#:fragment "bar"))
(pass-if "//foo:100/?q#bar"
(uri=? (string->uri-reference "//foo:100/?q#bar")
#:host "foo"
#:port 100
#:path "/"
#:query "q"
#:fragment "bar")))
(with-test-prefix "string->uri-reference"
(pass-if "/"
(uri=? (string->uri-reference "/")
#:path "/"))
(pass-if "/path/to/foo"
(uri=? (string->uri-reference "/path/to/foo")
#:path "/path/to/foo"))
(pass-if "//example.org"
(uri=? (string->uri-reference "//example.org")
#:host "example.org"
#:path ""))
(pass-if "//bar@example.org/path/to/foo"
(uri=? (string->uri-reference "//bar@example.org/path/to/foo")
#:userinfo "bar"
#:host "example.org"
#:path "/path/to/foo"))
(pass-if "nextdoc/foo"
(uri=? (string->uri-reference "nextdoc/foo")
#:path "nextdoc/foo")))
(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 "//foo/bar"
(equal? "//foo/bar"
(uri->string (string->uri-reference "//foo/bar"))))
(pass-if "ftp://foo@bar:22/baz"
(equal? "ftp://foo@bar:22/baz"
(uri->string (string->uri "ftp://foo@bar:22/baz"))))
(pass-if "//foo@bar:22/baz"
(equal? "//foo@bar:22/baz"
(uri->string (string->uri-reference "//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 "//192.0.2.1"
(equal? "//192.0.2.1"
(uri->string (string->uri-reference "//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 "//[2001:db8::1]"
(equal? "//[2001:db8::1]"
(uri->string (string->uri-reference "//[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 "//[::ffff:192.0.2.1]"
(equal? "//[::ffff:192.0.2.1]"
(uri->string (string->uri-reference "//[::ffff:192.0.2.1]")))))
(pass-if "http://foo:"
(equal? "http://foo"
(uri->string (string->uri "http://foo:"))))
(pass-if "//foo"
(equal? "//foo"
(uri->string (string->uri-reference "//foo"))))
(pass-if "http://foo:/"
(equal? "http://foo/"
(uri->string (string->uri "http://foo:/"))))
(pass-if "//foo:/"
(equal? "//foo/"
(uri->string (string->uri-reference "//foo:/"))))
(pass-if "/"
(equal? "/"
(uri->string (string->uri-reference "/"))))
(pass-if "/foo"
(equal? "/foo"
(uri->string (string->uri-reference "/foo"))))
(pass-if "/foo/"
(equal? "/foo/"
(uri->string (string->uri-reference "/foo/"))))
(pass-if "/foo/?bar#baz"
(equal? "/foo/?bar#baz"
(uri->string (string->uri-reference "/foo/?bar#baz"))))
(pass-if "foo/?bar#baz"
(equal? "foo/?bar#baz"
(uri->string (string->uri-reference "foo/?bar#baz"))))
(pass-if "/path/to/foo"
(equal? "/path/to/foo"
(uri->string (string->uri-reference "/path/to/foo"))))
(pass-if "//example.org"
(equal? "//example.org"
(uri->string (string->uri-reference "//example.org"))))
(pass-if "//bar@example.org/path/to/foo"
(equal? "//bar@example.org/path/to/foo"
(uri->string (string->uri-reference "//bar@example.org/path/to/foo"))))
(pass-if "nextdoc/foo"
(equal? "nextdoc/foo"
(uri->string (string->uri-reference "nextdoc/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")))
(pass-if "foo+bar"
(equal? '("foo+bar") (split-and-decode-uri-path "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 "<>\\^"))))
View git blame Copy permalink