{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Spec.Parser (specs) where
import Data.Attoparsec.Text (parseOnly)
import qualified Data.Set as Set
import Data.Text (Text)
import Test.Tasty
import Test.Tasty.HUnit
import Auth.Biscuit.Datalog.AST
import Auth.Biscuit.Datalog.Parser (authorizerParser, checkParser,
expressionParser, policyParser,
predicateParser, ruleParser,
termParser)
parseTerm :: Text -> Either String Term
parseTerm = parseOnly termParser
parseTermQQ :: Text -> Either String QQTerm
parseTermQQ = parseOnly termParser
parsePredicate :: Text -> Either String Predicate
parsePredicate = parseOnly predicateParser
parseRule :: Text -> Either String Rule
parseRule = parseOnly ruleParser
parseExpression :: Text -> Either String Expression
parseExpression = parseOnly expressionParser
parseCheck :: Text -> Either String Check
parseCheck = parseOnly checkParser
parseAuthorizer :: Text -> Either String Authorizer
parseAuthorizer = parseOnly authorizerParser
parsePolicy :: Text -> Either String Policy
parsePolicy = parseOnly policyParser
specs :: TestTree
specs = testGroup "datalog parser"
[ factWithDate
, simpleFact
, oneLetterFact
, simpleRule
, multilineRule
, termsGroup
, termsGroupQQ
, constraints
, constrainedRule
, constrainedRuleOrdering
, checkParsing
, policyParsing
, authorizerParsing
]
termsGroup :: TestTree
termsGroup = testGroup "Parse terms"
[ testCase "String" $ parseTerm "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")
, testCase "Positive integer" $ parseTerm "123" @?= Right (LInteger 123)
, testCase "Negative integer" $ parseTerm "-42" @?= Right (LInteger (-42))
, testCase "Date" $ parseTerm "2019-12-02T13:49:53Z" @?=
Right (LDate $ read "2019-12-02 13:49:53 UTC")
, testCase "Variable" $ parseTerm "$1" @?= Right (Variable "1")
, testCase "Antiquote" $ parseTerm "${toto}" @?= Left "Failed reading: empty"
]
termsGroupQQ :: TestTree
termsGroupQQ = testGroup "Parse terms (in a QQ setting)"
[ testCase "String" $ parseTermQQ "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")
, testCase "Positive integer" $ parseTermQQ "123" @?= Right (LInteger 123)
, testCase "Negative integer" $ parseTermQQ "-42" @?= Right (LInteger (-42))
, testCase "Date" $ parseTermQQ "2019-12-02T13:49:53Z" @?=
Right (LDate $ read "2019-12-02 13:49:53 UTC")
, testCase "Variable" $ parseTermQQ "$1" @?= Right (Variable "1")
, testCase "Antiquote" $ parseTermQQ "${toto}" @?= Right (Antiquote "toto")
]
simpleFact :: TestTree
simpleFact = testCase "Parse simple fact" $
parsePredicate "right(\"file1\", \"read\")" @?=
Right (Predicate "right" [LString "file1", LString "read"])
oneLetterFact :: TestTree
oneLetterFact = testCase "Parse one-letter fact" $
parsePredicate "a(12)" @?=
Right (Predicate "a" [LInteger 12])
factWithDate :: TestTree
factWithDate = testCase "Parse fact containing a date" $
parsePredicate "date(2019-12-02T13:49:53Z)" @?=
Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53 UTC"])
simpleRule :: TestTree
simpleRule = testCase "Parse simple rule" $
parseRule "right($0, \"read\") <- resource( $0), operation(\"read\")" @?=
Right (Rule (Predicate "right" [Variable "0", LString "read"])
[ Predicate "resource" [Variable "0"]
, Predicate "operation" [LString "read"]
] [] Nothing)
multilineRule :: TestTree
multilineRule = testCase "Parse multiline rule" $
parseRule "right($0, \"read\") <-\n resource( $0),\n operation(\"read\")" @?=
Right (Rule (Predicate "right" [Variable "0", LString "read"])
[ Predicate "resource" [Variable "0"]
, Predicate "operation" [LString "read"]
] [] Nothing)
constrainedRule :: TestTree
constrainedRule = testCase "Parse constained rule" $
parseRule "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2019-12-04T09:46:41+00:00" @?=
Right (Rule (Predicate "valid_date" [LString "file1"])
[ Predicate "time" [Variable "0"]
, Predicate "resource" [LString "file1"]
]
[ EBinary LessOrEqual
(EValue $ Variable "0")
(EValue $ LDate $ read "2019-12-04 09:46:41 UTC")
] Nothing)
constrainedRuleOrdering :: TestTree
constrainedRuleOrdering = testCase "Parse constained rule (interleaved)" $
parseRule "valid_date(\"file1\") <- time($0), $0 <= 2019-12-04T09:46:41+00:00, resource(\"file1\")" @?=
Right (Rule (Predicate "valid_date" [LString "file1"])
[ Predicate "time" [Variable "0"]
, Predicate "resource" [LString "file1"]
]
[ EBinary LessOrEqual
(EValue $ Variable "0")
(EValue $ LDate $ read "2019-12-04 09:46:41 UTC")
] Nothing)
constraints :: TestTree
constraints = testGroup "Parse expressions"
[ testCase "date comparison (LTE)" $
parseExpression "$0 <= 2030-12-31T12:59:59+00:00" @?=
Right (EBinary LessOrEqual
(EValue (Variable "0"))
(EValue (LDate $ read "2030-12-31 12:59:59 UTC"))
)
, testCase "date comparison (GTE)" $
parseExpression "$0 >= 2030-12-31T12:59:59+00:00" @?=
Right (EBinary GreaterOrEqual
(EValue (Variable "0"))
(EValue (LDate $ read "2030-12-31 12:59:59 UTC"))
)
, testCase "int comparison (LT)" $
parseExpression "$0 < 1234" @?=
Right (EBinary LessThan
(EValue (Variable "0"))
(EValue (LInteger 1234))
)
, testCase "int comparison (GT)" $
parseExpression "$0 > 1234" @?=
Right (EBinary GreaterThan
(EValue (Variable "0"))
(EValue (LInteger 1234))
)
, testCase "int comparison (LTE)" $
parseExpression "$0 <= 1234" @?=
Right (EBinary LessOrEqual
(EValue (Variable "0"))
(EValue (LInteger 1234))
)
, testCase "int comparison (EQ)" $
parseExpression "$0 == 1" @?=
Right (EBinary Equal
(EValue (Variable "0"))
(EValue (LInteger 1))
)
, testCase "negative int comparison (GTE)" $
parseExpression "$0 >= -1234" @?=
Right (EBinary GreaterOrEqual
(EValue (Variable "0"))
(EValue (LInteger (-1234)))
)
, testCase "string comparison" $
parseExpression "$0 == \"abc\"" @?=
Right (EBinary Equal
(EValue (Variable "0"))
(EValue (LString "abc"))
)
, testCase "string comparison (starts_with)" $
parseExpression "$0.starts_with(\"abc\")" @?=
Right (EBinary Prefix
(EValue (Variable "0"))
(EValue (LString "abc"))
)
, testCase "string comparison (ends_with)" $
parseExpression "$0.ends_with(\"abc\")" @?=
Right (EBinary Suffix
(EValue (Variable "0"))
(EValue (LString "abc"))
)
, testCase "string comparison (matches)" $
parseExpression "$0.matches(\"abc\")" @?=
Right (EBinary Regex
(EValue (Variable "0"))
(EValue (LString "abc"))
)
, testCase "int set operation" $
parseExpression "[1, 2].contains($0)" @?=
Right (EBinary Contains
(EValue (TermSet $ Set.fromList [LInteger 1, LInteger 2]))
(EValue (Variable "0"))
)
, testCase "negated int set operation" $
parseExpression "![1, 2].contains($0)" @?=
Right (EUnary Negate
(EBinary Contains
(EValue (TermSet $ Set.fromList [LInteger 1, LInteger 2]))
(EValue (Variable "0"))
))
, testCase "string set operation" $
parseExpression "[\"abc\", \"def\"].contains($0)" @?=
Right (EBinary Contains
(EValue (TermSet $ Set.fromList [LString "abc", LString "def"]))
(EValue (Variable "0"))
)
, testCase "negated string set operation" $
parseExpression "![\"abc\", \"def\"].contains($0)" @?=
Right (EUnary Negate
(EBinary Contains
(EValue (TermSet $ Set.fromList [LString "abc", LString "def"]))
(EValue (Variable "0"))
))
, operatorPrecedences
]
operatorPrecedences :: TestTree
operatorPrecedences = testGroup "mixed-precedence operators"
[ testCase "< +" $
parseExpression " 1 < $test + 2 " @?=
Right (EBinary LessThan
(EValue $ LInteger 1)
(EBinary Add
(EValue $ Variable "test")
(EValue $ LInteger 2)
)
)
, testCase "< && starts_with" $
parseExpression " 2 < $test && $var2.starts_with(\"test\") && true " @?=
Right (EBinary And
(EBinary And
(EBinary LessThan
(EValue $ LInteger 2)
(EValue $ Variable "test")
)
(EBinary Prefix
(EValue $ Variable "var2")
(EValue $ LString "test")
)
)
(EValue $ LBool True)
)
, testCase "+ *" $
parseExpression "1 + 2 * 3" @?=
Right (EBinary Add
(EValue $ LInteger 1)
(EBinary Mul
(EValue $ LInteger 2)
(EValue $ LInteger 3)
)
)
, testCase "+ * parens" $
parseExpression "(1 + 2) * 3" @?=
Right (EBinary Mul
(EUnary Parens
(EBinary Add
(EValue $ LInteger 1)
(EValue $ LInteger 2)
)
)
(EValue $ LInteger 3)
)
]
checkParsing :: TestTree
checkParsing = testGroup "check blocks"
[ testCase "Simple check" $
parseCheck "check if true" @?=
Right [QueryItem [] [EValue $ LBool True] Nothing]
, testCase "Multiple groups" $
parseCheck
"check if fact($var), $var == true or \
\other($var), $var == 2" @?=
Right
[ QueryItem [Predicate "fact" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]
Nothing
, QueryItem [Predicate "other" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]
Nothing
]
]
policyParsing :: TestTree
policyParsing = testGroup "policy blocks"
[ testCase "Simple allow policy" $
parsePolicy "allow if true" @?=
Right (Allow, [QueryItem [] [EValue $ LBool True] Nothing])
, testCase "Simple deny policy" $
parsePolicy "deny if true" @?=
Right (Deny, [QueryItem [] [EValue $ LBool True] Nothing])
, testCase "Allow with multiple groups" $
parsePolicy
"allow if fact($var), $var == true or \
\other($var), $var == 2" @?=
Right
( Allow
, [ QueryItem [Predicate "fact" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]
Nothing
, QueryItem [Predicate "other" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]
Nothing
]
)
, testCase "Deny with multiple groups" $
parsePolicy
"deny if fact($var), $var == true or \
\other($var), $var == 2" @?=
Right
( Deny
, [ QueryItem [Predicate "fact" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]
Nothing
, QueryItem [Predicate "other" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]
Nothing
]
)
, testCase "Deny with multiple groups, multiline" $
parsePolicy
"deny if\n\
\fact($var), $var == true or\n\
\other($var), $var == 2" @?=
Right
( Deny
, [ QueryItem [Predicate "fact" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]
Nothing
, QueryItem [Predicate "other" [Variable "var"]]
[EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]
Nothing
]
)
]
authorizerParsing :: TestTree
authorizerParsing = testGroup "Simple authorizers"
[ testCase "Just a deny" $
parseAuthorizer "deny if true;" @?=
Right (Authorizer [(Deny, [QueryItem [] [EValue (LBool True)] Nothing])] mempty
)
, testCase "Allow and deny" $
parseAuthorizer "allow if operation(\"read\");\n deny if true;" @?=
Right (Authorizer
[ (Allow, [QueryItem [Predicate "operation" [LString "read"]] [] Nothing])
, (Deny, [QueryItem [] [EValue (LBool True)] Nothing])
]
mempty
)
, testCase "Complete authorizer" $ do
let spec :: Text
spec =
"// the owner has all rights\n\
\right($blog_id, $article_id, $operation) <-\n\
\ article($blog_id, $article_id),\n\
\ operation($operation),\n\
\ user($user_id),\n\
\ owner($user_id, $blog_id);\n\
\// premium users can access some restricted articles\n\
\right($blog_id, $article_id, \"read\") <-\n\
\ article($blog_id, $article_id),\n\
\ premium_readable($blog_id, $article_id),\n\
\ user($user_id),\n\
\ premium_user($user_id, $blog_id);\n\
\// define teams and roles\n\
\right($blog_id, $article_id, $operation) <-\n\
\ article($blog_id, $article_id),\n\
\ operation($operation),\n\
\ user($user_id),\n\
\ member($user_id, $team_id),\n\
\ team_role($team_id, $blog_id, \"contributor\"),\n\
\ [\"read\", \"write\"].contains($operation);\n\
\// unauthenticated users have read access on published articles\n\
\allow if\n\
\ operation(\"read\"),\n\
\ article($blog_id, $article_id),\n\
\ readable($blog_id, $article_id);\n\
\// authorize if got the rights on this blog and article\n\
\allow if\n\
\ blog($blog_id),\n\
\ article($blog_id, $article_id),\n\
\ operation($operation),\n\
\ right($blog_id, $article_id, $operation);\n\
\// catch all rule in case the allow did not match\n\
\deny if true;\
\ "
p = Predicate
sRead = LString "read"
sWrite = LString "write"
sContributor = LString "contributor"
vBlogId = Variable "blog_id"
vArticleId = Variable "article_id"
vUserId = Variable "user_id"
vTeamId = Variable "team_id"
vOp = Variable "operation"
bRules =
[ Rule (p "right" [vBlogId, vArticleId, vOp])
[ p "article" [vBlogId, vArticleId]
, p "operation" [vOp]
, p "user" [vUserId]
, p "owner" [vUserId, vBlogId]
] [] Nothing
, Rule (p "right" [vBlogId, vArticleId, sRead])
[ p "article" [vBlogId, vArticleId]
, p "premium_readable" [vBlogId, vArticleId]
, p "user" [vUserId]
, p "premium_user" [vUserId, vBlogId]
] [] Nothing
, Rule (p "right" [vBlogId, vArticleId, vOp])
[ p "article" [vBlogId, vArticleId]
, p "operation" [vOp]
, p "user" [vUserId]
, p "member" [vUserId, vTeamId]
, p "team_role" [vTeamId, vBlogId, sContributor]
] [EBinary Contains (EValue (TermSet $ Set.fromList [sRead, sWrite]))
(EValue vOp)] Nothing
]
bFacts = []
bChecks = []
bContext = Nothing
bScope = Nothing
vPolicies =
[ (Allow, [QueryItem [ p "operation" [sRead]
, p "article" [vBlogId, vArticleId]
, p "readable" [vBlogId, vArticleId]
] [] Nothing])
, (Allow, [QueryItem [ p "blog" [vBlogId]
, p "article" [vBlogId, vArticleId]
, p "operation" [vOp]
, p "right" [vBlogId, vArticleId, vOp]
] [] Nothing])
, (Deny, [QueryItem [] [EValue (LBool True)] Nothing])
]
parseAuthorizer spec @?= Right Authorizer{vBlock = Block{..}, ..}
]