servant-auth-token-persistent 0.4.0.0 → 0.5.0.0

raw patch · 3 files changed

+44/−14 lines, 3 filesdep −persistent-postgresql

Dependencies removed: persistent-postgresql

Files

CHANGELOG.md +5/−0
servant-auth-token-persistent.cabal +1/−2
src/Servant/Server/Auth/Token/Persistent.hs +38/−12

CHANGELOG.md view

@@ -1,3 +1,8 @@+0.5.0.0+=======++* MTL instances for `PersistentBackendT`. Use `liftDB` instead of removed `MonadReader SqlBackend` instance. + 0.3.2.0 =======

servant-auth-token-persistent.cabal view

@@ -1,5 +1,5 @@ name:                servant-auth-token-persistent-version:             0.4.0.0+version:             0.5.0.0 synopsis:            Persistent backend for servant-auth-token server description:         Please see README.md homepage:            https://github.com/ncrashed/servant-auth-token#readme@@ -29,7 +29,6 @@     , monad-control           >= 1.0    && < 1.1     , mtl                     >= 2.2    && < 2.3     , persistent              >= 2.2    && < 2.7-    , persistent-postgresql   >= 2.2    && < 2.7     , persistent-template     >= 2.1    && < 2.7     , servant-server          >= 0.9    && < 0.10     , servant-auth-token      >= 0.4    && < 0.5

src/Servant/Server/Auth/Token/Persistent.hs view

@@ -1,11 +1,18 @@+{-# LANGUAGE UndecidableInstances #-}+ module Servant.Server.Auth.Token.Persistent(     PersistentBackendT   , runPersistentBackendT+  , liftDB   ) where +import Control.Monad.Cont.Class (MonadCont(..))+import Control.Monad.Except import Control.Monad.Reader+import Control.Monad.RWS.Class (MonadRWS)+import Control.Monad.State.Class (MonadState(state)) import Control.Monad.Trans.Control-import Control.Monad.Except+import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson.WithField import Database.Persist import Database.Persist.Sql@@ -17,20 +24,39 @@ import qualified Servant.Server.Auth.Token.Persistent.Schema as S  -- | Monad transformer that implements storage backend-newtype PersistentBackendT m a = PersistentBackendT { unPersistentBackendT :: ReaderT (AuthConfig, ConnectionPool) (ExceptT ServantErr (SqlPersistT m)) a }-  deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr)+newtype PersistentBackendT m a = PersistentBackendT { unPersistentBackendT :: PersistentBackendInternal m a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadCont, MonadError ServantErr) -instance Monad m => MonadReader SqlBackend (PersistentBackendT m) where-  ask = PersistentBackendT $ lift . lift $ ask-  local f m = do-    (cfg, pool) <- PersistentBackendT ask-    em <- PersistentBackendT . lift . lift $ local f $ runExceptT $ runReaderT (unPersistentBackendT m) (cfg, pool)-    case em of-      Left er -> PersistentBackendT . lift $ throwError er-      Right m' -> return m'+type PersistentBackendInternal m = ReaderT (AuthConfig, ConnectionPool) (ExceptT ServantErr (SqlPersistT m))  instance Monad m => HasAuthConfig (PersistentBackendT m) where-  getAuthConfig = fmap fst $ PersistentBackendT ask+  getAuthConfig = PersistentBackendT $ asks fst++instance MonadTrans PersistentBackendT where+  lift = PersistentBackendT . lift . lift . lift++instance (MonadReader r m) => MonadReader r (PersistentBackendT m) where+  ask   = lift ask+  local = mapPersistentBackendT . local++instance (MonadState s m) => MonadState s (PersistentBackendT m) where+  state = lift . state++instance (MonadWriter w m) => MonadWriter w (PersistentBackendT m) where+  writer = lift . writer+  tell   = lift . tell+  listen = unwrapPersistentBackendT listen+  pass   = unwrapPersistentBackendT pass++instance (MonadRWS r w s m) => MonadRWS r w s (PersistentBackendT m)++mapPersistentBackendT :: (m (Either ServantErr a) -> n (Either ServantErr b))+                         -> PersistentBackendT m a -> PersistentBackendT n b+mapPersistentBackendT f = unwrapPersistentBackendT (mapReaderT (mapExceptT (mapReaderT f)))++unwrapPersistentBackendT :: (PersistentBackendInternal m a -> PersistentBackendInternal n b)+                            -> PersistentBackendT m a -> PersistentBackendT n b+unwrapPersistentBackendT f = PersistentBackendT . f . unPersistentBackendT  -- | Execute backend action with given connection pool. runPersistentBackendT :: MonadBaseControl IO m => AuthConfig -> ConnectionPool -> PersistentBackendT m a -> m (Either ServantErr a)