module Network.Wai.RequestSpec.Internal.Env (
Env(..),
EnvMap,
ParamMap,
QueryParams,
FormParams,
defaultEnv,
mkHeaders,
mkQParams,
mkFParams,
toEnv,
toEnvWithForm,
toEnvRaw,
) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI, original, mk)
import Data.Maybe
import Data.Text (Text, splitOn)
import Data.Text.Encoding (decodeUtf8, decodeUtf8')
import Network.HTTP.Types
import Network.Wai (Request, requestHeaders, queryString)
import qualified Data.Map as M
data QueryParams
data FormParams
type EnvMap k v = M.Map k v
type Headers = EnvMap (CI Text) Text
type ParamMap a = EnvMap Text (Maybe Text)
type QParams = ParamMap QueryParams
type FParams = ParamMap FormParams
data Env = Env { headers :: Headers
, qParams :: QParams
, fParams :: FParams
} deriving Show
mkQParams :: Query -> QParams
mkQParams = M.fromList . fmap (bt *** fmap bt)
mkFParams :: ByteString -> Maybe [(Text, Maybe Text)]
mkFParams b =
mplus (parse_ <$> decode' b) Nothing
where repack t = case splitOn "=" t of
["", ""] -> ("", Nothing)
["", _] -> ("", Nothing)
[x, ""] -> (x, Nothing)
[x, y] -> (x, Just y)
_ -> ("", Nothing)
decode' = either (const Nothing) Just . decodeUtf8'
parse_ = filter (\(_,x) -> isJust x) . fmap repack . splitOn "&"
mkHeaders :: RequestHeaders -> Headers
mkHeaders = M.fromList . fmap ((mk . bt . original) *** bt)
defaultEnv :: Env
defaultEnv = Env M.empty M.empty M.empty
toEnvRaw :: Request -> ByteString -> Env
toEnvRaw r body = toEnv_ r (mkFParams body)
toEnvWithForm :: Request -> [(Text,Text)] -> Env
toEnvWithForm r params = toEnv_ r (f params)
where f = Just . fmap (second Just)
toEnv :: Request -> Env
toEnv r = toEnv_ r Nothing
bt :: ByteString -> Text
bt = decodeUtf8
toEnv_ :: Request -> Maybe [(Text, Maybe Text)] -> Env
toEnv_ r params = Env headers' qParams' fParams'
where headers' = (mkHeaders . requestHeaders) r
qParams' = (mkQParams . queryString) r
fParams' = maybe M.empty fromFormList params
fromFormList ps = case content_type headers' of
Nothing -> M.empty
Just ["application/x-www-form-urlencoded"] -> M.fromList ps
Just ["application/x-www-form-urlencoded", _] -> M.fromList ps
Just _ -> M.empty
content_type = fmap (splitOn ";") . M.lookup "content-type"