summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNCrashed <>2018-09-13 17:39:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-09-13 17:39:00 (GMT)
commitaed21d408dc668ba91c4199e9bb43006ac104bbf (patch)
tree0074ff4cb81ecadfc845a87ad42d1da4454b9070
parentc65917d1b5eac2c410bae501fa7605db9e18f56d (diff)
version 0.6.0.0HEAD0.6.0.0master
-rw-r--r--CHANGELOG.md6
-rw-r--r--servant-auth-token-leveldb.cabal17
-rw-r--r--src/Servant/Server/Auth/Token/LevelDB.hs39
-rw-r--r--src/Servant/Server/Auth/Token/LevelDB/Schema.hs19
4 files changed, 46 insertions, 35 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 78a68b1..71c56d3 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,9 @@
+0.6.0.0
+=======
+
+* Return to original `safecopy` instead of `safecopy-store`.
+* Use `unliftio` insteal of `monad-control`.
+
0.5.3.0
=======
diff --git a/servant-auth-token-leveldb.cabal b/servant-auth-token-leveldb.cabal
index f26c73e..40361c0 100644
--- a/servant-auth-token-leveldb.cabal
+++ b/servant-auth-token-leveldb.cabal
@@ -1,5 +1,5 @@
name: servant-auth-token-leveldb
-version: 0.5.3.0
+version: 0.6.0.0
synopsis: Leveldb backend for servant-auth-token server
description: Please see README.md
homepage: https://github.com/ncrashed/servant-auth-token#readme
@@ -24,24 +24,23 @@ library
base >= 4.7 && < 5
, aeson-injector >= 1.1 && < 1.2
, bytestring >= 0.10 && < 0.11
+ , cereal >= 0.5 && < 0.6
, concurrent-extra >= 0.7 && < 0.8
, containers >= 0.5 && < 0.6
- , exceptions >= 0.8 && < 0.9
- , lens >= 4.15 && < 4.16
+ , exceptions >= 0.8 && < 0.11
+ , lens >= 4.15 && < 4.17
, leveldb-haskell >= 0.6 && < 0.7
- , monad-control >= 1.0 && < 1.1
, mtl >= 2.2 && < 2.3
- , resourcet >= 1.1 && < 1.2
+ , resourcet >= 1.1 && < 1.3
, safe >= 0.3 && < 0.4
- , safecopy-store >= 0.9 && < 0.10
+ , safecopy >= 0.9 && < 0.10
, servant-auth-token >= 0.5 && < 0.6
, servant-auth-token-api >= 0.5 && < 0.6
- , servant-server >= 0.9 && < 0.14
- , store >= 0.3 && < 0.5
+ , 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
, vector >= 0.11 && < 0.13
default-language: Haskell2010
diff --git a/src/Servant/Server/Auth/Token/LevelDB.hs b/src/Servant/Server/Auth/Token/LevelDB.hs
index f28f613..97c9b10 100644
--- a/src/Servant/Server/Auth/Token/LevelDB.hs
+++ b/src/Servant/Server/Auth/Token/LevelDB.hs
@@ -5,11 +5,10 @@ module Servant.Server.Auth.Token.LevelDB(
, newLevelDBEnv
) where
-import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
+import Control.Monad.IO.Unlift
import Control.Monad.Reader
-import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Servant.Server
import Servant.Server.Auth.Token.Config
@@ -19,25 +18,33 @@ import Servant.Server.Auth.Token.Model
import qualified Servant.Server.Auth.Token.LevelDB.Schema as S
-- | Monad transformer that implements storage backend
-newtype LevelDBBackendT m a = LevelDBBackendT { unLevelDBBackendT :: ReaderT (AuthConfig, LevelDBEnv) (ExceptT ServantErr (ResourceT m)) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, MonadReader (AuthConfig, LevelDBEnv), MonadThrow, MonadCatch)
+newtype LevelDBBackendT m a = LevelDBBackendT { unLevelDBBackendT :: ReaderT (AuthConfig, LevelDBEnv) (ResourceT m) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader (AuthConfig, LevelDBEnv), MonadThrow, MonadCatch)
-deriving instance MonadBase IO m => MonadBase IO (LevelDBBackendT m)
-deriving instance (MonadBase IO m, MonadThrow m, MonadIO m) => MonadResource (LevelDBBackendT m)
+deriving instance (MonadThrow m, MonadIO m) => MonadResource (LevelDBBackendT m)
+
+instance MonadCatch m => MonadError ServantErr (LevelDBBackendT m) where
+ throwError = throwM
+ catchError = catch
instance Monad m => HasAuthConfig (LevelDBBackendT m) where
getAuthConfig = fst <$> LevelDBBackendT ask
-newtype StMLevelDBBackendT m a = StMLevelDBBackendT { unStMLevelDBBackendT :: StM (ReaderT (AuthConfig, LevelDBEnv) (ExceptT ServantErr m)) a }
+instance MonadUnliftIO m => MonadUnliftIO (LevelDBBackendT m) where
+ askUnliftIO = LevelDBBackendT $ withUnliftIO $ \u -> pure (UnliftIO (unliftIO u . unLevelDBBackendT))
-instance MonadBaseControl IO m => MonadBaseControl IO (LevelDBBackendT m) where
- type StM (LevelDBBackendT m) a = StMLevelDBBackendT m a
- liftBaseWith f = LevelDBBackendT $ liftBaseWith $ \q -> f (fmap StMLevelDBBackendT . q . unLevelDBBackendT)
- restoreM = LevelDBBackendT . restoreM . unStMLevelDBBackendT
+-- newtype StMLevelDBBackendT m a = StMLevelDBBackendT { unStMLevelDBBackendT :: StM (ReaderT (AuthConfig, LevelDBEnv) (ExceptT ServantErr m)) a }
+--
+-- instance MonadBaseControl IO m => MonadBaseControl IO (LevelDBBackendT m) where
+-- type StM (LevelDBBackendT m) a = StMLevelDBBackendT m a
+-- liftBaseWith f = LevelDBBackendT $ liftBaseWith $ \q -> f (fmap StMLevelDBBackendT . q . unLevelDBBackendT)
+-- restoreM = LevelDBBackendT . restoreM . unStMLevelDBBackendT
-- | Execute backend action with given connection pool.
-runLevelDBBackendT :: MonadBaseControl IO m => AuthConfig -> LevelDBEnv -> LevelDBBackendT m a -> m (Either ServantErr a)
-runLevelDBBackendT cfg db ma = runResourceT . runExceptT $ runReaderT (unLevelDBBackendT ma) (cfg, db)
+runLevelDBBackendT :: (MonadUnliftIO m, MonadCatch m) => AuthConfig -> LevelDBEnv -> LevelDBBackendT m a -> m (Either ServantErr a)
+runLevelDBBackendT cfg db ma = do
+ let ma' = runResourceT $ runReaderT (unLevelDBBackendT ma) (cfg, db)
+ catch (Right <$> ma') $ \e -> pure $ Left e
-- | Helper to extract LevelDB reference
getEnv :: Monad m => LevelDBBackendT m LevelDBEnv
@@ -45,11 +52,9 @@ getEnv = snd <$> LevelDBBackendT ask
-- | Helper to lift low-level LevelDB queries to backend monad
liftEnv :: Monad m => (LevelDBEnv -> ResourceT m a) -> LevelDBBackendT m a
-liftEnv f = do
- e <- getEnv
- LevelDBBackendT . lift . lift $ f e
+liftEnv f = LevelDBBackendT . ReaderT $ f . snd
-instance (MonadBase IO m, MonadIO m, MonadThrow m, MonadMask m) => HasStorage (LevelDBBackendT m) where
+instance (MonadIO m, MonadThrow m, MonadMask m) => HasStorage (LevelDBBackendT m) where
getUserImpl = liftEnv . flip S.load
getUserImplByLogin = liftEnv . S.getUserImplByLogin
listUsersPaged page size = liftEnv $ S.listUsersPaged page size
diff --git a/src/Servant/Server/Auth/Token/LevelDB/Schema.hs b/src/Servant/Server/Auth/Token/LevelDB/Schema.hs
index b569da2..2ee256c 100644
--- a/src/Servant/Server/Auth/Token/LevelDB/Schema.hs
+++ b/src/Servant/Server/Auth/Token/LevelDB/Schema.hs
@@ -13,10 +13,11 @@ import Data.List (sort, sortBy)
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Ord
-import Data.SafeCopy.Store
-import Data.SafeCopy.Store.Internal
+import Data.SafeCopy
+import Data.SafeCopy.Internal
+import Data.Serialize.Get
+import Data.Serialize.Put
import Data.Set (Set)
-import Data.Store
import Data.Text (Text)
import Data.Time
import Data.Typeable hiding (Proxy)
@@ -124,8 +125,8 @@ class Key i a | i -> a, a -> i where
encodeKey :: i -> ByteString
default encodeKey :: (SafeCopy i, Typeable i) => i -> ByteString
- encodeKey i = runEncode $ do
- _ <- pokeE tname
+ encodeKey i = runPut $ do
+ safePut tname
safePut i
where
tname = show $ typeRep (Proxy :: Proxy i)
@@ -153,11 +154,11 @@ newLevelDBEnv db rops wopts = do
load :: (MonadResource m, Key i a, SafeCopy a) => LevelDBEnv -> i -> m (Maybe a)
load (LevelDBEnv db ropts _ _) i = do
mbs <- get db ropts (encodeKey i)
- return $ decodeExWith safeGet <$> mbs
+ return $ join $ either (const Nothing) Just . runGet safeGet <$> mbs
-- | Store object by id in leveldb
store :: (MonadResource m, Key i a, SafeCopy a) => LevelDBEnv -> i -> a -> m ()
-store (LevelDBEnv db _ wopts _) i a = put db wopts (encodeKey i) (runEncode $ safePut a)
+store (LevelDBEnv db _ wopts _) i a = put db wopts (encodeKey i) (runPut $ safePut a)
-- | Remove object by given id in leveldb
remove :: (MonadResource m, Key i a) => LevelDBEnv -> i -> m ()
@@ -510,10 +511,10 @@ deriveSafeCopy 0 'base ''ModelId
deriveSafeCopy 0 'base ''Model
instance (SafeCopy k, SafeCopy v) => SafeCopy (WithField i k v) where
- putCopy a@(WithField k v) = contain $ do
+ putCopy (WithField k v) = contain $ do
_ <- safePut k
_ <- safePut v
- return a
+ return ()
getCopy = contain $ WithField
<$> safeGet
<*> safeGet