module Factis.Haskoon.RqAccessM
(RqData(..), RqAccess(..), RqAccessM(..), runRqAccessM)
where
import Control.Monad (MonadPlus)
import Control.Monad.Reader (ReaderT(runReaderT),asks)
import Safe (atMay)
import Factis.Haskoon.RqAccess (RqAccess(..))
data RqData = RqData { rqd_method :: String
, rqd_params :: [(String,String)]
, rqd_headers :: [(String,String)]
, rqd_repls :: [String]
, rqd_cookies :: [(String, String)]
}
type RqRead a = ReaderT RqData (Either String) a
newtype RqAccessM a = RqAccessM (RqRead a) deriving (Monad, MonadPlus)
instance RqAccess RqAccessM where
param n = RqAccessM (readFromPairs rqd_params n "Parameter")
repl i = RqAccessM (readFromRqData rqd_repls (flip atMay i) desc)
where desc = "Replacement "++show i
cookie n = RqAccessM (readFromPairs rqd_cookies n "Cookie")
header n = RqAccessM (readFromPairs rqd_headers n "Header")
checkMethod isMethOk =
RqAccessM $
do meth <- asks rqd_method
if isMethOk meth
then return meth
else fail $ "Invalid request method `"++meth++"'."
readFromPairs :: (Eq a,Show a) => (RqData -> [(a,b)]) -> a -> String -> RqRead b
readFromPairs rqd_pairs key name = readFromRqData rqd_pairs findIn desc
where findIn = lookup key
desc = name ++ " `"++show key++"'"
readFromRqData :: (RqData -> a) -> (a -> Maybe b) -> String -> RqRead b
readFromRqData rqd_value findIn desc =
do value <- asks rqd_value
case findIn value of
Nothing -> fail $ desc ++ " not found."
Just v -> return v
runRqAccessM :: RqAccessM t -> RqData -> Either String t
runRqAccessM (RqAccessM r) d = runReaderT r d