servant-auth-token-leveldb (empty) → 0.4.1.0

raw patch · 7 files changed

+820/−0 lines, 7 filesdep +aeson-injectordep +basedep +bytestringsetup-changed

Dependencies added: aeson-injector, base, bytestring, concurrent-extra, containers, exceptions, lens, leveldb-haskell, monad-control, mtl, resourcet, safe, safecopy-store, servant-auth-token, servant-auth-token-api, servant-server, store, text, time, transformers, transformers-base, uuid, vector

Files

CHANGELOG.md +4/−0
LICENSE +30/−0
README.md +60/−0
Setup.hs +2/−0
servant-auth-token-leveldb.cabal +74/−0
src/Servant/Server/Auth/Token/LevelDB.hs +129/−0
src/Servant/Server/Auth/Token/LevelDB/Schema.hs +521/−0

+ CHANGELOG.md view

@@ -0,0 +1,4 @@+0.4.1.0+=======++* Initial release.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Anton Gushcha (c) 2016-2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of NCrashed nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,60 @@+# servant-auth-token-acid++Storage backend on acid for [servant-auth-token](https://github.com/NCrashed/servant-auth-token) server.++As `acid-state` is bad at composing states, the integration of the library in your project requires a massive TH mixins.+The authentification state's queries are simply copied to your app.++First, define you own global `acid-state` type:++``` haskell+import Data.SafeCopy+import Servant.Server.Auth.Token.Acid.Schema as A++-- | Application global state for acid-state+data DB = DB {+  dbAuth :: A.Model -- ^ Storage for Auth state+, dbCustom :: () -- ^ Demo of custom state+}++-- | Generation of inital state+newDB :: DB+newDB = DB {+    dbAuth = A.newModel+  , dbCustom = ()+  }++-- | Extraction of Auth model from global state+instance HasModelRead DB where+  askModel = dbAuth++-- | Extraction of Auth model from global state+instance HasModelWrite DB where+  putModel db m = db { dbAuth = m }++deriveSafeCopy 0 'base ''DB++-- Mixin auth state queries and derive acid-state instances for them+A.deriveQueries ''DB+A.makeModelAcidic ''DB+```++Next, define your monad stack for the authorization actions:+``` haskell+-- Derive HasStorage for 'AcidBackendT' with your 'DB'.+-- It is important that it is come before the below newtype+deriveAcidHasStorage ''DB++-- | Special monad for authorisation actions+newtype AuthM a = AuthM { unAuthM :: AcidBackendT DB IO a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)++-- | Execution of authorisation actions that require 'AuthHandler' context+runAuth :: AuthM a -> ServerM a+runAuth m = do+  cfg <- asks envAuthConfig+  db <- asks envDB+  liftHandler $ ExceptT $ runAcidBackendT cfg db $ unAuthM m+```++See a full example in [servant-auth-token-example-acid](https://github.com/NCrashed/servant-auth-token/tree/master/example/acid).

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ servant-auth-token-leveldb.cabal view

@@ -0,0 +1,74 @@+name:                servant-auth-token-leveldb+version:             0.4.1.0+synopsis:            Leveldb backend for servant-auth-token server+description:         Please see README.md+homepage:            https://github.com/ncrashed/servant-auth-token#readme+license:             BSD3+license-file:        LICENSE+author:              NCrashed+maintainer:          ncrashed@gmail.com+copyright:           2017 Anton Gushcha+category:            Web+build-type:          Simple+extra-source-files:+  README.md+  CHANGELOG.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+    Servant.Server.Auth.Token.LevelDB+    Servant.Server.Auth.Token.LevelDB.Schema+  build-depends:+      base                    >= 4.7    && < 5+    , aeson-injector          >= 1.0    && < 1.1+    , bytestring              >= 0.10   && < 0.11+    , concurrent-extra        >= 0.7    && < 0.8+    , containers              >= 0.5    && < 0.6+    , exceptions              >= 0.8    && < 0.9+    , lens                    >= 4.15   && < 4.16+    , leveldb-haskell         >= 0.6    && < 0.7+    , monad-control           >= 1.0    && < 1.1+    , mtl                     >= 2.2    && < 2.3+    , resourcet               >= 1.1    && < 1.2+    , safe                    >= 0.3    && < 0.4+    , safecopy-store          >= 0.9    && < 0.10+    , servant-auth-token      >= 0.4    && < 0.5+    , servant-auth-token-api  >= 0.4    && < 0.5+    , servant-server          >= 0.9    && < 0.10+    , store                   >= 0.3    && < 0.4+    , text                    >= 1.2    && < 1.3+    , time                    >= 1.5    && < 1.7+    , transformers            >= 0.4    && < 0.6+    , transformers-base       >= 0.4    && < 0.5+    , uuid                    >= 1.3    && < 1.4+    , vector                  >= 0.11   && < 0.12+  default-language:    Haskell2010+  default-extensions:+    BangPatterns+    DataKinds+    DefaultSignatures+    DeriveGeneric+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    MultiParamTypeClasses+    OverloadedStrings+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators+    UndecidableInstances++source-repository head+  type:     git+  location: https://github.com/ncrashed/servant-auth-token

+ src/Servant/Server/Auth/Token/LevelDB.hs view

@@ -0,0 +1,129 @@+module Servant.Server.Auth.Token.LevelDB(+    LevelDBBackendT+  , runLevelDBBackendT+  , LevelDBEnv+  , newLevelDBEnv+  ) where++import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Database.LevelDB+import Servant.Server+import Servant.Server.Auth.Token.Config+import Servant.Server.Auth.Token.LevelDB.Schema (LevelDBEnv, newLevelDBEnv)+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)++deriving instance MonadBase IO m => MonadBase IO (LevelDBBackendT m)+deriving instance (MonadBase IO m, MonadThrow m, MonadIO m) => MonadResource (LevelDBBackendT m)++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 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)++-- | Helper to extract LevelDB reference+getEnv :: Monad m => LevelDBBackendT m LevelDBEnv+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++instance (MonadBase IO m, 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+  getUserImplPermissions = liftEnv . S.getUserImplPermissions+  deleteUserPermissions = liftEnv . S.deleteUserPermissions+  insertUserPerm = liftEnv . S.insertUserPerm+  insertUserImpl = liftEnv . S.insertUserImpl+  replaceUserImpl i v = liftEnv $ S.replaceUserImpl i v+  deleteUserImpl = liftEnv . S.deleteUserImpl+  hasPerm i p = liftEnv $ S.hasPerm i p+  getFirstUserByPerm = liftEnv . S.getFirstUserByPerm+  selectUserImplGroups = liftEnv . S.selectUserImplGroups+  clearUserImplGroups = liftEnv . S.clearUserImplGroups+  insertAuthUserGroup = liftEnv . S.insertAuthUserGroup+  insertAuthUserGroupUsers = liftEnv . S.insertAuthUserGroupUsers+  insertAuthUserGroupPerms = liftEnv . S.insertAuthUserGroupPerms+  getAuthUserGroup = liftEnv . flip S.load+  listAuthUserGroupPermissions = liftEnv . S.listAuthUserGroupPermissions+  listAuthUserGroupUsers = liftEnv . S.listAuthUserGroupUsers+  replaceAuthUserGroup i v = liftEnv $ S.replaceAuthUserGroup i v+  clearAuthUserGroupUsers = liftEnv . S.clearAuthUserGroupUsers+  clearAuthUserGroupPerms = liftEnv . S.clearAuthUserGroupPerms+  deleteAuthUserGroup = liftEnv . S.deleteAuthUserGroup+  listGroupsPaged page size = liftEnv $ S.listGroupsPaged page size+  setAuthUserGroupName i n = liftEnv $ S.setAuthUserGroupName i n+  setAuthUserGroupParent i mp = liftEnv $ S.setAuthUserGroupParent i mp+  insertSingleUseCode = liftEnv . S.insertSingleUseCode+  setSingleUseCodeUsed i mt = liftEnv $ S.setSingleUseCodeUsed i mt+  getUnusedCode c i t = liftEnv $ S.getUnusedCode c i t+  invalidatePermamentCodes i t = liftEnv $ S.invalidatePermamentCodes i t+  selectLastRestoreCode i t = liftEnv $ S.selectLastRestoreCode i t+  insertUserRestore = liftEnv . S.insertUserRestore+  findRestoreCode i rc t = liftEnv $ S.findRestoreCode i rc t+  replaceRestoreCode i v = liftEnv $ S.replaceRestoreCode i v+  findAuthToken i t = liftEnv $ S.findAuthToken i t+  findAuthTokenByValue t = liftEnv $ S.findAuthTokenByValue t+  insertAuthToken = liftEnv . S.insertAuthToken+  replaceAuthToken i v = liftEnv $ S.replaceAuthToken i v+  {-# INLINE getUserImpl #-}+  {-# INLINE getUserImplByLogin #-}+  {-# INLINE listUsersPaged #-}+  {-# INLINE getUserImplPermissions #-}+  {-# INLINE deleteUserPermissions #-}+  {-# INLINE insertUserPerm #-}+  {-# INLINE insertUserImpl #-}+  {-# INLINE replaceUserImpl #-}+  {-# INLINE deleteUserImpl #-}+  {-# INLINE hasPerm #-}+  {-# INLINE getFirstUserByPerm #-}+  {-# INLINE selectUserImplGroups #-}+  {-# INLINE clearUserImplGroups #-}+  {-# INLINE insertAuthUserGroup #-}+  {-# INLINE insertAuthUserGroupUsers #-}+  {-# INLINE insertAuthUserGroupPerms #-}+  {-# INLINE getAuthUserGroup #-}+  {-# INLINE listAuthUserGroupPermissions #-}+  {-# INLINE listAuthUserGroupUsers #-}+  {-# INLINE replaceAuthUserGroup #-}+  {-# INLINE clearAuthUserGroupUsers #-}+  {-# INLINE clearAuthUserGroupPerms #-}+  {-# INLINE deleteAuthUserGroup #-}+  {-# INLINE listGroupsPaged #-}+  {-# INLINE setAuthUserGroupName #-}+  {-# INLINE setAuthUserGroupParent #-}+  {-# INLINE insertSingleUseCode #-}+  {-# INLINE setSingleUseCodeUsed #-}+  {-# INLINE getUnusedCode #-}+  {-# INLINE invalidatePermamentCodes #-}+  {-# INLINE selectLastRestoreCode #-}+  {-# INLINE insertUserRestore #-}+  {-# INLINE findRestoreCode #-}+  {-# INLINE replaceRestoreCode #-}+  {-# INLINE findAuthToken #-}+  {-# INLINE findAuthTokenByValue #-}+  {-# INLINE insertAuthToken #-}+  {-# INLINE replaceAuthToken #-}

+ src/Servant/Server/Auth/Token/LevelDB/Schema.hs view

@@ -0,0 +1,521 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.Server.Auth.Token.LevelDB.Schema where++import Control.Concurrent.RLock+import Control.Lens+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Aeson.WithField+import Data.ByteString (ByteString)+import Data.Int+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.Set (Set)+import Data.Store+import Data.Text (Text)+import Data.Time+import Data.Typeable hiding (Proxy)+import Data.Vector (Vector)+import Database.LevelDB+import Safe++import Servant.API.Auth.Token+import Servant.API.Auth.Token.Pagination+import Servant.Server.Auth.Token.Common+import Servant.Server.Auth.Token.Model(+    UserImplId+  , UserImpl(..)+  , UserPermId+  , UserPerm(..)+  , AuthTokenId+  , AuthToken(..)+  , UserRestoreId+  , UserRestore(..)+  , UserSingleUseCodeId+  , UserSingleUseCode(..)+  , AuthUserGroupId+  , AuthUserGroup(..)+  , AuthUserGroupUsersId+  , AuthUserGroupUsers(..)+  , AuthUserGroupPermsId+  , AuthUserGroupPerms(..)+  )++import qualified Data.Foldable as F+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Vector as V++-- | ID of global model index+newtype ModelId = ModelId { unModelId :: Int64 }+  deriving (Show, Read, Ord, Eq)++-- | Global id of model index+modelId :: ModelId+modelId = ModelId 0++-- | Holds all data for auth server in acid-state container+data Model = Model {+  -- | Holds users by id+  _modelUsers                    :: !(Set UserImplId)+  -- | Holds users by login (same content as 'modelUsers')+, _modelUsersByLogin             :: !(Map Login UserImplId)+  -- | Holds 'UserPerm'+, _modelUserPerms                :: !(Set UserPermId)+  -- | Holds 'AuthToken'+, _modelAuthTokens               :: !(Set AuthTokenId)+  -- | Holds 'UserRestore'+, _modelUserRestores             :: !(Set UserRestoreId)+  -- | Holds 'UserSingleUseCode'+, _modelUserSingleUseCodes       :: !(Set UserSingleUseCodeId)+  -- | Holds 'AuthUserGroup'+, _modelAuthUserGroups           :: !(Set AuthUserGroupId)+  -- | Holds 'AuthUserGroupUsers'+, _modelAuthUserGroupUsers       :: !(Set AuthUserGroupUsersId)+  -- | Holds 'AuthUserGroupPerms'+, _modelAuthUserGroupPerms       :: !(Set AuthUserGroupPermsId)+  -- | Holds next id for entities+, _modelNextUserImplId           :: !Int64+-- | Holds next id for entities+, _modelNextUserPermId           :: !Int64+-- | Holds next id for entities+, _modelNextAuthTokenId          :: !Int64+-- | Holds next id for entities+, _modelNextUserRestoreId        :: !Int64+-- | Holds next id for entities+, _modelNextUserSingleUseCodeId  :: !Int64+-- | Holds next id for entities+, _modelNextAuthUserGroupId      :: !Int64+-- | Holds next id for entities+, _modelNextAuthUserGroupUserId  :: !Int64+-- | Holds next id for entities+, _modelNextAuthUserGroupPermId  :: !Int64+}++makeLenses ''Model++-- | Defines empty model for new database+newModel :: Model+newModel = Model {+    _modelUsers = mempty+  , _modelUsersByLogin = mempty+  , _modelUserPerms = mempty+  , _modelAuthTokens = mempty+  , _modelUserRestores = mempty+  , _modelUserSingleUseCodes = mempty+  , _modelAuthUserGroups = mempty+  , _modelAuthUserGroupUsers = mempty+  , _modelAuthUserGroupPerms = mempty+  , _modelNextUserImplId = 0+  , _modelNextUserPermId = 0+  , _modelNextAuthTokenId = 0+  , _modelNextUserRestoreId = 0+  , _modelNextUserSingleUseCodeId = 0+  , _modelNextAuthUserGroupId = 0+  , _modelNextAuthUserGroupUserId = 0+  , _modelNextAuthUserGroupPermId = 0+  }++-- | Helper that defines bijection between key and record+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+    safePut i+    where+      tname = show $ typeRep (Proxy :: Proxy i)++instance Key AuthTokenId AuthToken+instance Key AuthUserGroupId AuthUserGroup+instance Key AuthUserGroupPermsId AuthUserGroupPerms+instance Key AuthUserGroupUsersId AuthUserGroupUsers+instance Key ModelId Model+instance Key UserImplId UserImpl+instance Key UserPermId UserPerm+instance Key UserRestoreId UserRestore+instance Key UserSingleUseCodeId UserSingleUseCode++-- | Holds together db reference and options for read/write and mutex+data LevelDBEnv = LevelDBEnv !DB !ReadOptions !WriteOptions !RLock++-- | Make new environment for execution of LevelDB operations+newLevelDBEnv :: MonadIO m => DB -> ReadOptions -> WriteOptions -> m LevelDBEnv+newLevelDBEnv db rops wopts = do+  rlock <- liftIO new+  return $ LevelDBEnv db rops wopts rlock++-- | Load object by id from leveldb+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++-- | 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)++-- | Remove object by given id in leveldb+remove :: (MonadResource m, Key i a) => LevelDBEnv -> i -> m ()+remove (LevelDBEnv db _ wopts _) i = delete db wopts (encodeKey i)++-- | Modify value by id in leveldb+modify :: (MonadResource m, MonadMask m, Key i a, SafeCopy a) => LevelDBEnv -> i -> (a -> a) -> m ()+modify db@(LevelDBEnv _ _ _ mut) i f = bracket_ (liftIO $ acquire mut) (liftIO $ release mut) $ do+  ma <- load db i+  case ma of+    Nothing -> return ()+    Just a -> store db i (f a)++-- | Modify value by id in leveldb+modifyM :: (MonadResource m, MonadMask m, Key i a, SafeCopy a) => LevelDBEnv -> i -> (a -> m a) -> m ()+modifyM db@(LevelDBEnv _ _ _ mut) i f = bracket_ (liftIO $ acquire mut) (liftIO $ release mut) $ do+  ma <- load db i+  case ma of+    Nothing -> return ()+    Just a -> store db i =<< f a++-- | Load global index from leveldb+loadModel :: MonadResource m => LevelDBEnv -> m Model+loadModel db = do+  mm <- load db modelId+  return $ fromMaybe newModel mm++-- | Store glogal index to leveldb+storeModel :: MonadResource m => LevelDBEnv -> Model -> m ()+storeModel db = store db modelId++-- | Modify global index+modifyModel :: MonadResource m => LevelDBEnv -> (Model -> Model) -> m ()+modifyModel db f = do+  m <- loadModel db+  storeModel db $ f m++-- | Modify global index+modifyModelM :: (MonadResource m, MonadMask m) => LevelDBEnv -> (Model -> m (Model, a)) -> m a+modifyModelM db@(LevelDBEnv _ _ _ mut) f = bracket_ (liftIO $ acquire mut) (liftIO $ release mut) $ do+  m <- loadModel db+  (m', a) <- f m+  storeModel db m'+  return a++-- | Helper to get paged list of entities+getPagedList :: (MonadResource m, Ord i, Key i a, SafeCopy a) => LevelDBEnv -> Page -> PageSize -> Set i -> m ([WithId i a], Word)+getPagedList db p s is = do+  let is' = take (fromIntegral s) . drop (fromIntegral $ p * s) . sort . F.toList $ is+  es <- traverse (\i -> fmap (i,) <$> load db i) is'+  return (fmap (uncurry WithField) . catMaybes $ es, fromIntegral $ F.length is)++-- | Generic way to insert record in the leveldb with track in global registry+insertRecord :: (MonadResource m, MonadMask m, Key i a, ConvertableKey i, Ord i, SafeCopy a)+  => Lens' Model Int64 -- ^ Field of model that store counter of the record ids+  -> Lens' Model (Set i) -- ^ Field of model that store a registry of the record ids+  -> a -> LevelDBEnv -> m i+insertRecord counterL registryL v db = modifyModelM db $ \m -> do+  let+    i = toKey $ view counterL m+    m' = m & over counterL (+1)+           & over registryL (S.insert i)+  store db i v+  return (m', i)++-- | Generic way to select all records that satisfies given predicate+selectRecords :: (MonadResource m, Key i a, SafeCopy a)+  => Lens' Model (Set i) -- ^ Model field with registry of the records+  -> (i -> a -> Bool) -- ^ Predicate+  -> LevelDBEnv -> m [WithId i a]+selectRecords registryL f db = do+  is <- view registryL <$> loadModel db+  fmap catMaybes $ forM (F.toList is) $ \i -> do+    ma <- load db i+    return $ case ma of+      Just a | f i a -> Just $ WithField i a+      _ -> Nothing++-- | Generic way to delete several records with respect of global registry+deleteRecords :: (MonadResource m, MonadMask m, Key i a, Ord i, Foldable f)+  => Lens' Model (Set i) -- ^ Model field with registry of the records+  -> f i -- ^ Set of ids of records that should be deleted+  -> LevelDBEnv -> m ()+deleteRecords registryL is db = modifyModelM db $ \m -> do+  F.traverse_ (remove db) is+  return . (, ()) $ m & over registryL (`S.difference` (S.fromList . F.toList) is)++-- | Generic way to replace record in registry and leveldb+replaceRecord :: (MonadResource m, MonadMask m, Key i a, Ord i, SafeCopy a)+  => Lens' Model (Set i) -- ^ Model field with registry of the records+  -> i -- ^ ID of record+  -> a -- ^ Value of record+  -> LevelDBEnv -> m ()+replaceRecord registryL i v db = modifyModelM db $ \m -> do+  store db i v+  return . (, ()) $ m & over registryL (S.insert i)++-- | Extract id+withId :: WithField s i a -> i+withId (WithField i _) = i++-- | Extract value+withVal :: WithField s i a -> a+withVal (WithField _ v) = v++--------------------------------------------------------------------------------+-- End of generic helpers+--------------------------------------------------------------------------------++-- | Getting user from storage by login+getUserImplByLogin :: MonadResource m => Login -> LevelDBEnv -> m (Maybe (WithId UserImplId UserImpl))+getUserImplByLogin login db = do+  Model{..} <- loadModel db+  case M.lookup login _modelUsersByLogin of+    Nothing -> return Nothing+    Just i -> fmap (WithField i) <$> load db i++-- | Get paged list of users and total count of users+listUsersPaged :: MonadResource m => Page -> PageSize -> LevelDBEnv -> m ([WithId UserImplId UserImpl], Word)+listUsersPaged p s db = getPagedList db p s =<< (_modelUsers <$> loadModel db)++-- | Get user permissions, ascending by tag+getUserImplPermissions :: MonadResource m => UserImplId -> LevelDBEnv -> m [WithId UserPermId UserPerm]+getUserImplPermissions i = selectRecords modelUserPerms $ \ _ perm -> userPermUser perm == i++-- | Delete user permissions+deleteUserPermissions :: (MonadResource m, MonadMask m) => UserImplId -> LevelDBEnv -> m ()+deleteUserPermissions i db = do+  is <- fmap withId <$> getUserImplPermissions i db+  deleteRecords modelUserPerms is db++-- | Insertion of new user permission+insertUserPerm :: (MonadResource m, MonadMask m) => UserPerm -> LevelDBEnv -> m UserPermId+insertUserPerm = insertRecord modelNextUserPermId modelUserPerms++-- | Insertion of new user+insertUserImpl :: (MonadResource m, MonadMask m) => UserImpl -> LevelDBEnv -> m UserImplId+insertUserImpl v db = modifyModelM db $ \m -> do+  let+    i = toKey $ view modelNextUserImplId m+    m' = m & over modelNextUserImplId (+1)+           & over modelUsers (S.insert i)+           & over modelUsersByLogin (M.insert (userImplLogin v) i)+  store db i v+  return (m', i)++-- | Replace user with new value+replaceUserImpl :: (MonadResource m, MonadMask m) => UserImplId -> UserImpl -> LevelDBEnv -> m ()+replaceUserImpl i v db = modifyModelM db $ \m -> do+  muser <- load db i+  let cleanOld = case muser of+        Nothing -> id+        Just v' -> M.delete (userImplLogin v')+  store db i v+  return . (, ()) $ m & over modelUsersByLogin (M.insert (userImplLogin v) i . cleanOld)++-- | Delete user by id+deleteUserImpl :: (MonadResource m, MonadMask m) => UserImplId -> LevelDBEnv -> m ()+deleteUserImpl i db = do+  muser <- load db i+  case muser of+    Nothing -> return ()+    Just u  -> modifyModelM db $ \m -> do+      deleteUserPermissions i db+      remove db i+      return . (, ()) $ m+        & over modelUsers (S.delete i)+        & over modelUsersByLogin (M.delete (userImplLogin u))+++-- | Check whether the user has particular permission+hasPerm :: MonadResource m => UserImplId -> Permission -> LevelDBEnv -> m Bool+hasPerm i p db = do+  ps <- getUserImplPermissions i db+  return $ (> 0) . F.length . filter (\(WithField _ p') -> userPermUser p' == i && userPermPermission p' == p) $ ps++-- | Get any user with given permission+getFirstUserByPerm :: MonadResource m => Permission -> LevelDBEnv -> m (Maybe (WithId UserImplId UserImpl))+getFirstUserByPerm perm db = do+  ps <- view modelUserPerms <$> loadModel db+  let+    go _ v@Just{} = pure v+    go i Nothing  = do+      mp <- load db i+      case mp of+        Just p | userPermPermission p == perm -> fmap (WithField (userPermUser p)) <$> load db (userPermUser p)+        Nothing -> pure Nothing+  F.foldrM go Nothing ps++-- | Select user groups and sort them by ascending name+selectUserImplGroups :: MonadResource m => UserImplId -> LevelDBEnv -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]+selectUserImplGroups i = selectRecords modelAuthUserGroupUsers $ \_ g -> authUserGroupUsersUser g == i++-- | Remove user from all groups+clearUserImplGroups :: (MonadResource m, MonadMask m) => UserImplId -> LevelDBEnv -> m ()+clearUserImplGroups i db = do+  is <- fmap withId <$> selectUserImplGroups i db+  deleteRecords modelAuthUserGroupUsers is db++-- | Add new user group+insertAuthUserGroup :: (MonadResource m, MonadMask m) => AuthUserGroup -> LevelDBEnv -> m AuthUserGroupId+insertAuthUserGroup = insertRecord modelNextAuthUserGroupId modelAuthUserGroups++-- | Add user to given group+insertAuthUserGroupUsers :: (MonadResource m, MonadMask m) => AuthUserGroupUsers -> LevelDBEnv -> m AuthUserGroupUsersId+insertAuthUserGroupUsers = insertRecord modelNextAuthUserGroupUserId modelAuthUserGroupUsers++-- | Add permission to given group+insertAuthUserGroupPerms :: (MonadResource m, MonadMask m) => AuthUserGroupPerms -> LevelDBEnv -> m AuthUserGroupPermsId+insertAuthUserGroupPerms = insertRecord modelNextAuthUserGroupPermId modelAuthUserGroupPerms++-- | Get list of permissions of given group+listAuthUserGroupPermissions :: MonadResource m => AuthUserGroupId -> LevelDBEnv -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]+listAuthUserGroupPermissions i = selectRecords modelAuthUserGroupPerms $ \_ p -> authUserGroupPermsGroup p == i++-- | Get list of all users of the group+listAuthUserGroupUsers :: MonadResource m => AuthUserGroupId -> LevelDBEnv -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]+listAuthUserGroupUsers i = selectRecords modelAuthUserGroupUsers $ \_ p -> authUserGroupUsersGroup p == i++-- | Replace record of user group+replaceAuthUserGroup :: (MonadResource m, MonadMask m) => AuthUserGroupId -> AuthUserGroup -> LevelDBEnv -> m ()+replaceAuthUserGroup = replaceRecord modelAuthUserGroups++-- | Remove all users from group+clearAuthUserGroupUsers :: (MonadResource m, MonadMask m) => AuthUserGroupId -> LevelDBEnv -> m ()+clearAuthUserGroupUsers i db = do+  is <- fmap withId <$> listAuthUserGroupUsers i db+  deleteRecords modelAuthUserGroupUsers is db++-- | Remove all permissions from group+clearAuthUserGroupPerms :: (MonadResource m, MonadMask m) => AuthUserGroupId -> LevelDBEnv -> m ()+clearAuthUserGroupPerms i db = do+  is <- fmap withId <$> listAuthUserGroupPermissions i db+  deleteRecords modelAuthUserGroupPerms is db++-- | Delete user group from storage+deleteAuthUserGroup :: (MonadResource m, MonadMask m) => AuthUserGroupId -> LevelDBEnv -> m ()+deleteAuthUserGroup i db = modifyModelM db $ \m -> do+  clearAuthUserGroupUsers i db+  clearAuthUserGroupPerms i db+  remove db i+  return . (, ()) $ m & over modelAuthUserGroups (S.delete i)++-- | Get paged list of user groups with total count+listGroupsPaged :: MonadResource m => Page -> PageSize -> LevelDBEnv -> m ([WithId AuthUserGroupId AuthUserGroup], Word)+listGroupsPaged p s db = getPagedList db p s =<< (view modelAuthUserGroups <$> loadModel db)++-- | Set group name+setAuthUserGroupName :: (MonadResource m, MonadMask m) => AuthUserGroupId -> Text -> LevelDBEnv -> m ()+setAuthUserGroupName i n db = modify db i $ \v -> v { authUserGroupName = n }++-- | Set group parent+setAuthUserGroupParent :: (MonadResource m, MonadMask m) => AuthUserGroupId -> Maybe AuthUserGroupId -> LevelDBEnv -> m ()+setAuthUserGroupParent i p db = modify db i $ \v -> v { authUserGroupParent = p }++-- | Add new single use code+insertSingleUseCode :: (MonadResource m, MonadMask m) => UserSingleUseCode -> LevelDBEnv -> m UserSingleUseCodeId+insertSingleUseCode = insertRecord modelNextUserSingleUseCodeId modelUserSingleUseCodes++-- | Set usage time of the single use code+setSingleUseCodeUsed :: (MonadResource m, MonadMask m) => UserSingleUseCodeId -> Maybe UTCTime -> LevelDBEnv -> m ()+setSingleUseCodeUsed i mt db = modify db i $ \v -> v { userSingleUseCodeUsed = mt }++-- | Find unused code for the user and expiration time greater than the given time+getUnusedCode :: MonadResource m => SingleUseCode -> UserImplId -> UTCTime -> LevelDBEnv -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))+getUnusedCode c i t db = headMay . sorting <$> selectRecords modelUserSingleUseCodes f db+  where+    sorting = sortBy (comparing $ Down . userSingleUseCodeExpire . (\(WithField _ v) -> v))+    f _ usc =+      userSingleUseCodeValue usc == c+      && userSingleUseCodeUser usc == i+      && isNothing (userSingleUseCodeUsed usc)+      && (isNothing (userSingleUseCodeExpire usc) || userSingleUseCodeExpire usc >= Just t)++-- | Invalidate all permament codes for user and set use time for them+invalidatePermamentCodes :: (MonadResource m, MonadMask m) => UserImplId -> UTCTime -> LevelDBEnv -> m ()+invalidatePermamentCodes i t db = do+  cs <- view modelUserSingleUseCodes <$> loadModel db+  forM_ (F.toList cs) $ \cid -> do+    mc <- load db cid+    case mc of+      Just usc | isPermament usc -> modify db cid invalidate+      _ -> return ()+  where+    invalidate su = su { userSingleUseCodeUsed = Just t }+    isPermament usc =+         userSingleUseCodeUser usc == i+      && isNothing (userSingleUseCodeUsed usc)+      && isNothing (userSingleUseCodeExpire usc)++-- | Select last valid restoration code by the given current time+selectLastRestoreCode :: MonadResource m => UserImplId -> UTCTime -> LevelDBEnv -> m (Maybe (WithId UserRestoreId UserRestore))+selectLastRestoreCode i t db = headMay . sorting <$> selectRecords modelUserRestores (const f) db+  where+    sorting = sortBy (comparing $ Down . userRestoreExpire . withVal)+    f ur = userRestoreUser ur == i && userRestoreExpire ur > t++-- | Insert new restore code+insertUserRestore :: (MonadResource m, MonadMask m) => UserRestore -> LevelDBEnv -> m UserRestoreId+insertUserRestore = insertRecord modelNextUserRestoreId modelUserRestores++-- | Find unexpired by the time restore code+findRestoreCode :: MonadResource m => UserImplId -> RestoreCode -> UTCTime -> LevelDBEnv -> m (Maybe (WithId UserRestoreId UserRestore))+findRestoreCode i rc t db = headMay . sorting <$> selectRecords modelUserRestores (const f) db+  where+    sorting = sortBy (comparing $ Down . userRestoreExpire . (\(WithField _ v) -> v ))+    f ur = userRestoreUser ur == i && userRestoreValue ur == rc && userRestoreExpire ur > t++-- | Replace restore code with new value+replaceRestoreCode :: (MonadResource m, MonadMask m) => UserRestoreId -> UserRestore ->  LevelDBEnv -> m ()+replaceRestoreCode = replaceRecord modelUserRestores++-- | Find first non-expired by the time token for user+findAuthToken :: MonadResource m => UserImplId -> UTCTime -> LevelDBEnv -> m (Maybe (WithId AuthTokenId AuthToken))+findAuthToken i t db = headMay <$> selectRecords modelAuthTokens (const f) db+  where+    f atok = authTokenUser atok == i && authTokenExpire atok > t++-- | Find token by value+findAuthTokenByValue :: MonadResource m => SimpleToken -> LevelDBEnv -> m (Maybe (WithId AuthTokenId AuthToken))+findAuthTokenByValue v db = headMay <$> selectRecords modelAuthTokens (const f) db+  where+    f atok = authTokenValue atok == v++-- | Insert new token+insertAuthToken :: (MonadResource m, MonadMask m) => AuthToken -> LevelDBEnv -> m AuthTokenId+insertAuthToken = insertRecord modelNextAuthTokenId modelAuthTokens++-- | Replace auth token with new value+replaceAuthToken :: (MonadResource m, MonadMask m) => AuthTokenId -> AuthToken -> LevelDBEnv -> m ()+replaceAuthToken = replaceRecord modelAuthTokens++deriveSafeCopy 0 'base ''UserImplId+deriveSafeCopy 0 'base ''UserImpl+deriveSafeCopy 0 'base ''UserPermId+deriveSafeCopy 0 'base ''UserPerm+deriveSafeCopy 0 'base ''AuthTokenId+deriveSafeCopy 0 'base ''AuthToken+deriveSafeCopy 0 'base ''UserRestoreId+deriveSafeCopy 0 'base ''UserRestore+deriveSafeCopy 0 'base ''UserSingleUseCodeId+deriveSafeCopy 0 'base ''UserSingleUseCode+deriveSafeCopy 0 'base ''AuthUserGroupId+deriveSafeCopy 0 'base ''AuthUserGroup+deriveSafeCopy 0 'base ''AuthUserGroupUsersId+deriveSafeCopy 0 'base ''AuthUserGroupUsers+deriveSafeCopy 0 'base ''AuthUserGroupPermsId+deriveSafeCopy 0 'base ''AuthUserGroupPerms+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+    safePut k+    safePut v+    return a+  getCopy = contain $ WithField+    <$> safeGet+    <*> safeGet