module Control.Access.RoleBased.Checker where
import Control.Monad
import Control.Monad.Logic
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import Control.Access.RoleBased.Internal.RoleMap (RoleMap)
import qualified Control.Access.RoleBased.Internal.RoleMap as RM
import Control.Access.RoleBased.Internal.Types
import Control.Access.RoleBased.Role
type RoleBuilder a = StateT RoleMap RoleMonad a
applyRule :: Role -> Rule -> [Role]
applyRule r (Rule _ f) = f r
applyRuleSet :: Role -> RuleSet -> [Role]
applyRuleSet r (RuleSet m) = f r
where
f = fromMaybe (const []) $ M.lookup (_roleName r) m
checkUnseen :: Role -> RoleBuilder ()
checkUnseen role = do
m <- get
if isJust $ RM.lookup role m then mzero else return ()
checkSeen :: Role -> RoleBuilder ()
checkSeen = lnot . checkUnseen
markSeen :: Role -> RoleBuilder ()
markSeen role = modify $ RM.insert role
isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a
isum l = case l of
[] -> mzero
(x:xs) -> x `interleave` isum xs
expandRoles :: [Rule] -> [Role] -> RoleMonad Role
expandRoles rules roles0 = evalStateT (go roles0) RM.empty
where
ruleSet = rulesToSet rules
go roles = isum $ map expandOne roles
expandOne role = do
checkUnseen role
markSeen role
return role `interleave` go newRoles
where
newRoles = applyRuleSet role ruleSet
hasRole :: Role -> RuleChecker ()
hasRole r = RuleChecker $ do
ch <- ask
once $ go ch
where
go gen = do
r' <- lift gen
if r `matches` r' then return () else mzero
missingRole :: Role -> RuleChecker ()
missingRole = lnot . hasRole
hasAllRoles :: [Role] -> RuleChecker ()
hasAllRoles rs = RuleChecker $ do
ch <- ask
lift $ once $ go ch $ RM.fromList rs
where
go gen !st = do
mr <- msplit gen
maybe mzero
(\(r,gen') -> let st' = RM.delete r st
in if RM.null st'
then return ()
else go gen' st')
mr
hasAnyRoles :: [Role] -> RuleChecker ()
hasAnyRoles rs = RuleChecker $ do
ch <- ask
lift $ once $ go ch
where
st = RM.fromList rs
go gen = do
mr <- msplit gen
maybe mzero
(\(r,gen') -> if isJust $ RM.lookup r st
then return ()
else go gen')
mr
runRuleChecker :: [Rule]
-> [Role]
-> RuleChecker a
-> Bool
runRuleChecker rules roles (RuleChecker f) =
case outs of
[] -> False
_ -> True
where
(RoleMonad st) = runReaderT f $ expandRoles rules roles
outs = observeMany 1 st
mkRule :: Text -> (Role -> [Role]) -> Rule
mkRule = Rule
implies :: Role -> [Role] -> Rule
implies src dest = Rule (_roleName src)
(\role -> if role `matches` src then dest else [])
impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule
impliesWith src f = Rule (_roleName src)
(\role -> if src `matches` role
then f $ _roleData role
else [])
testRules :: [Rule]
testRules = [ "user" `implies` ["guest", "can_post"]
, "superuser" `implies` [ "user"
, "can_moderate"
, "can_administrate"]
, "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ]
, "with_arg" `impliesWith` \dat ->
maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $
M.lookup "arg" dat
, "superuser" `implies` [ addRoleData "arg1" "a" $
addRoleData "arg2" "b" "multi_args" ]
]
tX :: RuleChecker () -> Bool
tX f = runRuleChecker testRules ["superuser"] f
t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool
t1 = tX $ hasAnyRoles ["guest","userz"]
t2 = tX $ hasAllRoles ["guest","userz"]
t3 = tX $ hasAllRoles ["guest","user"]
t4 = tX $ hasRole "can_administrate"
t5 = tX $ hasRole "lkfdhjkjfhds"
t6 = tX $ do
hasRole "guest"
hasRole "superuser"
t7 = tX $ do
hasRole "zzzzz"
hasRole "superuser"
t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg"
t9 = tX $ hasRole "multi_args"
t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args"
t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args"
t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"]
t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"
, addRoleData "arg2" "b" "multi_args" ]
t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"
, addRoleData "arg2" "aaa" "multi_args" ]
t15 = tX $ missingRole "jflsdkjf"
t16 = tX $ do
missingRole "fdjlksjlf"
hasRole "multi_args"
t17 = tX $ missingRole "multi_args"