{-# 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 c11) = do isRoleManager <- checkCapability uid roleCanManageRoles if (auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager) then insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11 =<< 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 _ _ = notImplemented roleAssociationList :: MateHandler [RoleAssociation] roleAssociationList = selectAllRoleAssociations =<< asks rsConnection roleAssociationSubmit _ _ = notImplemented roleAssociationDelete _ _ = notImplemented -- | 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!" }