biscuit-haskell-0.2.1.0: test/Spec/Executor.hs
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Spec.Executor (specs) where
import Data.Attoparsec.Text (parseOnly)
import Data.Map.Strict as Map
import Data.Set as Set
import Data.Text (Text, unpack)
import Numeric.Natural (Natural)
import Test.Tasty
import Test.Tasty.HUnit
import Auth.Biscuit.Datalog.AST
import Auth.Biscuit.Datalog.Executor (ExecutionError (..),
Limits (..),
defaultLimits,
evaluateExpression)
import Auth.Biscuit.Datalog.Parser (expressionParser, fact,
rule)
import Auth.Biscuit.Datalog.ScopedExecutor hiding (limits)
specs :: TestTree
specs = testGroup "Datalog evaluation"
[ grandparent
, ancestor
, scopedRules
, exprEval
, exprEvalError
, rulesWithConstraints
, ruleHeadWithNoVars
, limits
]
authGroup :: Set Fact -> FactGroup
authGroup = FactGroup . Map.singleton (Set.singleton 0)
authRulesGroup :: Set Rule -> Map Natural (Set Rule)
authRulesGroup = Map.singleton 0
grandparent :: TestTree
grandparent = testCase "Basic grandparent rule" $
let rules = authRulesGroup $ Set.fromList
[ [rule|grandparent($a,$b) <- parent($a,$c), parent($c,$b)|]
]
facts = authGroup $ Set.fromList
[ [fact|parent("alice", "bob")|]
, [fact|parent("bob", "jean-pierre")|]
, [fact|parent("alice", "toto")|]
]
in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList
[ [fact|parent("alice", "bob")|]
, [fact|parent("bob", "jean-pierre")|]
, [fact|parent("alice", "toto")|]
, [fact|grandparent("alice", "jean-pierre")|]
])
ancestor :: TestTree
ancestor = testCase "Ancestor rule" $
let rules = authRulesGroup $ Set.fromList
[ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|]
, [rule|ancestor($a,$b) <- parent($a,$b)|]
]
facts = authGroup $ Set.fromList
[ [fact|parent("alice", "bob")|]
, [fact|parent("bob", "jean-pierre")|]
, [fact|parent("alice", "toto")|]
]
in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList
[ [fact|parent("alice", "bob")|]
, [fact|parent("bob", "jean-pierre")|]
, [fact|parent("alice", "toto")|]
, [fact|ancestor("alice", "bob")|]
, [fact|ancestor("bob", "jean-pierre")|]
, [fact|ancestor("alice", "toto")|]
, [fact|ancestor("alice", "jean-pierre")|]
])
expr :: Text -> Expression
expr = either error id . parseOnly expressionParser
exprEval :: TestTree
exprEval = do
let bindings = Map.fromList
[ ("var1", LInteger 0)
, ("topDomain", LString "example.com")
, ("domain", LString "test.example.com")
]
eval (e, r) = testCase (unpack e) $
evaluateExpression defaultLimits bindings (expr e) @?= Right r
-- ("1 / 0") @?= Left "Divide by 0"
testGroup "Expressions evaluation" $ eval <$>
[ ("!(1 < $var1)", LBool True)
, ("[0].contains($var1)", LBool True)
, ("1 + 2 * 3", LInteger 7)
, ("!(1 + 2 * 3 > 4)", LBool False)
, ("!true", LBool False)
, ("!false", LBool True)
, ("(true)", LBool True)
, ("\"test\".length()", LInteger 4)
, ("hex:ababab.length()", LInteger 3)
, ("[].length()", LInteger 0)
, ("[\"test\", \"test\"].length()", LInteger 1)
, ("1 == 1", LBool True)
, ("2 == 1", LBool False)
, ("\"toto\" == \"toto\"", LBool True)
, ("\"toto\" == \"truc\"", LBool False)
, ("\"toto\".matches(\"to(to)?\")", LBool True)
, ("\"toto\".matches(\"^to$\")", LBool False)
, ("2021-05-07T18:00:00Z == 2021-05-07T18:00:00Z", LBool True)
, ("2021-05-07T18:00:00Z == 2021-05-07T19:00:00Z", LBool False)
, ("hex:ababab == hex:ababab", LBool True)
, ("hex:ababab == hex:ababac", LBool False)
, ("true == true", LBool True)
, ("true == false", LBool False)
, ("[1,2,3] == [1,2,3]", LBool True)
, ("[1,2,3] == [1,2,4]", LBool False)
, ("1 < 2", LBool True)
, ("2 < 1", LBool False)
, ("2021-05-07T18:00:00Z < 2021-05-07T19:00:00Z", LBool True)
, ("2021-05-07T19:00:00Z < 2021-05-07T18:00:00Z", LBool False)
, ("2 > 1", LBool True)
, ("1 > 2", LBool False)
, ("2021-05-07T19:00:00Z > 2021-05-07T18:00:00Z", LBool True)
, ("2021-05-07T18:00:00Z > 2021-05-07T19:00:00Z", LBool False)
, ("1 <= 2", LBool True)
, ("1 <= 1", LBool True)
, ("2 <= 1", LBool False)
, ("2021-05-07T18:00:00Z <= 2021-05-07T19:00:00Z", LBool True)
, ("2021-05-07T18:00:00Z <= 2021-05-07T18:00:00Z", LBool True)
, ("2021-05-07T19:00:00Z <= 2021-05-07T18:00:00Z", LBool False)
, ("2 >= 1", LBool True)
, ("2 >= 2", LBool True)
, ("1 >= 2", LBool False)
, ("2021-05-07T19:00:00Z >= 2021-05-07T18:00:00Z", LBool True)
, ("2021-05-07T18:00:00Z >= 2021-05-07T18:00:00Z", LBool True)
, ("2021-05-07T18:00:00Z >= 2021-05-07T19:00:00Z", LBool False)
, ("\"my string\".starts_with(\"my\")", LBool True)
, ("\"my string\".starts_with(\"string\")", LBool False)
, ("\"my string\".ends_with(\"string\")", LBool True)
, ("\"my string\".ends_with(\"my\")", LBool False)
, ("$domain.ends_with(\".\" + $topDomain)", LBool True)
, ("2 + 1", LInteger 3)
, ("2 - 1", LInteger 1)
, ("5 / 2", LInteger 2)
, ("2 * 1", LInteger 2)
, ("true && true", LBool True)
, ("true && false", LBool False)
, ("false && true", LBool False)
, ("false && false", LBool False)
, ("true || true", LBool True)
, ("true || false", LBool True)
, ("false || true", LBool True)
, ("false || false", LBool False)
, ("[1].contains([1])", LBool True)
, ("[1].contains(1)", LBool True)
, ("[].contains(1)", LBool False)
, ("[\"test\"].contains(2)", LBool False)
, ("[1].intersection([1])", TermSet (Set.fromList [LInteger 1]))
, ("[1].intersection([\"test\"])", TermSet (Set.fromList []))
, ("[1].union([1])", TermSet (Set.fromList [LInteger 1]))
, ("[1].union([\"test\"])", TermSet (Set.fromList [LInteger 1, LString "test"]))
]
exprEvalError :: TestTree
exprEvalError = do
let bindings = Map.fromList
[ ("var1", LInteger 0)
]
l = defaultLimits { allowRegexes = False }
evalFail (e, r) = testCase (unpack e) $
evaluateExpression l bindings (expr e) @?= Left r
testGroup "Expressions evaluation (expected errors)" $ evalFail <$>
[ ("1 / 0", "Divide by 0")
, ("\"toto\".matches(\"to\")", "Regex evaluation is disabled")
]
rulesWithConstraints :: TestTree
rulesWithConstraints = testCase "Rule with constraints" $
let rules = authRulesGroup $ Set.fromList
[ [rule|valid_date("file1") <- time($0), resource("file1"), $0 <= 2019-12-04T09:46:41+00:00|]
, [rule|valid_date("file2") <- time($0), resource("file2"), $0 <= 2010-12-04T09:46:41+00:00|]
]
facts = authGroup $ Set.fromList
[ [fact|time(2019-12-04T01:00:00Z)|]
, [fact|resource("file1")|]
, [fact|resource("file2")|]
]
in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList
[ [fact|time(2019-12-04T01:00:00Z)|]
, [fact|resource("file1")|]
, [fact|resource("file2")|]
, [fact|valid_date("file1")|]
])
ruleHeadWithNoVars :: TestTree
ruleHeadWithNoVars = testCase "Rule head with no variables" $
let rules = authRulesGroup $ Set.fromList
[ [rule|operation("authority", "read") <- test($yolo, "nothing")|]
]
facts = authGroup $ Set.fromList
[ [fact|test("whatever", "notNothing")|]
]
in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList
[ [fact|test("whatever", "notNothing")|]
])
limits :: TestTree
limits =
let rules = authRulesGroup $ Set.fromList
[ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|]
, [rule|ancestor($a,$b) <- parent($a,$b)|]
]
facts = authGroup $ Set.fromList
[ [fact|parent("alice", "bob")|]
, [fact|parent("bob", "jean-pierre")|]
, [fact|parent("bob", "marielle")|]
, [fact|parent("alice", "toto")|]
]
factLimits = defaultLimits { maxFacts = 10 }
iterLimits = defaultLimits { maxIterations = 2 }
in testGroup "Facts generation limits"
[ testCase "max facts" $
runFactGeneration factLimits rules facts @?= Left Facts
, testCase "max iterations" $
runFactGeneration iterLimits rules facts @?= Left Iterations
]
scopedRules :: TestTree
scopedRules = testCase "Rules and facts in different scopes, with default scoping for rules" $
let rules :: Map Natural (Set Rule)
rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b)|] ])
, (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] ])
]
facts :: FactGroup
facts = FactGroup
[ ([0], [ [fact|parent("alice", "bob")|]
, [fact|parent("bob", "trudy")|]
])
, ([1], [ [fact|parent("bob", "jean-pierre")|]
])
, ([2], [ [fact|parent("toto", "toto")|]
])
]
in runFactGeneration defaultLimits rules facts @?= Right (FactGroup
[ ([0], [ [fact|parent("alice", "bob")|]
, [fact|ancestor("alice", "bob")|]
, [fact|parent("bob", "trudy")|]
, [fact|ancestor("bob", "trudy")|]
])
, ([1], [ [fact|parent("bob", "jean-pierre")|]
])
, ([0,1], [ [fact|ancestor("alice", "trudy")|]
])
, ([2], [ [fact|parent("toto", "toto")|] ])
])