mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Allow trailing "." in urls

Browse source 
Fixes https://debbugs.gnu.org/53201

* module/web/uri.scm (valid-host?): Allow trailing "." in URLs
* test-suite/tests/web-uri.test: Add tests for trailing "."
This commit is contained in:
Dale P. Smith 2022-01-27 19:20:57 -05:00 • committed by Arne Babenhauserheide
parent 5be5a10a8a
commit 29c27afe96
2 changed files with 20 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

17
module/web/uri.scm
View file

@ -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 "_.!~*'();:&=+$,-]+"))

10
test-suite/tests/web-uri.test
View file

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