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 de519da58ea013412f8862889c8e2556d7eacd6b..ca29c9a12e531432c66fcc9deced4be509820352 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -26,7 +26,7 @@ import qualified Data.Text.Encoding as T
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Response.StatusCode
 import Network.Socket
 import Network.URI
 import Prelude.Unicode
@@ -36,7 +36,6 @@ data AugmentedRequest
         arRequest          ∷ !Request
       , arInitialStatus    ∷ !SomeStatusCode
       , arWillChunkBody    ∷ !Bool
-      , arWillDiscardBody  ∷ !Bool
       , arWillClose        ∷ !Bool
       , arExpectedContinue ∷ !Bool
       , arReqBodyLength    ∷ !(Maybe RequestBodyLength)
@@ -56,7 +55,6 @@ preprocess localHost localPort req@(Request {..})
                     arRequest          = req
                   , arInitialStatus    = fromStatusCode OK
                   , arWillChunkBody    = False
-                  , arWillDiscardBody  = False
                   , arWillClose        = False
                   , arExpectedContinue = False
                   , arReqBodyLength    = Nothing
@@ -101,7 +99,7 @@ examineMethod
     = do req ← gets arRequest
          case reqMethod req of
            GET    → return ()
-           HEAD   → modify $ \ar → ar { arWillDiscardBody = True }
+           HEAD   → return ()
            POST   → return ()
            PUT    → return ()
            DELETE → return ()
@@ -122,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...
@@ -146,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
@@ -198,7 +201,7 @@ examineBodyLength ∷ State AugmentedRequest ()
 examineBodyLength
     = do req ← gets arRequest
          len ← gets arReqBodyLength
-         if reqMustHaveBody req then
+         if reqHasBody req then
              -- POST and PUT requests must have an entity body.
              when (isNothing len)
                  $ setStatus LengthRequired