{-# 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")|] ])
        ])