bug#40582: Valid URIs are rejected

[Ludovic Courtès]

Hi Julien,

Julien Lepiller <julien@lepiller.eu> skribis:

> Using (web uri), I was trying to parse "uri://a/c". Reading RFC3986, it 
> should be a valid URI (see rule for reg-name in 3.2.2). However, passing it 
> to string->uri results in #f. I've tracked this down to valid-host? which 
> returns #f for "a".
>
> The reason is that the regexp checking if the host is an ipv6 matches "a", 
> which shouldn't happen because a is not an ipv6 address. Indeed, when I try 
> (string->uri "uri://g/b"), I get the expected result.

Right.  ‘authority-regexp’ is fine, but ‘ipv6-regexp’, used by
‘valid-host?’, was too lax and would match “a” because it’s an hex digit
sequence.

The regexp below is still an approximation, but I think a better one.
Can you confirm?

Thanks,
Ludo’.

diff --git a/module/web/uri.scm b/module/web/uri.scm
index b4b89b9cc..d76432737 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -188,7 +188,7 @@ for ‘build-uri’ except there is no scheme."
 (define ipv4-regexp
   (make-regexp (string-append "^([" digits ".]+)$")))
 (define ipv6-regexp
-  (make-regexp (string-append "^([" hex-digits ":.]+)$")))
+  (make-regexp (string-append "^([" hex-digits "]*:[" hex-digits ":.]+)$")))
 (define domain-label-regexp
   (make-regexp
    (string-append "^[" letters digits "]"
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 94778acac..95fd82f16 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -1,6 +1,6 @@
 ;;;; web-uri.test --- URI library          -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;;   Copyright (C) 2010-2012, 2014, 2017, 2019 Free Software Foundation, Inc.
+;;;;   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
@@ -179,6 +179,13 @@
            #: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";)))