From 1cc52a85c0185b0d19a37faf72c9b3339bf5ca49 Mon Sep 17 00:00:00 2001 From: Clement Delafargue Date: Wed, 3 Jul 2024 22:20:38 +0200 Subject: [PATCH 1/3] abort on evaluation error instead of silently ignoring errors, blow up the whole evaluation, as per the spec. --- biscuit/src/Auth/Biscuit/Datalog/Executor.hs | 81 ++++++++++--------- .../Auth/Biscuit/Datalog/ScopedExecutor.hs | 73 +++++++++-------- biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs | 8 +- biscuit/src/Auth/Biscuit/Token.hs | 6 +- biscuit/src/Auth/Biscuit/Utils.hs | 35 +++++++- biscuit/test/Spec/Executor.hs | 18 +++++ biscuit/test/Spec/SampleReader.hs | 38 +++++---- biscuit/test/Spec/ScopedExecutor.hs | 12 +-- 8 files changed, 161 insertions(+), 110 deletions(-) diff --git a/biscuit/src/Auth/Biscuit/Datalog/Executor.hs b/biscuit/src/Auth/Biscuit/Datalog/Executor.hs index 700acbb..102bdab 100644 --- a/biscuit/src/Auth/Biscuit/Datalog/Executor.hs +++ b/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,26 +230,24 @@ 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 @@ -255,13 +255,13 @@ getBindingsForRuleBody l facts body expressions = -- 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'') + diff --git a/biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs b/biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs index d8bec7f..b14777b 100644 --- a/biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs +++ b/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,6 +173,7 @@ 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)] @@ -179,13 +181,14 @@ runAuthorizerNoTimeout limits authority blocks authorizer = do 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. diff --git a/biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs b/biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs index 37ffd9f..e4fa1a0 100644 --- a/biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs +++ b/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 diff --git a/biscuit/src/Auth/Biscuit/Token.hs b/biscuit/src/Auth/Biscuit/Token.hs index 2651f3f..a3149d1 100644 --- a/biscuit/src/Auth/Biscuit/Token.hs +++ b/biscuit/src/Auth/Biscuit/Token.hs @@ -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 @@ -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' @@ -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 diff --git a/biscuit/src/Auth/Biscuit/Utils.hs b/biscuit/src/Auth/Biscuit/Utils.hs index a0b9bdc..ba7ac80 100644 --- a/biscuit/src/Auth/Biscuit/Utils.hs +++ b/biscuit/src/Auth/Biscuit/Utils.hs @@ -11,15 +11,25 @@ module Auth.Biscuit.Utils encodeHex, encodeHex', decodeHex, + anyM, + allM, + setFilterM, + foldMapM, + mapMaybeM, ) where #if MIN_VERSION_base16(1,0,0) -import qualified Data.Base16.Types as Hex +import qualified Data.Base16.Types as Hex #endif -import Data.ByteString (ByteString) +import Data.Bool (bool) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Hex -import Data.Text (Text) +import Data.Maybe (maybeToList) +import Data.Monoid (All (..), Any (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) encodeHex :: ByteString -> Text #if MIN_VERSION_base16(1,0,0) @@ -51,3 +61,22 @@ maybeToRight b = maybe (Left b) Right -- but without the dependency footprint rightToMaybe :: Either b a -> Maybe a rightToMaybe = either (const Nothing) Just + +anyM :: (Foldable t, Monad m) => (a -> m Bool) -> t a -> m Bool +anyM f = fmap getAny . foldMapM (fmap Any . f) + +allM :: (Foldable t, Monad m) => (a -> m Bool) -> t a -> m Bool +allM f = fmap getAll . foldMapM (fmap All . f) + +setFilterM :: (Ord a, Monad m) => (a -> m Bool) -> Set a -> m (Set a) +setFilterM p = foldMapM (\a -> bool mempty (Set.singleton a) <$> p a) + +-- from Relude +foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b +foldMapM f xs = foldr step return xs mempty + where + step x r z = f x >>= \y -> r $! z `mappend` y +{-# INLINE foldMapM #-} + +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = foldMapM (fmap maybeToList . f) diff --git a/biscuit/test/Spec/Executor.hs b/biscuit/test/Spec/Executor.hs index 47811b6..72caad6 100644 --- a/biscuit/test/Spec/Executor.hs +++ b/biscuit/test/Spec/Executor.hs @@ -30,6 +30,7 @@ specs = testGroup "Datalog evaluation" , rulesWithConstraints , ruleHeadWithNoVars , limits + , overflow ] authGroup :: Set Fact -> FactGroup @@ -296,3 +297,20 @@ scopedRules = testGroup "Rules and facts in different scopes" ]) ]) ] + +overflow :: TestTree +overflow = + let subtraction = authRulesGroup $ Set.singleton + [rule|test(true) <- -9223372036854775808 - 1 != 0|] + multiplication = authRulesGroup $ Set.singleton + [rule|test(true) <- 10000000000 * 10000000000 != 0|] + addition = authRulesGroup $ Set.singleton + [rule|test(true) <- 9223372036854775807 + 1 != 0|] + in testGroup "Arithmetic overflow" + [ testCase "subtraction" $ + runFactGeneration defaultLimits 1 subtraction mempty @?= Left (BadExpression "integer underflow") + , testCase "multiplication" $ + runFactGeneration defaultLimits 1 multiplication mempty @?= Left (BadExpression "integer overflow") + , testCase "addition" $ + runFactGeneration defaultLimits 1 addition mempty @?= Left (BadExpression "integer overflow") + ] diff --git a/biscuit/test/Spec/SampleReader.hs b/biscuit/test/Spec/SampleReader.hs index e253a17..133f3ef 100644 --- a/biscuit/test/Spec/SampleReader.hs +++ b/biscuit/test/Spec/SampleReader.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module Spec.SampleReader where import Control.Arrow ((&&&)) @@ -34,7 +34,7 @@ import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Traversable (for) import GHC.Generics (Generic) -import GHC.Records (HasField(getField)) +import GHC.Records (HasField (getField)) import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit @@ -158,7 +158,7 @@ data BlockDesc data FactSet = FactSet { origin :: [Maybe Integer] - , facts :: [Text] + , facts :: [Text] } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -166,7 +166,7 @@ data FactSet data RuleSet = RuleSet { origin :: Maybe Integer - , rules :: [Text] + , rules :: [Text] } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -226,9 +226,6 @@ processTestCase step rootPk TestCase{..} = if fst filename == "test018_unbound_variables_in_rule.bc" then step "Skipping for now (unbound variables are now caught before evaluation)" - else if fst filename == "test027_integer_wraparound.bc" - then - step "Skipping for now (evaluation fails silently)" else do step "Parsing " let vList = Map.toList validations @@ -279,6 +276,7 @@ compareExecErrors ee re = TooManyFacts -> mustMatch $ key "RunLimit" . key "TooManyFacts" TooManyIterations -> mustMatch $ key "RunLimit" . key "TooManyIterations" InvalidRule -> mustMatch $ key "FailedLogic" . key "InvalidBlockRule" + EvaluationError _ -> mustMatch $ key "Execution" ResultError (NoPoliciesMatched cs) -> mustMatch $ key "FailedLogic" . key "Unauthorized" ResultError (FailedChecks cs) -> mustMatch $ key "FailedLogic" . key "Unauthorized" ResultError (DenyRuleMatched cs q) -> mustMatch $ key "FailedLogic" . key "Unauthorized" diff --git a/biscuit/test/Spec/ScopedExecutor.hs b/biscuit/test/Spec/ScopedExecutor.hs index e589046..a50d101 100644 --- a/biscuit/test/Spec/ScopedExecutor.hs +++ b/biscuit/test/Spec/ScopedExecutor.hs @@ -269,7 +269,7 @@ authorizerFactsAreQueried = testGroup "AuthorizedBiscuit can be queried" expected = Set.singleton $ Map.fromList [ ("user", LInteger 1234) ] - getUser <$> result @?= Right expected + getUser <$> result @?= Right (Right expected) , testCase "Attenuation blocks can be accessed if asked nicely" $ do (p,s) <- (toPublic &&& id) <$> newSecret b <- mkBiscuit s [block|user(1234);|] @@ -280,7 +280,7 @@ authorizerFactsAreQueried = testGroup "AuthorizedBiscuit can be queried" [ Map.fromList [("user", LInteger 1234)] , Map.fromList [("user", LString "tampered value")] ] - getUser <$> result @?= Right expected + getUser <$> result @?= Right (Right expected) , testCase "Signed blocks can be accessed if asked nicely" $ do (p,s) <- (toPublic &&& id) <$> newSecret (p1,s1) <- (toPublic &&& id) <$> newSecret @@ -293,7 +293,7 @@ authorizerFactsAreQueried = testGroup "AuthorizedBiscuit can be queried" [ Map.fromList [("user", LInteger 1234)] , Map.fromList [("user", LString "from signed")] ] - getUser <$> result @?= Right expected + getUser <$> result @?= Right (Right expected) ] biscuitFactsAreQueried :: TestTree @@ -306,7 +306,7 @@ biscuitFactsAreQueried = testGroup "Biscuit can be queried" expected = Set.singleton $ Map.fromList [ ("user", LInteger 1234) ] - user @?= expected + user @?= Right expected , testCase "Attenuation blocks can be accessed if asked nicely" $ do (p,s) <- (toPublic &&& id) <$> newSecret b <- mkBiscuit s [block|user(1234);|] @@ -316,7 +316,7 @@ biscuitFactsAreQueried = testGroup "Biscuit can be queried" [ Map.fromList [("user", LInteger 1234)] , Map.fromList [("user", LString "tampered value")] ] - user @?= expected + user @?= Right expected , testCase "Signed blocks can be accessed if asked nicely" $ do (p,s) <- (toPublic &&& id) <$> newSecret (p1,s1) <- (toPublic &&& id) <$> newSecret @@ -328,5 +328,5 @@ biscuitFactsAreQueried = testGroup "Biscuit can be queried" [ Map.fromList [("user", LInteger 1234)] , Map.fromList [("user", LString "from signed")] ] - user @?= expected + user @?= Right expected ] From 2cde3b81dfefa05cef142e1159b97c771ef44d7d Mon Sep 17 00:00:00 2001 From: Clement Delafargue Date: Wed, 3 Jul 2024 23:14:37 +0200 Subject: [PATCH 2/3] ci: update haskell GH action --- .github/workflows/github-actions.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/github-actions.yml b/.github/workflows/github-actions.yml index 3df6407..a89703e 100644 --- a/.github/workflows/github-actions.yml +++ b/.github/workflows/github-actions.yml @@ -21,7 +21,7 @@ jobs: - 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: From 5d553cde3e078b4579ce94f9f9f8fdd498e14ad7 Mon Sep 17 00:00:00 2001 From: Clement Delafargue Date: Thu, 4 Jul 2024 00:19:56 +0200 Subject: [PATCH 3/3] ci: remove macos and ghc-9.0.2 from the build matrix biscuit-haskell is not supported on 9.0.2 anymore, and there is nothing specific about macos in biscuit-haskell itself. Since those two items tend to make the CI way slower and flakier, let's drop them. --- .github/workflows/github-actions.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/github-actions.yml b/.github/workflows/github-actions.yml index a89703e..b1f0b8b 100644 --- a/.github/workflows/github-actions.yml +++ b/.github/workflows/github-actions.yml @@ -13,9 +13,9 @@ 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