From b1c46fd30a4615b4ab534d6bd824a81e3f536660 Mon Sep 17 00:00:00 2001
From: Daniel Hartwig <mandyke@gmail.com>
Date: Sat, 16 Mar 2013 19:53:07 +0800
Subject: [PATCH] http: support IP-literal (IPv6 address) in Host header

* 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.
---
 module/web/http.scm            | 26 ++++++++++++++++++++------
 test-suite/tests/web-http.test |  4 ++++
 2 files changed, 24 insertions(+), 6 deletions(-)

diff --git a/module/web/http.scm b/module/web/http.scm
index 712208b69..b5202b69c 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -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)
-    (display (car 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)
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 6fa16bd4c..291372445 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -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 "*" '*)