use time-http 0.5

[Lucu.git] / Network / HTTP / Lucu / Preprocess.hs

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index e01160dafe6ef46acd1888731abdd0b477943fd9..ca29c9a12e531432c66fcc9deced4be509820352 100644 (file)
--- 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