Executor.hs

{-# 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           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
  , exprEval
  , exprEvalError
  , rulesWithConstraints
  , ruleHeadWithNoVars
  , limits
  ]

grandparent :: TestTree
grandparent = testCase "Basic grandparent rule" $
  let world = World
        { rules = Set.fromList
                   [ [rule|grandparent($a,$b) <- parent($a,$c), parent($c,$b)|]
                   ]
        , facts = Set.fromList
                   [ [fact|parent("alice", "bob")|]
                   , [fact|parent("bob", "jean-pierre")|]
                   , [fact|parent("alice", "toto")|]
                   ]
        }
   in runFactGeneration defaultLimits world @?= Right (Set.fromList
        [ [fact|parent("alice", "bob")|]
        , [fact|parent("bob", "jean-pierre")|]
        , [fact|parent("alice", "toto")|]
        , [fact|grandparent("alice", "jean-pierre")|]
        ])

expr :: Text -> Expression
expr = either error id . parseOnly expressionParser

exprEval :: TestTree
exprEval = do
  let bindings = Map.fromList
        [ ("var1", LInteger 0)
        ]
      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)
    , ("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 world = World
        { rules = 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 = Set.fromList
                   [ [fact|time(2019-12-04T01:00:00Z)|]
                   , [fact|resource("file1")|]
                   , [fact|resource("file2")|]
                   ]
        }
   in runFactGeneration defaultLimits world @?= Right (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 world = World
        { rules = Set.fromList
                   [ [rule|operation("authority", "read") <- test($yolo, "nothing")|]
                   ]
        , facts = Set.fromList
                   [ [fact|test("whatever", "notNothing")|]
                   ]
        }
   in runFactGeneration defaultLimits world @?= Right (Set.fromList
        [ [fact|test("whatever", "notNothing")|]
        ])

limits :: TestTree
limits =
  let world = World
        { rules = Set.fromList
                   [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|]
                   , [rule|ancestor($a,$b) <- parent($a,$b)|]
                   ]
        , facts = 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 world @?= Left Facts
        , testCase "max iterations" $
            runFactGeneration iterLimits world @?= Left Iterations
        ]