servant-auth-token-leveldb 0.5.3.0 → 0.6.0.0

raw patch · 4 files changed

+46/−35 lines, 4 filesdep +cerealdep +safecopydep +unliftio-coredep −monad-controldep −safecopy-storedep −storedep ~exceptionsdep ~lensdep ~resourcetPVP ok

version bump matches the API change (PVP)

Dependencies added: cereal, safecopy, unliftio-core

Dependencies removed: monad-control, safecopy-store, store, transformers-base

Dependency ranges changed: exceptions, lens, resourcet, servant-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• servant-auth-token-leveldb.cabal +8/−9
• src/Servant/Server/Auth/Token/LevelDB.hs +22/−17
• src/Servant/Server/Auth/Token/LevelDB/Schema.hs +10/−9

@@ -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 ======= 

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

@@ -5,11 +5,10 @@   , 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 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 @@  -- | 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

@@ -13,10 +13,11 @@ 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 @@   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 @@ 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 ''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