Skip to content

Commit

Permalink
wip: abort on evaluation error
Browse files Browse the repository at this point in the history
instead of silently ignoring errors, blow up the whole evaluation
  • Loading branch information
divarvel committed Jul 3, 2024
1 parent 7f2024d commit a2b54d3
Show file tree
Hide file tree
Showing 5 changed files with 117 additions and 82 deletions.
81 changes: 41 additions & 40 deletions biscuit/src/Auth/Biscuit/Datalog/Executor.hs
Original file line number Diff line number Diff line change
Expand Up @@ -60,7 +60,7 @@ import qualified Text.Regex.TDFA.Text as Regex
import Validation (Validation (..), failure)

import Auth.Biscuit.Datalog.AST
import Auth.Biscuit.Utils (maybeToRight)
import Auth.Biscuit.Utils (maybeToRight, anyM, allM, setFilterM)

-- | A variable name
type Name = Text
Expand Down Expand Up @@ -105,6 +105,8 @@ data ExecutionError
| ResultError ResultError
-- ^ The evaluation ran to completion, but checks and policies were not
-- fulfilled.
| EvaluationError String
-- ^ Datalog evaluation failed while evaluating an expression
deriving (Eq, Show)

-- | Settings for the executor runtime restrictions.
Expand Down Expand Up @@ -186,40 +188,40 @@ fromScopedFacts = FactGroup . Map.fromListWith (<>) . Set.toList . Set.map (fmap
countFacts :: FactGroup -> Int
countFacts (FactGroup facts) = sum $ Set.size <$> Map.elems facts

-- todo handle Check All
checkCheck :: Limits -> Natural -> Natural -> FactGroup -> EvalCheck -> Validation (NonEmpty Check) ()
checkCheck l blockCount checkBlockId facts c@Check{cQueries,cKind} =
checkCheck :: Limits -> Natural -> Natural -> FactGroup -> EvalCheck -> Either String (Validation (NonEmpty Check) ())
checkCheck l blockCount checkBlockId facts c@Check{cQueries,cKind} = do
let isQueryItemOk = case cKind of
One -> isQueryItemSatisfied l blockCount checkBlockId facts
All -> isQueryItemSatisfiedForAllMatches l blockCount checkBlockId facts
in if any (isJust . isQueryItemOk) cQueries
then Success ()
else failure (toRepresentation c)

checkPolicy :: Limits -> Natural -> FactGroup -> EvalPolicy -> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy l blockCount facts (pType, query) =
let bindings = fold $ mapMaybe (isQueryItemSatisfied l blockCount blockCount facts) query
in if not (null bindings)
then Just $ case pType of
Allow -> Right $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings}
Deny -> Left $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings}
else Nothing

isQueryItemSatisfied :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Maybe (Set Bindings)
isQueryItemSatisfied l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} =
hasOkQueryItem <- anyM (fmap isJust . isQueryItemOk) cQueries
pure $ if hasOkQueryItem
then Success ()
else failure (toRepresentation c)

checkPolicy :: Limits -> Natural -> FactGroup -> EvalPolicy -> Either String (Maybe (Either MatchedQuery MatchedQuery))
checkPolicy l blockCount facts (pType, query) = do
bindings <- fold . fold <$> traverse (isQueryItemSatisfied l blockCount blockCount facts) query
pure $ if not (null bindings)
then Just $ case pType of
Allow -> Right $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings}
Deny -> Left $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings}
else Nothing

isQueryItemSatisfied :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Either String (Maybe (Set Bindings))
isQueryItemSatisfied l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} = do
let removeScope = Set.map snd
facts = toScopedFacts $ keepAuthorized' False blockCount allFacts qScope blockId
bindings = removeScope $ getBindingsForRuleBody l facts qBody qExpressions
in if Set.size bindings > 0
then Just bindings
else Nothing
bindings <- removeScope <$> getBindingsForRuleBody l facts qBody qExpressions
pure $ if Set.size bindings > 0
then Just bindings
else Nothing

-- | Given a set of scoped facts and a rule body, we generate a set of variable
-- bindings that satisfy the rule clauses (predicates match, and expression constraints
-- are fulfilled), and ensure that all bindings where predicates match also fulfill
-- expression constraints. This is the behaviour of `check all`.
isQueryItemSatisfiedForAllMatches :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Maybe (Set Bindings)
isQueryItemSatisfiedForAllMatches l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} =
isQueryItemSatisfiedForAllMatches :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Either String (Maybe (Set Bindings))
isQueryItemSatisfiedForAllMatches l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} = do
let removeScope = Set.map snd
facts = toScopedFacts $ keepAuthorized' False blockCount allFacts qScope blockId
allVariables = extractVariables qBody
Expand All @@ -228,40 +230,38 @@ isQueryItemSatisfiedForAllMatches l blockCount blockId allFacts QueryItem{qBody,
-- bindings that unify correctly (each variable has a single possible match)
legalBindingsForFacts = reduceCandidateBindings allVariables candidateBindings
-- bindings that fulfill the constraints
constraintFulfillingBindings = Set.filter (\b -> all (satisfies l b) qExpressions) legalBindingsForFacts
in if Set.size constraintFulfillingBindings > 0 -- there is at least one match that fulfills the constraints
&& constraintFulfillingBindings == legalBindingsForFacts -- all matches fulfill the constraints
then Just $ removeScope constraintFulfillingBindings
else Nothing
constraintFulfillingBindings <- setFilterM (\b -> allM (satisfies l b) qExpressions) legalBindingsForFacts
pure $ if Set.size constraintFulfillingBindings > 0 -- there is at least one match that fulfills the constraints
&& constraintFulfillingBindings == legalBindingsForFacts -- all matches fulfill the constraints
then Just $ removeScope constraintFulfillingBindings
else Nothing

-- | Given a rule and a set of available (scoped) facts, we find all fact
-- combinations that match the rule body, and generate new facts by applying
-- the bindings to the rule head (while keeping track of the facts origins)
getFactsForRule :: Limits -> Set (Scoped Fact) -> EvalRule -> Set (Scoped Fact)
getFactsForRule l facts Rule{rhead, body, expressions} =
let legalBindings :: Set (Scoped Bindings)
legalBindings = getBindingsForRuleBody l facts body expressions
newFacts = mapMaybe (applyBindings rhead) $ Set.toList legalBindings
in Set.fromList newFacts
getFactsForRule :: Limits -> Set (Scoped Fact) -> EvalRule -> Either String (Set (Scoped Fact))
getFactsForRule l facts Rule{rhead, body, expressions} = do
legalBindings <- getBindingsForRuleBody l facts body expressions
pure $ Set.fromList $ mapMaybe (applyBindings rhead) $ Set.toList legalBindings

-- | Given a set of scoped facts and a rule body, we generate a set of variable
-- bindings that satisfy the rule clauses (predicates match, and expression constraints
-- are fulfilled)
getBindingsForRuleBody :: Limits -> Set (Scoped Fact) -> [Predicate] -> [Expression] -> Set (Scoped Bindings)
getBindingsForRuleBody :: Limits -> Set (Scoped Fact) -> [Predicate] -> [Expression] -> Either String (Set (Scoped Bindings))
getBindingsForRuleBody l facts body expressions =
let -- gather bindings from all the facts that match the query's predicates
candidateBindings = getCandidateBindings facts body
allVariables = extractVariables body
-- only keep bindings combinations where each variable has a single possible match
legalBindingsForFacts = reduceCandidateBindings allVariables candidateBindings
-- only keep bindings that satisfy the query expressions
in Set.filter (\b -> all (satisfies l b) expressions) legalBindingsForFacts
in setFilterM (\b -> allM (satisfies l b) expressions) legalBindingsForFacts

satisfies :: Limits
-> Scoped Bindings
-> Expression
-> Bool
satisfies l b e = evaluateExpression l (snd b) e == Right (LBool True)
-> Either String Bool
satisfies l b e = (== LBool True) <$> evaluateExpression l (snd b) e

applyBindings :: Predicate -> Scoped Bindings -> Maybe (Scoped Fact)
applyBindings p@Predicate{terms} (origins, bindings) =
Expand Down Expand Up @@ -475,3 +475,4 @@ evaluateExpression l b = \case
EValue term -> applyVariable b term
EUnary op e' -> evalUnary op =<< evaluateExpression l b e'
EBinary op e' e'' -> uncurry (evalBinary l op) =<< join bitraverse (evaluateExpression l b) (e', e'')

71 changes: 38 additions & 33 deletions biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs
Original file line number Diff line number Diff line change
Expand Up @@ -37,7 +37,6 @@ import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Map.Strict ((!?))
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
Expand All @@ -58,11 +57,13 @@ import Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..),
keepAuthorized', toScopedFacts)
import Auth.Biscuit.Datalog.Parser (fact)
import Auth.Biscuit.Timer (timer)
import Data.Bitraversable (bisequence)
import Auth.Biscuit.Utils (foldMapM, mapMaybeM)

type BlockWithRevocationId = (Block, ByteString, Maybe PublicKey)

-- | A subset of 'ExecutionError' that can only happen during fact generation
data PureExecError = Facts | Iterations | BadRule
data PureExecError = Facts | Iterations | BadRule | BadExpression String
deriving (Eq, Show)

-- | Proof that a biscuit was authorized successfully. In addition to the matched
Expand Down Expand Up @@ -172,20 +173,22 @@ runAuthorizerNoTimeout limits authority blocks authorizer = do
Facts -> TooManyFacts
Iterations -> TooManyIterations
BadRule -> InvalidRule
BadExpression e -> EvaluationError e
allFacts <- first toExecutionError $ computeAllFacts initState
let checks = bChecks <$$> ( zip [0..] (fst' <$> authority : blocks)
<> [(blockCount,vBlock authorizer)]
)
policies = vPolicies authorizer
checkResults = checkChecks limits blockCount allFacts (checkToEvaluation externalKeys <$$$> checks)
policyResults = checkPolicies limits blockCount allFacts (policyToEvaluation externalKeys <$> policies)
case (checkResults, policyResults) of
(Success (), Left Nothing) -> Left $ ResultError $ NoPoliciesMatched []
(Success (), Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p
(Failure cs, Left Nothing) -> Left $ ResultError $ NoPoliciesMatched (NE.toList cs)
(Failure cs, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched (NE.toList cs) p
(Failure cs, Right _) -> Left $ ResultError $ FailedChecks cs
(Success (), Right p) -> Right $ AuthorizationSuccess { matchedAllowQuery = p
case bisequence (checkResults, policyResults) of
Left e -> Left $ EvaluationError e
Right (Success (), Left Nothing) -> Left $ ResultError $ NoPoliciesMatched []
Right (Success (), Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p
Right (Failure cs, Left Nothing) -> Left $ ResultError $ NoPoliciesMatched (NE.toList cs)
Right (Failure cs, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched (NE.toList cs) p
Right (Failure cs, Right _) -> Left $ ResultError $ FailedChecks cs
Right (Success (), Right p) -> Right $ AuthorizationSuccess { matchedAllowQuery = p
, allFacts
, limits
}
Expand All @@ -195,8 +198,10 @@ runStep = do
state@ComputeState{sLimits,sFacts,sRules,sBlockCount,sIterations} <- get
let Limits{maxFacts, maxIterations} = sLimits
previousCount = countFacts sFacts
newFacts = sFacts <> extend sLimits sBlockCount sRules sFacts
newCount = countFacts newFacts
generatedFacts :: Either PureExecError FactGroup
generatedFacts = first BadExpression $ extend sLimits sBlockCount sRules sFacts
newFacts <- (sFacts <>) <$> lift generatedFacts
let newCount = countFacts newFacts
-- counting the facts returned by `extend` is not equivalent to
-- comparing complete counts, as `extend` may return facts that
-- are already present in `sFacts`
Expand All @@ -206,7 +211,7 @@ runStep = do
put $ state { sIterations = sIterations + 1
, sFacts = newFacts
}
return addedFactsCount
pure addedFactsCount

-- | Check if every variable from the head is present in the body
checkRuleHead :: EvalRule -> Bool
Expand Down Expand Up @@ -234,39 +239,39 @@ runFactGeneration sLimits sBlockCount sRules sFacts =
let initState = ComputeState{sIterations = 0, ..}
in computeAllFacts initState

checkChecks :: Limits -> Natural -> FactGroup -> [(Natural, [EvalCheck])] -> Validation (NonEmpty Check) ()
checkChecks :: Limits -> Natural -> FactGroup -> [(Natural, [EvalCheck])] -> Either String (Validation (NonEmpty Check) ())
checkChecks limits blockCount allFacts =
traverse_ (uncurry $ checkChecksForGroup limits blockCount allFacts)
fmap (traverse_ id) . traverse (uncurry $ checkChecksForGroup limits blockCount allFacts)

checkChecksForGroup :: Limits -> Natural -> FactGroup -> Natural -> [EvalCheck] -> Validation (NonEmpty Check) ()
checkChecksForGroup :: Limits -> Natural -> FactGroup -> Natural -> [EvalCheck] -> Either String (Validation (NonEmpty Check) ())
checkChecksForGroup limits blockCount allFacts checksBlockId =
traverse_ (checkCheck limits blockCount checksBlockId allFacts)
fmap (traverse_ id) . traverse (checkCheck limits blockCount checksBlockId allFacts)

checkPolicies :: Limits -> Natural -> FactGroup -> [EvalPolicy] -> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies limits blockCount allFacts policies =
let results = mapMaybe (checkPolicy limits blockCount allFacts) policies
in case results of
p : _ -> first Just p
[] -> Left Nothing
checkPolicies :: Limits -> Natural -> FactGroup -> [EvalPolicy] -> Either String (Either (Maybe MatchedQuery) MatchedQuery)
checkPolicies limits blockCount allFacts policies = do
results <- mapMaybeM (checkPolicy limits blockCount allFacts) policies
pure $ case results of
p : _ -> first Just p
[] -> Left Nothing

-- | Generate new facts by applying rules on existing facts
extend :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> FactGroup
extend :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> Either String FactGroup
extend l blockCount rules facts =
let buildFacts :: Natural -> Set EvalRule -> FactGroup -> Set (Scoped Fact)
let buildFacts :: Natural -> Set EvalRule -> FactGroup -> Either String (Set (Scoped Fact))
buildFacts ruleBlockId ruleGroup factGroup =
let extendRule :: EvalRule -> Set (Scoped Fact)
let extendRule :: EvalRule -> Either String (Set (Scoped Fact))
extendRule r@Rule{scope} = getFactsForRule l (toScopedFacts $ keepAuthorized' False blockCount factGroup scope ruleBlockId) r
in foldMap extendRule ruleGroup
in foldMapM extendRule ruleGroup

extendRuleGroup :: Natural -> Set EvalRule -> FactGroup
extendRuleGroup :: Natural -> Set EvalRule -> Either String FactGroup
extendRuleGroup ruleBlockId ruleGroup =
-- todo pre-filter facts based on the weakest rule scope to avoid passing too many facts
-- to buildFacts
let authorizedFacts = facts -- test $ keepAuthorized facts $ Set.fromList [0..ruleBlockId]
addRuleOrigin = FactGroup . Map.mapKeysWith (<>) (Set.insert ruleBlockId) . getFactGroup
in addRuleOrigin . fromScopedFacts $ buildFacts ruleBlockId ruleGroup authorizedFacts
in addRuleOrigin . fromScopedFacts <$> buildFacts ruleBlockId ruleGroup authorizedFacts

in foldMap (uncurry extendRuleGroup) $ Map.toList rules
in foldMapM (uncurry extendRuleGroup) $ Map.toList rules


collectWorld :: Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup)
Expand All @@ -278,18 +283,18 @@ collectWorld blockId Block{..} =
, FactGroup $ Map.singleton (Set.singleton blockId) $ Set.fromList bFacts
)

queryGeneratedFacts :: [Maybe PublicKey] -> AuthorizationSuccess -> Query -> Set Bindings
queryGeneratedFacts :: [Maybe PublicKey] -> AuthorizationSuccess -> Query -> Either String (Set Bindings)
queryGeneratedFacts ePks AuthorizationSuccess{allFacts, limits} =
queryAvailableFacts ePks allFacts limits

queryAvailableFacts :: [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Set Bindings
queryAvailableFacts :: [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Either String (Set Bindings)
queryAvailableFacts ePks allFacts limits q =
let blockCount = genericLength ePks
getBindingsForQueryItem QueryItem{qBody,qExpressions,qScope} =
let facts = toScopedFacts $ keepAuthorized' True blockCount allFacts qScope blockCount
in Set.map snd $
in Set.map snd <$>
getBindingsForRuleBody limits facts qBody qExpressions
in foldMap (getBindingsForQueryItem . toEvaluation ePks) q
in foldMapM (getBindingsForQueryItem . toEvaluation ePks) q

-- | Extract a set of values from a matched variable for a specific type.
-- Returning @Set Value@ allows to get all values, whatever their type.
Expand Down
6 changes: 3 additions & 3 deletions biscuit/src/Auth/Biscuit/Token.hs
Original file line number Diff line number Diff line change
Expand Up @@ -215,7 +215,7 @@ data Biscuit proof check
-- with a @trusting@ annotation. Be careful with @trusting previous@, as it queries
-- facts from all blocks, even untrusted ones.
queryRawBiscuitFactsWithLimits :: Biscuit openOrSealed check -> Limits -> Query
-> Set Bindings
-> Either String (Set Bindings)
queryRawBiscuitFactsWithLimits b@Biscuit{authority,blocks} =
let ePks = externalKeys b
getBlock ((_, block), _, _, _) = block
Expand All @@ -235,7 +235,7 @@ queryRawBiscuitFactsWithLimits b@Biscuit{authority,blocks} =
-- 💁 If the facts you want to query are part of an allow query in the authorizer,
-- you can directly get values by calling 'getBindings' on 'AuthorizationSuccess'.
queryRawBiscuitFacts :: Biscuit openOrSealed check -> Query
-> Set Bindings
-> Either String (Set Bindings)
queryRawBiscuitFacts b = queryRawBiscuitFactsWithLimits b defaultLimits

-- | Turn a 'Biscuit' statically known to be 'Open' into a more generic 'OpenOrSealed' 'Biscuit'
Expand Down Expand Up @@ -621,7 +621,7 @@ data AuthorizedBiscuit p
-- 💁 If you are trying to extract facts from a biscuit in order to generate an
-- authorizer, have a look at 'queryRawBiscuitFacts' instead.
queryAuthorizerFacts :: AuthorizedBiscuit p -> Query
-> Set Bindings
-> Either String (Set Bindings)
queryAuthorizerFacts AuthorizedBiscuit{authorizedBiscuit, authorizationSuccess} =
let ePks = externalKeys authorizedBiscuit
in queryGeneratedFacts ePks authorizationSuccess
Loading

0 comments on commit a2b54d3

Please sign in to comment.