mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

more uri-related ipv6 fixes

Browse source 
* module/web/uri.scm (ipv6-regexp): IPv6 numeric addresses do not have
  brackets.  It's only in URIs that they have them.
  (ipv6-host-pat, authority-regexp, parse-authority): Refactor ipv6
  detection to fix a bug with |, and to extract IPv6 hosts from their
  brackets.  This way we can pass the uri-host directly to inet-pton.
  (uri->string): If the host contains a `:', assume it is ipv6 and add
  brackets.

* test-suite/tests/web-uri.test ("build-uri"): Adapt tests to assume
  that the address returned by uri-host and passed to build-uri #:host
  does not have brackets.
This commit is contained in:
Andy Wingo 2012-07-06 13:13:19 +02:00
parent 81e7210f14
commit 3fabb2d2be
2 changed files with 21 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/web/uri.scm
View file

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

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

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