servant-auth-token-acid (empty) → 0.4.0.0

raw patch · 7 files changed

+761/−0 lines, 7 filesdep +acid-statedep +aeson-injectordep +basesetup-changed

Dependencies added: acid-state, aeson-injector, base, bytestring, containers, ghc-prim, monad-control, mtl, safe, safecopy, servant-auth-token, servant-auth-token-api, servant-server, template-haskell, text, time, transformers, transformers-base, uuid

Files

CHANGELOG.md +4/−0
LICENSE +30/−0
README.md +60/−0
Setup.hs +2/−0
servant-auth-token-acid.cabal +66/−0
src/Servant/Server/Auth/Token/Acid.hs +132/−0
src/Servant/Server/Auth/Token/Acid/Schema.hs +467/−0

+ CHANGELOG.md view

@@ -0,0 +1,4 @@+0.3.2.0+=======++* Initial factor out from parent package.

+ 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-acid.cabal view

@@ -0,0 +1,66 @@+name:                servant-auth-token-acid+version:             0.4.0.0+synopsis:            Acid-state 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:           2016 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.Acid+    Servant.Server.Auth.Token.Acid.Schema+  build-depends:+      base                    >= 4.7    && < 5+    , acid-state              >= 0.14   && < 0.15+    , aeson-injector          >= 1.0    && < 1.1+    , bytestring              >= 0.10   && < 0.11+    , containers              >= 0.5    && < 0.6+    , ghc-prim                >= 0.5    && < 0.6+    , monad-control           >= 1.0    && < 1.1+    , mtl                     >= 2.2    && < 2.3+    , safe                    >= 0.3    && < 0.4+    , safecopy                >= 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+    , template-haskell        >= 2.11   && < 2.12+    , 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+  default-language:    Haskell2010+  default-extensions:+    BangPatterns+    DataKinds+    DeriveGeneric+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    MultiParamTypeClasses+    OverloadedStrings+    QuasiQuotes+    RecordWildCards+    ScopedTypeVariables+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators++source-repository head+  type:     git+  location: https://github.com/ncrashed/servant-auth-token

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

@@ -0,0 +1,132 @@+module Servant.Server.Auth.Token.Acid(+    AcidBackendT+  , runAcidBackendT+  , deriveAcidHasStorage+  ) where++import Control.Monad.Except+import Control.Monad.Reader+import Data.Acid+import Data.Acid.Core+import Language.Haskell.TH+import Servant.Server+import Servant.Server.Auth.Token.Config+import Servant.Server.Auth.Token.Model++-- | Monad transformer that implements storage backend+newtype AcidBackendT st m a = AcidBackendT { unAcidBackendT :: ReaderT (AuthConfig, AcidState st) (ExceptT ServantErr m) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, MonadReader (AuthConfig, AcidState st))++instance Monad m => HasAuthConfig (AcidBackendT st m) where+  getAuthConfig = fmap fst $ AcidBackendT ask++-- | Execute backend action with given connection pool.+runAcidBackendT :: AuthConfig -> AcidState st -> AcidBackendT st m a -> m (Either ServantErr a)+runAcidBackendT cfg db ma = runExceptT $ runReaderT (unAcidBackendT ma) (cfg, db)++-- | Derives acid-state 'HasStorage' instance for functions that are generated in 'makeModelAcidic'.+--+-- Use this as following:+-- @+-- instance HasModelRead MyState where+--   askModel = authModel+--+-- instance HasModelWrite MyState where+--   putModel m v = m { authModel = v }+--+-- makeModelAcidic ''MyState+-- deriveAcidHasStorage+-- @+deriveAcidHasStorage :: Name -> DecsQ+deriveAcidHasStorage globalState = [d|+  -- | Helper to execute DB actions in backend monad+  liftAcidQuery :: (QueryEvent event, MonadIO m, MethodState event ~ $st) => event -> AcidBackendT $st m (EventResult event)+  liftAcidQuery e = do+    (_, db) <- ask+    liftIO $ query db e++  -- | Helper to execute DB actions in backend monad+  liftAcidUpdate :: (UpdateEvent event, MonadIO m, MethodState event ~ $st) => event -> AcidBackendT $st m (EventResult event)+  liftAcidUpdate e = do+    (_, db) <- ask+    liftIO $ update db e++  instance MonadIO m => HasStorage (AcidBackendT $st m) where+    getUserImpl = liftAcidQuery . $(conE $ mkName "GetUserImpl")+    getUserImplByLogin = liftAcidQuery . $(conE $ mkName "GetUserImplByLogin")+    listUsersPaged page size = liftAcidQuery $ $(conE $ mkName "ListUsersPaged") page size+    getUserImplPermissions = liftAcidQuery . $(conE $ mkName "GetUserImplPermissions")+    deleteUserPermissions = liftAcidUpdate . $(conE $ mkName "DeleteUserPermissions")+    insertUserPerm = liftAcidUpdate . $(conE $ mkName "InsertUserPerm")+    insertUserImpl = liftAcidUpdate . $(conE $ mkName "InsertUserImpl")+    replaceUserImpl i v = liftAcidUpdate $ $(conE $ mkName "ReplaceUserImpl") i v+    deleteUserImpl = liftAcidUpdate . $(conE $ mkName "DeleteUserImpl")+    hasPerm i p = liftAcidQuery $ $(conE $ mkName "HasPerm") i p+    getFirstUserByPerm = liftAcidQuery . $(conE $ mkName "GetFirstUserByPerm")+    selectUserImplGroups = liftAcidQuery . $(conE $ mkName "SelectUserImplGroups")+    clearUserImplGroups = liftAcidUpdate . $(conE $ mkName "ClearUserImplGroups")+    insertAuthUserGroup = liftAcidUpdate . $(conE $ mkName "InsertAuthUserGroup")+    insertAuthUserGroupUsers = liftAcidUpdate . $(conE $ mkName "InsertAuthUserGroupUsers")+    insertAuthUserGroupPerms = liftAcidUpdate . $(conE $ mkName "InsertAuthUserGroupPerms")+    getAuthUserGroup = liftAcidQuery . $(conE $ mkName "GetAuthUserGroup")+    listAuthUserGroupPermissions = liftAcidQuery . $(conE $ mkName "ListAuthUserGroupPermissions")+    listAuthUserGroupUsers = liftAcidQuery . $(conE $ mkName "ListAuthUserGroupUsers")+    replaceAuthUserGroup i v = liftAcidUpdate $ $(conE $ mkName "ReplaceAuthUserGroup") i v+    clearAuthUserGroupUsers = liftAcidUpdate . $(conE $ mkName "ClearAuthUserGroupUsers")+    clearAuthUserGroupPerms = liftAcidUpdate . $(conE $ mkName "ClearAuthUserGroupPerms")+    deleteAuthUserGroup = liftAcidUpdate . $(conE $ mkName "DeleteAuthUserGroup")+    listGroupsPaged page size = liftAcidQuery $ $(conE $ mkName "ListGroupsPaged") page size+    setAuthUserGroupName i n = liftAcidUpdate $ $(conE $ mkName "SetAuthUserGroupName") i n+    setAuthUserGroupParent i mp = liftAcidUpdate $ $(conE $ mkName "SetAuthUserGroupParent") i mp+    insertSingleUseCode = liftAcidUpdate . $(conE $ mkName "InsertSingleUseCode")+    setSingleUseCodeUsed i mt = liftAcidUpdate $ $(conE $ mkName "SetSingleUseCodeUsed") i mt+    getUnusedCode c i t = liftAcidQuery $ $(conE $ mkName "GetUnusedCode") c i t+    invalidatePermamentCodes i t = liftAcidUpdate $ $(conE $ mkName "InvalidatePermamentCodes") i t+    selectLastRestoreCode i t = liftAcidQuery $ $(conE $ mkName "SelectLastRestoreCode") i t+    insertUserRestore = liftAcidUpdate . $(conE $ mkName "InsertUserRestore")+    findRestoreCode i rc t = liftAcidQuery $ $(conE $ mkName "FindRestoreCode") i rc t+    replaceRestoreCode i v = liftAcidUpdate $ $(conE $ mkName "ReplaceRestoreCode") i v+    findAuthToken i t = liftAcidQuery $ $(conE $ mkName "FindAuthToken") i t+    findAuthTokenByValue t = liftAcidQuery $ $(conE $ mkName "FindAuthTokenByValue") t+    insertAuthToken = liftAcidUpdate . $(conE $ mkName "InsertAuthToken")+    replaceAuthToken i v = liftAcidUpdate $ $(conE $ mkName "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 #-}+  |]+  where st = conT globalState

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

@@ -0,0 +1,467 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NoDisambiguateRecordFields, NoRecordWildCards #-}+module Servant.Server.Auth.Token.Acid.Schema where++import Control.Monad.Reader+import Control.Monad.State+import Data.Acid+import Data.Aeson.WithField+import Data.Int+import Data.List (sortBy)+import Data.Map.Strict (Map)+import Data.Ord+import Data.SafeCopy+import Data.Text (Text)+import Data.Time+import Language.Haskell.TH+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.Map.Strict as M+import qualified Data.Foldable as F++-- | Holds all data for auth server in acid-state container+data Model = Model {+  -- | Holds users by id+  modelUsers                    :: !(Map UserImplId UserImpl)+  -- | Holds users by login (same content as 'modelUsers')+, modelUsersByLogin             :: !(Map Login (WithId UserImplId UserImpl))+  -- | Holds 'UserPerm'+, modelUserPerms                :: !(Map UserPermId UserPerm)+  -- | Holds 'AuthToken'+, modelAuthTokens               :: !(Map AuthTokenId AuthToken)+  -- | Holds 'UserRestore'+, modelUserRestores             :: !(Map UserRestoreId UserRestore)+  -- | Holds 'UserSingleUseCode'+, modelUserSingleUseCodes       :: !(Map UserSingleUseCodeId UserSingleUseCode)+  -- | Holds 'AuthUserGroup'+, modelAuthUserGroups           :: !(Map AuthUserGroupId AuthUserGroup)+  -- | Holds 'AuthUserGroupUsers'+, modelAuthUserGroupUsers       :: !(Map AuthUserGroupUsersId AuthUserGroupUsers)+  -- | Holds 'AuthUserGroupPerms'+, modelAuthUserGroupPerms       :: !(Map AuthUserGroupPermsId AuthUserGroupPerms)+  -- | 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+}++-- | 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+  }++-- | The end user should implement this for his global type+class HasModelRead a where+  askModel :: a -> Model++-- | The end user should implement this fot his global type+class HasModelRead a => HasModelWrite a where+  putModel :: a -> Model -> a++-- | The end user should inline this TH in his code+makeModelAcidic :: Name -> DecsQ+makeModelAcidic globalStateName = makeAcidic globalStateName [+    mkName "getUserImpl"+  , mkName "getUserImplByLogin"+  , mkName "listUsersPaged"+  , mkName "getUserImplPermissions"+  , mkName "deleteUserPermissions"+  , mkName "insertUserPerm"+  , mkName "insertUserImpl"+  , mkName "replaceUserImpl"+  , mkName "deleteUserImpl"+  , mkName "hasPerm"+  , mkName "getFirstUserByPerm"+  , mkName "selectUserImplGroups"+  , mkName "clearUserImplGroups"+  , mkName "insertAuthUserGroup"+  , mkName "insertAuthUserGroupUsers"+  , mkName "insertAuthUserGroupPerms"+  , mkName "getAuthUserGroup"+  , mkName "listAuthUserGroupPermissions"+  , mkName "listAuthUserGroupUsers"+  , mkName "replaceAuthUserGroup"+  , mkName "clearAuthUserGroupUsers"+  , mkName "clearAuthUserGroupPerms"+  , mkName "deleteAuthUserGroup"+  , mkName "listGroupsPaged"+  , mkName "setAuthUserGroupName"+  , mkName "setAuthUserGroupParent"+  , mkName "insertSingleUseCode"+  , mkName "setSingleUseCodeUsed"+  , mkName "getUnusedCode"+  , mkName "invalidatePermamentCodes"+  , mkName "selectLastRestoreCode"+  , mkName "insertUserRestore"+  , mkName "findRestoreCode"+  , mkName "replaceRestoreCode"+  , mkName "findAuthToken"+  , mkName "findAuthTokenByValue"+  , mkName "insertAuthToken"+  , mkName "replaceAuthToken"+  ]++instance HasModelRead Model where+  askModel = id++instance HasModelWrite Model where+  putModel = const id++asksM :: HasModelRead a => (Model -> b) -> Query a b+asksM f = fmap (f . askModel) ask++modifyM :: HasModelWrite a => (Model -> Model) -> Update a ()+modifyM f = modify' (\a -> putModel a . f . askModel $ a)++getM :: HasModelWrite a => Update a Model+getM = fmap askModel get++putM :: HasModelWrite a => Model -> Update a ()+putM m = modifyM (const m)++-- | Mixin queries to work with auth state+deriveQueries :: Name -> DecsQ+deriveQueries globalStateName = [d|+    -- | Getting user from storage+    getUserImpl :: HasModelRead $a => UserImplId -> Query $a (Maybe UserImpl)+    getUserImpl i = M.lookup i <$> asksM modelUsers++    -- | Getting user from storage by login+    getUserImplByLogin :: HasModelRead $a => Login -> Query $a (Maybe (WithId UserImplId UserImpl))+    getUserImplByLogin l = M.lookup l <$> asksM modelUsersByLogin++    -- | Helper to get page from map+    getPagedList :: Ord i => Page -> PageSize -> Map i a -> ([WithId i a], Word)+    getPagedList p s m = (uncurry WithField <$> es, fromIntegral $ F.length m)+      where+        es = take (fromIntegral s) . drop (fromIntegral $ p * s) . sortBy (comparing fst) . M.toList $ m++    -- | Get paged list of users and total count of users+    listUsersPaged :: HasModelRead $a => Page -> PageSize -> Query $a ([WithId UserImplId UserImpl], Word)+    listUsersPaged p s = getPagedList p s <$> asksM modelUsers++    -- | Get user permissions, ascending by tag+    getUserImplPermissions :: HasModelRead $a => UserImplId -> Query $a [WithId UserPermId UserPerm]+    getUserImplPermissions i = fmap (uncurry WithField) . M.toList . M.filter ((i ==) . userPermUser) <$> asksM modelUserPerms++    -- | Delete user permissions+    deleteUserPermissions :: HasModelWrite $a => UserImplId -> Update $a ()+    deleteUserPermissions i = modifyM $ \m -> m { modelUserPerms = f $ modelUserPerms m }+      where+        f m = m `M.difference` M.filter ((i ==) . userPermUser) m++    -- | Insertion of new user permission+    insertUserPerm :: HasModelWrite $a => UserPerm -> Update $a UserPermId+    insertUserPerm p = do+      m <- getM+      let+        i = toKey $ modelNextUserPermId m+        perms = M.insert i p . modelUserPerms $ m+        m' = m { modelUserPerms = perms, modelNextUserPermId = modelNextUserPermId m + 1 }+      m' `seq` putM m'+      return i++    -- | Insertion of new user+    insertUserImpl :: HasModelWrite $a => UserImpl -> Update $a UserImplId+    insertUserImpl v = do+      m <- getM+      let+        i = toKey $ modelNextUserImplId m+        vals = M.insert i v . modelUsers $ m+        vals' = M.insert (userImplLogin v) (WithField i v) . modelUsersByLogin $ m+        m' = m { modelUsers = vals, modelUsersByLogin = vals', modelNextUserImplId = modelNextUserImplId m + 1 }+      m' `seq` putM m'+      return i++    -- | Replace user with new value+    replaceUserImpl :: HasModelWrite $a => UserImplId -> UserImpl -> Update $a ()+    replaceUserImpl i v = modifyM $ \m -> m {+        modelUsers = M.insert i v . modelUsers $ m+      , modelUsersByLogin = M.insert (userImplLogin v) (WithField i v) . modelUsersByLogin $ m+      }++    -- | Delete user by id+    deleteUserImpl :: HasModelWrite $a => UserImplId -> Update $a ()+    deleteUserImpl i = do+      deleteUserPermissions i+      modifyM $ \m -> case M.lookup i . modelUsers $ m of+        Nothing -> m+        Just ui -> m {+            modelUsers = M.delete i . modelUsers $ m+          , modelUsersByLogin = M.delete (userImplLogin ui) . modelUsersByLogin $ m+          }++    -- | Check whether the user has particular permission+    hasPerm :: HasModelRead $a => UserImplId -> Permission -> Query $a Bool+    hasPerm i p = (> 0) . F.length . M.filter (\up -> userPermUser up == i && userPermPermission up == p) <$> asksM modelUserPerms++    -- | Get any user with given permission+    getFirstUserByPerm :: HasModelRead $a => Permission -> Query $a (Maybe (WithId UserImplId UserImpl))+    getFirstUserByPerm perm = do+      m <- asksM modelUserPerms+      case M.toList . M.filter (\p -> userPermPermission p == perm) $ m of+        [] -> return Nothing+        ((_, p) : _) -> fmap (WithField $ userPermUser p) <$> getUserImpl (userPermUser p)++    -- | Select user groups and sort them by ascending name+    selectUserImplGroups :: HasModelRead $a => UserImplId -> Query $a [WithId AuthUserGroupUsersId AuthUserGroupUsers]+    selectUserImplGroups i = fmap (uncurry WithField) . M.toList . M.filter ((i ==) . authUserGroupUsersUser) <$> asksM modelAuthUserGroupUsers++    -- | Remove user from all groups+    clearUserImplGroups :: HasModelWrite $a => UserImplId -> Update $a ()+    clearUserImplGroups i = modifyM $ \m -> m { modelAuthUserGroupUsers = f $ modelAuthUserGroupUsers m }+      where+        f m = m `M.difference` M.filter ((i ==) . authUserGroupUsersUser) m++    -- | Add new user group+    insertAuthUserGroup :: HasModelWrite $a => AuthUserGroup -> Update $a AuthUserGroupId+    insertAuthUserGroup v = do+      m <- getM+      let+        i = toKey $ modelNextAuthUserGroupId m+        vals = M.insert i v . modelAuthUserGroups $ m+        m' = m { modelAuthUserGroups = vals, modelNextAuthUserGroupId = modelNextAuthUserGroupId m + 1 }+      m' `seq` putM m'+      return i++    -- | Add user to given group+    insertAuthUserGroupUsers :: HasModelWrite $a => AuthUserGroupUsers -> Update $a AuthUserGroupUsersId+    insertAuthUserGroupUsers v = do+      m <- getM+      let+        i = toKey $ modelNextAuthUserGroupUserId m+        vals = M.insert i v . modelAuthUserGroupUsers $ m+        m' = m { modelAuthUserGroupUsers = vals, modelNextAuthUserGroupUserId = modelNextAuthUserGroupUserId m + 1 }+      m' `seq` putM m'+      return i++    -- | Add permission to given group+    insertAuthUserGroupPerms :: HasModelWrite $a => AuthUserGroupPerms -> Update $a AuthUserGroupPermsId+    insertAuthUserGroupPerms v = do+      m <- getM+      let+        i = toKey $ modelNextAuthUserGroupPermId m+        vals = M.insert i v . modelAuthUserGroupPerms $ m+        m' = m { modelAuthUserGroupPerms = vals, modelNextAuthUserGroupPermId = modelNextAuthUserGroupPermId m + 1 }+      m' `seq` putM m'+      return i++    -- | Find user group by id+    getAuthUserGroup :: HasModelRead $a => AuthUserGroupId -> Query $a (Maybe AuthUserGroup)+    getAuthUserGroup i = M.lookup i <$> asksM modelAuthUserGroups++    -- | Get list of permissions of given group+    listAuthUserGroupPermissions :: HasModelRead $a => AuthUserGroupId -> Query $a [WithId AuthUserGroupPermsId AuthUserGroupPerms]+    listAuthUserGroupPermissions i = fmap (uncurry WithField) . M.toList . M.filter ((i ==) . authUserGroupPermsGroup) <$> asksM modelAuthUserGroupPerms++    -- | Get list of all users of the group+    listAuthUserGroupUsers :: HasModelRead $a => AuthUserGroupId -> Query $a [WithId AuthUserGroupUsersId AuthUserGroupUsers]+    listAuthUserGroupUsers i = fmap (uncurry WithField) . M.toList . M.filter ((i ==) . authUserGroupUsersGroup) <$> asksM modelAuthUserGroupUsers++    -- | Replace record of user group+    replaceAuthUserGroup :: HasModelWrite $a => AuthUserGroupId -> AuthUserGroup -> Update $a ()+    replaceAuthUserGroup i v = modifyM $ \m -> m { modelAuthUserGroups = M.insert i v $ modelAuthUserGroups m }++    -- | Remove all users from group+    clearAuthUserGroupUsers :: HasModelWrite $a => AuthUserGroupId -> Update $a ()+    clearAuthUserGroupUsers i = modifyM $ \m -> m { modelAuthUserGroupUsers = f $ modelAuthUserGroupUsers m }+      where+        f m = m `M.difference` M.filter ((i ==) . authUserGroupUsersGroup) m++    -- | Remove all permissions from group+    clearAuthUserGroupPerms :: HasModelWrite $a => AuthUserGroupId -> Update $a ()+    clearAuthUserGroupPerms i = modifyM $ \m -> m { modelAuthUserGroupPerms = f $ modelAuthUserGroupPerms m }+      where+        f m = m `M.difference` M.filter ((i ==) . authUserGroupPermsGroup) m++    -- | Delete user group from storage+    deleteAuthUserGroup :: HasModelWrite $a => AuthUserGroupId -> Update $a ()+    deleteAuthUserGroup i = do+      clearAuthUserGroupUsers i+      clearAuthUserGroupPerms i+      modifyM $ \m -> m { modelAuthUserGroups = M.delete i $ modelAuthUserGroups m }++    -- | Get paged list of user groups with total count+    listGroupsPaged :: HasModelRead $a => Page -> PageSize -> Query $a ([WithId AuthUserGroupId AuthUserGroup], Word)+    listGroupsPaged p s = getPagedList p s <$> asksM modelAuthUserGroups++    -- | Set group name+    setAuthUserGroupName :: HasModelWrite $a => AuthUserGroupId -> Text -> Update $a ()+    setAuthUserGroupName i n = modifyM $ \m -> m { modelAuthUserGroups = M.adjust (\v -> v { authUserGroupName = n }) i $ modelAuthUserGroups m }++    -- | Set group parent+    setAuthUserGroupParent :: HasModelWrite $a => AuthUserGroupId -> Maybe AuthUserGroupId -> Update $a ()+    setAuthUserGroupParent i p = modifyM $ \m -> m { modelAuthUserGroups = M.adjust (\v -> v { authUserGroupParent = p }) i $ modelAuthUserGroups m }++    -- | Add new single use code+    insertSingleUseCode :: HasModelWrite $a => UserSingleUseCode -> Update $a UserSingleUseCodeId+    insertSingleUseCode v = do+      m <- getM+      let+        i = toKey $ modelNextUserSingleUseCodeId m+        vals = M.insert i v . modelUserSingleUseCodes $ m+        m' = m { modelUserSingleUseCodes = vals, modelNextUserSingleUseCodeId = modelNextUserSingleUseCodeId m + 1 }+      m' `seq` putM m'+      return i++    -- | Set usage time of the single use code+    setSingleUseCodeUsed :: HasModelWrite $a => UserSingleUseCodeId -> Maybe UTCTime -> Update $a ()+    setSingleUseCodeUsed i mt = modifyM $ \m -> m { modelUserSingleUseCodes = M.adjust (\v -> v { userSingleUseCodeUsed = mt }) i $ modelUserSingleUseCodes m }++    -- | Find unused code for the user and expiration time greater than the given time+    getUnusedCode :: HasModelRead $a => SingleUseCode -> UserImplId -> UTCTime -> Query $a (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))+    getUnusedCode c i t = fmap (uncurry WithField) . headMay . sorting . M.toList . M.filter f <$> asksM modelUserSingleUseCodes+      where+        sorting = sortBy (comparing $ Down . userSingleUseCodeExpire . snd)+        f usc =+             userSingleUseCodeValue usc == c+          && userSingleUseCodeUser usc == i+          && userSingleUseCodeUsed usc == Nothing+          && (userSingleUseCodeExpire usc == Nothing || userSingleUseCodeExpire usc >= Just t)++    -- | Invalidate all permament codes for user and set use time for them+    invalidatePermamentCodes :: HasModelWrite $a => UserImplId -> UTCTime -> Update $a ()+    invalidatePermamentCodes i t = modifyM $ \m -> m { modelUserSingleUseCodes = f $ modelUserSingleUseCodes m }+      where+        f m = (fmap invalidate . M.filter isPermament $ m) `M.union` m+        invalidate su = su { userSingleUseCodeUsed = Just t }+        isPermament usc =+             userSingleUseCodeUser usc == i+          && userSingleUseCodeUsed usc == Nothing+          && userSingleUseCodeExpire usc == Nothing++    -- | Select last valid restoration code by the given current time+    selectLastRestoreCode :: HasModelRead $a => UserImplId -> UTCTime -> Query $a (Maybe (WithId UserRestoreId UserRestore))+    selectLastRestoreCode i t = fmap (uncurry WithField) . headMay . sorting . M.toList . M.filter f <$> asksM modelUserRestores+      where+        sorting = sortBy (comparing $ Down . userRestoreExpire . snd)+        f ur = userRestoreUser ur == i && userRestoreExpire ur > t++    -- | Insert new restore code+    insertUserRestore :: HasModelWrite $a => UserRestore -> Update $a UserRestoreId+    insertUserRestore v = do+      m <- getM+      let+        i = toKey $ modelNextUserRestoreId m+        vals = M.insert i v . modelUserRestores $ m+        m' = m { modelUserRestores = vals, modelNextUserRestoreId = modelNextUserRestoreId m + 1 }+      m' `seq` putM m'+      return i++    -- | Find unexpired by the time restore code+    findRestoreCode :: HasModelRead $a => UserImplId -> RestoreCode -> UTCTime -> Query $a (Maybe (WithId UserRestoreId UserRestore))+    findRestoreCode i rc t = fmap (uncurry WithField) . headMay . sorting . M.toList . M.filter f <$> asksM modelUserRestores+      where+        sorting = sortBy (comparing $ Down . userRestoreExpire . snd)+        f ur = userRestoreUser ur == i && userRestoreValue ur == rc && userRestoreExpire ur > t++    -- | Replace restore code with new value+    replaceRestoreCode :: HasModelWrite $a => UserRestoreId -> UserRestore -> Update $a ()+    replaceRestoreCode i v = modifyM $ \m -> m { modelUserRestores = M.insert i v $ modelUserRestores m }++    -- | Find first non-expired by the time token for user+    findAuthToken :: HasModelRead $a => UserImplId -> UTCTime -> Query $a (Maybe (WithId AuthTokenId AuthToken))+    findAuthToken i t = fmap (uncurry WithField) . headMay . M.toList . M.filter f <$> asksM modelAuthTokens+      where+        f atok = authTokenUser atok == i && authTokenExpire atok > t++    -- | Find token by value+    findAuthTokenByValue :: HasModelRead $a => SimpleToken -> Query $a (Maybe (WithId AuthTokenId AuthToken))+    findAuthTokenByValue v = fmap (uncurry WithField) . headMay . M.toList . M.filter f <$> asksM modelAuthTokens+      where+        f atok = authTokenValue atok == v++    -- | Insert new token+    insertAuthToken :: HasModelWrite $a => AuthToken -> Update $a AuthTokenId+    insertAuthToken v = do+      m <- getM+      let+        i = toKey $ modelNextAuthTokenId m+        vals = M.insert i v . modelAuthTokens $ m+        m' = m { modelAuthTokens = vals, modelNextAuthTokenId = modelNextAuthTokenId m + 1 }+      m' `seq` putM m'+      return i++    -- | Replace auth token with new value+    replaceAuthToken :: HasModelWrite $a => AuthTokenId -> AuthToken -> Update $a ()+    replaceAuthToken i v = modifyM $ \m -> m { modelAuthTokens = M.insert i v $ modelAuthTokens m }+    |]+  where+    a = conT globalStateName++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 ''Model++instance (SafeCopy k, SafeCopy v) => SafeCopy (WithField i k v) where+  putCopy (WithField k v) = contain $ do+    safePut k+    safePut v+  getCopy = contain $ WithField+    <$> safeGet+    <*> safeGet