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.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
data AugmentedRequest
= AugmentedRequest {
- arRequest ∷ !(Maybe Request)
+ arRequest ∷ !Request
, arInitialStatus ∷ !StatusCode
- , arWillClose ∷ !Bool
+ , arWillChunkBody ∷ !Bool
, arWillDiscardBody ∷ !Bool
- , arExpectedContinue ∷ !(Maybe Bool)
- , arReqBodyLength ∷ !(Maybe RequestBodyLength)
+ , arWillClose ∷ !Bool
+ , arExpectedContinue ∷ !Bool
+ , arReqBodyLength ∷ !(S.Maybe RequestBodyLength)
}
data RequestBodyLength
| 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 ∷ Text → PortNumber → Request → AugmentedRequest
+preprocess localHost localPort req@(Request {..})
= execState go initialAR
where
initialAR ∷ AugmentedRequest
initialAR = AugmentedRequest {
- arRequest = Just req
+ arRequest = req
, arInitialStatus = Ok
- , arWillClose = False
+ , arWillChunkBody = False
, arWillDiscardBody = False
- , arExpectedContinue = Just False
- , arReqBodyLength = Nothing
+ , arWillClose = False
+ , arExpectedContinue = False
+ , arReqBodyLength = S.Nothing
}
-
go ∷ State AugmentedRequest ()
go = do examineHttpVersion
examineMethod
setRequest ∷ Request → State AugmentedRequest ()
setRequest req
- = modify $ \ar → ar { arRequest = Just req }
+ = modify $ \ar → ar { arRequest = req }
setStatus ∷ StatusCode → State AugmentedRequest ()
setStatus sc
setWillClose b
= modify $ \ar → ar { arWillClose = b }
-setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength ∷ S.Maybe RequestBodyLength → State AugmentedRequest ()
setBodyLength len
= modify $ \ar → ar { arReqBodyLength = 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 ()
+ → 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 }
examineAuthority ∷ 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
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
| v ≡ "identity"
→ return ()
| v ≡ "chunked"
- → setBodyLength $ Just Chunked
+ → setBodyLength $ S.Just Chunked
| otherwise
→ setStatus NotImplemented
Just value → case C8.readInt value of
Just (len, garbage)
| C8.null garbage ∧ len ≥ 0
- → setBodyLength $ Just $ Fixed len
+ → setBodyLength $ S.Just $ Fixed len
_ → setStatus BadRequest
case getCIHeader "Connection" req of
examineBodyLength ∷ State AugmentedRequest ()
examineBodyLength
- = do req ← gets (fromJust ∘ arRequest)
+ = do req ← gets arRequest
len ← gets arReqBodyLength
if reqMustHaveBody req then
-- POST and PUT requests must have an entity body.
- when (isNothing len)
+ when (S.isNothing len)
$ setStatus LengthRequired
else
-- Other requests must NOT have an entity body.
- when (isJust len)
+ when (S.isJust len)
$ setStatus BadRequest