{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Spec.Executor (specs) where 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) import Spec.Parser (parseExpression) 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 EvalRule) authRulesGroup = Map.singleton 0 . adaptRules adaptRules :: Set Rule -> Set EvalRule adaptRules = Set.map (toEvaluation []) 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 1 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 1 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 . parseExpression 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 1 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 1 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 1 rules facts @?= Left Facts , testCase "max iterations" $ runFactGeneration iterLimits 1 rules facts @?= Left Iterations ] scopedRules :: TestTree scopedRules = testGroup "Rules and facts in different scopes" [ testCase "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 3 (adaptRules <$> 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")|] ]) ]) , testCase "with explicit scoping for rules (authority)" $ let rules :: Map Natural (Set Rule) rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b) trusting authority |] ]) , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b) trusting authority |] ]) , (2, [ [rule|family($a,$b) <- parent($a,$b) trusting authority |] ]) ] 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 3 (adaptRules <$> 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")|] , [fact|family("toto", "toto")|] ]) , ([0,2], [ [fact|family("alice", "bob")|] , [fact|family("bob", "trudy")|] ]) ]) ]