bug#53201: string->uri-reference rejects domain names with final ‘.’

[dsmich]

New patch. Now with 3 test cases!

-Dale



From f4eece6395e75197030bff42a583e847e5a34e15 Mon Sep 17 00:00:00 2001
From: "Dale P. Smith" <dalepsm...@gmail.com>
Date: Thu, 27 Jan 2022 19:20:57 -0500
Subject: [PATCH] Allow trailing "." in urls

bug #53201
---
 module/web/uri.scm            | 17 ++++++++++-------
 test-suite/tests/web-uri.test | 10 ++++++++++
 2 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/module/web/uri.scm b/module/web/uri.scm
index 8e0b9bee7..8c5c0d6f0 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -206,13 +206,16 @@ for ‘build-uri’ except there is no scheme."
    ((regexp-exec ipv6-regexp host)
     (false-if-exception (inet-pton AF_INET6 host)))
    (else
-    (let lp ((start 0))
-      (let ((end (string-index host #\. start)))
-        (if end
-            (and (regexp-exec domain-label-regexp
-                              (substring host start end))
-                 (lp (1+ end)))
-            (regexp-exec top-label-regexp host start)))))))
+    (let ((last (1- (string-length host))))
+      (let lp ((start 0))
+        (let ((end (string-index host #\. start)))
+          (if (and end (< end last))
+              (and (regexp-exec domain-label-regexp
+                                (substring host start end))
+                   (lp (1+ end)))
+              (if end
+                  (regexp-exec top-label-regexp (substring host start end))
+                  (regexp-exec top-label-regexp host start)))))))))
 
 (define userinfo-pat
   (string-append "[" letters digits "_.!~*'();:&=+$,-]+"))
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 95fd82f16..e9fb766f0 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -367,6 +367,16 @@
   (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 ""))
-- 
2.30.2