mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +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 (define ipv4-regexp
(make-regexp "^([0-9.]+)$")) (make-regexp "^([0-9.]+)$"))
(define ipv6-regexp (define ipv6-regexp
(make-regexp "^\\[([0-9a-fA-F:.]+)\\]$")) (make-regexp "^([0-9a-fA-F:.]+)$"))
(define domain-label-regexp (define domain-label-regexp
(make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$")) (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
(define top-label-regexp (define top-label-regexp
@ -115,13 +115,15 @@ consistency checks to make sure that the constructed URI is valid."
(define userinfo-pat (define userinfo-pat
"[a-zA-Z0-9_.!~*'();:&=+$,-]+") "[a-zA-Z0-9_.!~*'();:&=+$,-]+")
(define host-pat (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 (define port-pat
"[0-9]*") "[0-9]*")
(define authority-regexp (define authority-regexp
(make-regexp (make-regexp
(format #f "^//((~a)@)?(~a)(:(~a))?$" (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$"
userinfo-pat host-pat port-pat))) userinfo-pat host-pat ipv6-host-pat port-pat)))
(define (parse-authority authority fail) (define (parse-authority authority fail)
(if (equal? authority "//") (if (equal? authority "//")
@ -129,10 +131,12 @@ consistency checks to make sure that the constructed URI is valid."
;; file:/etc/hosts. ;; file:/etc/hosts.
(values #f #f #f) (values #f #f #f)
(let ((m (regexp-exec authority-regexp authority))) (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) (values (match:substring m 2)
(match:substring m 3) (or (match:substring m 4)
(let ((port (match:substring m 5))) (match:substring m 6))
(let ((port (match:substring m 8)))
(and port (not (string-null? port)) (and port (not (string-null? port))
(string->number port)))) (string->number port))))
(fail))))) (fail)))))
@ -216,7 +220,9 @@ printed."
(string-append "//" (string-append "//"
(if userinfo (string-append userinfo "@") (if userinfo (string-append userinfo "@")
"") "")
host (if (string-index host #\:)
(string-append "[" host "]")
host)
(if (default-port? (uri-scheme uri) port) (if (default-port? (uri-scheme uri) port)
"" ""
(string-append ":" (number->string 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 "")) #:scheme 'http #:host "192.0.2.1" #:path ""))
(pass-if "http://[2001:db8::1]" (pass-if "http://[2001:db8::1]"
(uri=? (build-uri 'http #:host "[2001:db8::1]") (uri=? (build-uri 'http #:host "2001:db8::1")
#:scheme 'http #:host "[2001:db8::1]" #:path "")) #:scheme 'http #:host "2001:db8::1" #:path ""))
(pass-if "http://[::ffff:192.0.2.1]" (pass-if "http://[::ffff:192.0.2.1]"
(uri=? (build-uri 'http #:host "[::ffff:192.0.2.1]") (uri=? (build-uri 'http #:host "::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-uri-exception "http://foo:not-a-port" (pass-if-uri-exception "http://foo:not-a-port"
"Expected.*port" "Expected.*port"
@ -161,18 +161,18 @@
(pass-if "http://[2001:db8::1]" (pass-if "http://[2001:db8::1]"
(uri=? (string->uri "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" (pass-if "http://[2001:db8::1]:80"
(uri=? (string->uri "http://[2001:db8::1]:80") (uri=? (string->uri "http://[2001:db8::1]:80")
#:scheme 'http #:scheme 'http
#:host "[2001:db8::1]" #:host "2001:db8::1"
#:port 80 #:port 80
#:path "")) #:path ""))
(pass-if "http://[::ffff:192.0.2.1]" (pass-if "http://[::ffff:192.0.2.1]"
(uri=? (string->uri "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:" (pass-if "http://foo:"
(uri=? (string->uri "http://foo:") (uri=? (string->uri "http://foo:")