support URIs with domain names starting with numbers

* module/web/uri.scm (valid-host?): Fix regexp to support
domain names starting with numbers.
* test-suite/tests/web-uri.scm: Add tests for above and
IP literals.

2 files changed, 49 insertions, 2 deletions

diff --git a/module/web/uri.scm b/module/web/uri.scm
index a2a930a6a..695442904 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -91,7 +91,7 @@ consistency checks to make sure that the constructed URI is valid."
 (define ipv4-regexp
   (make-regexp "^([0-9.]+)$"))
 (define ipv6-regexp
-  (make-regexp "^\\[([0-9a-fA-F:]+)\\]+$"))
+  (make-regexp "^\\[([0-9a-fA-F:]+)\\]$"))
 (define domain-label-regexp
   (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
 (define top-label-regexp
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 940fb3147..62ec295a3 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -90,6 +90,18 @@
     (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 ""))
+
+  (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-uri-exception "http://foo:not-a-port"
                          "Expected.*port"
                          (build-uri 'http #:host "foo" #:port "not-a-port"))
@@ -135,6 +147,25 @@
   (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 ""))
+
+  (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]")
+           #:scheme 'http
+           #:host "[2001:db8::1]"
+           #:port 80
+           #:path ""))
+
   (pass-if "http://foo:"
     (uri=? (string->uri "http://foo:")
            #:scheme 'http #:host "foo" #:path ""))
@@ -188,6 +219,18 @@
     (equal? "ftp://foo@bar:22/baz"
             (uri->string (string->uri "ftp://foo@bar:22/baz"))))
   
+  (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://[2001:db8::1]:80"
+    (equal? "http://[2001:db8::1]:80"
+           (uri->string (string->uri "http://[2001:db8::1]:80"))))
+
   (pass-if "http://foo:"
     (equal? "http://foo"
             (uri->string (string->uri "http://foo:"))))
@@ -197,7 +240,11 @@
             (uri->string (string->uri "http://foo:/")))))
 
 (with-test-prefix "decode"
-  (pass-if (equal? "foo bar" (uri-decode "foo%20bar"))))
+  (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"))))