module Rest.Driver.RestM
( RestM
, runRestM
, runRestM_
, RestInput (..)
, emptyInput
, RestOutput (..)
) where
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Rest.Driver.Perform (Rest)
import qualified Rest.Driver.Types as Rest
import qualified Rest.Driver.Perform as Rest
data RestInput = RestInput
{ headers :: Map String String
, parameters :: Map String String
, body :: UTF8.ByteString
, method :: Rest.Method
, paths :: [String]
, mimeTypes :: Map String String
}
emptyInput :: RestInput
emptyInput = RestInput
{ headers = Map.empty
, parameters = Map.empty
, body = mempty
, method = Rest.GET
, paths = []
, mimeTypes = Map.empty
}
data RestOutput = RestOutput
{ headersSet :: Map String String
, responseCode :: Maybe Int
} deriving Show
instance Monoid RestOutput where
mempty = RestOutput { headersSet = Map.empty, responseCode = Nothing }
o1 `mappend` o2 = RestOutput
{ headersSet = headersSet o2 `Map.union` headersSet o1
, responseCode = responseCode o2 <|> responseCode o1
}
outputHeader :: String -> String -> RestOutput
outputHeader h v = mempty { headersSet = Map.singleton h v }
outputCode :: Int -> RestOutput
outputCode cd = mempty { responseCode = Just cd }
newtype RestM m a = RestM { unRestM :: ReaderT RestInput (WriterT RestOutput m) a }
deriving (Functor, Applicative, Monad)
instance MonadTrans RestM where
lift = RestM . lift . lift
runRestM :: RestInput -> RestM m a -> m (a, RestOutput)
runRestM i = runWriterT . flip runReaderT i . unRestM
runRestM_ :: Functor m => RestInput -> RestM m a -> m a
runRestM_ i = fmap fst . runRestM i
instance (Functor m, Applicative m, Monad m) => Rest (RestM m) where
getHeader h = RestM $ asks (Map.lookup h . headers )
getParameter p = RestM $ asks (Map.lookup p . parameters)
getBody = RestM $ asks body
getMethod = RestM $ asks method
getPaths = RestM $ asks paths
lookupMimeType t = RestM $ asks (Map.lookup t . mimeTypes)
setHeader h v = RestM $ tell (outputHeader h v)
setResponseCode cd = RestM $ tell (outputCode cd)