Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

abort on evaluation error #91

Merged
merged 3 commits into from
Jul 4, 2024
Merged

abort on evaluation error #91

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
1cc52a8
abort on evaluation error
divarvel Jul 3, 2024
2cde3b8
ci: update haskell GH action
divarvel Jul 3, 2024
5d553cd
ci: remove macos and ghc-9.0.2 from the build matrix
divarvel Jul 3, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 3 additions & 3 deletions .github/workflows/github-actions.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,15 +13,15 @@ jobs:
runs-on: ${{ matrix.os }}
strategy:
matrix:
os: [ubuntu-latest, macos-latest]
os: [ubuntu-latest]
cabal: ["3.10.3.0"]
ghc: ["9.0.2", "9.2.4", "9.4.8", "9.6.5", "9.8.2"]
ghc: ["9.2.4", "9.4.8", "9.6.5", "9.8.2"]

steps:
- uses: actions/checkout@v3
if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main'

- uses: haskell/actions/setup@v2
- uses: haskell-actions/setup@v2
id: setup-haskell-cabal
name: Setup Haskell
with:
Expand Down
81 changes: 41 additions & 40 deletions biscuit/src/Auth/Biscuit/Datalog/Executor.hs
View file
Open in desktop
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 (allM, anyM, maybeToRight, 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'')

73 changes: 39 additions & 34 deletions biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -30,14 +30,13 @@ import Control.Monad.State (StateT (..), evalStateT, get,
gets, lift, put)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.Foldable (traverse_)
import Data.Foldable (sequenceA_)
import Data.List (genericLength)
import Data.List.NonEmpty (NonEmpty)
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 Auth.Biscuit.Utils (foldMapM, mapMaybeM)
import Data.Bitraversable (bisequence)

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 sequenceA_ . 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 sequenceA_ . 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
8 changes: 4 additions & 4 deletions biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -132,10 +132,10 @@ pbToBlock ePk PB.Block{..} = do
let isV3 = isNothing ePk
&& Set.null bScope
&& all ruleHasNoScope bRules
&& all queryHasNoScope (cQueries <$> bChecks)
&& all (queryHasNoScope . cQueries) bChecks
&& all isCheckOne bChecks
&& all ruleHasNoV4Operators bRules
&& all queryHasNoV4Operators (cQueries <$> bChecks)
&& all (queryHasNoV4Operators . cQueries) bChecks
case (bVersion, isV3) of
(Just 4, _) -> pure Block {..}
(Just 3, True) -> pure Block {..}
Expand All @@ -151,10 +151,10 @@ blockToPb hasExternalPk existingSymbols b@Block{..} =
let isV3 = not hasExternalPk
&& Set.null bScope
&& all ruleHasNoScope bRules
&& all queryHasNoScope (cQueries <$> bChecks)
&& all (queryHasNoScope . cQueries) bChecks
&& all isCheckOne bChecks
&& all ruleHasNoV4Operators bRules
&& all queryHasNoV4Operators (cQueries <$> bChecks)
&& all (queryHasNoV4Operators . cQueries) bChecks
bSymbols = buildSymbolTable existingSymbols b
s = reverseSymbols $ addFromBlock existingSymbols bSymbols
symbols = PB.putField $ getSymbolList bSymbols
Expand Down
Loading
Loading