{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}

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


------------------------------------------------------------------------------
-- | Given a set of roles to check, and a set of implication rules describing
-- how a given role inherits from other roles, this function produces a stream
-- of expanded Roles. If a Role is seen twice, expandRoles mzeros.
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 [])


------------------------------------------------------------------------------
-- Testing code follows: TODO: move into test suite


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"