summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNCrashed <>2018-09-13 17:40:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-09-13 17:40:00 (GMT)
commit396a3b0f30871e6da097d3ff96bc6361676f387f (patch)
treefb940f4d2b8ccdf8458d42f947a7e5d4f7fd9969
parenteea9264a8f2ee5f5dc3615804241e66790508f11 (diff)
version 0.7.0.0HEAD0.7.0.0master
-rw-r--r--CHANGELOG.md5
-rw-r--r--servant-auth-token-persistent.cabal10
-rw-r--r--src/Servant/Server/Auth/Token/Persistent.hs30
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