X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;fp=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=ca29c9a12e531432c66fcc9deced4be509820352;hp=e01160dafe6ef46acd1888731abdd0b477943fd9;hb=3b448555e621530c3483f03b4b5156dc606b2035;hpb=f093019cb10a88fee13b8c99d05b60f895ceb01f

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index e01160d..ca29c9a 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -120,15 +120,21 @@ examineAuthority localHost localPort
                          req' = updateAuthority host port req
                      in
                        setRequest req'
-               -- HTTP/1.1 requests MUST have a Host header.
+               -- HTTP/1.1 requests MUST have a Host header, but if
+               -- the requested URI has an authority, the value of
+               -- Host header must be ignored. See:
+               -- http://tools.ietf.org/html/rfc2616#section-5.2
                HttpVersion 1 1
                    → case getHeader "Host" req of
                         Just str
-                            → let (host, port)
-                                       = parseHost str
-                                  req' = updateAuthority host port req
-                              in
-                                setRequest req'
+                            | isNothing ∘ uriAuthority ∘ reqURI $ req
+                                → let (host, port)
+                                           = parseHost str
+                                      req' = updateAuthority host port req
+                                  in
+                                    setRequest req'
+                            | otherwise
+                                → return ()
                         Nothing
                             → setStatus BadRequest
                -- Should never reach here...
@@ -144,9 +150,8 @@ parseHost hp
         (hText, pAscii)
 
 updateAuthority ∷ CI Text → Ascii → Request → Request
-updateAuthority host port req
-    = let uri  = reqURI req
-          uri' = uri {
+updateAuthority host port req@(Request {..})
+    = let uri' = reqURI {
                    uriAuthority = Just URIAuth {
                                     uriUserInfo = ""
                                   , uriRegName  = cs $ CI.original host