servant-auth-token-persistent 0.6.3.0 → 0.7.0.0

raw patch · 3 files changed

+28/−17 lines, 3 filesdep +exceptionsdep +unliftio-coredep −monad-controldep −transformers-basedep ~persistentdep ~servant-server

Dependencies added: exceptions, unliftio-core

Dependencies removed: monad-control, transformers-base

Dependency ranges changed: persistent, servant-server

Files

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

@@ -1,3 +1,8 @@+0.7.0.0+=======++* Move to 'unliftio' from 'monad-control'+ 0.6.3.0 ======= 

@@ -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 @@     , 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:

@@ -6,34 +6,39 @@   , 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) (ExceptT ServantErr (SqlPersistT m))+type PersistentBackendInternal m = ReaderT (AuthConfig, ConnectionPool) (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 (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 @@  -- | 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