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 8e3087ebae70654ae0b4a8f74b5e1f0a4102c466..ca29c9a12e531432c66fcc9deced4be509820352 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -16,15 +16,17 @@ import Control.Monad.State.Strict
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
 import Data.Maybe
-import qualified Data.Strict.Maybe as S
 import Data.Text (Text)
-import qualified Data.Text as T
 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
@@ -32,12 +34,11 @@ import Prelude.Unicode
 data AugmentedRequest
     = AugmentedRequest {
         arRequest          ∷ !Request
-      , arInitialStatus    ∷ !StatusCode
+      , arInitialStatus    ∷ !SomeStatusCode
       , arWillChunkBody    ∷ !Bool
-      , arWillDiscardBody  ∷ !Bool
       , arWillClose        ∷ !Bool
       , arExpectedContinue ∷ !Bool
-      , arReqBodyLength    ∷ !(S.Maybe RequestBodyLength)
+      , arReqBodyLength    ∷ !(Maybe RequestBodyLength)
       }
 
 data RequestBodyLength
@@ -45,19 +46,18 @@ data RequestBodyLength
     | Chunked
     deriving (Eq, Show)
 
-preprocess ∷ Text → PortNumber → Request → AugmentedRequest
+preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
 preprocess localHost localPort req@(Request {..})
     = execState go initialAR
     where
       initialAR ∷ AugmentedRequest
       initialAR = AugmentedRequest {
                     arRequest          = req
-                  , arInitialStatus    = Ok
+                  , arInitialStatus    = fromStatusCode OK
                   , arWillChunkBody    = False
-                  , arWillDiscardBody  = False
                   , arWillClose        = False
                   , arExpectedContinue = False
-                  , arReqBodyLength    = S.Nothing
+                  , arReqBodyLength    = Nothing
                   }
       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion
@@ -70,15 +70,15 @@ setRequest ∷ Request → State AugmentedRequest ()
 setRequest req
     = modify $ \ar → ar { arRequest = req }
 
-setStatus ∷ StatusCode → State AugmentedRequest ()
+setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest ()
 setStatus sc
-    = modify $ \ar → ar { arInitialStatus = sc }
+    = modify $ \ar → ar { arInitialStatus = fromStatusCode sc }
 
 setWillClose ∷ Bool → State AugmentedRequest ()
 setWillClose b
     = modify $ \ar → ar { arWillClose = b }
 
-setBodyLength ∷ S.Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
 setBodyLength len
     = modify $ \ar → ar { arReqBodyLength = len }
 
@@ -91,7 +91,7 @@ examineHttpVersion
                → setWillClose True
            HttpVersion 1 1
                → modify $ \ar → ar { arWillChunkBody = True }
-           _   → do setStatus    HttpVersionNotSupported
+           _   → do setStatus    HTTPVersionNotSupported
                     setWillClose True
 
 examineMethod ∷ State AugmentedRequest ()
@@ -99,13 +99,13 @@ 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 ()
            _      → setStatus NotImplemented
 
-examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
+examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
 examineAuthority localHost localPort
     = do req ← gets arRequest
          when (isNothing $ uriAuthority $ reqURI req) $
@@ -120,37 +120,42 @@ 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...
                ver → fail ("internal error: unknown version: " ⧺ show ver)
 
-parseHost ∷ Ascii → (Text, Ascii)
+parseHost ∷ Ascii → (CI Text, Ascii)
 parseHost hp
-    = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
+    = let (h, p) = C8.break (≡ ':') $ cs hp
           -- FIXME: should decode punycode here.
-          hText  = T.decodeUtf8 h
+          hText  = CI.mk $ T.decodeUtf8 h
           pAscii = A.unsafeFromByteString p
       in
         (hText, pAscii)
 
-updateAuthority ∷ Text → Ascii → Request → Request
-updateAuthority host port req
-    = let uri  = reqURI req
-          uri' = uri {
+updateAuthority ∷ CI Text → Ascii → Request → Request
+updateAuthority host port req@(Request {..})
+    = let uri' = reqURI {
                    uriAuthority = Just URIAuth {
                                     uriUserInfo = ""
-                                  , uriRegName  = T.unpack host
-                                  , uriPort     = A.toString port
+                                  , uriRegName  = cs $ CI.original host
+                                  , uriPort     = cs port
                                   }
                  }
       in
@@ -174,16 +179,16 @@ examineHeaders
                | v ≡ "identity"
                    → return ()
                | v ≡ "chunked"
-                   → setBodyLength $ S.Just Chunked
+                   → setBodyLength $ Just Chunked
                | otherwise
                    → setStatus NotImplemented
 
-         case A.toByteString <$> getHeader "Content-Length" req of
+         case cs <$> getHeader "Content-Length" req of
            Nothing    → return ()
            Just value → case C8.readInt value of
                            Just (len, garbage)
                                | C8.null garbage ∧ len ≥ 0
-                                   → setBodyLength $ S.Just $ Fixed len
+                                   → setBodyLength $ Just $ Fixed len
                            _       → setStatus BadRequest
 
          case getCIHeader "Connection" req of
@@ -196,11 +201,11 @@ 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 (S.isNothing len)
+             when (isNothing len)
                  $ setStatus LengthRequired
          else
              -- Other requests must NOT have an entity body.
-             when (S.isJust len)
+             when (isJust len)
                  $ setStatus BadRequest