module Web.Respond.Monad (
MonadRespond(..),
RespondT,
runRespondT,
mapRespondT,
FailureHandlers(..),
unsupportedMethod,
unmatchedPath,
bodyParseFailed,
authFailed,
accessDenied,
caughtException,
unacceptableResponse
) where
import Data.Monoid
import Control.Applicative
import Network.Wai
import Network.HTTP.Types.Method
import Control.Monad.Trans.Reader (ReaderT(ReaderT), runReaderT, mapReaderT)
import qualified Control.Monad.Trans.Identity as Identity
import qualified Control.Monad.Trans.Maybe as Maybe
import qualified Control.Monad.Trans.List as List
import qualified Control.Monad.Trans.Except as Except
import qualified Control.Monad.Trans.Cont as Cont
import qualified Control.Monad.Trans.State.Lazy as LazyState
import qualified Control.Monad.Trans.State.Strict as StrictState
import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter
import qualified Control.Monad.Trans.Writer.Strict as StrictWriter
import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS
import qualified Control.Monad.Trans.RWS.Strict as StrictRWS
import Control.Monad.Reader.Class
import qualified Control.Monad.Cont.Class as Mtl
import qualified Control.Monad.Error.Class as Mtl
import qualified Control.Monad.State.Class as Mtl
import qualified Control.Monad.Writer.Class as Mtl
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault)
import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith, restoreT, defaultLiftWith, defaultRestoreT, MonadBaseControl, StM, liftBaseWith, defaultLiftBaseWith, restoreM, defaultRestoreM, ComposeSt)
import Control.Monad.Trans.Class
import Control.Monad.Logger
import Control.Monad.Catch
import Control.Lens ((%~), (.~), makeLenses, view)
import Web.Respond.Types
class (Functor m, MonadIO m) => MonadRespond m where
respond :: Response -> m ResponseReceived
getRequest :: m Request
withRequest :: Request -> m a -> m a
getHandlers :: m FailureHandlers
withHandlers :: (FailureHandlers -> FailureHandlers) -> m a -> m a
getPath :: m PathConsumer
withPath :: (PathConsumer -> PathConsumer) -> m a -> m a
#define MRESPDEF(mapfun) {\
respond = lift . respond; \
getRequest = lift getRequest; \
withRequest = mapfun . withRequest; \
getHandlers = lift getHandlers; \
withHandlers = mapfun . withHandlers; \
getPath = lift getPath; \
withPath = mapfun . withPath; \
}
instance MonadRespond m => MonadRespond (ReaderT a m) where MRESPDEF(mapReaderT)
instance MonadRespond m => MonadRespond (Identity.IdentityT m) where MRESPDEF(Identity.mapIdentityT)
instance MonadRespond m => MonadRespond (Maybe.MaybeT m) where MRESPDEF(Maybe.mapMaybeT)
instance MonadRespond m => MonadRespond (List.ListT m) where MRESPDEF(List.mapListT)
instance MonadRespond m => MonadRespond (Except.ExceptT e m) where MRESPDEF(Except.mapExceptT)
instance MonadRespond m => MonadRespond (Cont.ContT r m) where MRESPDEF(Cont.mapContT)
instance MonadRespond m => MonadRespond (LazyState.StateT s m) where MRESPDEF(LazyState.mapStateT)
instance MonadRespond m => MonadRespond (StrictState.StateT s m) where MRESPDEF(StrictState.mapStateT)
instance (MonadRespond m, Monoid w) => MonadRespond (LazyWriter.WriterT w m) where MRESPDEF(LazyWriter.mapWriterT)
instance (MonadRespond m, Monoid w) => MonadRespond (StrictWriter.WriterT w m) where MRESPDEF(StrictWriter.mapWriterT)
instance (Monoid w, MonadRespond m) => MonadRespond (LazyRWS.RWST r w s m) where MRESPDEF(LazyRWS.mapRWST)
instance (Monoid w, MonadRespond m) => MonadRespond (StrictRWS.RWST r w s m) where MRESPDEF(StrictRWS.mapRWST)
rmapLoggingT :: (m a -> n b) -> LoggingT m a -> LoggingT n b
rmapLoggingT f = LoggingT . (f .) . runLoggingT
rmapNoLoggingT :: (m a -> n b) -> NoLoggingT m a -> NoLoggingT n b
rmapNoLoggingT f = NoLoggingT . f . runNoLoggingT
instance MonadRespond m => MonadRespond (LoggingT m) where MRESPDEF(rmapLoggingT)
instance MonadRespond m => MonadRespond (NoLoggingT m) where MRESPDEF(rmapNoLoggingT)
data FailureHandlers = FailureHandlers {
_unsupportedMethod :: MonadRespond m => [StdMethod] -> Method -> m ResponseReceived,
_unmatchedPath :: MonadRespond m => m ResponseReceived,
_bodyParseFailed :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,
_authFailed :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,
_accessDenied :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,
_caughtException :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,
_unacceptableResponse :: (MonadRespond m) => m ResponseReceived
}
makeLenses ''FailureHandlers
data RespondData = RespondData {
_handlers :: FailureHandlers,
_request :: Request,
_responder :: Responder,
_pathConsumer :: PathConsumer
}
makeLenses ''RespondData
newtype RespondT m a = RespondT {
unRespondT :: ReaderT RespondData m a
} deriving (Functor, Applicative, Monad, MonadReader RespondData)
instance (Functor m, MonadIO m) => MonadRespond (RespondT m) where
respond v = view responder >>= \r -> liftIO . r $ v
getRequest = view request
withRequest r = local (request .~ r)
getHandlers = view handlers
withHandlers h = local (handlers %~ h)
getPath = view pathConsumer
withPath f = local (pathConsumer %~ f)
runRespondTBase :: RespondT m a -> RespondData -> m a
runRespondTBase = runReaderT . unRespondT
runRespondT :: RespondT m a -> FailureHandlers -> Request -> Responder -> m a
runRespondT act h req res = runRespondTBase act $ RespondData h req res (mkPathConsumer $ pathInfo req)
mapRespondT :: (m a -> n b) -> RespondT m a -> RespondT n b
mapRespondT f = RespondT . mapReaderT f . unRespondT
instance MonadTrans RespondT where
lift act = RespondT $ lift act
instance MonadIO m => MonadIO (RespondT m) where
liftIO act = RespondT $ liftIO act
instance MonadThrow m => MonadThrow (RespondT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (RespondT m) where
catch act h = RespondT $ catch (unRespondT act) (\e -> unRespondT (h e))
instance MonadBase b m => MonadBase b (RespondT m) where
liftBase = liftBaseDefault
instance MonadTransControl RespondT where
#if MIN_VERSION_monad_control(1, 0, 0)
type StT RespondT a = StT (ReaderT RespondData) a
liftWith = defaultLiftWith RespondT unRespondT
restoreT = defaultRestoreT RespondT
#else
newtype StT RespondT a = StRespond { unStRespond :: StT (ReaderT RespondData) a }
liftWith = defaultLiftWith RespondT unRespondT StRespond
restoreT = defaultRestoreT RespondT unStRespond
#endif
instance MonadBaseControl b m => MonadBaseControl b (RespondT m) where
#if MIN_VERSION_monad_control(1, 0, 0)
type StM (RespondT m) a = ComposeSt RespondT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
#else
newtype StM (RespondT m) a = StMT { unStMT :: ComposeSt RespondT m a}
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
#endif
instance Mtl.MonadWriter w m => Mtl.MonadWriter w (RespondT m) where
writer = lift . Mtl.writer
tell = lift . Mtl.tell
listen = mapRespondT Mtl.listen
pass = mapRespondT Mtl.pass
instance Mtl.MonadError e m => Mtl.MonadError e (RespondT m) where
throwError = lift . Mtl.throwError
catchError m h = RespondT $ Mtl.catchError (unRespondT m) (unRespondT . h)
instance Mtl.MonadCont m => Mtl.MonadCont (RespondT m) where
callCC = liftCallCC Mtl.callCC
where
liftCallCC callCC f = RespondT $ ReaderT $ \ r -> callCC $ \ c -> runRespondTBase (f (RespondT . ReaderT . const . c)) r
instance Mtl.MonadState s m => Mtl.MonadState s (RespondT m) where
get = lift Mtl.get
put = lift . Mtl.put
state = lift . Mtl.state
instance MonadLogger m => MonadLogger (RespondT m) where
monadLoggerLog loc src level msg = lift $ monadLoggerLog loc src level msg