diff options
author | NCrashed <> | 2018-09-13 17:40:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2018-09-13 17:40:00 (GMT) |
commit | 396a3b0f30871e6da097d3ff96bc6361676f387f (patch) | |
tree | fb940f4d2b8ccdf8458d42f947a7e5d4f7fd9969 | |
parent | eea9264a8f2ee5f5dc3615804241e66790508f11 (diff) |
-rw-r--r-- | CHANGELOG.md | 5 | ||||
-rw-r--r-- | servant-auth-token-persistent.cabal | 10 | ||||
-rw-r--r-- | src/Servant/Server/Auth/Token/Persistent.hs | 30 |
3 files changed, 28 insertions, 17 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 86782bf..d45403b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.7.0.0 +======= + +* Move to 'unliftio' from 'monad-control' + 0.6.3.0 ======= diff --git a/servant-auth-token-persistent.cabal b/servant-auth-token-persistent.cabal index 4f1c20a..fc29f62 100644 --- a/servant-auth-token-persistent.cabal +++ b/servant-auth-token-persistent.cabal @@ -1,5 +1,5 @@ name: servant-auth-token-persistent -version: 0.6.3.0 +version: 0.7.0.0 synopsis: Persistent backend for servant-auth-token server description: Please see README.md homepage: https://github.com/ncrashed/servant-auth-token#readme @@ -25,17 +25,17 @@ library , aeson-injector >= 1.0 && < 1.2 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 - , monad-control >= 1.0 && < 1.1 + , exceptions >= 0.8 && < 0.11 , mtl >= 2.2 && < 2.3 - , persistent >= 2.2 && < 2.8 + , persistent >= 2.2 && < 2.9 , persistent-template >= 2.1 && < 2.7 - , servant-server >= 0.9 && < 0.14 , servant-auth-token >= 0.5 && < 0.6 , servant-auth-token-api >= 0.5 && < 0.6 + , servant-server >= 0.9 && < 0.15 , text >= 1.2 && < 1.3 , time >= 1.5 && < 1.9 , transformers >= 0.4 && < 0.6 - , transformers-base >= 0.4 && < 0.5 + , unliftio-core >= 0.1 && < 0.3 , uuid >= 1.3 && < 1.4 default-language: Haskell2010 default-extensions: diff --git a/src/Servant/Server/Auth/Token/Persistent.hs b/src/Servant/Server/Auth/Token/Persistent.hs index 6dad6a1..d354dca 100644 --- a/src/Servant/Server/Auth/Token/Persistent.hs +++ b/src/Servant/Server/Auth/Token/Persistent.hs @@ -6,34 +6,39 @@ module Servant.Server.Auth.Token.Persistent( , liftDB ) where +import Control.Monad.Catch import Control.Monad.Cont.Class (MonadCont(..)) import Control.Monad.Except +import Control.Monad.IO.Unlift 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.Writer.Class (MonadWriter(..)) import Data.Aeson.WithField import Database.Persist import Database.Persist.Sql import Servant.Server -import Servant.Server.Auth.Token.Monad -import Servant.Server.Auth.Token.Model import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Model +import Servant.Server.Auth.Token.Monad import qualified Servant.Server.Auth.Token.Persistent.Schema as S -- | Monad transformer that implements storage backend newtype PersistentBackendT m a = PersistentBackendT { unPersistentBackendT :: PersistentBackendInternal m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadCont, MonadError ServantErr) + deriving (Functor, Applicative, Monad, MonadIO, MonadCont, MonadThrow, MonadCatch) + +type PersistentBackendInternal m = ReaderT (AuthConfig, ConnectionPool) (SqlPersistT m) -type PersistentBackendInternal m = ReaderT (AuthConfig, ConnectionPool) (ExceptT ServantErr (SqlPersistT m)) +instance MonadCatch m => MonadError ServantErr (PersistentBackendT m) where + throwError = throwM + catchError = catch instance Monad m => HasAuthConfig (PersistentBackendT m) where getAuthConfig = PersistentBackendT $ asks fst instance MonadTrans PersistentBackendT where - lift = PersistentBackendT . lift . lift . lift + lift = PersistentBackendT . lift . lift instance (MonadReader r m) => MonadReader r (PersistentBackendT m) where ask = lift ask @@ -50,17 +55,18 @@ instance (MonadWriter w m) => MonadWriter w (PersistentBackendT m) where 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))) +mapPersistentBackendT :: (m a -> n b) -> PersistentBackendT m a -> PersistentBackendT n b +mapPersistentBackendT f = unwrapPersistentBackendT (mapReaderT (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) -runPersistentBackendT cfg pool ma = runSqlPool (runExceptT $ runReaderT (unPersistentBackendT ma) (cfg, pool)) pool +runPersistentBackendT :: (MonadUnliftIO m, MonadCatch m) => AuthConfig -> ConnectionPool -> PersistentBackendT m a -> m (Either ServantErr a) +runPersistentBackendT cfg pool ma = do + let ma' = runSqlPool (runReaderT (unPersistentBackendT ma) (cfg, pool)) pool + catch (Right <$> ma') $ \e -> pure $ Left e -- | Convert entity struct to 'WithId' version toWithId :: (S.ConvertStorage a' a, S.ConvertStorage (Key a') i) => Entity a' -> WithId i a @@ -68,7 +74,7 @@ toWithId (Entity k v) = WithField (S.convertFrom k) (S.convertFrom v) -- | Helper to execute DB actions in backend monad liftDB :: Monad m => SqlPersistT m a -> PersistentBackendT m a -liftDB = PersistentBackendT . lift . lift +liftDB = PersistentBackendT . lift instance (MonadIO m) => HasStorage (PersistentBackendT m) where getUserImpl = liftDB . fmap (fmap S.convertFrom) . get . S.convertTo |