{-# LANGUAGE DefaultSignatures #-}
module Servant.Server.Auth.Token.Model(
UserImpl(..)
, UserPerm(..)
, AuthToken(..)
, UserRestore(..)
, AuthUserGroup(..)
, AuthUserGroupUsers(..)
, AuthUserGroupPerms(..)
, UserSingleUseCode(..)
, UserImplId
, UserPermId
, AuthTokenId
, UserRestoreId
, AuthUserGroupId
, AuthUserGroupUsersId
, AuthUserGroupPermsId
, UserSingleUseCodeId
, HasStorage(..)
, passToByteString
, byteStringToPass
, userToUserInfo
, readUserInfo
, readUserInfoByLogin
, getUserPermissions
, setUserPermissions
, createUser
, hasPerms
, createAdmin
, ensureAdmin
, patchUser
, setUserPassword'
, getUserGroups
, setUserGroups
, validateGroups
, getGroupPermissions
, getUserGroupPermissions
, getUserAllPermissions
, readUserGroup
, toAuthUserGroup
, insertUserGroup
, updateUserGroup
, deleteUserGroup
, patchUserGroup
, makeUserInfo
) where
import Control.Monad
import Control.Monad.Cont (ContT)
import Control.Monad.Except (ExceptT)
import Control.Monad.IO.Class
import Control.Monad.Reader (ReaderT)
import qualified Control.Monad.RWS.Lazy as LRWS
import qualified Control.Monad.RWS.Strict as SRWS
import qualified Control.Monad.State.Lazy as LS
import qualified Control.Monad.State.Strict as SS
import qualified Control.Monad.Writer.Lazy as LW
import qualified Control.Monad.Writer.Strict as SW
import Control.Monad.Trans.Class (MonadTrans(lift))
import Crypto.PasswordStore
import Data.Aeson.WithField
import Data.Int
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import Data.Time
import GHC.Generics
import qualified Data.ByteString as BS
import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.Sequence as S
import qualified Data.Text.Encoding as TE
import Servant.API.Auth.Token
import Servant.API.Auth.Token.Pagination
import Servant.Server.Auth.Token.Common
import Servant.Server.Auth.Token.Patch
newtype UserImplId = UserImplId { unUserImplId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey UserImplId where
toKey = UserImplId . fromIntegral
fromKey = fromIntegral . unUserImplId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data UserImpl = UserImpl {
userImplLogin :: !Login
, userImplPassword :: !Password
, userImplEmail :: !Email
} deriving (Generic, Show)
newtype UserPermId = UserPermId { unUserPermId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey UserPermId where
toKey = UserPermId . fromIntegral
fromKey = fromIntegral . unUserPermId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data UserPerm = UserPerm {
userPermUser :: !UserImplId
, userPermPermission :: !Permission
} deriving (Generic, Show)
newtype AuthTokenId = AuthTokenId { unAuthTokenId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey AuthTokenId where
toKey = AuthTokenId . fromIntegral
fromKey = fromIntegral . unAuthTokenId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data AuthToken = AuthToken {
authTokenValue :: !SimpleToken
, authTokenUser :: !UserImplId
, authTokenExpire :: !UTCTime
} deriving (Generic, Show)
newtype UserRestoreId = UserRestoreId { unUserRestoreId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey UserRestoreId where
toKey = UserRestoreId . fromIntegral
fromKey = fromIntegral . unUserRestoreId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data UserRestore = UserRestore {
userRestoreValue :: !RestoreCode
, userRestoreUser :: !UserImplId
, userRestoreExpire :: !UTCTime
} deriving (Generic, Show)
newtype UserSingleUseCodeId = UserSingleUseCodeId { unUserSingleUseCodeId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey UserSingleUseCodeId where
toKey = UserSingleUseCodeId . fromIntegral
fromKey = fromIntegral . unUserSingleUseCodeId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data UserSingleUseCode = UserSingleUseCode {
userSingleUseCodeValue :: !SingleUseCode
, userSingleUseCodeUser :: !UserImplId
, userSingleUseCodeExpire :: !(Maybe UTCTime)
, userSingleUseCodeUsed :: !(Maybe UTCTime)
} deriving (Generic, Show)
newtype AuthUserGroupId = AuthUserGroupId { unAuthUserGroupId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey AuthUserGroupId where
toKey = AuthUserGroupId . fromIntegral
fromKey = fromIntegral . unAuthUserGroupId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data AuthUserGroup = AuthUserGroup {
authUserGroupName :: !Text
, authUserGroupParent :: !(Maybe AuthUserGroupId)
} deriving (Generic, Show)
newtype AuthUserGroupUsersId = AuthUserGroupUsersId { unAuthUserGroupUsersId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey AuthUserGroupUsersId where
toKey = AuthUserGroupUsersId . fromIntegral
fromKey = fromIntegral . unAuthUserGroupUsersId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data AuthUserGroupUsers = AuthUserGroupUsers {
authUserGroupUsersGroup :: !AuthUserGroupId
, authUserGroupUsersUser :: !UserImplId
} deriving (Generic, Show)
newtype AuthUserGroupPermsId = AuthUserGroupPermsId { unAuthUserGroupPermsId :: Int64 }
deriving (Generic, Show, Eq, Ord)
instance ConvertableKey AuthUserGroupPermsId where
toKey = AuthUserGroupPermsId . fromIntegral
fromKey = fromIntegral . unAuthUserGroupPermsId
{-# INLINE toKey #-}
{-# INLINE fromKey #-}
data AuthUserGroupPerms = AuthUserGroupPerms {
authUserGroupPermsGroup :: AuthUserGroupId
, authUserGroupPermsPermission :: Permission
} deriving (Generic, Show)
class MonadIO m => HasStorage m where
getUserImpl :: UserImplId -> m (Maybe UserImpl)
default getUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m (Maybe UserImpl)
getUserImpl = lift . getUserImpl
getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl))
default getUserImplByLogin :: (m ~ t n, MonadTrans t, HasStorage n) => Login -> m (Maybe (WithId UserImplId UserImpl))
getUserImplByLogin = lift . getUserImplByLogin
listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
default listUsersPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
listUsersPaged = (lift .) . listUsersPaged
getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm]
default getUserImplPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId UserPermId UserPerm]
getUserImplPermissions = lift . getUserImplPermissions
deleteUserPermissions :: UserImplId -> m ()
default deleteUserPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
deleteUserPermissions = lift . deleteUserPermissions
insertUserPerm :: UserPerm -> m UserPermId
default insertUserPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserPerm -> m UserPermId
insertUserPerm = lift . insertUserPerm
insertUserImpl :: UserImpl -> m UserImplId
default insertUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImpl -> m UserImplId
insertUserImpl = lift . insertUserImpl
replaceUserImpl :: UserImplId -> UserImpl -> m ()
default replaceUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UserImpl -> m ()
replaceUserImpl = (lift .) . replaceUserImpl
deleteUserImpl :: UserImplId -> m ()
default deleteUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
deleteUserImpl = lift . deleteUserImpl
hasPerm :: UserImplId -> Permission -> m Bool
default hasPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> Permission -> m Bool
hasPerm = (lift .) . hasPerm
getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl))
default getFirstUserByPerm :: (m ~ t n, MonadTrans t, HasStorage n) => Permission -> m (Maybe (WithId UserImplId UserImpl))
getFirstUserByPerm = lift . getFirstUserByPerm
selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
default selectUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
selectUserImplGroups = lift . selectUserImplGroups
clearUserImplGroups :: UserImplId -> m ()
default clearUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
clearUserImplGroups = lift . clearUserImplGroups
insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId
default insertAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroup -> m AuthUserGroupId
insertAuthUserGroup = lift . insertAuthUserGroup
insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId
default insertAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupUsers -> m AuthUserGroupUsersId
insertAuthUserGroupUsers = lift . insertAuthUserGroupUsers
insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId
default insertAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupPerms -> m AuthUserGroupPermsId
insertAuthUserGroupPerms = lift . insertAuthUserGroupPerms
getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup)
default getAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m (Maybe AuthUserGroup)
getAuthUserGroup = lift . getAuthUserGroup
listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
default listAuthUserGroupPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
listAuthUserGroupPermissions = lift . listAuthUserGroupPermissions
listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
default listAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
listAuthUserGroupUsers = lift . listAuthUserGroupUsers
replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m ()
default replaceAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> AuthUserGroup -> m ()
replaceAuthUserGroup = (lift .) . replaceAuthUserGroup
clearAuthUserGroupUsers :: AuthUserGroupId -> m ()
default clearAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
clearAuthUserGroupUsers = lift . clearAuthUserGroupUsers
clearAuthUserGroupPerms :: AuthUserGroupId -> m ()
default clearAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
clearAuthUserGroupPerms = lift . clearAuthUserGroupPerms
deleteAuthUserGroup :: AuthUserGroupId -> m ()
default deleteAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
deleteAuthUserGroup = lift . deleteAuthUserGroup
listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
default listGroupsPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
listGroupsPaged = (lift .) . listGroupsPaged
setAuthUserGroupName :: AuthUserGroupId -> Text -> m ()
default setAuthUserGroupName :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Text -> m ()
setAuthUserGroupName = (lift .) . setAuthUserGroupName
setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
default setAuthUserGroupParent :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
setAuthUserGroupParent = (lift .) . setAuthUserGroupParent
insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId
default insertSingleUseCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCode -> m UserSingleUseCodeId
insertSingleUseCode = lift . insertSingleUseCode
setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m ()
default setSingleUseCodeUsed :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCodeId -> Maybe UTCTime -> m ()
setSingleUseCodeUsed = (lift .) . setSingleUseCodeUsed
getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
default getUnusedCode :: (m ~ t n, MonadTrans t, HasStorage n) => SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
getUnusedCode suc = (lift .) . getUnusedCode suc
invalidatePermanentCodes :: UserImplId -> UTCTime -> m ()
default invalidatePermanentCodes :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m ()
invalidatePermanentCodes = (lift .) . invalidatePermanentCodes
selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
default selectLastRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
selectLastRestoreCode = (lift .) . selectLastRestoreCode
insertUserRestore :: UserRestore -> m UserRestoreId
default insertUserRestore :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestore -> m UserRestoreId
insertUserRestore = lift . insertUserRestore
findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
default findRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
findRestoreCode uid = (lift .) . findRestoreCode uid
replaceRestoreCode :: UserRestoreId -> UserRestore -> m ()
default replaceRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestoreId -> UserRestore -> m ()
replaceRestoreCode = (lift .) . replaceRestoreCode
findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
default findAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
findAuthToken = (lift .) . findAuthToken
findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
default findAuthTokenByValue :: (m ~ t n, MonadTrans t, HasStorage n) => SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
findAuthTokenByValue = lift . findAuthTokenByValue
insertAuthToken :: AuthToken -> m AuthTokenId
default insertAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthToken -> m AuthTokenId
insertAuthToken = lift . insertAuthToken
replaceAuthToken :: AuthTokenId -> AuthToken -> m ()
default replaceAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthTokenId -> AuthToken -> m ()
replaceAuthToken = (lift .) . replaceAuthToken
instance HasStorage m => HasStorage (ContT r m)
instance HasStorage m => HasStorage (ExceptT e m)
instance HasStorage m => HasStorage (ReaderT r m)
instance (HasStorage m, Monoid w) => HasStorage (LRWS.RWST r w s m)
instance (HasStorage m, Monoid w) => HasStorage (SRWS.RWST r w s m)
instance HasStorage m => HasStorage (LS.StateT s m)
instance HasStorage m => HasStorage (SS.StateT s m)
instance (HasStorage m, Monoid w) => HasStorage (LW.WriterT w m)
instance (HasStorage m, Monoid w) => HasStorage (SW.WriterT w m)
passToByteString :: Password -> BS.ByteString
passToByteString = TE.encodeUtf8
byteStringToPass :: BS.ByteString -> Password
byteStringToPass = TE.decodeUtf8
userToUserInfo :: WithId UserImplId UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo
userToUserInfo (WithField uid UserImpl{..}) perms groups = RespUserInfo {
respUserId = fromKey uid
, respUserLogin = userImplLogin
, respUserEmail = userImplEmail
, respUserPermissions = perms
, respUserGroups = groups
}
makeUserInfo :: HasStorage m => WithId UserImplId UserImpl -> m RespUserInfo
makeUserInfo euser@(WithField uid _) = do
perms <- getUserPermissions uid
groups <- getUserGroups uid
return $ userToUserInfo euser perms groups
readUserInfo :: HasStorage m => UserId -> m (Maybe RespUserInfo)
readUserInfo uid' = do
let uid = toKey uid'
muser <- getUserImpl uid
maybe (return Nothing) (fmap Just . makeUserInfo . WithField uid) $ muser
readUserInfoByLogin :: HasStorage m => Login -> m (Maybe RespUserInfo)
readUserInfoByLogin login = do
muser <- getUserImplByLogin login
maybe (return Nothing) (fmap Just . makeUserInfo) muser
getUserPermissions :: HasStorage m => UserImplId -> m [Permission]
getUserPermissions uid = do
perms <- getUserImplPermissions uid
return $ userPermPermission . (\(WithField _ v) -> v) <$> perms
setUserPermissions :: HasStorage m => UserImplId -> [Permission] -> m ()
setUserPermissions uid perms = do
deleteUserPermissions uid
forM_ perms $ void . insertUserPerm . UserPerm uid
createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId
createUser strength login pass email perms = do
pass' <- liftIO $ makePassword (passToByteString pass) strength
i <- insertUserImpl UserImpl {
userImplLogin = login
, userImplPassword = byteStringToPass pass'
, userImplEmail = email
}
forM_ perms $ void . insertUserPerm . UserPerm i
return i
hasPerms :: HasStorage m => UserImplId -> [Permission] -> m Bool
hasPerms _ [] = return True
hasPerms i perms = do
perms' <- getUserAllPermissions i
return $ and $ (`elem` perms') <$> perms
createAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m UserImplId
createAdmin strength login pass email = createUser strength login pass email [adminPerm]
ensureAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m ()
ensureAdmin strength login pass email = do
madmin <- getFirstUserByPerm adminPerm
whenNothing madmin $ void $ createAdmin strength login pass email
patchUser :: HasStorage m => Int
-> PatchUser -> WithId UserImplId UserImpl -> m (WithId UserImplId UserImpl)
patchUser strength PatchUser{..} =
withPatch patchUserLogin (\l (WithField i u) -> pure $ WithField i u { userImplLogin = l })
>=> withPatch patchUserPassword patchPassword
>=> withPatch patchUserEmail (\e (WithField i u) -> pure $ WithField i u { userImplEmail = e })
>=> withPatch patchUserPermissions patchPerms
>=> withPatch patchUserGroups patchGroups
where
patchPassword ps (WithField i u) = WithField <$> pure i <*> setUserPassword' strength ps u
patchPerms ps (WithField i u) = do
setUserPermissions i ps
return $ WithField i u
patchGroups gs (WithField i u) = do
setUserGroups i gs
return $ WithField i u
setUserPassword' :: MonadIO m => Int
-> Password -> UserImpl -> m UserImpl
setUserPassword' strength pass user = do
pass' <- liftIO $ makePassword (passToByteString pass) strength
return $ user { userImplPassword = byteStringToPass pass' }
getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId]
getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . (\(WithField _ v) -> v)) <$> selectUserImplGroups i
setUserGroups :: HasStorage m => UserImplId -> [UserGroupId] -> m ()
setUserGroups i gs = do
clearUserImplGroups i
gs' <- validateGroups gs
forM_ gs' $ \g -> void $ insertAuthUserGroupUsers $ AuthUserGroupUsers g i
validateGroups :: HasStorage m => [UserGroupId] -> m [AuthUserGroupId]
validateGroups is = do
pairs <- mapM ((\i -> (i,) <$> getAuthUserGroup i) . toKey) is
return $ fmap fst . filter (isJust . snd) $ pairs
getGroupPermissions :: HasStorage m => UserGroupId -> m [Permission]
getGroupPermissions = go S.empty S.empty . toKey
where
go !visited !perms !i = do
mg <- getAuthUserGroup i
case mg of
Nothing -> return $ F.toList perms
Just AuthUserGroup{..} -> do
curPerms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i
let perms' = perms <> S.fromList curPerms
case authUserGroupParent of
Nothing -> return $ F.toList perms'
Just pid -> if isJust $ pid `S.elemIndexL` visited
then fail $ "Recursive user group graph: " <> show (visited S.|> pid)
else go (visited S.|> pid) perms' pid
getUserGroupPermissions :: HasStorage m => UserImplId -> m [Permission]
getUserGroupPermissions i = do
groups <- getUserGroups i
perms <- mapM getGroupPermissions groups
return $ L.sort . L.nub . concat $ perms
getUserAllPermissions :: HasStorage m => UserImplId -> m [Permission]
getUserAllPermissions i = do
permsDr <- getUserPermissions i
permsGr <- getUserGroupPermissions i
return $ L.sort . L.nub $ permsDr <> permsGr
readUserGroup :: HasStorage m => UserGroupId -> m (Maybe UserGroup)
readUserGroup i = do
let i' = toKey $ i
mu <- getAuthUserGroup i'
case mu of
Nothing -> return Nothing
Just AuthUserGroup{..} -> do
users <- fmap (authUserGroupUsersUser . (\(WithField _ v) -> v)) <$> listAuthUserGroupUsers i'
perms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i'
return $ Just UserGroup {
userGroupName = authUserGroupName
, userGroupUsers = fromKey <$> users
, userGroupPermissions = perms
, userGroupParent = fromKey <$> authUserGroupParent
}
toAuthUserGroup :: UserGroup -> (AuthUserGroup, AuthUserGroupId -> [AuthUserGroupUsers], AuthUserGroupId -> [AuthUserGroupPerms])
toAuthUserGroup UserGroup{..} = (ag, users, perms)
where
ag = AuthUserGroup {
authUserGroupName = userGroupName
, authUserGroupParent = toKey <$> userGroupParent
}
users i = (\ui -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers
perms i = (\perm -> AuthUserGroupPerms i perm) <$> userGroupPermissions
insertUserGroup :: HasStorage m => UserGroup -> m UserGroupId
insertUserGroup u = do
let (ag, users, perms) = toAuthUserGroup u
i <- insertAuthUserGroup ag
forM_ (users i) $ void . insertAuthUserGroupUsers
forM_ (perms i) $ void . insertAuthUserGroupPerms
return $ fromKey $ i
updateUserGroup :: HasStorage m => UserGroupId -> UserGroup -> m ()
updateUserGroup i u = do
let i' = toKey $ i
let (ag, users, perms) = toAuthUserGroup u
replaceAuthUserGroup i' ag
clearAuthUserGroupUsers i'
clearAuthUserGroupPerms i'
forM_ (users i') $ void . insertAuthUserGroupUsers
forM_ (perms i') $ void . insertAuthUserGroupPerms
deleteUserGroup :: HasStorage m => UserGroupId -> m ()
deleteUserGroup i = do
let i' = toKey $ i
clearAuthUserGroupUsers i'
clearAuthUserGroupPerms i'
deleteAuthUserGroup i'
patchUserGroup :: HasStorage m => UserGroupId -> PatchUserGroup -> m ()
patchUserGroup i PatchUserGroup{..} = do
let i' = toKey i
whenJust patchUserGroupName $ setAuthUserGroupName i'
whenJust patchUserGroupParent $ setAuthUserGroupParent i' . Just . toKey
whenJust patchUserGroupNoParent $ const $ setAuthUserGroupParent i' Nothing
whenJust patchUserGroupUsers $ \uids -> do
clearAuthUserGroupUsers i'
forM_ uids $ insertAuthUserGroupUsers . AuthUserGroupUsers i' . toKey
whenJust patchUserGroupPermissions $ \perms -> do
clearAuthUserGroupPerms i'
forM_ perms $ insertAuthUserGroupPerms . AuthUserGroupPerms i'