Merge pull request #91 from biscuit-auth/update-samples

abort on evaluation error

.github/workflows/github-actions.yml

@@ -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:

biscuit/src/Auth/Biscuit/Datalog/Executor.hs

@@ -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
@@ -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.
@@ -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
@@ -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) =
@@ -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'')
+

biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs

@@ -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)
@@ -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
@@ -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
                                                                 }
@@ -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`
@@ -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
@@ -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)
@@ -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.

biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs

@@ -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 {..}
@@ -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