biscuit-haskell 0.2.0.1 → 0.2.1.0

raw patch · 21 files changed

+729/−505 lines, 21 filesdep +lensdep +lens-aesondep ~attoparsecdep ~memorydep ~parser-combinatorsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: lens, lens-aeson

Dependency ranges changed: attoparsec, memory, parser-combinators, template-haskell

API changes (from Hackage documentation)

Files

• README.md +2/−2
• biscuit-haskell.cabal +12/−10
• src/Auth/Biscuit.hs +2/−2
• src/Auth/Biscuit/Crypto.hs +1/−1
• src/Auth/Biscuit/Datalog/AST.hs +26/−3
• src/Auth/Biscuit/Datalog/Executor.hs +148/−58
• src/Auth/Biscuit/Datalog/Parser.hs +4/−3
• src/Auth/Biscuit/Datalog/ScopedExecutor.hs +163/−172
• src/Auth/Biscuit/Proto.hs +1/−1
• src/Auth/Biscuit/ProtoBufAdapter.hs +33/−62
• src/Auth/Biscuit/Symbols.hs +121/−0
• src/Auth/Biscuit/Token.hs +16/−11
• test/Spec.hs +0/−2
• test/Spec/Executor.hs +82/−27
• test/Spec/Parser.hs +32/−23
• test/Spec/Quasiquoter.hs +2/−2
• test/Spec/RevocationIds.hs +0/−77
• test/Spec/Roundtrip.hs +2/−1
• test/Spec/SampleReader.hs +60/−28
• test/Spec/ScopedExecutor.hs +21/−0
• test/Spec/Verification.hs +1/−20

@@ -1,6 +1,6 @@ # biscuit-haskell [![CI-badge][CI-badge]][CI-url] [![Hackage][hackage]][hackage-url] -<img src="https://raw.githubusercontent.com/divarvel/biscuit-haskell/main/assets/biscuit-logo.png" align=right>+<img src="https://raw.githubusercontent.com/biscuit-auth/biscuit-haskell/main/assets/biscuit-logo.png" align=right>  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

@@ -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 <https://github.com/divarvel/biscuit-haskell#readme>-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 <https://github.com/biscuit-auth/biscuit-haskell#readme>+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

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

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

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

@@ -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')

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

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

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

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

@@ -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"+  ]

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

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

@@ -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")|] ])+        ])

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

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

@@ -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 ()

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

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

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

@@ -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 [])-        ]