X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=1284f2b322749e2e69dcd0d69702065a7aa99644;hp=f2212ab104b3052a47fd91de90050f0ccf31a6cd;hb=24d6b6e25e79495eaa00eb6eacdb707d181d0770;hpb=ca338174155913a969808d7b20193973394e474e

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index f2212ab..1284f2b 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -12,10 +12,12 @@ module Network.HTTP.Lucu.Preprocess
     where
 import Control.Applicative
 import Control.Monad
-import Control.Monad.State
+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.Maybe
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -30,54 +32,34 @@ import Prelude.Unicode
 
 data AugmentedRequest
     = AugmentedRequest {
-        arRequest          ∷ !(Maybe Request)
-      , arInitialStatus    ∷ !StatusCode
-      , arWillClose        ∷ !Bool
+        arRequest          ∷ !Request
+      , arInitialStatus    ∷ !SomeStatusCode
+      , arWillChunkBody    ∷ !Bool
       , arWillDiscardBody  ∷ !Bool
-      , arExpectedContinue ∷ !(Maybe Bool)
+      , arWillClose        ∷ !Bool
+      , arExpectedContinue ∷ !Bool
       , arReqBodyLength    ∷ !(Maybe RequestBodyLength)
       }
 
 data RequestBodyLength
     = Fixed !Int
     | Chunked
+    deriving (Eq, Show)
 
-preprocess ∷ Text
-           → PortNumber
-           → Either StatusCode Request
-           → AugmentedRequest
-preprocess localHost localPort request
-    = case request of
-        Right req
-            → preprocess' localHost localPort req
-        Left sc
-            → unparsable sc
-
-unparsable ∷ StatusCode → AugmentedRequest
-unparsable sc
-    = AugmentedRequest {
-        arRequest          = Nothing
-      , arInitialStatus    = sc
-      , arWillClose        = True
-      , arWillDiscardBody  = False
-      , arExpectedContinue = Nothing
-      , arReqBodyLength    = Nothing
-      }
-
-preprocess' ∷ Text → PortNumber → Request → AugmentedRequest
-preprocess' localHost localPort req@(Request {..})
+preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
+preprocess localHost localPort req@(Request {..})
     = execState go initialAR
     where
       initialAR ∷ AugmentedRequest
       initialAR = AugmentedRequest {
-                    arRequest          = Just req
-                  , arInitialStatus    = Ok
-                  , arWillClose        = False
+                    arRequest          = req
+                  , arInitialStatus    = fromStatusCode OK
+                  , arWillChunkBody    = False
                   , arWillDiscardBody  = False
-                  , arExpectedContinue = Just False
+                  , arWillClose        = False
+                  , arExpectedContinue = False
                   , arReqBodyLength    = Nothing
                   }
-
       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion
               examineMethod
@@ -87,11 +69,11 @@ preprocess' localHost localPort req@(Request {..})
 
 setRequest ∷ Request → State AugmentedRequest ()
 setRequest req
-    = modify $ \ar → ar { arRequest = Just 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
@@ -103,19 +85,19 @@ setBodyLength len
 
 examineHttpVersion ∷ State AugmentedRequest ()
 examineHttpVersion
-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest
          case reqVersion req of
            -- HTTP/1.0 requests can't Keep-Alive.
            HttpVersion 1 0
                → setWillClose True
            HttpVersion 1 1
-               → return ()
-           _   → do setStatus    HttpVersionNotSupported
+               → modify $ \ar → ar { arWillChunkBody = True }
+           _   → do setStatus    HTTPVersionNotSupported
                     setWillClose True
 
 examineMethod ∷ State AugmentedRequest ()
 examineMethod
-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest
          case reqMethod req of
            GET    → return ()
            HEAD   → modify $ \ar → ar { arWillDiscardBody = True }
@@ -124,9 +106,9 @@ examineMethod
            DELETE → return ()
            _      → setStatus NotImplemented
 
-examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
+examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
 examineAuthority localHost localPort
-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest
          when (isNothing $ uriAuthority $ reqURI req) $
              case reqVersion req of
                -- HTTP/1.0 requests have no Host header so complete it
@@ -153,22 +135,22 @@ examineAuthority localHost localPort
                -- 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
           -- 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 ∷ CI Text → Ascii → Request → Request
 updateAuthority host port req
     = let uri  = reqURI req
           uri' = uri {
                    uriAuthority = Just URIAuth {
                                     uriUserInfo = ""
-                                  , uriRegName  = T.unpack host
+                                  , uriRegName  = T.unpack $ CI.original host
                                   , uriPort     = A.toString port
                                   }
                  }
@@ -177,13 +159,13 @@ updateAuthority host port req
 
 examineHeaders ∷ State AugmentedRequest ()
 examineHeaders
-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest
 
          case getCIHeader "Expect" req of
            Nothing → return ()
            Just v
                | v ≡ "100-continue"
-                   → modify $ \ar → ar { arExpectedContinue = Just True }
+                   → modify $ \ar → ar { arExpectedContinue = True }
                | otherwise
                    → setStatus ExpectationFailed
 
@@ -213,9 +195,9 @@ examineHeaders
 
 examineBodyLength ∷ State AugmentedRequest ()
 examineBodyLength
-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest
          len ← gets arReqBodyLength
-         if reqHasBody req then
+         if reqMustHaveBody req then
              -- POST and PUT requests must have an entity body.
              when (isNothing len)
                  $ setStatus LengthRequired