#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)
#endif
module Data.IterIO.Http.Support.Action (
Action
, ActionState(..)
, Param(..)
, params, param, paramVal, paramValM
, setParams
, getBody
, getHttpReq
, setSession, destroySession
, requestHeader
) where
import Control.Monad
import Control.Monad.Trans.State
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.IterIO.Http
import Data.List (find)
data Param = Param {
paramKey :: S.ByteString
, paramValue :: L.ByteString
, paramHeaders :: [(S.ByteString, S.ByteString)]
} deriving (Show)
data ActionState t b m = ActionState {
actionReq :: HttpReq t
, actionResp :: HttpResp m
, actionParams :: [Param]
, actionBody :: b
}
type Action t b m a = StateT (ActionState t b m) m a
setSession :: Monad m => String -> Action t b m ()
setSession cookie = modify $ \s ->
let cookieHeader = (S.pack "Set-Cookie", S.pack $ "_sess=" ++ cookie ++ "; path=/;")
in s { actionResp = respAddHeader cookieHeader (actionResp s)}
destroySession :: Monad m => Action t b m ()
destroySession = modify $ \s ->
let cookieHeader = (S.pack "Set-Cookie", S.pack "_sess=; path=/; expires=Thu, Jan 01 1970 00:00:00 UTC;")
in s { actionResp = respAddHeader cookieHeader (actionResp s)}
requestHeader :: Monad m => S.ByteString -> Action t b m (Maybe S.ByteString)
requestHeader name = do
httpReq <- getHttpReq
return $ lookup name (reqHeaders httpReq)
getHttpReq :: Monad m => Action t b m (HttpReq t)
getHttpReq = gets actionReq
getBody :: Monad m => Action t b m b
getBody = gets actionBody
setParams :: Monad m => [Param] -> Action t b m [Param]
setParams prms = do
modify $ \s -> s { actionParams = prms }
return prms
params :: Monad m => Action t b m [Param]
params = do
gets actionParams
param :: Monad m => S.ByteString -> Action t b m (Maybe Param)
param key = find ((== key) . paramKey) `liftM` params
paramVal :: Monad m => S.ByteString -> Action t b m (L.ByteString)
paramVal n = param n >>=
maybe (fail "No such parameter") (return . paramValue)
paramValM :: Monad m
=> (L.ByteString -> a)
-> S.ByteString
-> Action t b m (Maybe a)
paramValM f n = fmap (f . paramValue) `liftM` param n