mateamt/src/Control/Role.hs

137 lines
3.7 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Control.Role where
import Servant
import Control.Monad (void, when)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Text as T
-- internal imports
import Types
import Model
roleList :: MateHandler [Role]
roleList = do
conn <- asks rsConnection
selectAllRoles conn
roleNew
:: Maybe (Int, AuthMethod)
-> RoleSubmit
-> MateHandler Int
roleNew (Just (uid, auth)) (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) =
do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then
insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 =<< asks rsConnection
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
roleNew Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
roleUpdate
:: Maybe (Int, AuthMethod)
-> Int
-> RoleSubmit
-> MateHandler ()
roleUpdate (Just (uid, auth)) id_ roleSubmit = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then
void $ updateRole id_ roleSubmit =<< asks rsConnection
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
roleUpdate Nothing _ _ =
throwError $ err401
{ errBody = "No Authentication present."
}
roleDelete
:: Maybe (Int, AuthMethod)
-> Int
-> MateHandler ()
roleDelete (Just (uid, auth)) id_ = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then
void $ deleteRole id_ =<< asks rsConnection
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
roleDelete Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
roleAssociationList
:: MateHandler [RoleAssociation]
roleAssociationList =
selectAllRoleAssociations =<< asks rsConnection
roleAssociationSubmit
:: Maybe (Int, AuthMethod)
-> RoleAssociationSubmit
-> MateHandler ()
roleAssociationSubmit (Just (uid, auth)) (RoleAssociationSubmit auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then
associateUserToRole auid arid =<< asks rsConnection
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
roleAssociationSubmit Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
roleAssociationDelete
:: Maybe (Int, AuthMethod)
-> RoleAssociation
-> MateHandler ()
roleAssociationDelete (Just (uid, auth)) (RoleAssociation auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then
void $ deleteAssociation auid arid =<< asks rsConnection
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
roleAssociationDelete Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
-- | This is the internal function to check a users authorization to do certain
-- actions
checkCapability
:: Int -- ^ User Id to check
-> (Role -> Bool) -- ^ Predicate to check
-> MateHandler Bool -- ^ Result
checkCapability uid accessRule = do
conn <- asks rsConnection
assocs <- selectUserAssociations uid conn
let rids = map roleAssociationRole assocs
roles <- selectRoleList rids conn
return $ any accessRule roles
notImplemented :: MateHandler a
notImplemented = throwError $ err501
{ errBody = "Function has not yet been implemented!"
}