mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 20:30:28 +02:00
Code Activity

http: support IP-literal (IPv6 address) in Host header

Browse source 
* module/web/http.scm ("Host"): Parse and write IP-literals treating
  escapes as uri module does: remove brackets on parse, replace them on
  write.
* test-suite/tests/web-http.test ("request headers"): Add tests.
This commit is contained in:
Daniel Hartwig 2013-03-16 19:53:07 +08:00
parent 2e08ff38b7
commit b1c46fd30a
2 changed files with 24 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

24
module/web/http.scm
View file

@ -1628,18 +1628,32 @@ treated specially, and is just returned as a plain string."
;;
(declare-header! "Host"
(lambda (str)
(let ((colon (string-index str #\:)))
(if colon
(cons (substring str 0 colon)
(parse-non-negative-integer str (1+ colon)))
(cons str #f))))
(let* ((rbracket (string-index str #\]))
(colon (string-index str #\: (or rbracket 0)))
(host (cond
(rbracket
(unless (eqv? (string-ref str 0) #\[)
(bad-header 'host str))
(substring str 1 rbracket))
(colon
(substring str 0 colon))
(else
str)))
(port (and colon
(parse-non-negative-integer str (1+ colon)))))
(cons host port)))
(lambda (val)
(and (pair? val)
(string? (car val))
(or (not (cdr val))
(non-negative-integer? (cdr val)))))
(lambda (val port)
(if (string-index (car val) #\:)
(begin
(display #\[ port)
(display (car val) port)
(display #\] port))
(display (car val) port))
(if (cdr val)
(begin
(display #\: port)

4
test-suite/tests/web-http.test
View file

@ -287,6 +287,10 @@
(pass-if-parse from "foo@bar" "foo@bar")
(pass-if-parse host "qux" '("qux" . #f))
(pass-if-parse host "qux:80" '("qux" . 80))
(pass-if-parse host "[2001:db8::1]" '("2001:db8::1" . #f))
(pass-if-parse host "[2001:db8::1]:80" '("2001:db8::1" . 80))
(pass-if-parse host "[::ffff:192.0.2.1]" '("::ffff:192.0.2.1" . #f))
(pass-if-round-trip "Host: [2001:db8::1]\r\n")
(pass-if-parse if-match "\"xyzzy\", W/\"qux\""
'(("xyzzy" . #t) ("qux" . #f)))
(pass-if-parse if-match "*" '*)