diff --git a/module/web/uri.scm b/module/web/uri.scm index ba36a3828..109118b12 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 @@ -115,13 +115,15 @@ consistency checks to make sure that the constructed URI is valid." (define userinfo-pat "[a-zA-Z0-9_.!~*'();:&=+$,-]+") (define host-pat - "[a-zA-Z0-9.-]+|\\[[0-9a-FA-F:.]+\\]") + "[a-zA-Z0-9.-]+") +(define ipv6-host-pat + "[0-9a-fA-F:.]+") (define port-pat "[0-9]*") (define authority-regexp (make-regexp - (format #f "^//((~a)@)?(~a)(:(~a))?$" - userinfo-pat host-pat port-pat))) + (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$" + userinfo-pat host-pat ipv6-host-pat port-pat))) (define (parse-authority authority fail) (if (equal? authority "//") @@ -129,10 +131,12 @@ consistency checks to make sure that the constructed URI is valid." ;; file:/etc/hosts. (values #f #f #f) (let ((m (regexp-exec authority-regexp authority))) - (if (and m (valid-host? (match:substring m 3))) + (if (and m (valid-host? (or (match:substring m 4) + (match:substring m 6)))) (values (match:substring m 2) - (match:substring m 3) - (let ((port (match:substring m 5))) + (or (match:substring m 4) + (match:substring m 6)) + (let ((port (match:substring m 8))) (and port (not (string-null? port)) (string->number port)))) (fail))))) @@ -216,7 +220,9 @@ printed." (string-append "//" (if userinfo (string-append userinfo "@") "") - host + (if (string-index host #\:) + (string-append "[" host "]") + host) (if (default-port? (uri-scheme uri) port) "" (string-append ":" (number->string port)))) diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 38929fe0d..74310258e 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -99,12 +99,12 @@ #: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 "")) + (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 "")) + (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" @@ -161,18 +161,18 @@ (pass-if "http://[2001:db8::1]" (uri=? (string->uri "http://[2001:db8::1]") - #:scheme 'http #:host "[2001:db8::1]" #:path "")) + #: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]" + #: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 "")) + #:scheme 'http #:host "::ffff:192.0.2.1" #:path "")) (pass-if "http://foo:" (uri=? (string->uri "http://foo:")