diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # biscuit-haskell [![CI-badge][CI-badge]][CI-url] [![Hackage][hackage]][hackage-url] - + Main library for biscuit tokens support, providing minting and signature verification of biscuit tokens, as well as a datalog engine allowing to compute the validity of a token in a given context. @@ -105,5 +105,5 @@ [biscuittutorial]: https://www.clever-cloud.com/blog/engineering/2021/04/15/biscuit-tutorial/ [v2spec]: https://github.com/CleverCloud/biscuit/blob/2.0/SPECIFICATIONS.md [quasiquotes]: https://wiki.haskell.org/Quasiquotation -[biscuitexample]: https://github.com/divarvel/biscuit-haskell/blob/main/biscuit/src/Auth/Biscuit/Example.hs +[biscuitexample]: https://github.com/biscuit-auth/biscuit-haskell/blob/main/biscuit/src/Auth/Biscuit/Example.hs [packagedoc]: https://hackage.haskell.org/package/biscuit-haskell-0.1.0.0/docs/Auth-Biscuit.html diff --git a/biscuit-haskell.cabal b/biscuit-haskell.cabal --- a/biscuit-haskell.cabal +++ b/biscuit-haskell.cabal @@ -1,12 +1,12 @@ cabal-version: 2.0 name: biscuit-haskell -version: 0.2.0.1 +version: 0.2.1.0 category: Security synopsis: Library support for the Biscuit security token -description: Please see the README on GitHub at -homepage: https://github.com/divarvel/biscuit-haskell#readme -bug-reports: https://github.com/divarvel/biscuit-haskell/issues +description: Please see the README on GitHub at +homepage: https://github.com/biscuit-auth/biscuit-haskell#readme +bug-reports: https://github.com/biscuit-auth/biscuit-haskell/issues author: Clément Delafargue maintainer: clement@delafargue.name copyright: 2021 Clément Delafargue @@ -19,11 +19,12 @@ source-repository head type: git - location: https://github.com/divarvel/biscuit-haskell + location: https://github.com/biscuit-auth/biscuit-haskell library exposed-modules: Auth.Biscuit + Auth.Biscuit.Symbols Auth.Biscuit.Utils Auth.Biscuit.Crypto Auth.Biscuit.Datalog.AST @@ -50,13 +51,13 @@ text ^>= 1.2, containers ^>= 0.6, cryptonite >= 0.27 && < 0.30, - memory ^>= 0.15, - template-haskell ^>= 2.16, - attoparsec ^>= 0.13, + memory >= 0.15 && < 0.17, + template-haskell >= 2.16 && < 2.18, + attoparsec >= 0.13 && < 0.15, base64 ^>= 0.4, cereal ^>= 0.5, mtl ^>= 2.2, - parser-combinators ^>= 1.2, + parser-combinators >= 1.2 && < 1.4, protobuf ^>= 0.2, random >= 1.0 && < 1.3, regex-tdfa ^>= 1.3, @@ -73,7 +74,6 @@ Spec.Executor Spec.Parser Spec.Quasiquoter - Spec.RevocationIds Spec.Roundtrip Spec.SampleReader Spec.ScopedExecutor @@ -94,6 +94,8 @@ , cereal , containers , cryptonite + , lens + , lens-aeson , mtl , parser-combinators , protobuf diff --git a/src/Auth/Biscuit.hs b/src/Auth/Biscuit.hs --- a/src/Auth/Biscuit.hs +++ b/src/Auth/Biscuit.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {-| Module : Auth.Biscuit Copyright : © Clément Delafargue, 2021 @@ -33,6 +32,7 @@ -- * Creating a biscuit -- $biscuitBlocks , mkBiscuit + , mkBiscuitWith , block , blockContext , Biscuit @@ -137,7 +137,7 @@ fromOpen, fromSealed, getRevocationIds, getVerifiedBiscuitPublicKey, - mkBiscuit, + mkBiscuit, mkBiscuitWith, parseBiscuitUnverified, parseBiscuitWith, seal, serializeBiscuit) diff --git a/src/Auth/Biscuit/Crypto.hs b/src/Auth/Biscuit/Crypto.hs --- a/src/Auth/Biscuit/Crypto.hs +++ b/src/Auth/Biscuit/Crypto.hs @@ -88,7 +88,7 @@ toSigs = getToSig <$> blocks -- key for block 0 is the root key -- key for block n is the key from block (n - 1) - keys = rootPk :| NE.init (getPublicKey <$> blocks) + keys = pure rootPk <> (getPublicKey <$> blocks) keysPayloadsSigs = NE.zipWith attachKey keys (NE.zip toSigs sigs) in all (uncurry3 verify) keysPayloadsSigs diff --git a/src/Auth/Biscuit/Datalog/AST.hs b/src/Auth/Biscuit/Datalog/AST.hs --- a/src/Auth/Biscuit/Datalog/AST.hs +++ b/src/Auth/Biscuit/Datalog/AST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingStrategies #-} @@ -50,6 +51,7 @@ , QueryItem' (..) , Rule , Rule' (..) + , RuleScope (..) , SetType , Slice (..) , SliceType @@ -85,6 +87,7 @@ import Instances.TH.Lift () import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Numeric.Natural (Natural) data IsWithinSet = NotWithinSet | WithinSet data ParsedAs = RegularString | QuasiQuote @@ -99,7 +102,11 @@ instance Lift Slice where lift (Slice name) = [| toTerm $(varE $ mkName name) |] +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = liftCode . unsafeTExpCoerce . lift +#else liftTyped = unsafeTExpCoerce . lift +#endif type family SliceType (ctx :: ParsedAs) where SliceType 'RegularString = Void @@ -168,7 +175,11 @@ lift (LDate t) = [| LDate (read $(lift $ show t)) |] lift (Antiquote s) = [| s |] +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = liftCode . unsafeTExpCoerce . lift +#else liftTyped = unsafeTExpCoerce . lift +#endif -- | This class describes how to turn a haskell value into a datalog value. -- | This is used when slicing a haskell variable in a datalog expression @@ -326,6 +337,7 @@ data QueryItem' ctx = QueryItem { qBody :: [Predicate' 'InPredicate ctx] , qExpressions :: [Expression' ctx] + , qScope :: Maybe RuleScope } type Query' ctx = [QueryItem' ctx] @@ -374,10 +386,18 @@ listSymbolsInCheck = foldMap listSymbolsInQueryItem +data RuleScope = + OnlyAuthority + | Previous + | UnsafeAny + | OnlyBlocks (Set Natural) + deriving (Eq, Ord, Show, Lift) + data Rule' ctx = Rule { rhead :: Predicate' 'InPredicate ctx , body :: [Predicate' 'InPredicate ctx] , expressions :: [Expression' ctx] + , scope :: Maybe RuleScope } deriving instance ( Eq (Predicate' 'InPredicate ctx) @@ -525,6 +545,7 @@ , bFacts :: [Predicate' 'InFact ctx] , bChecks :: [Check' ctx] , bContext :: Maybe Text + , bScope :: Maybe RuleScope } renderBlock :: Block -> Text @@ -557,6 +578,7 @@ , bFacts = bFacts b1 <> bFacts b2 , bChecks = bChecks b1 <> bChecks b2 , bContext = bContext b2 <|> bContext b1 + , bScope = bScope b1 <|> bScope b2 } instance Monoid (Block' ctx) where @@ -564,6 +586,7 @@ , bFacts = [] , bChecks = [] , bContext = Nothing + , bScope = Nothing } listSymbolsInBlock :: Block' 'RegularString -> Set.Set Text @@ -621,9 +644,9 @@ elementToBlock :: BlockElement' ctx -> Block' ctx elementToBlock = \case - BlockRule r -> Block [r] [] [] Nothing - BlockFact f -> Block [] [f] [] Nothing - BlockCheck c -> Block [] [] [c] Nothing + BlockRule r -> Block [r] [] [] Nothing Nothing + BlockFact f -> Block [] [f] [] Nothing Nothing + BlockCheck c -> Block [] [] [c] Nothing Nothing BlockComment -> mempty data AuthorizerElement' ctx diff --git a/src/Auth/Biscuit/Datalog/Executor.hs b/src/Auth/Biscuit/Datalog/Executor.hs --- a/src/Auth/Biscuit/Datalog/Executor.hs +++ b/src/Auth/Biscuit/Datalog/Executor.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-| Module : Auth.Biscuit.Datalog.Executor Copyright : © Clément Delafargue, 2021 @@ -17,30 +20,40 @@ , Bindings , Name , MatchedQuery (..) + , Scoped + , FactGroup (..) + , countFacts + , toScopedFacts + , fromScopedFacts + , keepAuthorized' , defaultLimits , evaluateExpression + , extractVariables -- , getFactsForRule , checkCheck , checkPolicy , getBindingsForRuleBody + , getCombinations ) where import Control.Monad (join, mfilter, zipWithM) import Data.Bitraversable (bitraverse) import qualified Data.ByteString as ByteString import Data.Foldable (fold) +import Data.Functor.Compose (Compose (..)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map, (!?)) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text, isInfixOf, unpack) import qualified Data.Text as Text import Data.Void (absurd) +import Numeric.Natural (Natural) import qualified Text.Regex.TDFA as Regex import qualified Text.Regex.TDFA.Text as Regex import Validation (Validation (..), failure) @@ -85,8 +98,9 @@ -- ^ Too many facts were generated during evaluation | TooManyIterations -- ^ Evaluation did not converge in the alloted number of iterations - | FactsInBlocks - -- ^ Some blocks contained either rules or facts while it was forbidden + | InvalidRule + -- ^ Some rules were malformed: every variable present in their head must + -- appear in their body | ResultError ResultError -- ^ The evaluation ran to completion, but checks and policies were not -- fulfilled. @@ -96,17 +110,15 @@ -- See `defaultLimits` for default values. data Limits = Limits - { maxFacts :: Int + { maxFacts :: Int -- ^ maximum number of facts that can be produced before throwing `TooManyFacts` - , maxIterations :: Int + , maxIterations :: Int -- ^ maximum number of iterations before throwing `TooManyIterations` - , maxTime :: Int + , maxTime :: Int -- ^ maximum duration the verification can take (in μs) - , allowRegexes :: Bool + , allowRegexes :: Bool -- ^ whether or not allowing `.matches()` during verification (untrusted regex computation -- can enable DoS attacks). This security risk is mitigated by the 'maxTime' setting. - , allowBlockFacts :: Bool - -- ^ whether or not accept facts and rules in blocks } deriving (Eq, Show) @@ -122,49 +134,103 @@ , maxIterations = 100 , maxTime = 1000 , allowRegexes = True - , allowBlockFacts = True } -checkCheck :: Limits -> Set Fact -> Check -> Validation (NonEmpty Check) () -checkCheck l facts items = - if any (isJust . isQueryItemSatisfied l facts) items +type Scoped a = (Set Natural, a) + +newtype FactGroup = FactGroup { getFactGroup :: Map (Set Natural) (Set Fact) } + deriving newtype (Eq) + +instance Show FactGroup where + show (FactGroup groups) = + let showGroup (origin, facts) = unlines + [ "For origin: " <> show (Set.toList origin) + , "Facts: \n" <> unlines (unpack . renderFact <$> Set.toList facts) + ] + in unlines $ showGroup <$> Map.toList groups + +instance Semigroup FactGroup where + FactGroup f1 <> FactGroup f2 = FactGroup $ Map.unionWith (<>) f1 f2 +instance Monoid FactGroup where + mempty = FactGroup mempty + +keepAuthorized :: FactGroup -> Set Natural -> FactGroup +keepAuthorized (FactGroup facts) authorizedOrigins = + let isAuthorized k _ = k `Set.isSubsetOf` authorizedOrigins + in FactGroup $ Map.filterWithKey isAuthorized facts + +keepAuthorized' :: FactGroup -> Maybe RuleScope -> Natural -> FactGroup +keepAuthorized' factGroup mScope currentBlockId = + let scope = fromMaybe OnlyAuthority mScope + in case scope of + OnlyAuthority -> keepAuthorized factGroup (Set.fromList [0, currentBlockId]) + Previous -> keepAuthorized factGroup (Set.fromList [0..currentBlockId]) + UnsafeAny -> factGroup + OnlyBlocks ids -> keepAuthorized factGroup (Set.insert currentBlockId ids) + +toScopedFacts :: FactGroup -> Set (Scoped Fact) +toScopedFacts (FactGroup factGroups) = + let distributeScope scope facts = Set.map (scope,) facts + in foldMap (uncurry distributeScope) $ Map.toList factGroups + +fromScopedFacts :: Set (Scoped Fact) -> FactGroup +fromScopedFacts = FactGroup . Map.fromListWith (<>) . Set.toList . Set.map (fmap Set.singleton) + +countFacts :: FactGroup -> Int +countFacts (FactGroup facts) = sum $ Set.size <$> Map.elems facts + +checkCheck :: Limits -> Natural -> FactGroup -> Check -> Validation (NonEmpty Check) () +checkCheck l checkBlockId facts items = + if any (isJust . isQueryItemSatisfied l checkBlockId facts) items then Success () else failure items -checkPolicy :: Limits -> Set Fact -> Policy -> Maybe (Either MatchedQuery MatchedQuery) +checkPolicy :: Limits -> FactGroup -> Policy -> Maybe (Either MatchedQuery MatchedQuery) checkPolicy l facts (pType, query) = - let bindings = fold $ mapMaybe (isQueryItemSatisfied l facts) query + let bindings = fold $ mapMaybe (isQueryItemSatisfied l 0 facts) query in if not (null bindings) then Just $ case pType of Allow -> Right $ MatchedQuery{matchedQuery = query, bindings} Deny -> Left $ MatchedQuery{matchedQuery = query, bindings} else Nothing -isQueryItemSatisfied :: Limits -> Set Fact -> QueryItem' 'RegularString -> Maybe (Set Bindings) -isQueryItemSatisfied l facts QueryItem{qBody, qExpressions} = - let bindings = getBindingsForRuleBody l facts qBody qExpressions +isQueryItemSatisfied :: Limits -> Natural -> FactGroup -> QueryItem' 'RegularString -> Maybe (Set Bindings) +isQueryItemSatisfied l blockId allFacts QueryItem{qBody, qExpressions, qScope} = + let removeScope = Set.map snd + facts = toScopedFacts $ keepAuthorized' allFacts qScope blockId + bindings = removeScope $ getBindingsForRuleBody l facts qBody qExpressions in if Set.size bindings > 0 then Just bindings else Nothing -getFactsForRule :: Limits -> Set Fact -> Rule -> Set Fact +-- | 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) -> Rule -> Set (Scoped Fact) getFactsForRule l facts Rule{rhead, body, expressions} = - let legalBindings = getBindingsForRuleBody l facts body expressions + let legalBindings :: Set (Scoped Bindings) + legalBindings = getBindingsForRuleBody l facts body expressions newFacts = mapMaybe (applyBindings rhead) $ Set.toList legalBindings in Set.fromList newFacts -getBindingsForRuleBody :: Limits -> Set Fact -> [Predicate] -> [Expression] -> Set Bindings +-- | 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 l facts body expressions = - let candidateBindings = getCandidateBindings facts body + 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 satisfies :: Limits - -> Bindings + -> Scoped Bindings -> Expression -> Bool -satisfies l b e = evaluateExpression l b e == Right (LBool True) +satisfies l b e = evaluateExpression l (snd b) e == Right (LBool True) extractVariables :: [Predicate] -> Set Name extractVariables predicates = @@ -175,8 +241,8 @@ in Set.fromList $ extractVariables' =<< predicates -applyBindings :: Predicate -> Bindings -> Maybe Fact -applyBindings p@Predicate{terms} bindings = +applyBindings :: Predicate -> Scoped Bindings -> Maybe (Scoped Fact) +applyBindings p@Predicate{terms} (origins, bindings) = let newTerms = traverse replaceTerm terms replaceTerm :: Term -> Maybe Value replaceTerm (Variable n) = Map.lookup n bindings @@ -187,38 +253,49 @@ replaceTerm (LBool t) = Just $ LBool t replaceTerm (TermSet t) = Just $ TermSet t replaceTerm (Antiquote t) = absurd t - in (\nt -> p { terms = nt}) <$> newTerms + in (\nt -> (origins, p { terms = nt})) <$> newTerms -getCombinations :: [[a]] -> [[a]] -getCombinations (x:xs) = do - y <- x - (y:) <$> getCombinations xs -getCombinations [] = [[]] +-- | Given a list of possible matches for each predicate, +-- give all the combinations of one match per predicate, +-- keeping track of the origin of each match +getCombinations :: [[Scoped Bindings]] -> [Scoped [Bindings]] +getCombinations = getCompose . traverse Compose +-- | merge a list of bindings, only keeping variables where +-- bindings are consistent mergeBindings :: [Bindings] -> Bindings mergeBindings = -- group all the values unified with each variable - let combinations = Map.unionsWith (<>) . fmap (fmap pure) + let combinations :: [Bindings] -> Map Name (NonEmpty Value) + combinations = Map.unionsWith (<>) . fmap (fmap pure) sameValues = fmap NE.head . mfilter ((== 1) . length) . Just . NE.nub - -- only keep + -- only keep consistent matches, where each variable takes a single value keepConsistent = Map.mapMaybe sameValues in keepConsistent . combinations +-- | given a set of bindings for each predicate of a query, +-- only keep combinations where every variable matches exactly +-- one value. This rejects both inconsitent bindings (where the +-- same variable reduceCandidateBindings :: Set Name - -> [Set Bindings] - -> Set Bindings + -> [Set (Scoped Bindings)] + -> Set (Scoped Bindings) reduceCandidateBindings allVariables matches = - let allCombinations :: [[Bindings]] + let allCombinations :: [(Set Natural, [Bindings])] allCombinations = getCombinations $ Set.toList <$> matches - isComplete :: Bindings -> Bool - isComplete = (== allVariables) . Set.fromList . Map.keys - in Set.fromList $ filter isComplete $ mergeBindings <$> allCombinations + isComplete :: Scoped Bindings -> Bool + isComplete = (== allVariables) . Set.fromList . Map.keys . snd + in Set.fromList $ filter isComplete $ fmap mergeBindings <$> allCombinations -getCandidateBindings :: Set Fact +-- | Given a set of facts and a series of predicates, return, for each fact, +-- a set of bindings corresponding to matched facts +getCandidateBindings :: Set (Scoped Fact) -> [Predicate] - -> [Set Bindings] + -> [Set (Scoped Bindings)] getCandidateBindings facts predicates = - let mapMaybeS f = foldMap (foldMap Set.singleton . f) + let mapMaybeS :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b + mapMaybeS f = foldMap (foldMap Set.singleton . f) + keepFacts :: Predicate -> Set (Scoped Bindings) keepFacts p = mapMaybeS (factMatchesPredicate p) facts in keepFacts <$> predicates @@ -231,18 +308,29 @@ isSame (TermSet t) (TermSet t') = t == t' isSame _ _ = False -factMatchesPredicate :: Predicate -> Fact -> Maybe Bindings +-- | Given a predicate and a fact, try to match the fact to the predicate, +-- and, in case of success, return the corresponding bindings +factMatchesPredicate :: Predicate -> Scoped Fact -> Maybe (Scoped Bindings) factMatchesPredicate Predicate{name = predicateName, terms = predicateTerms } - Predicate{name = factName, terms = factTerms } = + ( factOrigins + , Predicate{name = factName, terms = factTerms } + ) = let namesMatch = predicateName == factName lengthsMatch = length predicateTerms == length factTerms - allMatches = zipWithM yolo predicateTerms factTerms - yolo :: Term -> Value -> Maybe Bindings - yolo (Variable vname) value = Just (Map.singleton vname value) - yolo t t' | isSame t t' = Just mempty + allMatches = zipWithM compatibleMatch predicateTerms factTerms + -- given a term and a value, generate (possibly empty) bindings if + -- they can be unified: + -- - if the term is a variable, then it can be unified with the value, + -- generating a new binding pair + -- - if the term is equal to the value then it can be unified, but no bindings + -- are generated + -- - if the term is a different value, then they can't be unified + compatibleMatch :: Term -> Value -> Maybe Bindings + compatibleMatch (Variable vname) value = Just (Map.singleton vname value) + compatibleMatch t t' | isSame t t' = Just mempty | otherwise = Nothing in if namesMatch && lengthsMatch - then mergeBindings <$> allMatches + then (factOrigins,) . mergeBindings <$> allMatches else Nothing applyVariable :: Bindings @@ -298,7 +386,8 @@ evalBinary _ Regex _ _ = Left "Only strings support `.matches()`" -- num operations evalBinary _ Add (LInteger i) (LInteger i') = pure $ LInteger (i + i') -evalBinary _ Add _ _ = Left "Only integers support addition" +evalBinary _ Add (LString t) (LString t') = pure $ LString (t <> t') +evalBinary _ Add _ _ = Left "Only integers and strings support addition" evalBinary _ Sub (LInteger i) (LInteger i') = pure $ LInteger (i - i') evalBinary _ Sub _ _ = Left "Only integers support subtraction" evalBinary _ Mul (LInteger i) (LInteger i') = pure $ LInteger (i * i') @@ -316,7 +405,8 @@ evalBinary _ Contains (TermSet t) t' = case toSetTerm t' of Just t'' -> pure $ LBool (Set.member t'' t) Nothing -> Left "Sets cannot contain nested sets nor variables" -evalBinary _ Contains _ _ = Left "Only sets support `.contains()`" +evalBinary _ Contains (LString t) (LString t') = pure $ LBool (t' `isInfixOf` t) +evalBinary _ Contains _ _ = Left "Only sets and strings support `.contains()`" evalBinary _ Intersection (TermSet t) (TermSet t') = pure $ TermSet (Set.intersection t t') evalBinary _ Intersection _ _ = Left "Only sets support `.intersection()`" evalBinary _ Union (TermSet t) (TermSet t') = pure $ TermSet (Set.union t t') diff --git a/src/Auth/Biscuit/Datalog/Parser.hs b/src/Auth/Biscuit/Datalog/Parser.hs --- a/src/Auth/Biscuit/Datalog/Parser.hs +++ b/src/Auth/Biscuit/Datalog/Parser.hs @@ -213,7 +213,7 @@ hexBsParser :: Parser ByteString hexBsParser = do void $ string "hex:" - either fail pure =<< Hex.decode . encodeUtf8 <$> takeWhile1 (inClass "0-9a-fA-F") + either fail pure . Hex.decode . encodeUtf8 =<< takeWhile1 (inClass "0-9a-fA-F") litStringParser :: Parser Text litStringParser = @@ -284,11 +284,12 @@ skipSpace void $ string "<-" (body, expressions) <- ruleBodyParser - pure Rule{rhead, body, expressions} + pure Rule{rhead, body, expressions, scope = Nothing} -- todo parse scope queryParser :: HasParsers 'InPredicate ctx => Parser (Query' ctx) queryParser = - fmap (uncurry QueryItem) <$> sepBy1 ruleBodyParser (skipSpace *> asciiCI "or" <* satisfy isSpace) + let mkQueryItem (qBody, qExpressions) = QueryItem { qBody, qExpressions, qScope = Nothing } -- todo parse scope + in fmap mkQueryItem <$> sepBy1 ruleBodyParser (skipSpace *> asciiCI "or" <* satisfy isSpace) checkParser :: HasParsers 'InPredicate ctx => Parser (Check' ctx) checkParser = string "check if" *> queryParser diff --git a/src/Auth/Biscuit/Datalog/ScopedExecutor.hs b/src/Auth/Biscuit/Datalog/ScopedExecutor.hs --- a/src/Auth/Biscuit/Datalog/ScopedExecutor.hs +++ b/src/Auth/Biscuit/Datalog/ScopedExecutor.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Auth.Biscuit.Datalog.ScopedExecutor ( BlockWithRevocationId , runAuthorizer , runAuthorizerWithLimits , runAuthorizerNoTimeout - , World (..) - , computeAllFacts , runFactGeneration , PureExecError (..) , AuthorizationSuccess (..) @@ -16,95 +19,49 @@ , queryAuthorizerFacts , getVariableValues , getSingleVariableValue + , FactGroup (..) ) where -import Control.Monad (join, when) -import Control.Monad.State (StateT (..), get, lift, modify, - put, runStateT) +import Control.Applicative ((<|>)) +import Control.Monad (unless, when) +import Control.Monad.State (StateT (..), evalStateT, get, + gets, lift, put) import Data.Bifunctor (first) import Data.ByteString (ByteString) -import Data.Foldable (traverse_) -import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Foldable (fold, traverse_) +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, intercalate, unpack) -import Validation (Validation (..), validation) +import Data.Text (Text) +import Numeric.Natural (Natural) +import Validation (Validation (..)) import Auth.Biscuit.Datalog.AST import Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..), - Limits (..), MatchedQuery (..), - ResultError (..), checkCheck, - checkPolicy, defaultLimits, + FactGroup (..), Limits (..), + MatchedQuery (..), + ResultError (..), Scoped, + checkCheck, checkPolicy, + countFacts, defaultLimits, + extractVariables, + fromScopedFacts, getBindingsForRuleBody, - getFactsForRule) + getFactsForRule, + keepAuthorized', toScopedFacts) import Auth.Biscuit.Datalog.Parser (fact) import Auth.Biscuit.Timer (timer) type BlockWithRevocationId = (Block, ByteString) -- | A subset of 'ExecutionError' that can only happen during fact generation -data PureExecError = Facts | Iterations +data PureExecError = Facts | Iterations | BadRule deriving (Eq, Show) --- | State maintained by the datalog computation. -data ComputeState - = ComputeState - { sFacts :: Set Fact - -- ^ All the facts generated so far - , sAuthorityFacts :: Set Fact - -- ^ Facts generated by the authority block (and the authorizer). Those are kept separate - -- because they are provided by a trusted party (the one which has the root 'SecretKey'). - -- Block facts are not as trustworthy as they can be added by anyone. - , sIterations :: Int - -- ^ The current count of iterations - , sLimits :: Limits - -- ^ The configured limits for this computation. This field is effectively read-only - , sFailedChecks :: [Check] - -- ^ The failed checks gathered so far. The computation carries on even if some checks - -- fail, in order to be able to report all the failing checks in one go - , sPolicyResult :: Either (Maybe MatchedQuery) MatchedQuery - -- ^ The result of the authorizer-defined policies. 'Left' represents failure: - -- - @Left Nothing@ if no policies matched - -- - @Left (Just q)@ if a deny policy matched - -- - @Right q@ if an allow policy matched - } - -mkInitState :: Limits -> ComputeState -mkInitState sLimits = ComputeState - { sFacts = Set.empty -- no facts have been generated yet - , sAuthorityFacts = Set.empty -- no authority facts have been generated yet - , sIterations = 0 -- no evaluation iteration has taken place yet - , sLimits -- this field is read-only - , sFailedChecks = [] -- no checks have failed yet - , sPolicyResult = Left Nothing -- no policies have matched yet - } - -data World - = World - { facts :: Set Fact - , rules :: Set Rule - } - -instance Semigroup World where - w1 <> w2 = World - { rules = rules w1 <> rules w2 - , facts = facts w1 <> facts w2 - } - -instance Monoid World where - mempty = World mempty mempty - -instance Show World where - show World{..} = unpack . intercalate "\n" $ join - [ [ "Block Rules" ] - , renderRule <$> Set.toList rules - , [ "Facts" ] - , renderFact <$> Set.toList facts - ] - -- | Proof that a biscuit was authorized successfully. In addition to the matched -- @allow query@, the generated facts are kept around for further querying. -- Since only authority facts can be trusted, they are kept separate. @@ -112,12 +69,8 @@ = AuthorizationSuccess { matchedAllowQuery :: MatchedQuery -- ^ The allow query that matched - , authorityFacts :: Set Fact - -- ^ All the facts generated by the authority block (and the authorizer) - , allGeneratedFacts :: Set Fact - -- ^ All the facts that were generated by the biscuit. Be careful, the - -- biscuit signature check only guarantees that 'authorityFacts' are - -- signed with the corresponding 'SecretKey'. + , allFacts :: FactGroup + -- ^ All the facts that were generated by the biscuit, grouped by their origin , limits :: Limits -- ^ Limits used when running datalog. It is kept around to allow further -- datalog computation when querying facts @@ -130,8 +83,6 @@ getBindings :: AuthorizationSuccess -> Set Bindings getBindings AuthorizationSuccess{matchedAllowQuery=MatchedQuery{bindings}} = bindings -withFacts :: World -> Set Fact -> World -withFacts w@World{facts} newFacts = w { facts = newFacts <> facts } -- | Given a series of blocks and an authorizer, ensure that all -- the checks and policies match @@ -163,15 +114,6 @@ Just r -> r -runAllBlocks :: BlockWithRevocationId - -> [BlockWithRevocationId] - -> Authorizer - -> StateT ComputeState (Either PureExecError) () -runAllBlocks authority blocks authorizer = do - modify $ \state -> state { sFacts = mkRevocationIdFacts authority blocks } - runAuthority authority authorizer - traverse_ runBlock blocks - mkRevocationIdFacts :: BlockWithRevocationId -> [BlockWithRevocationId] -> Set Fact mkRevocationIdFacts authority blocks = @@ -180,99 +122,145 @@ mkFact (index, rid) = [fact|revocation_id(${index}, ${rid})|] in Set.fromList $ mkFact <$> allIds +data ComputeState + = ComputeState + { sLimits :: Limits -- readonly + , sRules :: Map Natural (Set Rule) -- readonly + -- state + , sIterations :: Int -- elapsed iterations + , sFacts :: FactGroup -- facts generated so far + } + deriving (Eq, Show) + +mkInitState :: Limits -> BlockWithRevocationId -> [BlockWithRevocationId] -> Authorizer -> ComputeState +mkInitState limits authority blocks authorizer = + let revocationWorld = (mempty, FactGroup $ Map.singleton (Set.singleton 0) $ mkRevocationIdFacts authority blocks) + firstBlock = fst authority <> vBlock authorizer + otherBlocks = fst <$> blocks + allBlocks = firstBlock : otherBlocks + (sRules, sFacts) = revocationWorld <> fold (zipWith collectWorld [0..] allBlocks) + in ComputeState + { sLimits = limits + , sRules + , sFacts + , sIterations = 0 + } + runAuthorizerNoTimeout :: Limits - -> BlockWithRevocationId - -> [BlockWithRevocationId] - -> Authorizer - -> Either ExecutionError AuthorizationSuccess + -> BlockWithRevocationId + -> [BlockWithRevocationId] + -> Authorizer + -> Either ExecutionError AuthorizationSuccess runAuthorizerNoTimeout limits authority blocks authorizer = do - let result = (`runStateT` mkInitState limits) $ runAllBlocks authority blocks authorizer - case result of - Left Facts -> Left TooManyFacts - Left Iterations -> Left TooManyIterations - Right ((), ComputeState{..}) -> case (nonEmpty sFailedChecks, sPolicyResult) of - (Nothing, Right p) -> Right $ AuthorizationSuccess { matchedAllowQuery = p - , authorityFacts = sAuthorityFacts - , allGeneratedFacts = sFacts - , limits - } - (Nothing, Left Nothing) -> Left $ ResultError $ NoPoliciesMatched [] - (Nothing, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p - (Just cs, Left Nothing) -> Left $ ResultError $ NoPoliciesMatched (NE.toList cs) - (Just cs, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched (NE.toList cs) p - (Just cs, Right _) -> Left $ ResultError $ FailedChecks cs + let initState = mkInitState limits authority blocks authorizer + toExecutionError = \case + Facts -> TooManyFacts + Iterations -> TooManyIterations + BadRule -> InvalidRule + allFacts <- first toExecutionError $ computeAllFacts initState + let checks = zip [0..] $ bChecks <$> ((fst authority <> vBlock authorizer) : (fst <$> blocks)) + policies = vPolicies authorizer + checkResults = checkChecks limits allFacts checks + policyResults = checkPolicies limits allFacts 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 + , allFacts + , limits + } +runStep :: StateT ComputeState (Either PureExecError) Int +runStep = do + state@ComputeState{sLimits,sFacts,sRules,sIterations} <- get + let Limits{maxFacts, maxIterations} = sLimits + previousCount = countFacts sFacts + newFacts = sFacts <> extend sLimits sRules sFacts + 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` + addedFactsCount = newCount - previousCount + when (newCount >= maxFacts) $ lift $ Left Facts + when (sIterations >= maxIterations) $ lift $ Left Iterations + put $ state { sIterations = sIterations + 1 + , sFacts = newFacts + } + return addedFactsCount -runFactGeneration :: Limits -> World -> Either PureExecError (Set Fact) -runFactGeneration limits w = - let getFacts = sFacts . snd - in getFacts <$> runStateT (computeAllFacts w) (mkInitState limits) +-- | Check if every variable from the head is present in the body +checkRuleHead :: Rule -> Bool +checkRuleHead Rule{rhead, body} = + let headVars = extractVariables [rhead] + bodyVars = extractVariables body + in headVars `Set.isSubsetOf` bodyVars -runAuthority :: BlockWithRevocationId - -> Authorizer - -> StateT ComputeState (Either PureExecError) () -runAuthority (block, _rid) Authorizer{..} = do - let world = collectWorld block <> collectWorld vBlock - computeAllFacts world - -- store the facts generated by the authority block (and the authorizer) - -- in a dedicated `sAuthorityFacts` so that they can be queried independently - -- later: we trust the authority facts, not the block facts - modify $ \c@ComputeState{sFacts} -> c { sAuthorityFacts = sFacts } - state@ComputeState{sFacts, sLimits} <- get - let checkResults = checkChecks sLimits (bChecks block <> bChecks vBlock) sFacts - let policyResult = checkPolicies sLimits vPolicies sFacts - put state { sPolicyResult = policyResult - , sFailedChecks = validation NE.toList mempty checkResults - } +-- | Repeatedly generate new facts until it converges (no new +-- facts are generated) +computeAllFacts :: ComputeState -> Either PureExecError FactGroup +computeAllFacts initState@ComputeState{sRules} = do + let checkRules = all (all checkRuleHead) sRules + go = do + newFacts <- runStep + if newFacts > 0 then go else gets sFacts -runBlock :: BlockWithRevocationId - -> StateT ComputeState (Either PureExecError) () -runBlock (block@Block{bChecks}, _rid) = do - let world = collectWorld block - computeAllFacts world - state@ComputeState{sFacts, sLimits, sFailedChecks} <- get - let checkResults = checkChecks sLimits bChecks sFacts - put state { sFailedChecks = validation NE.toList mempty checkResults <> sFailedChecks - } + unless checkRules $ Left BadRule + evalStateT go initState -checkChecks :: Limits -> [Check] -> Set Fact -> Validation (NonEmpty Check) () -checkChecks limits checks facts = traverse_ (checkCheck limits facts) checks +-- | Small helper used in tests to directly provide rules and facts without creating +-- a biscuit token +runFactGeneration :: Limits -> Map Natural (Set Rule) -> FactGroup -> Either PureExecError FactGroup +runFactGeneration sLimits sRules sFacts = + let initState = ComputeState{sIterations = 0, ..} + in computeAllFacts initState -checkPolicies :: Limits -> [Policy] -> Set Fact -> Either (Maybe MatchedQuery) MatchedQuery -checkPolicies limits policies facts = - let results = mapMaybe (checkPolicy limits facts) policies +checkChecks :: Limits -> FactGroup -> [(Natural, [Check])] -> Validation (NonEmpty Check) () +checkChecks limits allFacts = + traverse_ (uncurry $ checkChecksForGroup limits allFacts) + +checkChecksForGroup :: Limits -> FactGroup -> Natural -> [Check] -> Validation (NonEmpty Check) () +checkChecksForGroup limits allFacts checksBlockId = + traverse_ (checkCheck limits checksBlockId allFacts) + +checkPolicies :: Limits -> FactGroup -> [Policy] -> Either (Maybe MatchedQuery) MatchedQuery +checkPolicies limits allFacts policies = + let results = mapMaybe (checkPolicy limits allFacts) policies in case results of p : _ -> first Just p [] -> Left Nothing -computeAllFacts :: World - -> StateT ComputeState (Either PureExecError) () -computeAllFacts world = do - state@ComputeState{..} <- get - let Limits{..} = sLimits - let newFacts = extend sLimits (world `withFacts` sFacts) - allFacts = sFacts <> facts world <> newFacts - when (Set.size allFacts >= maxFacts) $ lift $ Left Facts - when (sIterations >= maxIterations) $ lift $ Left Iterations - put $ state { sIterations = sIterations + 1 - , sFacts = allFacts - } - if null newFacts - then pure () - else computeAllFacts world +-- | Generate new facts by applying rules on existing facts +extend :: Limits -> Map Natural (Set Rule) -> FactGroup -> FactGroup +extend l rules facts = + let buildFacts :: Natural -> Set Rule -> FactGroup -> Set (Scoped Fact) + buildFacts ruleBlockId ruleGroup factGroup = + let extendRule :: Rule -> Set (Scoped Fact) + extendRule r@Rule{scope} = getFactsForRule l (toScopedFacts $ keepAuthorized' factGroup scope ruleBlockId) r + in foldMap extendRule ruleGroup -extend :: Limits -> World -> Set Fact -extend l World{..} = - let buildFacts = foldMap (getFactsForRule l facts) - allNewFacts = buildFacts rules - in Set.difference allNewFacts facts + extendRuleGroup :: Natural -> Set Rule -> 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 -collectWorld :: Block -> World -collectWorld Block{..} = World - { facts = Set.fromList bFacts - , rules = Set.fromList bRules - } + in foldMap (uncurry extendRuleGroup) $ Map.toList rules + +collectWorld :: Natural -> Block -> (Map Natural (Set Rule), FactGroup) +collectWorld blockId Block{..} = + let -- a block can define a default scope for its rule + -- which is used unless the rule itself has defined a scope + applyScope r@Rule{scope} = r { scope = scope <|> bScope } + in ( Map.singleton blockId $ Set.map applyScope $ Set.fromList bRules + , FactGroup $ Map.singleton (Set.singleton blockId) $ Set.fromList bFacts + ) + -- | Query the facts generated by the authority and authorizer blocks -- during authorization. This can be used in conjuction with 'getVariableValues' -- and 'getSingleVariableValue' to retrieve actual values. @@ -283,9 +271,12 @@ -- 💁 If the facts you want to query are part of an allow query in the authorizer, -- you can directly get values from 'AuthorizationSuccess'. queryAuthorizerFacts :: AuthorizationSuccess -> Query -> Set Bindings -queryAuthorizerFacts AuthorizationSuccess{authorityFacts, limits} q = - let getBindingsForQueryItem QueryItem{qBody,qExpressions} = - getBindingsForRuleBody limits authorityFacts qBody qExpressions +queryAuthorizerFacts AuthorizationSuccess{allFacts, limits} q = + let authorityFacts = fold (Map.lookup (Set.singleton 0) $ getFactGroup allFacts) + -- we've already ensured that we've kept only authority facts, we don't + -- need to track their origin further + getBindingsForQueryItem QueryItem{qBody,qExpressions} = Set.map snd $ + getBindingsForRuleBody limits (Set.map (mempty,) authorityFacts) qBody qExpressions in foldMap getBindingsForQueryItem q -- | Extract a set of values from a matched variable for a specific type. diff --git a/src/Auth/Biscuit/Proto.hs b/src/Auth/Biscuit/Proto.hs --- a/src/Auth/Biscuit/Proto.hs +++ b/src/Auth/Biscuit/Proto.hs @@ -113,7 +113,7 @@ deriving anyclass (Decode, Encode) data TermV2 = - TermVariable (Required 1 (Value Int32)) + TermVariable (Required 1 (Value Int64)) | TermInteger (Required 2 (Value Int64)) | TermString (Required 3 (Value Int64)) | TermDate (Required 4 (Value Int64)) diff --git a/src/Auth/Biscuit/ProtoBufAdapter.hs b/src/Auth/Biscuit/ProtoBufAdapter.hs --- a/src/Auth/Biscuit/ProtoBufAdapter.hs +++ b/src/Auth/Biscuit/ProtoBufAdapter.hs @@ -12,9 +12,8 @@ -} module Auth.Biscuit.ProtoBufAdapter ( Symbols - , extractSymbols - , commonSymbols , buildSymbolTable + , extractSymbols , pbToBlock , blockToPb , pbToSignedBlock @@ -25,11 +24,8 @@ import Control.Monad (when) import Crypto.PubKey.Ed25519 (PublicKey) import Data.Bifunctor (first) -import Data.Int (Int32, Int64) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Int (Int64) import qualified Data.Set as Set -import Data.Text (Text) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) @@ -38,50 +34,22 @@ import qualified Auth.Biscuit.Crypto as Crypto import Auth.Biscuit.Datalog.AST import qualified Auth.Biscuit.Proto as PB -import Auth.Biscuit.Utils (maybeToRight) +import Auth.Biscuit.Symbols --- | A map to get symbol names from symbol ids -type Symbols = Map Int32 Text --- | A map to get symbol ids from symbol names -type ReverseSymbols = Map Text Int32 --- | The common symbols defined in the biscuit spec -commonSymbols :: Symbols -commonSymbols = Map.fromList $ zip [0..] - [ "authority" - , "ambient" - , "resource" - , "operation" - , "right" - , "time" - , "revocation_id" - ] - -- | Given existing symbols and a series of protobuf blocks, -- compute the complete symbol mapping -extractSymbols :: Symbols -> [PB.Block] -> Symbols -extractSymbols existingSymbols blocks = - let blocksSymbols = PB.getField . PB.symbols =<< blocks - startingIndex = fromIntegral $ length existingSymbols - in existingSymbols <> Map.fromList (zip [startingIndex..] blocksSymbols) +extractSymbols :: [PB.Block] -> Symbols +extractSymbols blocks = + addFromBlocks (PB.getField . PB.symbols <$> blocks) -- | Given existing symbols and a biscuit block, compute the -- symbol table for the given block. Already existing symbols -- won't be included -buildSymbolTable :: Symbols -> Block -> Symbols +buildSymbolTable :: Symbols -> Block -> BlockSymbols buildSymbolTable existingSymbols block = let allSymbols = listSymbolsInBlock block - newSymbols = Set.difference allSymbols (Set.fromList $ Map.elems existingSymbols) - newSymbolsWithIndices = zip (fromIntegral <$> [length existingSymbols..]) (Set.toList newSymbols) - in Map.fromList newSymbolsWithIndices - -reverseSymbols :: Symbols -> ReverseSymbols -reverseSymbols = - let swap (a,b) = (b,a) - in Map.fromList . fmap swap . Map.toList - -getSymbolCode :: Integral i => ReverseSymbols -> Text -> i -getSymbolCode = (fromIntegral .) . (Map.!) + in addSymbols existingSymbols allSymbols pbToPublicKey :: PB.PublicKey -> Either String PublicKey pbToPublicKey PB.PublicKey{..} = @@ -125,19 +93,20 @@ bFacts <- traverse (pbToFact s) $ PB.getField facts_v2 bRules <- traverse (pbToRule s) $ PB.getField rules_v2 bChecks <- traverse (pbToCheck s) $ PB.getField checks_v2 - when (bVersion /= Just 2) $ Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only version 2 is supported" + let bScope = Nothing -- todo parse from protobuf + when (bVersion /= Just 3) $ Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only version 3 is supported" pure Block{ .. } -- | Turn a biscuit block into a protobuf block, for serialization, -- along with the newly defined symbols -blockToPb :: Symbols -> Block -> (Symbols, PB.Block) +blockToPb :: Symbols -> Block -> (BlockSymbols, PB.Block) blockToPb existingSymbols b@Block{..} = let bSymbols = buildSymbolTable existingSymbols b - s = reverseSymbols $ existingSymbols <> bSymbols - symbols = PB.putField $ Map.elems bSymbols + s = reverseSymbols $ addFromBlock existingSymbols bSymbols + symbols = PB.putField $ getSymbolList bSymbols context = PB.putField bContext - version = PB.putField $ Just 2 + version = PB.putField $ Just 3 facts_v2 = PB.putField $ factToPb s <$> bFacts rules_v2 = PB.putField $ ruleToPb s <$> bRules checks_v2 = PB.putField $ checkToPb s <$> bChecks @@ -147,7 +116,7 @@ pbToFact s PB.FactV2{predicate} = do let pbName = PB.getField $ PB.name $ PB.getField predicate pbTerms = PB.getField $ PB.terms $ PB.getField predicate - name <- getSymbol s pbName + name <- getSymbol s $ SymbolRef pbName terms <- traverse (pbToValue s) pbTerms pure Predicate{..} @@ -155,7 +124,7 @@ factToPb s Predicate{..} = let predicate = PB.PredicateV2 - { name = PB.putField $ getSymbolCode s name + { name = PB.putField $ getSymbolRef $ getSymbolCode s name , terms = PB.putField $ valueToPb s <$> terms } in PB.FactV2{predicate = PB.putField predicate} @@ -168,6 +137,7 @@ rhead <- pbToPredicate s pbHead body <- traverse (pbToPredicate s) pbBody expressions <- traverse (pbToExpression s) pbExpressions + let scope = Nothing -- todo read it from PB pure Rule {..} ruleToPb :: ReverseSymbols -> Rule -> PB.RuleV2 @@ -180,7 +150,7 @@ pbToCheck :: Symbols -> PB.CheckV2 -> Either String Check pbToCheck s PB.CheckV2{queries} = do - let toCheck Rule{body,expressions} = QueryItem{qBody = body, qExpressions = expressions } + let toCheck Rule{body,expressions,scope} = QueryItem{qBody = body, qExpressions = expressions, qScope = scope} rules <- traverse (pbToRule s) $ PB.getField queries pure $ toCheck <$> rules @@ -188,24 +158,25 @@ checkToPb s items = let dummyHead = Predicate "query" [] toQuery QueryItem{..} = - ruleToPb s $ Rule dummyHead qBody qExpressions + ruleToPb s $ Rule { rhead = dummyHead + , body = qBody + , expressions = qExpressions + , scope = qScope + } in PB.CheckV2 { queries = PB.putField $ toQuery <$> items } -getSymbol :: (Show i, Integral i) => Symbols -> i -> Either String Text -getSymbol s i = maybeToRight ("Missing symbol at id " <> show i) $ Map.lookup (fromIntegral i) s - pbToPredicate :: Symbols -> PB.PredicateV2 -> Either String (Predicate' 'InPredicate 'RegularString) pbToPredicate s pbPredicate = do let pbName = PB.getField $ PB.name pbPredicate pbTerms = PB.getField $ PB.terms pbPredicate - name <- getSymbol s pbName + name <- getSymbol s $ SymbolRef pbName terms <- traverse (pbToTerm s) pbTerms pure Predicate{..} predicateToPb :: ReverseSymbols -> Predicate -> PB.PredicateV2 predicateToPb s Predicate{..} = PB.PredicateV2 - { name = PB.putField $ getSymbolCode s name + { name = PB.putField $ getSymbolRef $ getSymbolCode s name , terms = PB.putField $ termToPb s <$> terms } @@ -215,18 +186,18 @@ pbToTerm :: Symbols -> PB.TermV2 -> Either String Term pbToTerm s = \case PB.TermInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f - PB.TermString f -> LString <$> getSymbol s (PB.getField f) + PB.TermString f -> LString <$> getSymbol s (SymbolRef $ PB.getField f) PB.TermDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f PB.TermBytes f -> pure $ LBytes $ PB.getField f PB.TermBool f -> pure $ LBool $ PB.getField f - PB.TermVariable f -> Variable <$> getSymbol s (PB.getField f) + PB.TermVariable f -> Variable <$> getSymbol s (SymbolRef $ PB.getField f) PB.TermTermSet f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f) termToPb :: ReverseSymbols -> Term -> PB.TermV2 termToPb s = \case - Variable n -> PB.TermVariable $ PB.putField $ getSymbolCode s n + Variable n -> PB.TermVariable $ PB.putField $ getSymbolRef $ getSymbolCode s n LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v - LString v -> PB.TermString $ PB.putField $ getSymbolCode s v + LString v -> PB.TermString $ PB.putField $ getSymbolRef $ getSymbolCode s v LDate v -> PB.TermDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v LBytes v -> PB.TermBytes $ PB.putField v LBool v -> PB.TermBool $ PB.putField v @@ -237,7 +208,7 @@ pbToValue :: Symbols -> PB.TermV2 -> Either String Value pbToValue s = \case PB.TermInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f - PB.TermString f -> LString <$> getSymbol s (PB.getField f) + PB.TermString f -> LString <$> getSymbol s (SymbolRef $ PB.getField f) PB.TermDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f PB.TermBytes f -> pure $ LBytes $ PB.getField f PB.TermBool f -> pure $ LBool $ PB.getField f @@ -247,7 +218,7 @@ valueToPb :: ReverseSymbols -> Value -> PB.TermV2 valueToPb s = \case LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v - LString v -> PB.TermString $ PB.putField $ getSymbolCode s v + LString v -> PB.TermString $ PB.putField $ getSymbolRef $ getSymbolCode s v LDate v -> PB.TermDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v LBytes v -> PB.TermBytes $ PB.putField v LBool v -> PB.TermBool $ PB.putField v @@ -259,7 +230,7 @@ pbToSetValue :: Symbols -> PB.TermV2 -> Either String (Term' 'WithinSet 'InFact 'RegularString) pbToSetValue s = \case PB.TermInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f - PB.TermString f -> LString <$> getSymbol s (PB.getField f) + PB.TermString f -> LString <$> getSymbol s (SymbolRef $ PB.getField f) PB.TermDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f PB.TermBytes f -> pure $ LBytes $ PB.getField f PB.TermBool f -> pure $ LBool $ PB.getField f @@ -269,7 +240,7 @@ setValueToPb :: ReverseSymbols -> Term' 'WithinSet 'InFact 'RegularString -> PB.TermV2 setValueToPb s = \case LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v - LString v -> PB.TermString $ PB.putField $ getSymbolCode s v + LString v -> PB.TermString $ PB.putField $ getSymbolRef $ getSymbolCode s v LDate v -> PB.TermDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v LBytes v -> PB.TermBytes $ PB.putField v LBool v -> PB.TermBool $ PB.putField v diff --git a/src/Auth/Biscuit/Symbols.hs b/src/Auth/Biscuit/Symbols.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Symbols.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +module Auth.Biscuit.Symbols + ( Symbols + , BlockSymbols + , ReverseSymbols + , SymbolRef (..) + , getSymbol + , addSymbols + , addFromBlock + , addFromBlocks + , reverseSymbols + , getSymbolList + , getSymbolCode + , newSymbolTable + ) where + +import Control.Monad (join) +import Data.Int (Int64) +import Data.Map (Map, elems, (!?)) +import qualified Data.Map as Map +import Data.Set (Set, difference, union) +import qualified Data.Set as Set +import Data.Text (Text) + +import Auth.Biscuit.Utils (maybeToRight) + +newtype SymbolRef = SymbolRef { getSymbolRef :: Int64 } + deriving stock (Eq) + +instance Show SymbolRef where + show = ("#" <>) . show . getSymbolRef + +newtype Symbols = Symbols { getSymbols :: Map Int64 Text } + deriving stock (Eq, Show) + +newtype BlockSymbols = BlockSymbols { getBlockSymbols :: Map Int64 Text } + deriving stock (Eq, Show) + deriving newtype (Semigroup) + +newtype ReverseSymbols = ReverseSymbols { getReverseSymbols :: Map Text Int64 } + deriving stock (Eq, Show) + deriving newtype (Semigroup) + +getSymbol :: Symbols -> SymbolRef -> Either String Text +getSymbol (Symbols m) (SymbolRef i) = + maybeToRight ("Missing symbol at id #" <> show i) $ m !? i + +-- | Given already existing symbols and a set of symbols used in a block, +-- compute the symbol table carried by this specific block +addSymbols :: Symbols -> Set Text -> BlockSymbols +addSymbols (Symbols m) symbols = + let existingSymbols = Set.fromList (elems commonSymbols) `union` Set.fromList (elems m) + newSymbols = Set.toList $ symbols `difference` existingSymbols + starting = fromIntegral $ 1024 + (Map.size m - Map.size commonSymbols) + in BlockSymbols $ Map.fromList (zip [starting..] newSymbols) + +getSymbolList :: BlockSymbols -> [Text] +getSymbolList (BlockSymbols m) = Map.elems m + +newSymbolTable :: Symbols +newSymbolTable = Symbols commonSymbols + +-- | Given the symbol table of a protobuf block, update the provided symbol table +addFromBlock :: Symbols -> BlockSymbols -> Symbols +addFromBlock (Symbols m) (BlockSymbols bm) = + Symbols $ m <> bm + +-- | Compute a global symbol table from a series of block symbol tables +addFromBlocks :: [[Text]] -> Symbols +addFromBlocks blocksTables = + let allSymbols = join blocksTables + in Symbols $ commonSymbols <> Map.fromList (zip [1024..] allSymbols) + +-- | Reverse a symbol table +reverseSymbols :: Symbols -> ReverseSymbols +reverseSymbols = + let swap (a,b) = (b,a) + in ReverseSymbols . Map.fromList . fmap swap . Map.toList . getSymbols + +-- | Given a reverse symbol table (symbol refs indexed by their textual +-- representation), turn textual representations into symbol refs. +-- This function is partial, the reverse table is guaranteed to +-- contain the expected textual symbols. +getSymbolCode :: ReverseSymbols -> Text -> SymbolRef +getSymbolCode (ReverseSymbols rm) t = SymbolRef $ rm Map.! t + +-- | The common symbols defined in the biscuit spec +commonSymbols :: Map Int64 Text +commonSymbols = Map.fromList $ zip [0..] + [ "read" + , "write" + , "resource" + , "operation" + , "right" + , "time" + , "role" + , "owner" + , "tenant" + , "namespace" + , "user" + , "team" + , "service" + , "admin" + , "email" + , "group" + , "member" + , "ip_address" + , "client" + , "client_ip" + , "domain" + , "path" + , "version" + , "cluster" + , "node" + , "hostname" + , "nonce" + , "query" + ] diff --git a/src/Auth/Biscuit/Token.hs b/src/Auth/Biscuit/Token.hs --- a/src/Auth/Biscuit/Token.hs +++ b/src/Auth/Biscuit/Token.hs @@ -31,6 +31,7 @@ , Verified , Unverified , mkBiscuit + , mkBiscuitWith , addBlock , BiscuitEncoding (..) , ParserConfig (..) @@ -74,12 +75,11 @@ import Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess, runAuthorizerWithLimits) import qualified Auth.Biscuit.Proto as PB -import Auth.Biscuit.ProtoBufAdapter (Symbols, blockToPb, - commonSymbols, - extractSymbols, pbToBlock, - pbToProof, +import Auth.Biscuit.ProtoBufAdapter (blockToPb, extractSymbols, + pbToBlock, pbToProof, pbToSignedBlock, signedBlockToPb) +import Auth.Biscuit.Symbols -- | Protobuf serialization does not have a guaranteed deterministic behaviour, -- so we need to keep the initial serialized payload around in order to compute @@ -208,13 +208,18 @@ -- | Create a new biscuit with the provided authority block. Such a biscuit is 'Open' to -- further attenuation. mkBiscuit :: SecretKey -> Block -> IO (Biscuit Open Verified) -mkBiscuit sk authority = do - let (authoritySymbols, authoritySerialized) = PB.encodeBlock <$> blockToPb commonSymbols authority +mkBiscuit = mkBiscuitWith Nothing + +-- | Create a new biscuit with the provided authority block and root key id. Such a biscuit is 'Open' to +-- further attenuation. +mkBiscuitWith :: Maybe Int -> SecretKey -> Block -> IO (Biscuit Open Verified) +mkBiscuitWith rootKeyId sk authority = do + let (authoritySymbols, authoritySerialized) = PB.encodeBlock <$> blockToPb newSymbolTable authority (signedBlock, nextSk) <- signBlock sk authoritySerialized - pure Biscuit { rootKeyId = Nothing + pure Biscuit { rootKeyId , authority = toParsedSignedBlock authority signedBlock , blocks = [] - , symbols = commonSymbols <> authoritySymbols + , symbols = addFromBlock newSymbolTable authoritySymbols , proof = Open nextSk , proofCheck = Verified $ toPublic sk } @@ -229,7 +234,7 @@ Open p = proof (signedBlock, nextSk) <- signBlock p blockSerialized pure $ b { blocks = blocks <> [toParsedSignedBlock block signedBlock] - , symbols = symbols <> blockSymbols + , symbols = addFromBlock symbols blockSymbols , proof = Open nextSk } @@ -249,7 +254,7 @@ SealedProof sig -> PB.ProofSignature $ PB.putField (convert sig) OpenProof sk -> PB.ProofSecret $ PB.putField (convert sk) in PB.encodeBlockList PB.Biscuit - { rootKeyId = PB.putField Nothing -- TODO + { rootKeyId = PB.putField $ fromIntegral <$> rootKeyId , authority = PB.putField $ toPBSignedBlock authority , blocks = PB.putField $ toPBSignedBlock <$> blocks , proof = PB.putField proofField @@ -323,7 +328,7 @@ rawAuthority <- toRawSignedBlock wAuthority rawBlocks <- traverse toRawSignedBlock wBlocks - let symbols = extractSymbols commonSymbols $ (\((_, p), _, _) -> p) <$> rawAuthority : rawBlocks + let symbols = extractSymbols $ (\((_, p), _, _) -> p) <$> rawAuthority : rawBlocks authority <- rawSignedBlockToParsedSignedBlock symbols rawAuthority blocks <- traverse (rawSignedBlockToParsedSignedBlock symbols) rawBlocks diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,7 +6,6 @@ import qualified Spec.NewCrypto as NewCrypto import qualified Spec.Parser as Parser import qualified Spec.Quasiquoter as Quasiquoter -import qualified Spec.RevocationIds as RevocationIds import qualified Spec.Roundtrip as Roundtrip import qualified Spec.SampleReader as SampleReader import qualified Spec.ScopedExecutor as ScopedExecutor @@ -21,7 +20,6 @@ , Executor.specs , Parser.specs , Quasiquoter.specs - , RevocationIds.specs , Roundtrip.specs , Verification.specs , ScopedExecutor.specs diff --git a/test/Spec/Executor.hs b/test/Spec/Executor.hs --- a/test/Spec/Executor.hs +++ b/test/Spec/Executor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Spec.Executor (specs) where @@ -6,6 +7,7 @@ import Data.Map.Strict as Map import Data.Set as Set import Data.Text (Text, unpack) +import Numeric.Natural (Natural) import Test.Tasty import Test.Tasty.HUnit @@ -21,6 +23,8 @@ specs :: TestTree specs = testGroup "Datalog evaluation" [ grandparent + , ancestor + , scopedRules , exprEval , exprEvalError , rulesWithConstraints @@ -28,25 +32,50 @@ , limits ] +authGroup :: Set Fact -> FactGroup +authGroup = FactGroup . Map.singleton (Set.singleton 0) + +authRulesGroup :: Set Rule -> Map Natural (Set Rule) +authRulesGroup = Map.singleton 0 + grandparent :: TestTree grandparent = testCase "Basic grandparent rule" $ - let world = World - { rules = Set.fromList - [ [rule|grandparent($a,$b) <- parent($a,$c), parent($c,$b)|] - ] - , facts = Set.fromList - [ [fact|parent("alice", "bob")|] - , [fact|parent("bob", "jean-pierre")|] - , [fact|parent("alice", "toto")|] - ] - } - in runFactGeneration defaultLimits world @?= Right (Set.fromList + let rules = authRulesGroup $ Set.fromList + [ [rule|grandparent($a,$b) <- parent($a,$c), parent($c,$b)|] + ] + facts = authGroup $ Set.fromList + [ [fact|parent("alice", "bob")|] + , [fact|parent("bob", "jean-pierre")|] + , [fact|parent("alice", "toto")|] + ] + in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList [ [fact|parent("alice", "bob")|] , [fact|parent("bob", "jean-pierre")|] , [fact|parent("alice", "toto")|] , [fact|grandparent("alice", "jean-pierre")|] ]) +ancestor :: TestTree +ancestor = testCase "Ancestor rule" $ + let rules = authRulesGroup $ Set.fromList + [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] + , [rule|ancestor($a,$b) <- parent($a,$b)|] + ] + facts = authGroup $ Set.fromList + [ [fact|parent("alice", "bob")|] + , [fact|parent("bob", "jean-pierre")|] + , [fact|parent("alice", "toto")|] + ] + in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList + [ [fact|parent("alice", "bob")|] + , [fact|parent("bob", "jean-pierre")|] + , [fact|parent("alice", "toto")|] + , [fact|ancestor("alice", "bob")|] + , [fact|ancestor("bob", "jean-pierre")|] + , [fact|ancestor("alice", "toto")|] + , [fact|ancestor("alice", "jean-pierre")|] + ]) + expr :: Text -> Expression expr = either error id . parseOnly expressionParser @@ -54,6 +83,8 @@ exprEval = do let bindings = Map.fromList [ ("var1", LInteger 0) + , ("topDomain", LString "example.com") + , ("domain", LString "test.example.com") ] eval (e, r) = testCase (unpack e) $ evaluateExpression defaultLimits bindings (expr e) @?= Right r @@ -109,6 +140,7 @@ , ("\"my string\".starts_with(\"string\")", LBool False) , ("\"my string\".ends_with(\"string\")", LBool True) , ("\"my string\".ends_with(\"my\")", LBool False) + , ("$domain.ends_with(\".\" + $topDomain)", LBool True) , ("2 + 1", LInteger 3) , ("2 - 1", LInteger 1) , ("5 / 2", LInteger 2) @@ -147,18 +179,16 @@ rulesWithConstraints :: TestTree rulesWithConstraints = testCase "Rule with constraints" $ - let world = World - { rules = Set.fromList + let rules = authRulesGroup $ Set.fromList [ [rule|valid_date("file1") <- time($0), resource("file1"), $0 <= 2019-12-04T09:46:41+00:00|] , [rule|valid_date("file2") <- time($0), resource("file2"), $0 <= 2010-12-04T09:46:41+00:00|] ] - , facts = Set.fromList + facts = authGroup $ Set.fromList [ [fact|time(2019-12-04T01:00:00Z)|] , [fact|resource("file1")|] , [fact|resource("file2")|] ] - } - in runFactGeneration defaultLimits world @?= Right (Set.fromList + in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList [ [fact|time(2019-12-04T01:00:00Z)|] , [fact|resource("file1")|] , [fact|resource("file2")|] @@ -167,37 +197,62 @@ ruleHeadWithNoVars :: TestTree ruleHeadWithNoVars = testCase "Rule head with no variables" $ - let world = World - { rules = Set.fromList + let rules = authRulesGroup $ Set.fromList [ [rule|operation("authority", "read") <- test($yolo, "nothing")|] ] - , facts = Set.fromList + facts = authGroup $ Set.fromList [ [fact|test("whatever", "notNothing")|] ] - } - in runFactGeneration defaultLimits world @?= Right (Set.fromList + in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList [ [fact|test("whatever", "notNothing")|] ]) limits :: TestTree limits = - let world = World - { rules = Set.fromList + let rules = authRulesGroup $ Set.fromList [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] , [rule|ancestor($a,$b) <- parent($a,$b)|] ] - , facts = Set.fromList + facts = authGroup $ Set.fromList [ [fact|parent("alice", "bob")|] , [fact|parent("bob", "jean-pierre")|] , [fact|parent("bob", "marielle")|] , [fact|parent("alice", "toto")|] ] - } factLimits = defaultLimits { maxFacts = 10 } iterLimits = defaultLimits { maxIterations = 2 } in testGroup "Facts generation limits" [ testCase "max facts" $ - runFactGeneration factLimits world @?= Left Facts + runFactGeneration factLimits rules facts @?= Left Facts , testCase "max iterations" $ - runFactGeneration iterLimits world @?= Left Iterations + runFactGeneration iterLimits rules facts @?= Left Iterations ] + +scopedRules :: TestTree +scopedRules = testCase "Rules and facts in different scopes, with default scoping for rules" $ + let rules :: Map Natural (Set Rule) + rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b)|] ]) + , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] ]) + ] + facts :: FactGroup + facts = FactGroup + [ ([0], [ [fact|parent("alice", "bob")|] + , [fact|parent("bob", "trudy")|] + ]) + , ([1], [ [fact|parent("bob", "jean-pierre")|] + ]) + , ([2], [ [fact|parent("toto", "toto")|] + ]) + ] + in runFactGeneration defaultLimits rules facts @?= Right (FactGroup + [ ([0], [ [fact|parent("alice", "bob")|] + , [fact|ancestor("alice", "bob")|] + , [fact|parent("bob", "trudy")|] + , [fact|ancestor("bob", "trudy")|] + ]) + , ([1], [ [fact|parent("bob", "jean-pierre")|] + ]) + , ([0,1], [ [fact|ancestor("alice", "trudy")|] + ]) + , ([2], [ [fact|parent("toto", "toto")|] ]) + ]) diff --git a/test/Spec/Parser.hs b/test/Spec/Parser.hs --- a/test/Spec/Parser.hs +++ b/test/Spec/Parser.hs @@ -10,10 +10,10 @@ import Test.Tasty.HUnit import Auth.Biscuit.Datalog.AST -import Auth.Biscuit.Datalog.Parser (checkParser, expressionParser, - policyParser, predicateParser, - ruleParser, termParser, - authorizerParser) +import Auth.Biscuit.Datalog.Parser (authorizerParser, checkParser, + expressionParser, policyParser, + predicateParser, ruleParser, + termParser) parseTerm :: Text -> Either String Term parseTerm = parseOnly termParser @@ -99,7 +99,7 @@ Right (Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read"] - ] []) + ] [] Nothing) multilineRule :: TestTree multilineRule = testCase "Parse multiline rule" $ @@ -107,7 +107,7 @@ Right (Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read"] - ] []) + ] [] Nothing) constrainedRule :: TestTree constrainedRule = testCase "Parse constained rule" $ @@ -119,7 +119,7 @@ [ EBinary LessOrEqual (EValue $ Variable "0") (EValue $ LDate $ read "2019-12-04 09:46:41 UTC") - ]) + ] Nothing) constrainedRuleOrdering :: TestTree constrainedRuleOrdering = testCase "Parse constained rule (interleaved)" $ @@ -131,7 +131,7 @@ [ EBinary LessOrEqual (EValue $ Variable "0") (EValue $ LDate $ read "2019-12-04 09:46:41 UTC") - ]) + ] Nothing) constraints :: TestTree constraints = testGroup "Parse expressions" @@ -282,7 +282,7 @@ checkParsing = testGroup "check blocks" [ testCase "Simple check" $ parseCheck "check if true" @?= - Right [QueryItem [] [EValue $ LBool True]] + Right [QueryItem [] [EValue $ LBool True] Nothing] , testCase "Multiple groups" $ parseCheck "check if fact($var), $var == true or \ @@ -290,8 +290,10 @@ 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 ] ] @@ -299,10 +301,10 @@ policyParsing = testGroup "policy blocks" [ testCase "Simple allow policy" $ parsePolicy "allow if true" @?= - Right (Allow, [QueryItem [] [EValue $ LBool True]]) + Right (Allow, [QueryItem [] [EValue $ LBool True] Nothing]) , testCase "Simple deny policy" $ parsePolicy "deny if true" @?= - Right (Deny, [QueryItem [] [EValue $ LBool True]]) + Right (Deny, [QueryItem [] [EValue $ LBool True] Nothing]) , testCase "Allow with multiple groups" $ parsePolicy "allow if fact($var), $var == true or \ @@ -310,9 +312,11 @@ Right ( Allow , [ QueryItem [Predicate "fact" [Variable "var"]] - [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [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" $ @@ -322,9 +326,11 @@ Right ( Deny , [ QueryItem [Predicate "fact" [Variable "var"]] - [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [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" $ @@ -335,9 +341,11 @@ Right ( Deny , [ QueryItem [Predicate "fact" [Variable "var"]] - [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + Nothing , QueryItem [Predicate "other" [Variable "var"]] [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] + Nothing ] ) ] @@ -346,13 +354,13 @@ authorizerParsing = testGroup "Simple authorizers" [ testCase "Just a deny" $ parseAuthorizer "deny if true;" @?= - Right (Authorizer [(Deny, [QueryItem [] [EValue (LBool True)]])] mempty + 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"]] []]) - , (Deny, [QueryItem [] [EValue (LBool True)]]) + [ (Allow, [QueryItem [Predicate "operation" [LString "read"]] [] Nothing]) + , (Deny, [QueryItem [] [EValue (LBool True)] Nothing]) ] mempty ) @@ -408,13 +416,13 @@ , 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] @@ -422,22 +430,23 @@ , p "member" [vUserId, vTeamId] , p "team_role" [vTeamId, vBlogId, sContributor] ] [EBinary Contains (EValue (TermSet $ Set.fromList [sRead, sWrite])) - (EValue vOp)] + (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] - ] []]) - , (Deny, [QueryItem [] [EValue (LBool True)]]) + ] [] Nothing]) + , (Deny, [QueryItem [] [EValue (LBool True)] Nothing]) ] parseAuthorizer spec @?= Right Authorizer{vBlock = Block{..}, ..} ] diff --git a/test/Spec/Quasiquoter.hs b/test/Spec/Quasiquoter.hs --- a/test/Spec/Quasiquoter.hs +++ b/test/Spec/Quasiquoter.hs @@ -34,7 +34,7 @@ Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read"] - ] [] + ] [] Nothing antiquotedFact :: TestTree antiquotedFact = testCase "Sliced fact" $ @@ -57,4 +57,4 @@ Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read", LString "test"] - ] [] + ] [] Nothing diff --git a/test/Spec/RevocationIds.hs b/test/Spec/RevocationIds.hs deleted file mode 100644 --- a/test/Spec/RevocationIds.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -module Spec.RevocationIds - ( specs - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Base16 as Hex -import Data.Functor (void) -import Data.List (intersect) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (mapMaybe) -import Test.Tasty -import Test.Tasty.HUnit - -import Auth.Biscuit -import Auth.Biscuit.Token (getRevocationIds) - -pk :: PublicKey -pk = maybe undefined id $ parsePublicKeyHex "acdd6d5b53bfee478bf689f8e012fe7988bf755e3d7c5152947abc149bc20189" - -readFromFile :: FilePath -> IO (Biscuit OpenOrSealed Verified) -readFromFile path = do - result <- parse pk <$> ByteString.readFile ("test/samples/v2/" <> path) - case result of - Left x -> fail $ show x - Right b -> pure b - -readFromFileCheckRevocation :: [ByteString] - -> FilePath - -> IO (Either ParseError (Biscuit OpenOrSealed Verified)) -readFromFileCheckRevocation revokedIds path = - let parser = parseWith ParserConfig { encoding = RawBytes - , getPublicKey = const pk - , isRevoked = fromRevocationList revokedIds - } - in parser =<< ByteString.readFile ("test/samples/v2/" <> path) - -getHex :: Biscuit OpenOrSealed Verified -> [ByteString] -getHex = NE.toList . fmap Hex.encode . getRevocationIds - -specs :: TestTree -specs = testGroup "Revocation ids" - [ testGroup "Computation" - [ token1 - , token16 - ] - , parseTimeCheck - ] - -token1 :: TestTree -token1 = testCase "Token 1" $ do - b <- readFromFile "test1_basic.bc" - let rids = getHex b - rids @?= - [ "9d3e984bd0447eea9f31a56df51ba606160c66102063dd29410a2c85601a2139ce0cd212daf755ed0b8fe1f0e9388a89074b009b7169499e51df83c308e8d20b" - , "5cade9fd3690b72bf90c29c529cb5b1bb50832554ba525b15c5d3f7c994814af522c5a68d61a950bc5f98d9ff4e3e20ffecef65ddaa2858251768ec999ed8b06" - ] - -token16 :: TestTree -token16 = testCase "Token 16" $ do - b <- readFromFile "test16_caveat_head_name.bc" - let rids = getHex b - rids @?= - [ "aa8f26e32b6a55fe99decfb0f2c229776cc30360e5b68a5b06e730f1e9a13697f87929592f37b7b58dd00dececd6fa40540a3879f74bd232505f1c419907000c" - , "02766fa2dbb0bd5a2d4d3fc4e0dd9252ec4dc118fe5bc0eafb67fbce0ddf6a86f4db7ecc0b1da14c210b8dcae53fcfc44565edb32ba18bfc9ca9f97258c4db0d" - ] - -parseTimeCheck :: TestTree -parseTimeCheck = testCase "Parse time revocation check" $ do - let revokedIds :: [ByteString] - revokedIds = mapMaybe fromHex [ "02766fa2dbb0bd5a2d4d3fc4e0dd9252ec4dc118fe5bc0eafb67fbce0ddf6a86f4db7ecc0b1da14c210b8dcae53fcfc44565edb32ba18bfc9ca9f97258c4db0d" ] - res1 <- readFromFileCheckRevocation revokedIds "test16_caveat_head_name.bc" - res1 @?= Left RevokedBiscuit - res2 <- void <$> readFromFileCheckRevocation revokedIds "test1_basic.bc" - res2 @?= Right () diff --git a/test/Spec/Roundtrip.hs b/test/Spec/Roundtrip.hs --- a/test/Spec/Roundtrip.hs +++ b/test/Spec/Roundtrip.hs @@ -45,13 +45,14 @@ [] -> pure biscuit sk <- generateSecretKey let pk = toPublic sk - init' <- mkBiscuit sk authority' + init' <- mkBiscuitWith (Just 1) sk authority' final <- addBlocks blocks' init' let serialized = s final parsed = p pk serialized getBlock ((_, b), _, _) = b getBlocks b = getBlock <$> authority b :| blocks b getBlocks <$> parsed @?= Right i + rootKeyId <$> parsed @?= Right (Just 1) singleBlock :: Roundtrip -> TestTree singleBlock r = testCase "Single block" $ roundtrip r $ pure diff --git a/test/Spec/SampleReader.hs b/test/Spec/SampleReader.hs --- a/test/Spec/SampleReader.hs +++ b/test/Spec/SampleReader.hs @@ -13,19 +13,24 @@ import Debug.Trace import Control.Arrow ((&&&)) +import Control.Lens ((^?)) import Control.Monad (join, void, when) import Data.Aeson +import Data.Aeson.Lens (key) import Data.Aeson.Types (typeMismatch, unexpected) import Data.Attoparsec.Text (parseOnly) import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Hex +import qualified Data.ByteString.Lazy as LBS import Data.Foldable (traverse_) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), toList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Text (Text, pack) -import Data.Text.Encoding (encodeUtf8) +import Data.Maybe (isJust, isNothing) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) import Test.Tasty hiding (Timeout) @@ -95,22 +100,27 @@ parseJSON = genericParseJSON $ defaultOptions { sumEncoding = ObjectWithSingleField } +type RustError = Value + data ValidationR = ValidationR { world :: Maybe WorldDesc - , result :: RustResult [Text] Int + , result :: RustResult RustError Int , authorizer_code :: Authorizer + , revocation_ids :: [Text] } deriving stock (Eq, Show, Generic) deriving anyclass FromJSON checkResult :: Show a - => RustResult [Text] Int + => (a -> RustError -> Assertion) + -> RustResult RustError Int -> Either a b -> Assertion -checkResult r e = case (r, e) of +checkResult f r e = case (r, e) of (Err es, Right _) -> assertFailure $ "Got success, but expected failure: " <> show es (Ok _, Left e) -> assertFailure $ "Expected success, but got failure: " <> show e + (Err es, Left e) -> f e es _ -> pure () @@ -173,34 +183,52 @@ checkTokenBlocks step biscuit token traverse_ (processValidation step biscuit) vList -parseErrorToRust :: ParseError -> RustResult [Text] a -parseErrorToRust = Err . pure . \case - InvalidHexEncoding -> "todo" - InvalidB64Encoding -> "todo" - InvalidProtobufSer w e -> pack $ "todo " <> show w <> e - InvalidProtobuf True "Invalid signature" -> "Format(InvalidSignatureSize(16))" - InvalidProtobuf w e -> "todo" - InvalidProof -> "todo" - InvalidSignatures -> "Format(Signature(InvalidSignature(\"signature error\")))" +compareParseErrors :: ParseError -> RustError -> Assertion +compareParseErrors pe re = + let mustMatch p = assertBool (show re) $ isJust $ re ^? p + in case pe of + InvalidHexEncoding -> + assertFailure $ "InvalidHexEncoding can't appear here " <> show re + InvalidB64Encoding -> + mustMatch $ key "Base64" + InvalidProtobufSer True s -> + mustMatch $ key "Format" . key "SerializationError" + InvalidProtobufSer False s -> + mustMatch $ key "Format" . key "BlockSerializationError" + InvalidProtobuf True "Invalid signature" -> + mustMatch $ key "Format" . key "InvalidSignatureSize" + InvalidProtobuf True s -> + mustMatch $ key "Format" . key "DeserializationError" + InvalidProtobuf False s -> + mustMatch $ key "Format" . key "BlockDeserializationError" + InvalidSignatures -> + mustMatch $ key "Format" . key "Signature" . key "InvalidSignature" + InvalidProof -> + assertFailure $ "InvalidProof can't appear here " <> show re + RevokedBiscuit -> + assertFailure $ "RevokedBiscuit can't appear here " <> show re +compareExecErrors :: ExecutionError -> RustError -> Assertion +compareExecErrors ee re = + let errorMessage = "ExecutionError mismatch: " <> show ee <> " " <> unpack (decodeUtf8 . LBS.toStrict $ encode re) + mustMatch p = assertBool errorMessage $ isJust $ re ^? p + -- todo compare `Unauthorized` contents + in case ee of + Timeout -> mustMatch $ key "RunLimit" . key "Timeout" + TooManyFacts -> mustMatch $ key "RunLimit" . key "TooManyFacts" + TooManyIterations -> mustMatch $ key "RunLimit" . key "TooManyIterations" + InvalidRule -> mustMatch $ key "FailedLogic" . key "InvalidBlockRule" + 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" + processFailedValidation :: (String -> IO ()) -> ParseError -> (String, ValidationR) -> Assertion processFailedValidation step e (name, ValidationR{result}) = do step $ "Checking validation " <> name - checkResult result (Left e) - -execErrorToRust :: Either ExecutionError a -> RustResult [Text] Int -execErrorToRust (Right _) = Ok 0 -execErrorToRust (Left e) = Err $ case e of - Timeout -> ["todo"] - TooManyFacts -> ["todo"] - TooManyIterations -> ["todo"] - FactsInBlocks -> ["todo"] - ResultError (NoPoliciesMatched cs) -> ["todo"] - ResultError (FailedChecks cs) -> ["Block(FailedBlockCheck { block_id: 1, check_id: 0, rule: \"check if resource($0), operation(#read), right($0, #read)\" })"] - ResultError (DenyRuleMatched cs q) -> ["todo"] + checkResult compareParseErrors result (Left e) processValidation :: (String -> IO ()) -> Biscuit OpenOrSealed Verified @@ -211,7 +239,11 @@ w <- maybe (assertFailure "missing authorizer contents") pure world pols <- either (assertFailure . show) pure $ parseAuthorizer $ foldMap (<> ";") (policies w) res <- authorizeBiscuit b (authorizer_code <> pols) - checkResult result res + checkResult compareExecErrors result res + let revocationIds = decodeUtf8 . Hex.encode <$> toList (getRevocationIds b) + step "Comparing revocation ids" + revocation_ids @?= revocationIds + runTests :: (String -> IO ()) -> Assertion diff --git a/test/Spec/ScopedExecutor.hs b/test/Spec/ScopedExecutor.hs --- a/test/Spec/ScopedExecutor.hs +++ b/test/Spec/ScopedExecutor.hs @@ -24,6 +24,7 @@ [ authorizerOnlySeesAuthority , authorityOnlySeesItselfAndAuthorizer , block1OnlySeesAuthorityAndAuthorizer + , block2OnlySeesAuthorityAndAuthorizer , block1SeesAuthorityAndAuthorizer , iterationCountWorks , maxFactsCountWorks @@ -103,6 +104,26 @@ |] runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError $ NoPoliciesMatched []) +block2OnlySeesAuthorityAndAuthorizer :: TestTree +block2OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do + let authority = + [block| + user(1234); + |] + block1 = + [block| + right(1234, "file1", "read"); + |] + block2 = + [block| + is_allowed($user, $resource) <- right($user, $resource, "read"); + check if is_allowed(1234, "file1"); + |] + verif = + [authorizer| + allow if true; + |] + runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) iterationCountWorks :: TestTree iterationCountWorks = testCase "ScopedExecutions stops when hitting the iterations threshold" $ do diff --git a/test/Spec/Verification.hs b/test/Spec/Verification.hs --- a/test/Spec/Verification.hs +++ b/test/Spec/Verification.hs @@ -24,7 +24,6 @@ , errorAccumulation , unboundVarRule , symbolRestrictions - , factsRestrictions ] ifTrue :: MatchedQuery @@ -74,7 +73,7 @@ b1 <- mkBiscuit secret [block|check if operation("read");|] b2 <- addBlock [block|operation($unbound, "read") <- operation($any1, $any2);|] b1 res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|] - res @?= Left (Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation("read")|]) + res @?= Left InvalidRule symbolRestrictions :: TestTree symbolRestrictions = testGroup "Restricted symbols in blocks" @@ -91,21 +90,3 @@ res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|] res @?= Left (Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation("read")|]) ] - -factsRestrictions :: TestTree -factsRestrictions = - let limits = defaultLimits { allowBlockFacts = False } - in testGroup "No facts or rules in blocks" - [ testCase "No facts" $ do - secret <- newSecret - b1 <- mkBiscuit secret [block|right("read");|] - b2 <- addBlock [block|right("write");|] b1 - res <- authorizeBiscuitWithLimits limits b2 [authorizer|allow if right("write");|] - res @?= Left (Executor.ResultError $ Executor.NoPoliciesMatched []) - , testCase "No rules" $ do - secret <- newSecret - b1 <- mkBiscuit secret [block|right("read");|] - b2 <- addBlock [block|right("write") <- right("read");|] b1 - res <- authorizeBiscuitWithLimits limits b2 [authorizer|allow if right("write");|] - res @?= Left (Executor.ResultError $ Executor.NoPoliciesMatched []) - ]