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
import           Auth.Biscuit.Datalog.Parser   (expressionParser, fact, rule)

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)|]
                   ]
        , blockRules = mempty
        , facts = Set.fromList
                   [ [fact|parent("alice", "bob")|]
                   , [fact|parent("bob", "jean-pierre")|]
                   , [fact|parent("alice", "toto")|]
                   ]
        }
   in computeAllFacts 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)
    , ("#toto == #toto", LBool True)
    , ("#toto == #truc", LBool False)
    , ("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)
    , ("[#test].contains([#test])", LBool True)
    , ("[#test].contains(#test)", LBool True)
    , ("[].contains(#test)", LBool False)
    , ("[\"test\"].contains(#test)", LBool False)
    , ("[#test].intersection([#test])", TermSet (Set.fromList [Symbol "test"]))
    , ("[#test].intersection([\"test\"])", TermSet (Set.fromList []))
    , ("[#test].union([#test])", TermSet (Set.fromList [Symbol "test"]))
    , ("[#test].union([\"test\"])", TermSet (Set.fromList [Symbol "test", 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(#ambient, $0), resource(#ambient, "file1"), $0 <= 2019-12-04T09:46:41+00:00|]
                   , [rule|valid_date("file2") <- time(#ambient, $0), resource(#ambient, "file2"), $0 <= 2010-12-04T09:46:41+00:00|]
                   ]
        , blockRules = mempty
        , facts = Set.fromList
                   [ [fact|time(#ambient, 2019-12-04T01:00:00Z)|]
                   , [fact|resource(#ambient, "file1")|]
                   , [fact|resource(#ambient, "file2")|]
                   ]
        }
   in computeAllFacts defaultLimits world @?= Right (Set.fromList
        [ [fact|time(#ambient, 2019-12-04T01:00:00Z)|]
        , [fact|resource(#ambient, "file1")|]
        , [fact|resource(#ambient, "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)|]
                   ]
        , blockRules = mempty
        , facts = Set.fromList
                   [ [fact|test(#whatever, #notNothing)|]
                   ]
        }
   in computeAllFacts 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)|]
                   ]
        , blockRules = mempty
        , 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" $
            computeAllFacts factLimits world @?= Left TooManyFacts
        , testCase "max iterations" $
            computeAllFacts iterLimits world @?= Left TooManyIterations
        ]