respond 1.0.0 → 1.1.0
raw patch · 3 files changed
+138/−50 lines, 3 filesdep ~monad-control
Dependency ranges changed: monad-control
Files
- CHANGELOG.md +19/−0
- respond.cabal +18/−31
- src/Web/Respond/Monad.hs +101/−19
+ CHANGELOG.md view
@@ -0,0 +1,19 @@+changelog+=========+this library will attempt to maintain conformance to the rules of [semantic versioning](http://semver.org/).++1.1.0+-------++* add a method to MonadRespond to run an inner route with a different Request value+* implement MonadRespond instances lifted that lift over transformers+* implement MTL interface instances that lift over RespondT+* add compatibility for new version of monad-control.++1.0.0+-------+initial true release++0.2.0.0+-------+experimental release.
respond.cabal view
@@ -1,35 +1,22 @@-name: respond-version: 1.0.0-homepage:- https://github.com/raptros/respond-license:- BSD3-license-file:- LICENSE-author:- aidan coyne-maintainer:- coynea90@gmail.com-copyright:- 2014, aidan coyne-category:- Web-build-type:- Simple-extra-source-files:- README.md-cabal-version:- >=1.10-bug-reports:- https://github.com/raptros/respond/issues-synopsis:- process and route HTTP requests and generate responses on top of WAI-description:- a Haskell library built on top of WAI for processing and routing HTTP requests and generating responses. - see the source repository for a simple example application.+name: respond+version: 1.1.0+homepage: https://github.com/raptros/respond+license: BSD3+license-file: LICENSE+author: aidan coyne+maintainer: coynea90@gmail.com+copyright: 2014, aidan coyne+category: Web+build-type: Simple+extra-source-files: README.md, CHANGELOG.md+cabal-version: >=1.10+bug-reports: https://github.com/raptros/respond/issues+synopsis: process and route HTTP requests and generate responses on top of WAI+description: a Haskell library built on top of WAI for processing and routing HTTP requests and generating responses. see the source repository for a simple example application. + source-repository head- type: git+ type: git location: https://github.com/raptros/respond.git library@@ -60,7 +47,7 @@ build-depends: base >=4.7 && <4.8, transformers-base == 0.4.*,- monad-control == 0.3.*,+ monad-control >= 0.3 && < 1.1, data-default-class, exceptions >= 0.6 && < 0.7, bifunctors >= 4.1 && <= 4.3,
src/Web/Respond/Monad.hs view
@@ -14,6 +14,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} module Web.Respond.Monad ( -- * the monad interface MonadRespond(..),@@ -33,13 +34,27 @@ unacceptableResponse ) where +import Data.Monoid import Control.Applicative import Network.Wai import Network.HTTP.Types.Method-import Control.Monad.Trans.Reader (ReaderT, runReaderT, mapReaderT)-import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)-import Control.Monad.Trans.Except (ExceptT, mapExceptT)+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)@@ -47,7 +62,7 @@ import Control.Monad.Logger import Control.Monad.Catch -import Control.Lens ((%~), makeLenses, view)+import Control.Lens ((%~), (.~), makeLenses, view) import Web.Respond.Types -- | this class is the api for building your handler.@@ -57,6 +72,8 @@ respond :: Response -> m ResponseReceived -- | get out the request. getRequest :: m Request+ -- | run the inner route with a modified request+ withRequest :: Request -> m a -> m a -- | get the 'FailureHandlers'. getHandlers :: m FailureHandlers -- | run an inner action that will see an updates set of error@@ -68,22 +85,51 @@ -- | run the inner action with an updated path state. withPath :: (PathConsumer -> PathConsumer) -> m a -> m a -instance MonadRespond m => MonadRespond (ExceptT e m) where- respond = lift . respond- getRequest = lift getRequest- getHandlers = lift getHandlers- withHandlers = mapExceptT . withHandlers- getPath = lift getPath- withPath = mapExceptT . withPath+#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 (MaybeT m) where- respond = lift . respond- getRequest = lift getRequest- getHandlers = lift getHandlers- withHandlers = mapMaybeT . withHandlers- getPath = lift getPath- withPath = mapMaybeT . 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)++ -- | record containing responders that request matching tools can use when -- failures occur. data FailureHandlers = FailureHandlers {@@ -125,14 +171,18 @@ 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+ -- | run the RespondT action with failure handlers and request information. runRespondT :: RespondT m a -> FailureHandlers -> Request -> Responder -> m a-runRespondT (RespondT act) h req res = runReaderT act $ RespondData h req res (mkPathConsumer $ pathInfo req)+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@@ -157,14 +207,46 @@ -- and these two demand TypeFamilies 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