version 0.7.0.0HEAD0.7.0.0master

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