diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,4 @@
+0.4.1.0
+=======
+
+* Initial release.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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).
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/servant-auth-token-leveldb.cabal b/servant-auth-token-leveldb.cabal
new file mode 100644
--- /dev/null
+++ b/servant-auth-token-leveldb.cabal
@@ -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
diff --git a/src/Servant/Server/Auth/Token/LevelDB.hs b/src/Servant/Server/Auth/Token/LevelDB.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/Server/Auth/Token/LevelDB.hs
@@ -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 #-}
diff --git a/src/Servant/Server/Auth/Token/LevelDB/Schema.hs b/src/Servant/Server/Auth/Token/LevelDB/Schema.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/Server/Auth/Token/LevelDB/Schema.hs
@@ -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