guile/test-suite/tests/web-uri.test

;;;; web-uri.test --- URI library          -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010-2012, 2014, 2017, 2019, 2020 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"))

  ;; In this test, we need to reload the '(web uri)' module with a
  ;; different locale.  This is because some locale-dependent things
  ;; (e.g., compiled regexes) are computed when the module is loaded.
  (pass-if-uri-exception "http://illégal.com"
                         "Expected.*host"
                         (dynamic-wind
                           (lambda () #t)
                           (lambda ()
                             (with-locale "en_US.utf8"
                               (reload-module (resolve-module '(web uri)))
                               (build-uri 'http #:host "illégal.com")))
                           (lambda ()
                             (reload-module (resolve-module '(web uri)))))))

(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-equal "xyz://abc/x/y/z"         ;<https://bugs.gnu.org/40582>
      (list 'xyz "abc" "/x/y/z")
    (let ((uri (string->uri "xyz://abc/x/y/z")))
      (list (uri-scheme uri)
            (uri-host uri)
            (uri-path uri))))

  (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"))

  ;; This test reproduces bug #35785.  See the 'illégal' test above for
  ;; why we reload the module.
  (pass-if "http://www.example.com (sv_SE)"
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (with-locale "sv_SE.utf8"
          (reload-module (resolve-module '(web uri)))
          (uri=? (string->uri "http://www.example.com")
                 #:scheme 'http #:host "www.example.com" #:path "")))
      (lambda ()
        (reload-module (resolve-module '(web uri)))))))

(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 "//bad.host.1."
    (not (string->uri-reference "//bad.host.1.")))

  (pass-if "//bad.host.."
    (not (string->uri-reference "//bad.host..")))

  (pass-if "//1.good.host."
    (uri=? (string->uri-reference "//1.good.host.")
           #:host "1.good.host." #:path ""))

  (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 "<>\\^"))))