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.IO.Class
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
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
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
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
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
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
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
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
data AuthUserGroupPerms = AuthUserGroupPerms {
authUserGroupPermsGroup :: AuthUserGroupId
, authUserGroupPermsPermission :: Permission
} deriving (Generic, Show)
class MonadIO m => HasStorage m where
getUserImpl :: UserImplId -> m (Maybe UserImpl)
getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl))
listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm]
deleteUserPermissions :: UserImplId -> m ()
insertUserPerm :: UserPerm -> m UserPermId
insertUserImpl :: UserImpl -> m UserImplId
replaceUserImpl :: UserImplId -> UserImpl -> m ()
deleteUserImpl :: UserImplId -> m ()
hasPerm :: UserImplId -> Permission -> m Bool
getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl))
selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
clearUserImplGroups :: UserImplId -> m ()
insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId
insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId
insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId
getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup)
listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m ()
clearAuthUserGroupUsers :: AuthUserGroupId -> m ()
clearAuthUserGroupPerms :: AuthUserGroupId -> m ()
deleteAuthUserGroup :: AuthUserGroupId -> m ()
listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
setAuthUserGroupName :: AuthUserGroupId -> Text -> m ()
setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId
setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m ()
getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
invalidatePermamentCodes :: UserImplId -> UTCTime -> m ()
selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
insertUserRestore :: UserRestore -> m UserRestoreId
findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
replaceRestoreCode :: UserRestoreId -> UserRestore -> m ()
findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
insertAuthToken :: AuthToken -> m AuthTokenId
replaceAuthToken :: AuthTokenId -> AuthToken -> 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'