biscuit-haskell 0.2.1.0 → 0.3.0.0

raw patch · 51 files changed

+4324/−1002 lines, 51 filesdep +base16dep +megaparsecdep −attoparsecdep −base16-bytestringdep ~bytestringdep ~cryptonitedep ~memorysetup-changedbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: base16, megaparsec

Dependencies removed: attoparsec, base16-bytestring

Dependency ranges changed: bytestring, cryptonite, memory, template-haskell, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +33/−0
• README.md +1/−1
• Setup.hs +1/−1
• biscuit-haskell.cabal +14/−11
• src/Auth/Biscuit.hs +99/−32
• src/Auth/Biscuit/Crypto.hs +144/−33
• src/Auth/Biscuit/Datalog/AST.hs +605/−139
• src/Auth/Biscuit/Datalog/Executor.hs +63/−36
• src/Auth/Biscuit/Datalog/Parser.hs +352/−297
• src/Auth/Biscuit/Datalog/ScopedExecutor.hs +69/−57
• src/Auth/Biscuit/Example.hs +14/−6
• src/Auth/Biscuit/Proto.hs +72/−76
• src/Auth/Biscuit/ProtoBufAdapter.hs +165/−46
• src/Auth/Biscuit/Symbols.hs +115/−39
• src/Auth/Biscuit/Token.hs +214/−49
• src/Auth/Biscuit/Utils.hs +6/−0
• test/Spec/Executor.hs +75/−37
• test/Spec/NewCrypto.hs +53/−11
• test/Spec/Parser.hs +293/−49
• test/Spec/Quasiquoter.hs +7/−6
• test/Spec/Roundtrip.hs +78/−6
• test/Spec/SampleReader.hs +97/−41
• test/Spec/ScopedExecutor.hs +123/−23
• test/Spec/Verification.hs +44/−6
• test/samples/current/samples.json +1587/−0
• test/samples/current/test001_basic.bc binary
• test/samples/current/test002_different_root_key.bc binary
• test/samples/current/test003_invalid_signature_format.bc binary
• test/samples/current/test004_random_block.bc binary
• test/samples/current/test005_invalid_signature.bc binary
• test/samples/current/test006_reordered_blocks.bc binary
• test/samples/current/test007_scoped_rules.bc binary
• test/samples/current/test008_scoped_checks.bc binary
• test/samples/current/test009_expired_token.bc binary
• test/samples/current/test010_authorizer_scope.bc binary
• test/samples/current/test011_authorizer_authority_caveats.bc binary
• test/samples/current/test012_authority_caveats.bc binary
• test/samples/current/test013_block_rules.bc binary
• test/samples/current/test014_regex_constraint.bc binary
• test/samples/current/test015_multi_queries_caveats.bc binary
• test/samples/current/test016_caveat_head_name.bc binary
• test/samples/current/test017_expressions.bc binary
• test/samples/current/test018_unbound_variables_in_rule.bc binary
• test/samples/current/test019_generating_ambient_from_variables.bc binary
• test/samples/current/test020_sealed.bc binary
• test/samples/current/test021_parsing.bc binary
• test/samples/current/test022_default_symbols.bc binary
• test/samples/current/test023_execution_scope.bc binary
• test/samples/current/test024_third_party.bc binary
• test/samples/current/test025_check_all.bc binary
• test/samples/current/test026_public_keys_interning.bc binary

@@ -1,5 +1,38 @@ # Changelog for biscuit-haskell +## 0.3.0.0++- GHC 9.2 support+- support for `v4` blocks:+  - support for third-party blocks & scope annotations+  - support for `check all`+  - support for bitwise operations in datalog+  - support for scoped queries after authorization+- new datalog parser with better error reporting+- forbid unbound variables during datalog parsing and+  token deserialization+- update parameters syntax: `${name}` is now `{name}`+- support for runtime datalog parsing+- support for pre-authorization queries++## 0.2.1.0++- support for string concatenation in datalog+- support for `.contains()` on strings in datalog+- update default symbol table++## 0.2.0.1++- rename `verifier` to `authorizer`+- keep track of the public key used to verify a biscuit+- check revocation id during parsing+- support for sealing biscuits+- support for querying facts after authorization++## 0.2.0.0++- support for v2 biscuits+ ## 0.1.1.0  Bugfix for `serializeB64` and `serializeHex`.

@@ -47,7 +47,7 @@   -- verifiers are defined inline, directly in datalog, through the `verifier`   -- quasiquoter. datalog parsing and validation happens at compile time, but   -- can still reference haskell variables.-  let authorizer' = [authorizer|time(${now});+  let authorizer' = [authorizer|time({now});                                 allow if true;                                |]   -- `authorizeBiscuit` only works on valid biscuits, and runs the datalog verifications

@@ -1,2 +1,2 @@-import Distribution.Simple+import           Distribution.Simple main = defaultMain

@@ -1,7 +1,7 @@ cabal-version: 2.0  name:           biscuit-haskell-version:        0.2.1.0+version:        0.3.0.0 category:       Security synopsis:       Library support for the Biscuit security token description:    Please see the README on GitHub at <https://github.com/biscuit-auth/biscuit-haskell#readme>@@ -13,9 +13,12 @@ license:        BSD3 license-file:   LICENSE build-type:     Simple+tested-with:    GHC ==8.10.7 || == 9.0.2 || ==9.2.4 extra-source-files:     README.md     ChangeLog.md+    test/samples/current/samples.json+    test/samples/current/*.bc  source-repository head   type: git@@ -46,14 +49,13 @@   build-depends:     base                 >= 4.7 && <5,     async                ^>= 2.2,-    base16-bytestring    ^>= 1.0,-    bytestring           ^>= 0.10,-    text                 ^>= 1.2,+    base16               ^>= 0.3,+    bytestring           >= 0.10 && <0.12,+    text                 >= 1.2 && <3,     containers           ^>= 0.6,-    cryptonite           >= 0.27 && < 0.30,-    memory               >= 0.15 && < 0.17,-    template-haskell     >= 2.16 && < 2.18,-    attoparsec           >= 0.13 && < 0.15,+    cryptonite           >= 0.27 && < 0.31,+    memory               >= 0.15 && < 0.19,+    template-haskell     >= 2.16 && < 2.19,     base64               ^>= 0.4,     cereal               ^>= 0.5,     mtl                  ^>= 2.2,@@ -63,7 +65,8 @@     regex-tdfa           ^>= 1.3,     th-lift-instances    ^>= 0.1,     time                 ^>= 1.9,-    validation-selective ^>= 0.1+    validation-selective ^>= 0.1,+    megaparsec           ^>= 9.2   default-language: Haskell2010  test-suite biscuit-haskell-test@@ -85,9 +88,8 @@   build-depends:       async     , aeson-    , attoparsec     , base >=4.7 && <5-    , base16-bytestring ^>=1.0+    , base16 ^>=0.3     , base64     , biscuit-haskell     , bytestring@@ -96,6 +98,7 @@     , cryptonite     , lens     , lens-aeson+    , megaparsec     , mtl     , parser-combinators     , protobuf

@@ -58,6 +58,16 @@   -- ** Attenuating biscuits   -- $attenuatingBiscuits   , addBlock+  -- ** Third-party blocks+  -- $thirdPartyBlocks+  , addSignedBlock+  , mkThirdPartyBlockReq+  , mkThirdPartyBlockReqB64+  , mkThirdPartyBlock+  , mkThirdPartyBlockB64+  , applyThirdPartyBlock+  , applyThirdPartyBlockB64+  -- ** Sealing biscuits   -- $sealedBiscuits   , seal   , fromOpen@@ -75,39 +85,42 @@   , defaultLimits   , ParseError (..)   , ExecutionError (..)+  , AuthorizedBiscuit (..)   , AuthorizationSuccess (..)   , MatchedQuery (..)-  , query-  , queryAuthorizerFacts   , getBindings-  , getVariableValues-  , getSingleVariableValue   , ToTerm (..)   , FromValue (..)   , Term   , Term' (..)    -- * Retrieving information from a biscuit+  , queryAuthorizerFacts+  , queryRawBiscuitFacts+  , getVariableValues+  , getSingleVariableValue+  , query   , getRevocationIds   , getVerifiedBiscuitPublicKey   ) where  import           Control.Monad                       ((<=<)) import           Control.Monad.Identity              (runIdentity)+import           Data.Bifunctor                      (first) import           Data.ByteString                     (ByteString) import qualified Data.ByteString.Base16              as Hex import qualified Data.ByteString.Base64.URL          as B64 import           Data.Foldable                       (toList) import           Data.Set                            (Set) import qualified Data.Set                            as Set-import           Data.Text                           (Text)+import           Data.Text                           (Text, unpack)  import           Auth.Biscuit.Crypto                 (PublicKey, SecretKey,-                                                      convert,                                                       generateSecretKey,-                                                      maybeCryptoError,-                                                      publicKey, secretKey,-                                                      toPublic)+                                                      pkBytes,+                                                      readEd25519PublicKey,+                                                      readEd25519SecretKey,+                                                      skBytes, toPublic) import           Auth.Biscuit.Datalog.AST            (Authorizer, Block,                                                       FromValue (..), Term,                                                       Term' (..), ToTerm (..),@@ -120,17 +133,18 @@ import           Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess (..),                                                       getBindings,                                                       getSingleVariableValue,-                                                      getVariableValues,-                                                      queryAuthorizerFacts)-import           Auth.Biscuit.Token                  (Biscuit,+                                                      getVariableValues)+import           Auth.Biscuit.Token                  (AuthorizedBiscuit (..),+                                                      Biscuit,                                                       BiscuitEncoding (..),                                                       BiscuitProof (..), Open,                                                       OpenOrSealed,                                                       ParseError (..),                                                       ParserConfig (..), Sealed,                                                       Unverified, Verified,-                                                      addBlock, asOpen,-                                                      asSealed,+                                                      addBlock, addSignedBlock,+                                                      applyThirdPartyBlock,+                                                      asOpen, asSealed,                                                       authorizeBiscuit,                                                       authorizeBiscuitWithLimits,                                                       checkBiscuitSignatures,@@ -138,14 +152,19 @@                                                       getRevocationIds,                                                       getVerifiedBiscuitPublicKey,                                                       mkBiscuit, mkBiscuitWith,+                                                      mkThirdPartyBlock,+                                                      mkThirdPartyBlockReq,                                                       parseBiscuitUnverified,-                                                      parseBiscuitWith, seal,-                                                      serializeBiscuit)+                                                      parseBiscuitWith,+                                                      queryAuthorizerFacts,+                                                      queryRawBiscuitFacts,+                                                      seal, serializeBiscuit)+import qualified Data.Text                           as Text   -- $biscuitOverview ----- <https://github.com/CleverCloud/biscuit/blob/master/SUMMARY.md Biscuit> is a /bearer token/,+-- <https://github.com/biscuit-auth/biscuit/blob/master/SUMMARY.md Biscuit> is a /bearer token/, -- allowing /offline attenuation/ (meaning that anyone having a token can craft a new, more -- restricted token), -- and /'PublicKey' verification/. Token rights and attenuation are expressed using a logic@@ -204,25 +223,23 @@ -- >     Left e -> print e $> False -- >     Right biscuit -> do -- >       now <- getCurrentTime--- >       let verif = [authorizer|+-- >       let authorizer' = [authorizer| -- >                // the datalog snippets can reference haskell variables--- >                // with the ${variableName} syntax--- >                time(${now});+-- >                // with the {variableName} syntax+-- >                time({now}); -- > -- >                // policies are tried in order. The first matching policy -- >                // will decide if the token is valid or not. If no policies -- >                // match, the token will fail validation -- >                allow if resource("file1");--- >                // catch-all policy if the previous ones did not match--- >                deny if true; -- >             |]--- >       result <- authorizeBiscuit biscuit [authorizer|current_time()|]+-- >       result <- authorizeBiscuit biscuit authorizer' -- >       case result of -- >         Left e -> print e $> False -- >         Right _ -> pure True --- | Build a block containing an explicit context value.--- The context of a block can't be parsed from datalog currently,+-- | Build a block containing an explicit freeform context value.+-- The context of a block can't be parsed from datalog, -- so you'll need an explicit call to `blockContext` to add it -- -- >     [block|check if time($t), $t < 2021-01-01;|]@@ -232,7 +249,7 @@  -- | Decode a base16-encoded bytestring, reporting errors via `MonadFail` fromHex :: MonadFail m => ByteString -> m ByteString-fromHex = either fail pure . Hex.decode+fromHex = either (fail . Text.unpack) pure . Hex.decodeBase16  -- $keypairs --@@ -248,23 +265,23 @@  -- | Serialize a 'SecretKey' to raw bytes, without any encoding serializeSecretKey :: SecretKey -> ByteString-serializeSecretKey = convert+serializeSecretKey = skBytes  -- | Serialize a 'PublicKey' to raw bytes, without any encoding serializePublicKey :: PublicKey -> ByteString-serializePublicKey = convert+serializePublicKey = pkBytes  -- | Serialize a 'SecretKey' to a hex-encoded bytestring serializeSecretKeyHex :: SecretKey -> ByteString-serializeSecretKeyHex = Hex.encode . convert+serializeSecretKeyHex = Hex.encodeBase16' . skBytes  -- | Serialize a 'PublicKey' to a hex-encoded bytestring serializePublicKeyHex :: PublicKey -> ByteString-serializePublicKeyHex = Hex.encode . convert+serializePublicKeyHex = Hex.encodeBase16' . pkBytes  -- | Read a 'SecretKey' from raw bytes parseSecretKey :: ByteString -> Maybe SecretKey-parseSecretKey = maybeCryptoError . secretKey+parseSecretKey = readEd25519SecretKey  -- | Read a 'SecretKey' from an hex bytestring parseSecretKeyHex :: ByteString -> Maybe SecretKey@@ -272,7 +289,7 @@  -- | Read a 'PublicKey' from raw bytes parsePublicKey :: ByteString -> Maybe PublicKey-parsePublicKey = maybeCryptoError . publicKey+parsePublicKey = readEd25519PublicKey  -- | Read a 'PublicKey' from an hex bytestring parsePublicKeyHex :: ByteString -> Maybe PublicKey@@ -336,6 +353,28 @@ serializeB64 :: BiscuitProof p => Biscuit p Verified -> ByteString serializeB64 = B64.encodeBase64' . serialize +-- | Generate a base64-encoded third-party block request. It can be used in+-- conjunction with 'mkThirdPartyBlockB64' to generate a base64-encoded+-- third-party block, which can be then appended to a token with+-- 'applyThirdPartyBlockB64'.+mkThirdPartyBlockReqB64 :: Biscuit Open c -> ByteString+mkThirdPartyBlockReqB64 = B64.encodeBase64' . mkThirdPartyBlockReq++-- | Given a base64-encoded third-party block request, generate a base64-encoded+-- third-party block, which can be then appended to a token with+-- 'applyThirdPartyBlockB64'.+mkThirdPartyBlockB64 :: SecretKey -> ByteString -> Block -> Either String ByteString+mkThirdPartyBlockB64 sk reqB64 b = do+  req <- first unpack $ B64.decodeBase64 reqB64+  contents <- mkThirdPartyBlock sk req b+  pure $ B64.encodeBase64' contents++-- | Given a base64-encoded third-party block, append it to a token.+applyThirdPartyBlockB64 :: Biscuit Open check -> ByteString -> Either String (IO (Biscuit Open check))+applyThirdPartyBlockB64 b contentsB64 = do+  contents <- first unpack $ B64.decodeBase64 contentsB64+  applyThirdPartyBlock b contents+ -- $biscuitBlocks -- -- The core of a biscuit is its authority block. This block declares facts and rules and@@ -352,6 +391,34 @@ -- By default, biscuits can be /attenuated/. It means that any party that holds a biscuit can -- craft a new biscuit with fewer rights. A common example is taking a long-lived biscuit and -- adding a short TTL right before sending it over the wire.++-- $thirdPartyBlocks+--+-- Regular blocks can be added by anyone and as such can only /attenuate/ a token: the facts+-- they carry are not visible outside themselves, only their checks are evaluated.+--+-- Third-party blocks lift this limitation by carrying an extra signature, crafted with a+-- dedicated keypair. This way, the token authorizer (as well as blocks themselves) can+-- opt-in to trust facts coming from third-party blocks signed with specific keypairs.+--+-- For instance, adding `check if group("admin") trusting {publicKey};` to a token will+-- make it usable only if it carries a third party-block signed by the corresponding keypair,+-- and carrying a `group("admin")` fact.+--+-- Since it is not desirable to share the token with the external entity providing the third-party+-- block, a request mechanism is available:+--+-- - the token holder generates a /third-party block request/ from the token (it contains technical+--   information needed to generate a third-party block) with 'mkThirdPartyBlockReq';+-- - the token holder forwards this request to the external entity;+-- - the external entity uses this request, a 'Block' value, and a 'SecretKey' to generate a third-party+--   block, with 'mkThirdPartyBlock';+-- - the external entity sends this block back to the token holder;+-- - the token holder can now add the block to the token with 'applyThirdPartyBlock'.+--+-- In some cases, the party holding the token is also the one who's adding the third-party block. It+-- is then possible to directly use 'addSignedBlock' to append a third-party block to the token without+-- having to go through generating a third-party block request.  -- $sealedBiscuits --

@@ -1,39 +1,109 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeApplications           #-} module Auth.Biscuit.Crypto   ( SignedBlock   , Blocks   , signBlock+  , signExternalBlock+  , sign3rdPartyBlock   , verifyBlocks   , verifySecretProof   , verifySignatureProof   , getSignatureProof--  -- Ed25519 reexports+  , verifyExternalSig   , PublicKey+  , pkBytes+  , readEd25519PublicKey   , SecretKey+  , skBytes+  , readEd25519SecretKey   , Signature-  , convert-  , publicKey-  , secretKey+  , sigBytes   , signature-  , eitherCryptoError-  , maybeCryptoError   , generateSecretKey   , toPublic+  , sign   ) where -import           Control.Arrow         ((&&&))-import           Crypto.Error          (eitherCryptoError, maybeCryptoError)-import           Crypto.PubKey.Ed25519-import           Data.ByteArray        (convert)-import           Data.ByteString       (ByteString)-import           Data.Int              (Int32)-import           Data.List.NonEmpty    (NonEmpty (..))-import qualified Data.List.NonEmpty    as NE+import           Control.Arrow              ((&&&))+import           Crypto.Error               (maybeCryptoError)+import qualified Crypto.PubKey.Ed25519      as Ed25519+import           Data.ByteArray             (convert)+import           Data.ByteString            (ByteString)+import           Data.Function              (on)+import           Data.Int                   (Int32)+import           Data.List.NonEmpty         (NonEmpty (..))+import qualified Data.List.NonEmpty         as NE+import           Data.Maybe                 (catMaybes, fromJust)+import           Instances.TH.Lift          ()+import           Language.Haskell.TH.Syntax -import qualified Auth.Biscuit.Proto    as PB-import qualified Data.Serialize        as PB+import qualified Auth.Biscuit.Proto         as PB+import qualified Data.Serialize             as PB -type SignedBlock = (ByteString, Signature, PublicKey)+newtype PublicKey = PublicKey Ed25519.PublicKey+  deriving newtype (Eq, Show)++instance Ord PublicKey where+  compare = compare `on` serializePublicKey++instance Lift PublicKey where+  lift pk = [| fromJust $ readEd25519PublicKey $(lift $ pkBytes pk) |]+#if MIN_VERSION_template_haskell(2,17,0)+  liftTyped = liftCode . unsafeTExpCoerce . lift+#else+  liftTyped = unsafeTExpCoerce . lift+#endif++newtype SecretKey = SecretKey Ed25519.SecretKey+  deriving newtype (Eq, Show)+newtype Signature = Signature ByteString+  deriving newtype (Eq, Show)++signature :: ByteString -> Signature+signature = Signature++sigBytes :: Signature -> ByteString+sigBytes (Signature b) = b++readEd25519PublicKey :: ByteString -> Maybe PublicKey+readEd25519PublicKey bs = PublicKey <$> maybeCryptoError (Ed25519.publicKey bs)++readEd25519SecretKey :: ByteString -> Maybe SecretKey+readEd25519SecretKey bs = SecretKey <$> maybeCryptoError (Ed25519.secretKey bs)++readEd25519Signature :: Signature -> Maybe Ed25519.Signature+readEd25519Signature (Signature bs) = maybeCryptoError (Ed25519.signature bs)++-- | Generate a public key from a secret key+toPublic :: SecretKey -> PublicKey+toPublic (SecretKey sk) = PublicKey $ Ed25519.toPublic sk++generateSecretKey :: IO SecretKey+generateSecretKey = SecretKey <$> Ed25519.generateSecretKey++sign :: SecretKey -> PublicKey -> ByteString -> Signature+sign (SecretKey sk) (PublicKey pk) payload =+  Signature . convert $ Ed25519.sign sk pk payload++verify :: PublicKey -> ByteString -> Signature -> Bool+verify (PublicKey pk) payload sig =+  case readEd25519Signature sig of+    Just sig' -> Ed25519.verify pk payload sig'+    Nothing   -> False++pkBytes :: PublicKey -> ByteString+pkBytes (PublicKey pk) = convert pk++skBytes :: SecretKey -> ByteString+skBytes (SecretKey sk) = convert sk++type SignedBlock = (ByteString, Signature, PublicKey, Maybe (Signature, PublicKey)) type Blocks = NonEmpty SignedBlock  -- | Biscuit 2.0 allows multiple signature algorithms.@@ -44,7 +114,7 @@ -- signatures, and the final signature for sealed tokens). serializePublicKey :: PublicKey -> ByteString serializePublicKey pk =-  let keyBytes = convert pk+  let keyBytes = pkBytes pk       algId :: Int32       algId = fromIntegral $ fromEnum PB.Ed25519       -- The spec mandates that we serialize the algorithm id as a little-endian int32@@ -53,31 +123,64 @@  signBlock :: SecretKey           -> ByteString+          -> Maybe (Signature, PublicKey)           -> IO (SignedBlock, SecretKey)-signBlock sk payload = do+signBlock sk payload eSig = do   let pk = toPublic sk   (nextPk, nextSk) <- (toPublic &&& id) <$> generateSecretKey-  let toSign = payload <> serializePublicKey nextPk+  let toSign = getToSig (payload, (), nextPk, eSig)       sig = sign sk pk toSign-  pure ((payload, sig, nextPk), nextSk)+  pure ((payload, sig, nextPk, eSig), nextSk) +signExternalBlock :: SecretKey+                  -> SecretKey+                  -> PublicKey+                  -> ByteString+                  -> IO (SignedBlock, SecretKey)+signExternalBlock sk eSk pk payload =+  let eSig = sign3rdPartyBlock eSk pk payload+   in signBlock sk payload (Just eSig)++sign3rdPartyBlock :: SecretKey+                  -> PublicKey+                  -> ByteString+                  -> (Signature, PublicKey)+sign3rdPartyBlock eSk nextPk payload =+  let toSign = payload <> serializePublicKey nextPk+      ePk = toPublic eSk+      eSig = sign eSk ePk toSign+   in (eSig, ePk)+ getSignatureProof :: SignedBlock -> SecretKey -> Signature-getSignatureProof (lastPayload, lastSig, lastPk) nextSecret =+getSignatureProof (lastPayload, Signature lastSig, lastPk, _todo) nextSecret =   let sk = nextSecret       pk = toPublic nextSecret-      toSign = lastPayload <> serializePublicKey lastPk <> convert lastSig+      toSign = lastPayload <> serializePublicKey lastPk <> lastSig    in sign sk pk toSign -getToSig :: (ByteString, a, PublicKey) -> ByteString-getToSig (p, _, nextPk) =-    p <> serializePublicKey nextPk+getToSig :: (ByteString, a, PublicKey, Maybe (Signature, PublicKey)) -> ByteString+getToSig (p, _, nextPk, ePk) =+  p <> foldMap (sigBytes . fst) ePk <> serializePublicKey nextPk  getSignature :: SignedBlock -> Signature-getSignature (_, sig, _) = sig+getSignature (_, sig, _, _) = sig  getPublicKey :: SignedBlock -> PublicKey-getPublicKey (_, _, pk) = pk+getPublicKey (_, _, pk, _) = pk +-- | The data signed by the external key is the payload for the current block + the public key from+-- the previous block: this prevents signature reuse (the external signature cannot be used on another+-- token)+getExternalSigPayload :: PublicKey -> SignedBlock -> Maybe (PublicKey, ByteString, Signature)+getExternalSigPayload pkN (payload, _, _, Just (eSig, ePk)) = Just (ePk, payload <> serializePublicKey pkN, eSig)+getExternalSigPayload _ _ = Nothing++-- | When adding a pre-signed third-party block to a token, we make sure the third-party block is correctly+-- signed (pk-signature match, and the third-party block is pinned to the last biscuit block)+verifyExternalSig :: PublicKey -> (ByteString, Signature, PublicKey) -> Bool+verifyExternalSig previousPk (payload, eSig, ePk) =+  verify ePk (payload <> serializePublicKey previousPk) eSig+ verifyBlocks :: Blocks              -> PublicKey              -> Bool@@ -90,17 +193,25 @@       -- key for block n is the key from block (n - 1)       keys = pure rootPk <> (getPublicKey <$> blocks)       keysPayloadsSigs = NE.zipWith attachKey keys (NE.zip toSigs sigs)-   in all (uncurry3 verify) keysPayloadsSigs +      -- external_signature(block_n) = sign(external_key_n, payload_n <> public_key_n-1)+      -- so we need to pair each block with the public key carried by the previous block+      -- (the authority block can't have an external signature)+      previousKeys = getPublicKey <$> NE.init blocks+      blocksAfterAuthority = NE.tail blocks+      eKeysPayloadsESigs = catMaybes $ zipWith getExternalSigPayload previousKeys blocksAfterAuthority+   in  all (uncurry3 verify) keysPayloadsSigs+    && all (uncurry3 verify) eKeysPayloadsESigs+ verifySecretProof :: SecretKey                   -> SignedBlock                   -> Bool-verifySecretProof nextSecret (_, _, lastPk) =+verifySecretProof nextSecret (_, _, lastPk, _) =   lastPk == toPublic nextSecret  verifySignatureProof :: Signature                      -> SignedBlock                      -> Bool-verifySignatureProof extraSig (lastPayload, lastSig, lastPk) =-  let toSign = lastPayload <> serializePublicKey lastPk <> convert lastSig+verifySignatureProof extraSig (lastPayload, Signature lastSig, lastPk, _) =+  let toSign = lastPayload <> serializePublicKey lastPk <> lastSig    in verify lastPk toSign extraSig

@@ -1,3 +1,4 @@+{-# LANGUAGE ApplicativeDo              #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE DeriveLift                 #-}@@ -6,9 +7,11 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE NamedFieldPuns             #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeApplications           #-}@@ -25,10 +28,13 @@   (     Binary (..)   , Block+  , EvalBlock   , Block' (..)   , BlockElement' (..)+  , CheckKind (..)   , Check-  , Check'+  , EvalCheck+  , Check' (..)   , Expression   , Expression' (..)   , Fact@@ -38,8 +44,10 @@   , Term' (..)   , IsWithinSet (..)   , Op (..)-  , ParsedAs (..)+  , DatalogContext (..)+  , EvaluationContext (..)   , Policy+  , EvalPolicy   , Policy'   , PolicyType (..)   , Predicate@@ -50,76 +58,143 @@   , Query'   , QueryItem' (..)   , Rule+  , EvalRule   , Rule' (..)-  , RuleScope (..)+  , RuleScope' (..)+  , RuleScope+  , EvalRuleScope   , SetType   , Slice (..)+  , PkOrSlice (..)   , SliceType+  , BlockIdType   , Unary (..)   , Value   , VariableType   , Authorizer   , Authorizer' (..)   , AuthorizerElement' (..)+  , ToEvaluation (..)+  , makeRule+  , makeQueryItem+  , checkToEvaluation+  , policyToEvaluation   , elementToBlock   , elementToAuthorizer+  , extractVariables   , fromStack   , listSymbolsInBlock+  , listPublicKeysInBlock+  , queryHasNoScope+  , queryHasNoV4Operators+  , ruleHasNoScope+  , ruleHasNoV4Operators+  , isCheckOne   , renderBlock+  , renderAuthorizer   , renderFact   , renderRule-  , toSetTerm+  , valueToSetTerm   , toStack+  , substituteAuthorizer+  , substituteBlock+  , substituteCheck+  , substituteExpression+  , substituteFact+  , substitutePolicy+  , substitutePredicate+  , substitutePTerm+  , substituteQuery+  , substituteRule+  , substituteTerm   ) where  import           Control.Applicative        ((<|>)) import           Control.Monad              ((<=<)) import           Data.ByteString            (ByteString) import           Data.ByteString.Base16     as Hex-import           Data.Foldable              (fold)+import           Data.Foldable              (fold, toList)+import           Data.Function              (on)+import           Data.List.NonEmpty         (NonEmpty, nonEmpty)+import           Data.Map.Strict            (Map)+import qualified Data.Map.Strict            as Map+import           Data.Maybe                 (mapMaybe) import           Data.Set                   (Set) import qualified Data.Set                   as Set import           Data.String                (IsString) import           Data.Text                  (Text, intercalate, pack, unpack)-import           Data.Text.Encoding         (decodeUtf8)-import           Data.Time                  (UTCTime)+import           Data.Time                  (UTCTime, defaultTimeLocale,+                                             formatTime) import           Data.Void                  (Void, absurd) import           Instances.TH.Lift          () import           Language.Haskell.TH import           Language.Haskell.TH.Syntax import           Numeric.Natural            (Natural)+import           Validation                 (Validation (..), failure) +import           Auth.Biscuit.Crypto        (PublicKey, pkBytes)+ data IsWithinSet = NotWithinSet | WithinSet-data ParsedAs = RegularString | QuasiQuote+data DatalogContext+  = WithSlices+  -- ^ Intermediate Datalog representation, which may contain references+  -- to external variables (currently, only sliced in through TemplateHaskell,+  -- but it could also be done at runtime, a bit like parameter substitution in+  -- SQL queries)+  | Representation+  -- ^ A datalog representation faithful to its text display. There are no external+  -- variables, and the authorized blocks are identified through their public keys++data EvaluationContext = Repr | Eval+ data PredicateOrFact = InPredicate | InFact  type family VariableType (inSet :: IsWithinSet) (pof :: PredicateOrFact) where   VariableType 'NotWithinSet 'InPredicate = Text   VariableType inSet          pof         = Void -newtype Slice = Slice String+newtype Slice = Slice Text   deriving newtype (Eq, Show, Ord, IsString)  instance Lift Slice where-  lift (Slice name) = [| toTerm $(varE $ mkName name) |]+  lift (Slice name) = [| toTerm $(varE $ mkName $ unpack 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-  SliceType 'QuasiQuote    = Slice+type family SliceType (ctx :: DatalogContext) where+  SliceType 'Representation = Void+  SliceType 'WithSlices     = Slice -type family SetType (inSet :: IsWithinSet) (ctx :: ParsedAs) where+data PkOrSlice+  = PkSlice Text+  | Pk PublicKey+  deriving (Eq, Show, Ord)++instance Lift PkOrSlice where+  lift (PkSlice name) = [| $(varE $ mkName $ unpack name) |]+  lift (Pk pk)        = [| pk |]+#if MIN_VERSION_template_haskell(2,17,0)+  liftTyped = liftCode . unsafeTExpCoerce . lift+#else+  liftTyped = unsafeTExpCoerce . lift+#endif++type family SetType (inSet :: IsWithinSet) (ctx :: DatalogContext) where   SetType 'NotWithinSet ctx = Set (Term' 'WithinSet 'InFact ctx)   SetType 'WithinSet    ctx = Void +type family BlockIdType (evalCtx :: EvaluationContext) (ctx :: DatalogContext) where+  BlockIdType 'Repr 'WithSlices     = PkOrSlice+  BlockIdType 'Repr 'Representation = PublicKey+  BlockIdType 'Eval 'Representation = (Set Natural, PublicKey)+ -- | A single datalog item. -- | This can be a value, a set of items, or a slice (a value that will be injected later), -- | depending on the context-data Term' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: ParsedAs) =+data Term' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: DatalogContext) =     Variable (VariableType inSet pof)   -- ^ A variable (eg. @$0@)   | LInteger Int@@ -133,7 +208,7 @@   | LBool Bool   -- ^ A bool literal (eg. @true@)   | Antiquote (SliceType ctx)-  -- ^ A slice (eg. @${name}@)+  -- ^ A slice (eg. @{name}@)   | TermSet (SetType inSet ctx)   -- ^ A set (eg. @[true, false]@) @@ -153,13 +228,13 @@                   ) => Show (Term' inSet pof ctx)  -- | In a regular AST, slices have already been eliminated-type Term = Term' 'NotWithinSet 'InPredicate 'RegularString--- | In an AST parsed from a QuasiQuoter, there might be references to haskell variables-type QQTerm = Term' 'NotWithinSet 'InPredicate 'QuasiQuote+type Term = Term' 'NotWithinSet 'InPredicate 'Representation+-- | In an AST parsed from a WithSlicesr, there might be references to haskell variables+type QQTerm = Term' 'NotWithinSet 'InPredicate 'WithSlices -- | A term that is not a variable-type Value = Term' 'NotWithinSet 'InFact 'RegularString+type Value = Term' 'NotWithinSet 'InFact 'Representation -- | An element of a set-type SetValue = Term' 'WithinSet 'InFact 'RegularString+type SetValue = Term' 'WithinSet 'InFact 'Representation  instance  ( Lift (VariableType inSet pof)           , Lift (SetType inSet ctx)@@ -183,62 +258,65 @@  -- | 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-class ToTerm t where+class ToTerm t inSet pof where   -- | How to turn a value into a datalog item-  toTerm :: t -> Term' inSet pof 'RegularString+  toTerm :: t -> Term' inSet pof 'Representation  -- | This class describes how to turn a datalog value into a regular haskell value. class FromValue t where   fromValue :: Value -> Maybe t -instance ToTerm Int where+instance ToTerm Int inSet pof where   toTerm = LInteger  instance FromValue Int where   fromValue (LInteger v) = Just v   fromValue _            = Nothing -instance ToTerm Integer where+instance ToTerm Integer inSet pof where   toTerm = LInteger . fromIntegral  instance FromValue Integer where   fromValue (LInteger v) = Just (fromIntegral v)   fromValue _            = Nothing -instance ToTerm Text where+instance ToTerm Text inSet pof where   toTerm = LString  instance FromValue Text where   fromValue (LString t) = Just t   fromValue _           = Nothing -instance ToTerm Bool where+instance ToTerm Bool inSet pof where   toTerm = LBool  instance FromValue Bool where   fromValue (LBool b) = Just b   fromValue _         = Nothing -instance ToTerm ByteString where+instance ToTerm ByteString inSet pof where   toTerm = LBytes  instance FromValue ByteString where   fromValue (LBytes bs) = Just bs   fromValue _           = Nothing -instance ToTerm UTCTime where+instance ToTerm UTCTime inSet pof where   toTerm = LDate  instance FromValue UTCTime where   fromValue (LDate t) = Just t   fromValue _         = Nothing +instance (Foldable f, ToTerm a 'WithinSet 'InFact) => ToTerm (f a) 'NotWithinSet pof where+  toTerm vs = TermSet . Set.fromList $ toTerm <$> toList vs+ instance FromValue Value where   fromValue = Just -toSetTerm :: Value-          -> Maybe (Term' 'WithinSet 'InFact 'RegularString)-toSetTerm = \case+valueToSetTerm :: Value+               -> Maybe (Term' 'WithinSet 'InFact 'Representation)+valueToSetTerm = \case   LInteger i  -> Just $ LInteger i   LString i   -> Just $ LString i   LDate i     -> Just $ LDate i@@ -248,6 +326,17 @@   Variable v  -> absurd v   Antiquote v -> absurd v +valueToTerm :: Value -> Term+valueToTerm = \case+  LInteger i  -> LInteger i+  LString i   -> LString i+  LDate i     -> LDate i+  LBytes i    -> LBytes i+  LBool i     -> LBool i+  TermSet i   -> TermSet i+  Variable v  -> absurd v+  Antiquote v -> absurd v+ renderId' :: (VariableType inSet pof -> Text)           -> (SetType inSet ctx -> Text)           -> (SliceType ctx -> Text)@@ -256,11 +345,11 @@   Variable name -> var name   LInteger int  -> pack $ show int   LString str   -> pack $ show str-  LDate time    -> pack $ show time-  LBytes bs     -> "hex:" <> decodeUtf8 (Hex.encode bs)+  LDate time    -> pack $ formatTime defaultTimeLocale "%FT%T%Q%Ez" time+  LBytes bs     -> "hex:" <> Hex.encodeBase16 bs   LBool True    -> "true"   LBool False   -> "false"-  TermSet terms -> set terms -- "[" <> intercalate "," (renderInnerId <$> Set.toList terms) <> "]"+  TermSet terms -> set terms   Antiquote v   -> slice v  renderSet :: (SliceType ctx -> Text)@@ -272,7 +361,7 @@ renderId :: Term -> Text renderId = renderId' ("$" <>) (renderSet absurd) absurd -renderFactId :: Term' 'NotWithinSet 'InFact 'RegularString -> Text+renderFactId :: Term' 'NotWithinSet 'InFact 'Representation -> Text renderFactId = renderId' absurd (renderSet absurd) absurd  listSymbolsInTerm :: Term -> Set.Set Text@@ -299,7 +388,7 @@   Antiquote v -> absurd v   _           -> mempty -data Predicate' (pof :: PredicateOrFact) (ctx :: ParsedAs) = Predicate+data Predicate' (pof :: PredicateOrFact) (ctx :: DatalogContext) = Predicate   { name  :: Text   , terms :: [Term' 'NotWithinSet pof ctx]   }@@ -313,8 +402,8 @@  deriving instance Lift (Term' 'NotWithinSet pof ctx) => Lift (Predicate' pof ctx) -type Predicate = Predicate' 'InPredicate 'RegularString-type Fact = Predicate' 'InFact 'RegularString+type Predicate = Predicate' 'InPredicate 'Representation+type Fact = Predicate' 'InFact 'Representation  renderPredicate :: Predicate -> Text renderPredicate Predicate{name,terms} =@@ -334,46 +423,105 @@      Set.singleton name   <> foldMap listSymbolsInTerm terms -data QueryItem' ctx = QueryItem+data QueryItem' evalCtx ctx = QueryItem   { qBody        :: [Predicate' 'InPredicate ctx]   , qExpressions :: [Expression' ctx]-  , qScope       :: Maybe RuleScope+  , qScope       :: Set (RuleScope' evalCtx ctx)   } -type Query' ctx = [QueryItem' ctx]-type Query = Query' 'RegularString+type Query' evalCtx ctx = [QueryItem' evalCtx ctx]+type Query = Query' 'Repr 'Representation -type Check' ctx = Query' ctx-type Check = Query+queryHasNoScope :: Query -> Bool+queryHasNoScope = all (Set.null . qScope)++queryHasNoV4Operators :: Query -> Bool+queryHasNoV4Operators =+  all (all expressionHasNoV4Operators . qExpressions)++makeQueryItem :: [Predicate' 'InPredicate ctx]+              -> [Expression' ctx]+              -> Set (RuleScope' 'Repr ctx)+              -> Validation (NonEmpty Text) (QueryItem' 'Repr ctx)+makeQueryItem qBody qExpressions qScope =+  let boundVariables = extractVariables qBody+      exprVariables = foldMap extractExprVariables qExpressions+      unboundVariables = exprVariables `Set.difference` boundVariables+   in case nonEmpty (Set.toList unboundVariables) of+        Nothing -> pure QueryItem{..}+        Just vs -> Failure vs+++data CheckKind = One | All+  deriving (Eq, Show, Ord, Lift)++data Check' evalCtx ctx = Check+  { cQueries :: Query' evalCtx ctx+  , cKind    :: CheckKind+  }+deriving instance ( Eq (QueryItem' evalCtx ctx)+                  ) => Eq (Check' evalCtx ctx)+deriving instance ( Ord (QueryItem' evalCtx ctx)+                  ) => Ord (Check' evalCtx ctx)+deriving instance ( Show (QueryItem' evalCtx ctx)+                  ) => Show (Check' evalCtx ctx)+deriving instance ( Lift (QueryItem' evalCtx ctx)+                  ) => Lift (Check' evalCtx ctx)++type Check = Check' 'Repr 'Representation+type EvalCheck = Check' 'Eval 'Representation++isCheckOne :: Check' evalCtx ctx -> Bool+isCheckOne Check{cKind} = cKind == One+ data PolicyType = Allow | Deny   deriving (Eq, Show, Ord, Lift)-type Policy' ctx = (PolicyType, Query' ctx)-type Policy = (PolicyType, Query)+type Policy' evalCtx ctx = (PolicyType, Query' evalCtx ctx)+type Policy = Policy' 'Repr 'Representation+type EvalPolicy = Policy' 'Eval 'Representation  deriving instance ( Eq (Predicate' 'InPredicate ctx)                   , Eq (Expression' ctx)-                  ) => Eq (QueryItem' ctx)+                  , Eq (RuleScope' evalCtx ctx)+                  ) => Eq (QueryItem' evalCtx ctx) deriving instance ( Ord (Predicate' 'InPredicate ctx)                   , Ord (Expression' ctx)-                  ) => Ord (QueryItem' ctx)+                  , Ord (RuleScope' evalCtx ctx)+                  ) => Ord (QueryItem' evalCtx ctx) deriving instance ( Show (Predicate' 'InPredicate ctx)                   , Show (Expression' ctx)-                  ) => Show (QueryItem' ctx)+                  , Show (RuleScope' evalCtx ctx)+                  ) => Show (QueryItem' evalCtx ctx)+deriving instance ( Lift (Predicate' 'InPredicate ctx)+                  , Lift (Expression' ctx)+                  , Lift (RuleScope' evalCtx ctx)+                  ) => Lift (QueryItem' evalCtx ctx) -deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (QueryItem' ctx)+renderPolicy :: Policy -> Text+renderPolicy (pType, query) =+  let prefix = case pType of+        Allow -> "allow if "+        Deny  -> "deny if "+   in prefix <> intercalate " or \n" (renderQueryItem <$> query) <> ";" -renderQueryItem :: QueryItem' 'RegularString -> Text+renderQueryItem :: QueryItem' 'Repr 'Representation -> Text renderQueryItem QueryItem{..} =-  intercalate ",\n" $ fold+  intercalate ",\n" (fold     [ renderPredicate <$> qBody     , renderExpression <$> qExpressions-    ]+    ])+  <> if null qScope then ""+                   else " trusting " <> renderRuleScope qScope  renderCheck :: Check -> Text-renderCheck is = "check if " <>-  intercalate "\n or " (renderQueryItem <$> is)+renderCheck Check{..} =+  let kindToken = case cKind of+        One -> "if"+        All -> "all"+   in "check " <> kindToken <> " " <>+      intercalate "\n or " (renderQueryItem <$> cQueries) -listSymbolsInQueryItem :: QueryItem' 'RegularString -> Set.Set Text+listSymbolsInQueryItem :: QueryItem' evalCtx 'Representation -> Set.Set Text listSymbolsInQueryItem QueryItem{..} =      Set.singleton "query" -- query items are serialized as `Rule`s                            -- so an empty rule head is added: `query()`@@ -384,46 +532,124 @@  listSymbolsInCheck :: Check -> Set.Set Text listSymbolsInCheck =-  foldMap listSymbolsInQueryItem+  foldMap listSymbolsInQueryItem . cQueries -data RuleScope  =+listPublicKeysInQueryItem :: QueryItem' 'Repr 'Representation -> Set.Set PublicKey+listPublicKeysInQueryItem QueryItem{qScope} =+  listPublicKeysInScope qScope++listPublicKeysInCheck :: Check -> Set.Set PublicKey+listPublicKeysInCheck = foldMap listPublicKeysInQueryItem . cQueries++type RuleScope = RuleScope' 'Repr 'Representation+type EvalRuleScope = RuleScope' 'Eval 'Representation++data RuleScope' (evalCtx :: EvaluationContext) (ctx :: DatalogContext) =     OnlyAuthority   | Previous-  | UnsafeAny-  | OnlyBlocks (Set Natural)-  deriving (Eq, Ord, Show, Lift)+  | BlockId (BlockIdType evalCtx ctx) -data Rule' ctx = Rule+deriving instance Eq (BlockIdType evalCtx ctx) => Eq (RuleScope' evalCtx ctx)+deriving instance Ord (BlockIdType evalCtx ctx) => Ord (RuleScope' evalCtx ctx)+deriving instance Show (BlockIdType evalCtx ctx) => Show (RuleScope' evalCtx ctx)+deriving instance Lift (BlockIdType evalCtx ctx) => Lift (RuleScope' evalCtx ctx)++listPublicKeysInScope :: Set.Set RuleScope -> Set.Set PublicKey+listPublicKeysInScope = foldMap $+  \case BlockId pk -> Set.singleton pk+        _          -> Set.empty+++data Rule' evalCtx ctx = Rule   { rhead       :: Predicate' 'InPredicate ctx   , body        :: [Predicate' 'InPredicate ctx]   , expressions :: [Expression' ctx]-  , scope       :: Maybe RuleScope+  , scope       :: Set (RuleScope' evalCtx ctx)   }  deriving instance ( Eq (Predicate' 'InPredicate ctx)                   , Eq (Expression' ctx)-                  ) => Eq (Rule' ctx)+                  , Eq (RuleScope' evalCtx ctx)+                  ) => Eq (Rule' evalCtx ctx) deriving instance ( Ord (Predicate' 'InPredicate ctx)                   , Ord (Expression' ctx)-                  ) => Ord (Rule' ctx)+                  , Ord (RuleScope' evalCtx ctx)+                  ) => Ord (Rule' evalCtx ctx) deriving instance ( Show (Predicate' 'InPredicate ctx)                   , Show (Expression' ctx)-                  ) => Show (Rule' ctx)+                  , Show (RuleScope' evalCtx ctx)+                  ) => Show (Rule' evalCtx ctx)+deriving instance ( Lift (Predicate' 'InPredicate ctx)+                  , Lift (Expression' ctx)+                  , Lift (RuleScope' evalCtx ctx)+                  ) => Lift (Rule' evalCtx ctx) -type Rule = Rule' 'RegularString+type Rule = Rule' 'Repr 'Representation+type EvalRule = Rule' 'Eval 'Representation -deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (Rule' ctx)+ruleHasNoScope :: Rule -> Bool+ruleHasNoScope Rule{scope} = Set.null scope -renderRule :: Rule' 'RegularString -> Text-renderRule Rule{rhead,body,expressions} =-  renderPredicate rhead <> " <- " <> intercalate ", " (fmap renderPredicate body <> fmap renderExpression expressions)+expressionHasNoV4Operators :: Expression -> Bool+expressionHasNoV4Operators = \case+  EBinary BitwiseAnd _ _ -> False+  EBinary BitwiseOr _ _  -> False+  EBinary BitwiseXor _ _ -> False+  EBinary _ l r -> expressionHasNoV4Operators l && expressionHasNoV4Operators r+  _ -> True +ruleHasNoV4Operators :: Rule -> Bool+ruleHasNoV4Operators Rule{expressions} =+  all expressionHasNoV4Operators expressions++renderRule :: Rule -> Text+renderRule Rule{rhead,body,expressions,scope} =+     renderPredicate rhead <> " <- "+  <> intercalate ", " (fmap renderPredicate body <> fmap renderExpression expressions)+  <> if null scope then ""+                   else " trusting " <> renderRuleScope scope+ listSymbolsInRule :: Rule -> Set.Set Text listSymbolsInRule Rule{..} =      listSymbolsInPredicate rhead   <> foldMap listSymbolsInPredicate body   <> foldMap listSymbolsInExpression expressions +listPublicKeysInRule :: Rule -> Set.Set PublicKey+listPublicKeysInRule Rule{scope} = listPublicKeysInScope scope++extractVariables :: [Predicate' 'InPredicate ctx] -> Set Text+extractVariables predicates =+  let keepVariable = \case+        Variable name -> Just name+        _             -> Nothing+      extractVariables' Predicate{terms} = mapMaybe keepVariable terms+   in Set.fromList $ extractVariables' =<< predicates++extractExprVariables :: Expression' ctx -> Set Text+extractExprVariables =+  let keepVariable = \case+        Variable name -> Set.singleton name+        _             -> Set.empty+   in \case+        EValue t       -> keepVariable t+        EUnary _ e     -> extractExprVariables e+        EBinary _ e e' -> ((<>) `on` extractExprVariables) e e'++makeRule :: Predicate' 'InPredicate ctx+         -> [Predicate' 'InPredicate ctx]+         -> [Expression' ctx]+         -> Set (RuleScope' 'Repr ctx)+         -> Validation (NonEmpty Text) (Rule' 'Repr ctx)+makeRule rhead body expressions scope =+  let boundVariables = extractVariables body+      exprVariables = foldMap extractExprVariables expressions+      headVariables = extractVariables [rhead]+      unboundVariables = (headVariables `Set.union` exprVariables) `Set.difference` boundVariables+   in case nonEmpty (Set.toList unboundVariables) of+        Nothing -> pure Rule{..}+        Just vs -> Failure vs+ data Unary =     Negate   | Parens@@ -448,9 +674,12 @@   | Or   | Intersection   | Union+  | BitwiseAnd+  | BitwiseOr+  | BitwiseXor   deriving (Eq, Ord, Show, Lift) -data Expression' (ctx :: ParsedAs) =+data Expression' (ctx :: DatalogContext) =     EValue (Term' 'NotWithinSet 'InPredicate ctx)   | EUnary Unary (Expression' ctx)   | EBinary Binary (Expression' ctx) (Expression' ctx)@@ -460,7 +689,7 @@ deriving instance Lift (Term' 'NotWithinSet 'InPredicate ctx) => Lift (Expression' ctx) deriving instance Show (Term' 'NotWithinSet 'InPredicate ctx) => Show (Expression' ctx) -type Expression = Expression' 'RegularString+type Expression = Expression' 'Representation  listSymbolsInExpression :: Expression -> Set.Set Text listSymbolsInExpression = \case@@ -526,6 +755,9 @@         EBinary Div e e'            -> rOp "/" e e'         EBinary And e e'            -> rOp "&&" e e'         EBinary Or e e'             -> rOp "||" e e'+        EBinary BitwiseAnd e e'     -> rOp "&" e e'+        EBinary BitwiseOr e e'      -> rOp "|" e e'+        EBinary BitwiseXor e e'     -> rOp "^" e e'  -- | A biscuit block, containing facts, rules and checks. --@@ -533,132 +765,366 @@ -- to build composite blocks (eg if you need to generate a list of facts): -- -- > -- build a block from multiple variables v1, v2, v3--- > [block| value(${v1}); |] <>--- > [block| value(${v2}); |] <>--- > [block| value(${v3}); |]-type Block = Block' 'RegularString+-- > [block| value({v1}); |] <>+-- > [block| value({v2}); |] <>+-- > [block| value({v3}); |]+type Block = Block' 'Repr 'Representation+type EvalBlock = Block' 'Eval 'Representation  -- | A biscuit block, that may or may not contain slices referencing -- haskell variables-data Block' (ctx :: ParsedAs) = Block-  { bRules   :: [Rule' ctx]+data Block' (evalCtx :: EvaluationContext) (ctx :: DatalogContext) = Block+  { bRules   :: [Rule' evalCtx ctx]   , bFacts   :: [Predicate' 'InFact ctx]-  , bChecks  :: [Check' ctx]+  , bChecks  :: [Check' evalCtx ctx]   , bContext :: Maybe Text-  , bScope   :: Maybe RuleScope+  , bScope   :: Set (RuleScope' evalCtx ctx)   } -renderBlock :: Block -> Text-renderBlock Block{..} =-  intercalate ";\n" $ fold-    [ renderRule <$> bRules-    , renderFact <$> bFacts-    , renderCheck <$> bChecks-    ]- deriving instance ( Eq (Predicate' 'InFact ctx)-                  , Eq (Rule' ctx)-                  , Eq (QueryItem' ctx)-                  ) => Eq (Block' ctx)+                  , Eq (Rule' evalCtx ctx)+                  , Eq (QueryItem' evalCtx ctx)+                  , Eq (RuleScope' evalCtx ctx)+                  ) => Eq (Block' evalCtx ctx)+deriving instance ( Lift (Predicate' 'InFact ctx)+                  , Lift (Rule' evalCtx ctx)+                  , Lift (QueryItem' evalCtx ctx)+                  , Lift (RuleScope' evalCtx ctx)+                  ) => Lift (Block' evalCtx ctx) --- deriving instance ( Show (Predicate' 'InFact ctx)---                   , Show (Rule' ctx)---                   , Show (QueryItem' ctx)---                   ) => Show (Block' ctx) instance Show Block where   show = unpack . renderBlock -deriving instance ( Lift (Predicate' 'InFact ctx)-                  , Lift (Rule' ctx)-                  , Lift (QueryItem' ctx)-                  ) => Lift (Block' ctx)--instance Semigroup (Block' ctx) where+instance Semigroup (Block' evalCtx ctx) where   b1 <> b2 = Block { bRules = bRules b1 <> bRules b2                    , bFacts = bFacts b1 <> bFacts b2                    , bChecks = bChecks b1 <> bChecks b2                    , bContext = bContext b2 <|> bContext b1-                   , bScope = bScope b1 <|> bScope b2+                   -- `trusting` declarations in blocks override+                   -- each other, they don't accumulate+                   , bScope = if null (bScope b1)+                              then bScope b2+                              else bScope b1                    } -instance Monoid (Block' ctx) where+instance Monoid (Block' evalCtx ctx) where   mempty = Block { bRules = []                  , bFacts = []                  , bChecks = []                  , bContext = Nothing-                 , bScope = Nothing+                 , bScope = Set.empty                  } -listSymbolsInBlock :: Block' 'RegularString -> Set.Set Text+renderRuleScope :: Set RuleScope -> Text+renderRuleScope =+  let renderScopeElem = \case+        OnlyAuthority -> "authority"+        Previous      -> "previous"+        BlockId bs    -> "ed25519/" <> Hex.encodeBase16 (pkBytes bs)+   in intercalate ", " . Set.toList . Set.map renderScopeElem++renderBlock :: Block -> Text+renderBlock Block{..} =+  let renderScopeLine = ("trusting " <>) . renderRuleScope+   in foldMap (<> ";\n") $ fold+         [ [renderScopeLine bScope | not (null bScope)]+         , renderRule <$> bRules+         , renderFact <$> bFacts+         , renderCheck <$> bChecks+         ]++listSymbolsInBlock :: Block -> Set.Set Text listSymbolsInBlock Block {..} = fold   [ foldMap listSymbolsInRule bRules   , foldMap listSymbolsInFact bFacts   , foldMap listSymbolsInCheck bChecks   ] +listPublicKeysInBlock :: Block -> Set.Set PublicKey+listPublicKeysInBlock Block{..} = fold+  [ foldMap listPublicKeysInRule bRules+  , foldMap listPublicKeysInCheck bChecks+  , listPublicKeysInScope bScope+  ]+ -- | A biscuit authorizer, containing, facts, rules, checks and policies-type Authorizer = Authorizer' 'RegularString+type Authorizer = Authorizer' 'Repr 'Representation  -- | The context in which a biscuit policies and checks are verified. -- A authorizer may add policies (`deny if` / `allow if` conditions), as well as rules, facts, and checks. -- A authorizer may or may not contain slices referencing haskell variables.-data Authorizer' (ctx :: ParsedAs) = Authorizer-  { vPolicies :: [Policy' ctx]+data Authorizer' (evalCtx :: EvaluationContext) (ctx :: DatalogContext) = Authorizer+  { vPolicies :: [Policy' evalCtx ctx]   -- ^ the allow / deny policies.-  , vBlock    :: Block' ctx+  , vBlock    :: Block' evalCtx ctx   -- ^ the facts, rules and checks   } -instance Semigroup (Authorizer' ctx) where+instance Semigroup (Authorizer' evalCtx ctx) where   v1 <> v2 = Authorizer { vPolicies = vPolicies v1 <> vPolicies v2                       , vBlock = vBlock v1 <> vBlock v2                       } -instance Monoid (Authorizer' ctx) where+instance Monoid (Authorizer' evalCtx ctx) where   mempty = Authorizer { vPolicies = []                     , vBlock = mempty                     } -deriving instance ( Eq (Block' ctx)-                  , Eq (QueryItem' ctx)-                  ) => Eq (Authorizer' ctx)+deriving instance ( Eq (Block' evalCtx ctx)+                  , Eq (QueryItem' evalCtx ctx)+                  ) => Eq (Authorizer' evalCtx ctx) -deriving instance ( Show (Block' ctx)-                  , Show (QueryItem' ctx)-                  ) => Show (Authorizer' ctx)+deriving instance ( Show (Block' evalCtx ctx)+                  , Show (QueryItem' evalCtx ctx)+                  ) => Show (Authorizer' evalCtx ctx) -deriving instance ( Lift (Block' ctx)-                  , Lift (QueryItem' ctx)-                  ) => Lift (Authorizer' ctx)+deriving instance ( Lift (Block' evalCtx ctx)+                  , Lift (QueryItem' evalCtx ctx)+                  ) => Lift (Authorizer' evalCtx ctx) -data BlockElement' ctx+renderAuthorizer :: Authorizer -> Text+renderAuthorizer Authorizer{..} =+  renderBlock vBlock <> "\n" <>+  intercalate "\n" (renderPolicy <$> vPolicies)++data BlockElement' evalCtx ctx   = BlockFact (Predicate' 'InFact ctx)-  | BlockRule (Rule' ctx)-  | BlockCheck (Check' ctx)+  | BlockRule (Rule' evalCtx ctx)+  | BlockCheck (Check' evalCtx ctx)   | BlockComment  deriving instance ( Show (Predicate' 'InFact ctx)-                  , Show (Rule' ctx)-                  , Show (QueryItem' ctx)-                  ) => Show (BlockElement' ctx)+                  , Show (Rule' evalCtx ctx)+                  , Show (QueryItem' evalCtx ctx)+                  ) => Show (BlockElement' evalCtx ctx) -elementToBlock :: BlockElement' ctx -> Block' ctx+elementToBlock :: BlockElement' evalCtx ctx -> Block' evalCtx ctx elementToBlock = \case-   BlockRule r  -> Block [r] [] [] Nothing Nothing-   BlockFact f  -> Block [] [f] [] Nothing Nothing-   BlockCheck c -> Block [] [] [c] Nothing Nothing+   BlockRule r  -> Block [r] [] [] Nothing Set.empty+   BlockFact f  -> Block [] [f] [] Nothing Set.empty+   BlockCheck c -> Block [] [] [c] Nothing Set.empty    BlockComment -> mempty -data AuthorizerElement' ctx-  = AuthorizerPolicy (Policy' ctx)-  | BlockElement (BlockElement' ctx)+data AuthorizerElement' evalCtx ctx+  = AuthorizerPolicy (Policy' evalCtx ctx)+  | BlockElement (BlockElement' evalCtx ctx)  deriving instance ( Show (Predicate' 'InFact ctx)-                  , Show (Rule' ctx)-                  , Show (QueryItem' ctx)-                  ) => Show (AuthorizerElement' ctx)+                  , Show (Rule' evalCtx ctx)+                  , Show (QueryItem' evalCtx ctx)+                  ) => Show (AuthorizerElement' evalCtx ctx) -elementToAuthorizer :: AuthorizerElement' ctx -> Authorizer' ctx+elementToAuthorizer :: AuthorizerElement' evalCtx ctx -> Authorizer' evalCtx ctx elementToAuthorizer = \case   AuthorizerPolicy p -> Authorizer [p] mempty   BlockElement be    -> Authorizer [] (elementToBlock be)++class ToEvaluation elem where+  toEvaluation :: [Maybe PublicKey] -> elem 'Repr 'Representation -> elem 'Eval 'Representation+  toRepresentation :: elem 'Eval 'Representation -> elem 'Repr 'Representation++translateScope :: [Maybe PublicKey] -> Set RuleScope -> Set EvalRuleScope+translateScope ePks =+  let indexedPks :: Map PublicKey (Set Natural)+      indexedPks =+        let makeEntry (Just bPk, bId) = [(bPk, Set.singleton bId)]+            makeEntry _               = []+         in Map.fromListWith (<>) $ foldMap makeEntry $ zip ePks [0..]+      translateElem = \case+        Previous      -> Previous+        OnlyAuthority -> OnlyAuthority+        BlockId bPk   -> BlockId (fold $ Map.lookup bPk indexedPks, bPk)+   in Set.map translateElem++renderBlockIds :: Set EvalRuleScope -> Set RuleScope+renderBlockIds =+  let renderElem = \case+        Previous         -> Previous+        OnlyAuthority    -> OnlyAuthority+        BlockId (_, ePk) -> BlockId ePk+   in Set.map renderElem++instance ToEvaluation Rule' where+  toEvaluation ePks r = r { scope = translateScope ePks $ scope r }+  toRepresentation r  = r { scope = renderBlockIds $ scope r }++instance ToEvaluation QueryItem' where+  toEvaluation ePks qi = qi{ qScope = translateScope ePks $ qScope qi}+  toRepresentation qi  = qi { qScope = renderBlockIds $ qScope qi}++instance ToEvaluation Check' where+  toEvaluation ePks c =  c { cQueries = fmap (toEvaluation ePks) (cQueries c) }+  toRepresentation c  =  c { cQueries = fmap toRepresentation (cQueries c) }++instance ToEvaluation Block' where+  toEvaluation ePks b = b+    { bScope = translateScope ePks $ bScope b+    , bRules = toEvaluation ePks <$> bRules b+    , bChecks = checkToEvaluation ePks <$> bChecks b+    }+  toRepresentation b  = b+    { bScope = renderBlockIds $ bScope b+    , bRules = toRepresentation <$> bRules b+    , bChecks = toRepresentation <$> bChecks b+    }++instance ToEvaluation Authorizer' where+  toEvaluation ePks a = a+    { vBlock = toEvaluation ePks (vBlock a)+    , vPolicies = policyToEvaluation ePks <$> vPolicies a+    }+  toRepresentation a = a+    { vBlock = toRepresentation (vBlock a)+    , vPolicies = fmap (fmap toRepresentation) <$> vPolicies a+    }++checkToEvaluation :: [Maybe PublicKey] -> Check -> EvalCheck+checkToEvaluation = toEvaluation++policyToEvaluation :: [Maybe PublicKey] -> Policy -> EvalPolicy+policyToEvaluation ePks = fmap (fmap (toEvaluation ePks))++substituteAuthorizer :: Map Text Value+                     -> Map Text PublicKey+                     -> Authorizer' 'Repr 'WithSlices+                     -> Validation (NonEmpty Text) Authorizer+substituteAuthorizer termMapping keyMapping Authorizer{..} = do+  newPolicies <- traverse (substitutePolicy termMapping keyMapping) vPolicies+  newBlock <- substituteBlock termMapping keyMapping vBlock+  pure Authorizer{+    vPolicies = newPolicies,+    vBlock = newBlock+  }++substituteBlock :: Map Text Value+                -> Map Text PublicKey+                -> Block' 'Repr 'WithSlices+                -> Validation (NonEmpty Text) Block+substituteBlock termMapping keyMapping Block{..} = do+  newRules <-  traverse (substituteRule termMapping keyMapping) bRules+  newFacts <-  traverse (substituteFact termMapping) bFacts+  newChecks <- traverse (substituteCheck termMapping keyMapping) bChecks+  newScope <- Set.fromList <$> traverse (substituteScope keyMapping) (Set.toList bScope)+  pure Block{+   bRules = newRules,+   bFacts = newFacts,+   bChecks = newChecks,+   bScope = newScope,+   ..}++substituteRule :: Map Text Value -> Map Text PublicKey+               -> Rule' 'Repr 'WithSlices+               -> Validation (NonEmpty Text) Rule+substituteRule termMapping keyMapping Rule{..} = do+  newHead <- substitutePredicate termMapping rhead+  newBody <- traverse (substitutePredicate termMapping) body+  newExpressions <- traverse (substituteExpression termMapping) expressions+  newScope <- Set.fromList <$> traverse (substituteScope keyMapping) (Set.toList scope)+  pure Rule{+    rhead = newHead,+    body = newBody,+    expressions = newExpressions,+    scope = newScope+  }++substituteCheck :: Map Text Value -> Map Text PublicKey+                -> Check' 'Repr 'WithSlices+                -> Validation (NonEmpty Text) Check+substituteCheck termMapping keyMapping Check{..} = do+  newQueries <- traverse (substituteQuery termMapping keyMapping) cQueries+  pure Check{cQueries = newQueries, ..}++substitutePolicy :: Map Text Value -> Map Text PublicKey+                 -> Policy' 'Repr 'WithSlices+                 -> Validation (NonEmpty Text) Policy+substitutePolicy termMapping keyMapping =+  traverse (traverse (substituteQuery termMapping keyMapping))++substituteQuery :: Map Text Value-> Map Text PublicKey+                -> QueryItem' 'Repr 'WithSlices+                -> Validation (NonEmpty Text) (QueryItem' 'Repr 'Representation)+substituteQuery termMapping keyMapping QueryItem{..} = do+  newBody <- traverse (substitutePredicate termMapping) qBody+  newExpressions <- traverse (substituteExpression termMapping) qExpressions+  newScope <- Set.fromList <$> traverse (substituteScope keyMapping) (Set.toList qScope)+  pure QueryItem{+    qBody = newBody,+    qExpressions = newExpressions,+    qScope = newScope+  }++substitutePredicate :: Map Text Value+                    -> Predicate' 'InPredicate 'WithSlices+                    -> Validation (NonEmpty Text) (Predicate' 'InPredicate 'Representation)+substitutePredicate termMapping Predicate{..} = do+  newTerms <- traverse (substitutePTerm termMapping) terms+  pure Predicate{ terms = newTerms, .. }++substituteFact :: Map Text Value+               -> Predicate' 'InFact 'WithSlices+               -> Validation (NonEmpty Text) Fact+substituteFact termMapping Predicate{..} = do+  newTerms <- traverse (substituteTerm termMapping) terms+  pure Predicate{ terms = newTerms, .. }+++substitutePTerm :: Map Text Value+                -> Term' 'NotWithinSet 'InPredicate 'WithSlices+                -> Validation (NonEmpty Text) (Term' 'NotWithinSet 'InPredicate 'Representation)+substitutePTerm termMapping = \case+  LInteger i  -> pure $ LInteger i+  LString i   -> pure $ LString i+  LDate i     -> pure $ LDate i+  LBytes i    -> pure $ LBytes i+  LBool i     -> pure $ LBool i+  TermSet i   ->+    TermSet . Set.fromList <$> traverse (substituteSetTerm termMapping) (Set.toList i)+  Variable i  -> pure $ Variable i+  Antiquote (Slice v) -> maybe (failure v) (pure . valueToTerm) $ termMapping Map.!? v++substituteTerm :: Map Text Value+               -> Term' 'NotWithinSet 'InFact 'WithSlices+               -> Validation (NonEmpty Text) Value+substituteTerm termMapping = \case+  LInteger i  -> pure $ LInteger i+  LString i   -> pure $ LString i+  LDate i     -> pure $ LDate i+  LBytes i    -> pure $ LBytes i+  LBool i     -> pure $ LBool i+  TermSet i   ->+    TermSet . Set.fromList <$> traverse (substituteSetTerm termMapping) (Set.toList i)+  Variable v  -> absurd v+  Antiquote (Slice v) -> maybe (failure v) pure $ termMapping Map.!? v++substituteSetTerm :: Map Text Value+                  -> Term' 'WithinSet 'InFact 'WithSlices+                  -> Validation (NonEmpty Text) (Term' 'WithinSet 'InFact 'Representation)+substituteSetTerm termMapping = \case+  LInteger i  -> pure $ LInteger i+  LString i   -> pure $ LString i+  LDate i     -> pure $ LDate i+  LBytes i    -> pure $ LBytes i+  LBool i     -> pure $ LBool i+  TermSet v   -> absurd v+  Variable v  -> absurd v+  Antiquote (Slice v) ->+    let setTerm = valueToSetTerm =<< termMapping Map.!? v+     in maybe (failure v) pure setTerm++substituteExpression :: Map Text Value+                     -> Expression' 'WithSlices+                     -> Validation (NonEmpty Text) Expression+substituteExpression termMapping = \case+  EValue v -> EValue <$> substitutePTerm termMapping v+  EUnary op e -> EUnary op <$> substituteExpression termMapping e+  EBinary op e e' -> EBinary op <$> substituteExpression termMapping e+                                <*> substituteExpression termMapping e'++substituteScope :: Map Text PublicKey+                -> RuleScope' 'Repr 'WithSlices+                -> Validation (NonEmpty Text) RuleScope+substituteScope keyMapping = \case+    OnlyAuthority -> pure OnlyAuthority+    Previous      -> pure Previous+    BlockId (Pk pk) -> pure $ BlockId pk+    BlockId (PkSlice n) -> maybe (failure n) (pure . BlockId) $ keyMapping Map.!? n

@@ -28,8 +28,6 @@   , keepAuthorized'   , defaultLimits   , evaluateExpression-  , extractVariables-   --   , getFactsForRule   , checkCheck@@ -40,6 +38,7 @@  import           Control.Monad            (join, mfilter, zipWithM) import           Data.Bitraversable       (bitraverse)+import           Data.Bits                (xor, (.&.), (.|.)) import qualified Data.ByteString          as ByteString import           Data.Foldable            (fold) import           Data.Functor.Compose     (Compose (..))@@ -47,7 +46,7 @@ import qualified Data.List.NonEmpty       as NE import           Data.Map.Strict          (Map, (!?)) import qualified Data.Map.Strict          as Map-import           Data.Maybe               (fromMaybe, isJust, mapMaybe)+import           Data.Maybe               (isJust, mapMaybe) import           Data.Set                 (Set) import qualified Data.Set                 as Set import           Data.Text                (Text, isInfixOf, unpack)@@ -159,18 +158,24 @@   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)+keepAuthorized' :: Bool -> Natural -> FactGroup -> Set EvalRuleScope -> Natural -> FactGroup+keepAuthorized' allowPreviousInAuthorizer blockCount factGroup trustedBlocks currentBlockId =+  let scope = if null trustedBlocks then Set.singleton OnlyAuthority+                                    else trustedBlocks+      toBlockIds = \case+        OnlyAuthority    -> Set.singleton 0+        Previous         -> if allowPreviousInAuthorizer || currentBlockId < blockCount+                            then Set.fromList [0..currentBlockId]+                            else mempty -- `Previous` is forbidden in the authorizer+                                        -- except when querying the authorizer contents+                                        -- after authorization+        BlockId (idx, _) -> idx+      allBlockIds = foldMap toBlockIds scope+   in keepAuthorized factGroup $ Set.insert currentBlockId $ Set.insert blockCount allBlockIds  toScopedFacts :: FactGroup -> Set (Scoped Fact) toScopedFacts (FactGroup factGroups) =-  let distributeScope scope facts = Set.map (scope,) facts+  let distributeScope scope = Set.map (scope,)    in foldMap (uncurry distributeScope) $ Map.toList factGroups  fromScopedFacts :: Set (Scoped Fact) -> FactGroup@@ -179,34 +184,58 @@ 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+-- todo handle Check All+checkCheck :: Limits -> Natural -> Natural -> FactGroup -> EvalCheck -> Validation (NonEmpty Check) ()+checkCheck l blockCount checkBlockId facts c@Check{cQueries,cKind} =+  let isQueryItemOk = case cKind of+        One -> isQueryItemSatisfied l blockCount checkBlockId facts+        All -> isQueryItemSatisfiedForAllMatches l blockCount checkBlockId facts+   in if any (isJust . isQueryItemOk) cQueries+      then Success ()+      else failure (toRepresentation c) -checkPolicy :: Limits -> FactGroup -> Policy -> Maybe (Either MatchedQuery MatchedQuery)-checkPolicy l facts (pType, query) =-  let bindings = fold $ mapMaybe (isQueryItemSatisfied l 0 facts) query+checkPolicy :: Limits -> Natural -> FactGroup -> EvalPolicy -> Maybe (Either MatchedQuery MatchedQuery)+checkPolicy l blockCount facts (pType, query) =+  let bindings = fold $ mapMaybe (isQueryItemSatisfied l blockCount blockCount facts) query    in if not (null bindings)       then Just $ case pType of-        Allow -> Right $ MatchedQuery{matchedQuery = query, bindings}-        Deny  -> Left $ MatchedQuery{matchedQuery = query, bindings}+        Allow -> Right $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings}+        Deny  -> Left $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings}       else Nothing -isQueryItemSatisfied :: Limits -> Natural -> FactGroup -> QueryItem' 'RegularString -> Maybe (Set Bindings)-isQueryItemSatisfied l blockId allFacts QueryItem{qBody, qExpressions, qScope} =+isQueryItemSatisfied :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Maybe (Set Bindings)+isQueryItemSatisfied l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} =   let removeScope = Set.map snd-      facts = toScopedFacts $ keepAuthorized' allFacts qScope blockId+      facts = toScopedFacts $ keepAuthorized' False blockCount allFacts qScope blockId       bindings = removeScope $ getBindingsForRuleBody l facts qBody qExpressions    in if Set.size bindings > 0       then Just bindings       else Nothing +-- | Given a set of scoped facts and a rule body, we generate a set of variable+-- bindings that satisfy the rule clauses (predicates match, and expression constraints+-- are fulfilled), and ensure that all bindings where predicates match also fulfill+-- expression constraints. This is the behaviour of `check all`.+isQueryItemSatisfiedForAllMatches :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Maybe (Set Bindings)+isQueryItemSatisfiedForAllMatches l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} =+  let removeScope = Set.map snd+      facts = toScopedFacts $ keepAuthorized' False blockCount allFacts qScope blockId+      allVariables = extractVariables qBody+      -- bindings that match facts+      candidateBindings = getCandidateBindings facts qBody+      -- bindings that unify correctly (each variable has a single possible match)+      legalBindingsForFacts = reduceCandidateBindings allVariables candidateBindings+      -- bindings that fulfill the constraints+      constraintFulfillingBindings = Set.filter (\b -> all (satisfies l b) qExpressions) legalBindingsForFacts+   in if Set.size constraintFulfillingBindings > 0 -- there is at least one match that fulfills the constraints+      && constraintFulfillingBindings == legalBindingsForFacts -- all matches fulfill the constraints+      then Just $ removeScope constraintFulfillingBindings+      else Nothing+ -- | 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 :: Limits -> Set (Scoped Fact) -> EvalRule -> Set (Scoped Fact) getFactsForRule l facts Rule{rhead, body, expressions} =   let legalBindings :: Set (Scoped Bindings)       legalBindings = getBindingsForRuleBody l facts body expressions@@ -232,15 +261,6 @@           -> Bool satisfies l b e = evaluateExpression l (snd b) e == Right (LBool True) -extractVariables :: [Predicate] -> Set Name-extractVariables predicates =-  let keepVariable = \case-        Variable name -> Just name-        _             -> Nothing-      extractVariables' Predicate{terms} = mapMaybe keepVariable terms-   in Set.fromList $ extractVariables' =<< predicates-- applyBindings :: Predicate -> Scoped Bindings -> Maybe (Scoped Fact) applyBindings p@Predicate{terms} (origins, bindings) =   let newTerms = traverse replaceTerm terms@@ -395,6 +415,13 @@ evalBinary _ Div (LInteger _) (LInteger 0) = Left "Divide by 0" evalBinary _ Div (LInteger i) (LInteger i') = pure $ LInteger (i `div` i') evalBinary _ Div _ _ = Left "Only integers support division"+-- bitwise operations+evalBinary _ BitwiseAnd (LInteger i) (LInteger i') = pure $ LInteger (i .&. i')+evalBinary _ BitwiseAnd _ _ = Left "Only integers support bitwise and"+evalBinary _ BitwiseOr  (LInteger i) (LInteger i') = pure $ LInteger (i .|. i')+evalBinary _ BitwiseOr _ _ = Left "Only integers support bitwise or"+evalBinary _ BitwiseXor (LInteger i) (LInteger i') = pure $ LInteger (i `xor` i')+evalBinary _ BitwiseXor _ _ = Left "Only integers support bitwise xor" -- boolean operations evalBinary _ And (LBool b) (LBool b') = pure $ LBool (b && b') evalBinary _ And _ _ = Left "Only booleans support &&"@@ -402,7 +429,7 @@ evalBinary _ Or _ _ = Left "Only booleans support ||" -- set operations evalBinary _ Contains (TermSet t) (TermSet t') = pure $ LBool (Set.isSubsetOf t' t)-evalBinary _ Contains (TermSet t) t' = case toSetTerm t' of+evalBinary _ Contains (TermSet t) t' = case valueToSetTerm t' of     Just t'' -> pure $ LBool (Set.member t'' t)     Nothing  -> Left "Sets cannot contain nested sets nor variables" evalBinary _ Contains (LString t) (LString t') = pure $ LBool (t' `isInfixOf` t)

@@ -1,397 +1,452 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveLift            #-} {-# LANGUAGE DerivingStrategies    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-} {-# LANGUAGE LambdaCase            #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections         #-} {-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{- HLINT ignore "Reduce duplication" -} module Auth.Biscuit.Datalog.Parser-  ( block-  , check-  , fact-  , predicate-  , rule-  , authorizer-  , query-  -- these are only exported for testing purposes-  , checkParser-  , expressionParser-  , policyParser-  , predicateParser-  , ruleParser-  , termParser-  , blockParser-  , authorizerParser-  , HasParsers-  , HasTermParsers-  ) where+  where -import           Control.Applicative            (liftA2, optional, (<|>))+import           Auth.Biscuit.Crypto            (PublicKey,+                                                 readEd25519PublicKey)+import           Auth.Biscuit.Datalog.AST+import           Control.Monad                  (join) import qualified Control.Monad.Combinators.Expr as Expr-import           Data.Attoparsec.Text-import qualified Data.Attoparsec.Text           as A+import           Data.Bifunctor import           Data.ByteString                (ByteString) import           Data.ByteString.Base16         as Hex-import           Data.Char                      (isAlphaNum, isLetter, isSpace)+import qualified Data.ByteString.Char8          as C8+import           Data.Char import           Data.Either                    (partitionEithers)-import           Data.Foldable                  (fold)-import           Data.Functor                   (void, ($>))+import           Data.List.NonEmpty             (NonEmpty)+import qualified Data.List.NonEmpty             as NE+import           Data.Map.Strict                (Map)+import           Data.Maybe                     (isJust)+import           Data.Set                       (Set) import qualified Data.Set                       as Set-import           Data.Text                      (Text, pack, singleton, unpack)-import           Data.Text.Encoding             (encodeUtf8)+import           Data.Text                      (Text)+import qualified Data.Text                      as T import           Data.Time                      (UTCTime, defaultTimeLocale,                                                  parseTimeM)-import           Data.Void                      (Void) import           Instances.TH.Lift              () import           Language.Haskell.TH-import           Language.Haskell.TH.Quote+import           Language.Haskell.TH.Quote      (QuasiQuoter (..)) import           Language.Haskell.TH.Syntax     (Lift)+import           Text.Megaparsec+import qualified Text.Megaparsec.Char           as C+import qualified Text.Megaparsec.Char.Lexer     as L+import           Validation                     (Validation (..),+                                                 validationToEither) -import           Auth.Biscuit.Datalog.AST+type Parser = Parsec SemanticError Text -class ConditionalParse a v where-  ifPresent :: String -> Parser a -> Parser v+type Span = (Int, Int) -instance ConditionalParse a Void where-  ifPresent name _ = fail $ name <> " is not available in this context"+data SemanticError =+    VarInFact Span+  | VarInSet  Span+  | NestedSet Span+  | InvalidBs Text Span+  | InvalidPublicKey Text Span+  | UnboundVariables (NonEmpty Text) Span+  | PreviousInAuthorizer Span+  deriving stock (Eq, Ord) -instance ConditionalParse m m where-  ifPresent _ p = p+instance ShowErrorComponent SemanticError where+  showErrorComponent = \case+    VarInFact _            -> "Variables can't appear in a fact"+    VarInSet  _            -> "Variables can't appear in a set"+    NestedSet _            -> "Sets cannot be nested"+    InvalidBs e _          -> "Invalid bytestring literal: " <> T.unpack e+    InvalidPublicKey e _   -> "Invalid public key: " <> T.unpack e+    UnboundVariables e _   -> "Unbound variables: " <> T.unpack (T.intercalate ", " $ NE.toList e)+    PreviousInAuthorizer _ -> "'previous' can't appear in an authorizer scope" -class SetParser (inSet :: IsWithinSet) (ctx :: ParsedAs) where-  parseSet :: Parser (SetType inSet ctx)+run :: Parser a -> Text -> Either String a+run p = first errorBundlePretty . runParser (l (pure ()) *> l p <* eof) "" -instance SetParser 'WithinSet ctx where-  parseSet = fail "nested sets are forbidden"+l :: Parser a -> Parser a+l = L.lexeme $ L.space C.space1 (L.skipLineComment "//") empty -instance SetParser 'NotWithinSet 'QuasiQuote where-  parseSet = Set.fromList <$> (char '[' *> commaList0 termParser <* char ']')+getSpan :: Parser a -> Parser (Span, a)+getSpan p = do+  begin <- getOffset+  a <- p+  end <- getOffset+  pure ((begin, end), a) -instance SetParser 'NotWithinSet 'RegularString where-  parseSet = Set.fromList <$> (char '[' *> commaList0 termParser <* char ']')+registerError :: (Span -> SemanticError) -> Span -> Parser a+registerError mkError sp = do+  let err = FancyError (fst sp) (Set.singleton (ErrorCustom $ mkError sp))+  registerParseError err+  pure $ error "delayed parsing error" -type HasTermParsers inSet pof ctx =-  ( ConditionalParse (SliceType 'QuasiQuote)                   (SliceType ctx)-  , ConditionalParse (VariableType 'NotWithinSet 'InPredicate) (VariableType inSet pof)-  , SetParser inSet ctx-  )-type HasParsers pof ctx = HasTermParsers 'NotWithinSet pof ctx+forbid :: (Span -> SemanticError) -> Parser a -> Parser b+forbid mkError p = do+  (sp, _) <- getSpan p+  registerError mkError sp --- | Parser for a datalog predicate name-predicateNameParser :: Parser Text-predicateNameParser = do-  first <- satisfy isLetter-  rest  <- A.takeWhile $ \c -> c == '_' || c == ':' || isAlphaNum c-  pure $ singleton first <> rest+variableParser :: Parser Text+variableParser =+  C.char '$' *> takeWhile1P (Just "_, :, or any alphanumeric char") (\c -> c == '_' || c == ':' || isAlphaNum c) -variableNameParser :: Parser Text-variableNameParser = char '$' *> takeWhile1 (\c -> c == '_' || c == ':' || isAlphaNum c)+haskellVariableParser :: Parser Text+haskellVariableParser = l $ do+  _ <- chunk "{"+  leadingUS <- optional $ C.char '_'+  x <- if isJust leadingUS then C.letterChar else C.lowerChar+  xs <- takeWhileP (Just "_, ', or any alphanumeric char") (\c -> c == '_' || c == '\'' || isAlphaNum c)+  _ <- C.char '}'+  pure . maybe id T.cons leadingUS $ T.cons x xs -delimited :: Parser x-          -> Parser y-          -> Parser a-          -> Parser a-delimited before after p = before *> p <* after+setParser :: Parser (Set (Term' 'WithinSet 'InFact 'WithSlices))+setParser = do+  _ <- l $ C.char '['+  ts <- sepBy (termParser (forbid VarInSet variableParser) (forbid NestedSet setParser)) (l $ C.char ',')+  _ <- l $ C.char ']'+  pure $ Set.fromList ts -parens :: Parser a -> Parser a-parens = delimited (char '(') (skipSpace *> char ')')+factTermParser :: Parser (Term' 'NotWithinSet 'InFact 'WithSlices)+factTermParser = termParser (forbid VarInFact variableParser)+                            setParser -commaList :: Parser a -> Parser [a]-commaList p =-  sepBy1 p (skipSpace *> char ',')+predicateTermParser :: Parser (Term' 'NotWithinSet 'InPredicate 'WithSlices)+predicateTermParser = termParser variableParser+                                 setParser -commaList0 :: Parser a -> Parser [a]-commaList0 p =-  sepBy p (skipSpace *> char ',')+termParser :: Parser (VariableType inSet pof)+           -> Parser (SetType inSet 'WithSlices)+           -> Parser (Term' inSet pof 'WithSlices)+termParser parseVar parseSet = l $ choice+  [ Antiquote . Slice <$> haskellVariableParser <?> "parameter (eg. {paramName})"+  , Variable <$> parseVar <?> "datalog variable (eg. $variable)"+  , TermSet <$> parseSet <?> "set (eg. [1,2,3])"+  , LBytes <$> (chunk "hex:" *> hexParser) <?> "hex-encoded bytestring (eg. hex:00ff99)"+  , LDate <$> rfc3339DateParser <?> "RFC3339-formatted timestamp (eg. 2022-11-29T00:00:00Z)"+  , LInteger <$> L.signed C.space L.decimal <?> "(signed) integer"+  , LString . T.pack <$> (C.char '"' *> manyTill L.charLiteral (C.char '"')) <?> "string literal"+  , LBool <$> choice [ True <$ chunk "true"+                     , False <$ chunk "false"+                     ]+          <?> "boolean value (eg. true or false)"+  ] -predicateParser :: HasParsers pof ctx => Parser (Predicate' pof ctx)-predicateParser = do-  skipSpace-  name <- predicateNameParser-  skipSpace-  terms <- parens (commaList termParser)-  pure Predicate{name,terms}+hexParser :: Parser ByteString+hexParser = do+  (sp, hexStr) <- getSpan $ C8.pack <$> some C.hexDigitChar+  case Hex.decodeBase16 hexStr of+    Left e   -> registerError (InvalidBs e) sp+    Right bs -> pure bs -unary :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)-unary = choice-  [ unaryParens-  , unaryNegate-  , unaryLength-  ]+publicKeyParser :: Parser PublicKey+publicKeyParser = do+  (sp, hexStr) <- getSpan $ C8.pack <$> (chunk "ed25519/" *> some C.hexDigitChar)+  case Hex.decodeBase16 hexStr of+    Left e -> registerError (InvalidPublicKey e) sp+    Right bs -> case readEd25519PublicKey bs of+      Nothing -> registerError (InvalidPublicKey "Invalid ed25519 public key") sp+      Just pk -> pure pk -unaryParens :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)-unaryParens = do-  skipSpace-  _ <- char '('-  skipSpace-  e <- expressionParser-  skipSpace-  _ <- char ')'-  pure $ EUnary Parens e+rfc3339DateParser :: Parser UTCTime+rfc3339DateParser = do+  let parseDate = parseTimeM False defaultTimeLocale "%FT%T%Q%EZ"+  input <- sequenceA [+      try (sequenceA [+        C.digitChar,+        C.digitChar,+        C.digitChar,+        C.digitChar,+        C.char '-',+        C.digitChar,+        C.digitChar,+        C.char '-',+        C.digitChar,+        C.digitChar,+        C.char 'T'+      ]),+      pure <$> C.digitChar,+      pure <$> C.digitChar,+      pure <$> C.char ':',+      pure <$> C.digitChar,+      pure <$> C.digitChar,+      pure <$> C.char ':',+      pure <$> C.digitChar,+      pure <$> C.digitChar,+      foldMap join <$> optional (sequenceA [+        pure <$> C.char '.',+        some C.digitChar+      ]),+      choice [+        pure <$> C.char 'Z',+        sequenceA [+           choice [C.char '+', C.char '-'],+           C.digitChar,+           C.digitChar,+           C.char ':',+           C.digitChar,+           C.digitChar+        ]+      ]+    ]+  parseDate $ join input -unaryNegate :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)-unaryNegate = do-  skipSpace-  _ <- char '!'-  skipSpace-  EUnary Negate <$> expressionParser+predicateParser' :: Parser (Term' 'NotWithinSet pof 'WithSlices)+                 -> Parser (Predicate' pof 'WithSlices)+predicateParser' parseTerm = l $ do+  name <- try . (<?> "predicate name") $ do+    x      <- C.letterChar+    xs     <- takeWhileP (Just "_, :, or any alphanumeric char") (\c -> c == '_' || c == ':' || isAlphaNum c)+    _      <- l $ C.char '('+    pure $ T.cons x xs+  terms  <- sepBy1 parseTerm (l $ C.char ',')+  _      <- l $ C.char ')'+  pure Predicate {+    name,+    terms+  } -unaryLength :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)-unaryLength = do-  skipSpace-  e <- choice-         [ EValue <$> termParser-         , unaryParens-         ]-  skipSpace-  _ <- string ".length()"-  pure $ EUnary Length e+factParser :: Parser (Predicate' 'InFact 'WithSlices)+factParser = predicateParser' factTermParser -exprTerm :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)-exprTerm = choice-  [ unary-  , EValue <$> termParser-  ]+predicateParser :: Parser (Predicate' 'InPredicate 'WithSlices)+predicateParser = predicateParser' predicateTermParser -methodParser :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)-methodParser = do+expressionParser :: Parser (Expression' 'WithSlices)+expressionParser =+  let base = choice [ try binaryMethodParser+                    , try unaryMethodParser+                    , exprTerm+                    ]+   in Expr.makeExprParser base table++table :: [[Expr.Operator Parser (Expression' 'WithSlices)]]+table =+  let infixL name op = Expr.InfixL (EBinary op <$ l (chunk name) <?> "infix operator")+      infixN name op = Expr.InfixN (EBinary op <$ l (chunk name) <?> "infix operator")+      prefix name op = Expr.Prefix (EUnary op <$  l (chunk name) <?> "prefix operator")+   in [ [ prefix "!" Negate]+      , [ infixL  "*" Mul+        , infixL  "/" Div+        ]+      , [ infixL  "+" Add+        , infixL  "-" Sub+        ]+      -- TODO find a better way to avoid eager parsing+      -- of && and || by the bitwise operators+      , [ infixL  "& " BitwiseAnd ]+      , [ infixL  "| " BitwiseOr  ]+      , [ infixL  "^" BitwiseXor ]+      , [ infixN  "<=" LessOrEqual+        , infixN  ">=" GreaterOrEqual+        , infixN  "<"  LessThan+        , infixN  ">"  GreaterThan+        , infixN  "==" Equal+        ]+      , [ infixL "&&" And ]+      , [ infixL "||" Or ]+      ]++binaryMethodParser :: Parser (Expression' 'WithSlices)+binaryMethodParser = do   e1 <- exprTerm-  _ <- char '.'+  _ <- C.char '.'   method <- choice-    [ Contains     <$ string "contains"-    , Intersection <$ string "intersection"-    , Union        <$ string "union"-    , Prefix       <$ string "starts_with"-    , Suffix       <$ string "ends_with"-    , Regex        <$ string "matches"+    [ Contains     <$ chunk "contains"+    , Intersection <$ chunk "intersection"+    , Union        <$ chunk "union"+    , Prefix       <$ chunk "starts_with"+    , Suffix       <$ chunk "ends_with"+    , Regex        <$ chunk "matches"     ]-  _ <- char '('-  skipSpace-  e2 <- expressionParser-  skipSpace-  _ <- char ')'+  _ <- l $ C.char '('+  e2 <- l expressionParser+  _ <- l $ C.char ')'   pure $ EBinary method e1 e2 -expressionParser :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)-expressionParser = Expr.makeExprParser (methodParser <|> exprTerm) table--table :: HasParsers 'InPredicate ctx-      => [[Expr.Operator Parser (Expression' ctx)]]-table = [ [ binary  "*" Mul-          , binary  "/" Div-          ]-        , [ binary  "+" Add-          , binary  "-" Sub-          ]-        , [ binary  "<=" LessOrEqual-          , binary  ">=" GreaterOrEqual-          , binary  "<"  LessThan-          , binary  ">"  GreaterThan-          , binary  "==" Equal-          ]-        , [ binary  "&&" And-          , binary  "||" Or-          ]-        ]--binary :: HasParsers 'InPredicate ctx-       => Text-       -> Binary-       -> Expr.Operator Parser (Expression' ctx)-binary name op = Expr.InfixL  (EBinary op <$ (skipSpace *> string name))--hexBsParser :: Parser ByteString-hexBsParser = do-  void $ string "hex:"-  either fail pure . Hex.decode . encodeUtf8 =<< takeWhile1 (inClass "0-9a-fA-F")+unaryMethodParser :: Parser (Expression' 'WithSlices)+unaryMethodParser = do+  e1 <- exprTerm+  _ <- C.char '.'+  method <- Length <$ chunk "length"+  _ <- l $ chunk "()"+  pure $ EUnary method e1 -litStringParser :: Parser Text-litStringParser =-  let regularChars = takeTill (inClass "\"\\")-      escaped = choice-        [ string "\\n" $> "\n"-        , string "\\\"" $> "\""-        , string "\\\\"  $> "\\"-        ]-      str = do-        f <- regularChars-        r <- optional (liftA2 (<>) escaped str)-        pure $ f <> fold r-   in char '"' *> str <* char '"'+methodParser :: Parser (Expression' 'WithSlices)+methodParser = binaryMethodParser <|> unaryMethodParser -rfc3339DateParser :: Parser UTCTime-rfc3339DateParser =-  -- get all the chars until the end of the term-  -- a term can be terminated by-  --  - a space (before another delimiter)-  --  - a comma (before another term)-  --  - a closing paren (the end of a term list)-  --  - a closing bracket (the end of a set)-  let getDateInput = takeWhile1 (notInClass ", )];")-      parseDate = parseTimeM False defaultTimeLocale "%FT%T%Q%EZ"-   in parseDate . unpack =<< getDateInput+unaryParens :: Parser (Expression' 'WithSlices)+unaryParens = do+  _ <- l $ C.char '('+  e <- l expressionParser+  _ <- l $ C.char ')'+  pure $ EUnary Parens e -termParser :: forall inSet pof ctx-            . ( HasTermParsers inSet pof ctx-              )-           => Parser (Term' inSet pof ctx)-termParser = skipSpace *> choice-  [ Antiquote <$> ifPresent "slice" (Slice <$> (string "${" *> many1 letter <* char '}'))-  , Variable <$> ifPresent "var" variableNameParser-  , TermSet <$> parseSet @inSet @ctx-  , LBytes <$> hexBsParser-  , LDate <$> rfc3339DateParser-  , LInteger <$> signed decimal-  , LString <$> litStringParser-  , LBool <$> choice [ string "true"  $> True-                     , string "false" $> False-                     ]+exprTerm :: Parser (Expression' 'WithSlices)+exprTerm = choice+  [ unaryParens <?> "parens"+  , EValue <$> predicateTermParser   ] --- | same as a predicate, but allows empty--- | terms list-ruleHeadParser :: HasParsers 'InPredicate ctx => Parser (Predicate' 'InPredicate ctx)-ruleHeadParser = do-  skipSpace-  name <- predicateNameParser-  skipSpace-  terms <- parens (commaList0 termParser)-  pure Predicate{name,terms}+ruleParser :: Bool -> Parser (Rule' 'Repr 'WithSlices)+ruleParser inAuthorizer = do+  begin <- getOffset+  rhead <- try $ l predicateParser <* l (chunk "<-")+  (body, expressions, scope) <- ruleBodyParser inAuthorizer+  end <- getOffset+  case makeRule rhead body expressions scope of+    Failure vs -> registerError (UnboundVariables vs) (begin, end)+    Success r  -> pure r -ruleBodyParser :: HasParsers 'InPredicate ctx-               => Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])-ruleBodyParser = do+ruleBodyParser :: Bool -> Parser ([Predicate' 'InPredicate 'WithSlices], [Expression' 'WithSlices], Set.Set (RuleScope' 'Repr 'WithSlices))+ruleBodyParser inAuthorizer = do   let predicateOrExprParser =-            Right <$> expressionParser-        <|> Left <$> predicateParser-  elems <- sepBy1 (skipSpace *> predicateOrExprParser)-                  (skipSpace *> char ',')-  pure $ partitionEithers elems+            Left  <$> (predicateParser <?> "predicate")+        <|> Right <$> (expressionParser <?> "expression")+  elems <- l $ sepBy1 (l predicateOrExprParser)+                      (l $ C.char ',')+  scope <- option Set.empty $ scopeParser inAuthorizer+  let (predicates, expressions) = partitionEithers elems+  pure (predicates, expressions, scope) -ruleParser :: HasParsers 'InPredicate ctx => Parser (Rule' ctx)-ruleParser = do-  rhead <- ruleHeadParser-  skipSpace-  void $ string "<-"-  (body, expressions) <- ruleBodyParser-  pure Rule{rhead, body, expressions, scope = Nothing} -- todo parse scope+scopeParser :: Bool -> Parser (Set.Set (RuleScope' 'Repr 'WithSlices))+scopeParser inAuthorizer = (<?> "scope annotation") $ do+  _ <- l $ chunk "trusting "+  let elemParser = do+        (sp, s) <- getSpan $ choice [ OnlyAuthority <$  chunk "authority"+                                    , Previous      <$  chunk "previous"+                                    , BlockId       <$>+                                       choice [ PkSlice <$> haskellVariableParser <?> "parameter (eg. {paramName})"+                                              , Pk <$> publicKeyParser <?> "public key (eg. ed25519/00ff99)"+                                              ]+                                    ]+        if inAuthorizer && s == Previous+        then registerError PreviousInAuthorizer sp+        else pure s+  Set.fromList <$> sepBy1 (l elemParser)+                          (l $ C.char ',') -queryParser :: HasParsers 'InPredicate ctx => Parser (Query' ctx)-queryParser =-  let mkQueryItem (qBody, qExpressions) = QueryItem { qBody, qExpressions, qScope = Nothing } -- todo parse scope-   in fmap mkQueryItem <$> sepBy1 ruleBodyParser (skipSpace *> asciiCI "or" <* satisfy isSpace)+queryItemParser :: Bool -> Parser (QueryItem' 'Repr 'WithSlices)+queryItemParser inAuthorizer = do+  (sp, (predicates, expressions, scope)) <- getSpan $ ruleBodyParser inAuthorizer+  case makeQueryItem predicates expressions scope of+    Failure e  -> registerError (UnboundVariables e) sp+    Success qi -> pure qi -checkParser :: HasParsers 'InPredicate ctx => Parser (Check' ctx)-checkParser = string "check if" *> queryParser+queryParser :: Bool -> Parser [QueryItem' 'Repr 'WithSlices]+queryParser inAuthorizer =+   sepBy1 (queryItemParser inAuthorizer) (l $ C.string' "or" <* C.space)+     <?> "datalog query" -commentParser :: Parser ()-commentParser = do-  skipSpace-  _ <- string "//"-  _ <- skipWhile ((&&) <$> (/= '\r') <*> (/= '\n'))-  void $ choice [ void (char '\n')-                , void (string "\r\n")-                , endOfInput-                ]+checkParser :: Bool -> Parser (Check' 'Repr 'WithSlices)+checkParser inAuthorizer = do+  cKind <- l $ choice [ One <$ chunk "check if"+                      , All <$ chunk "check all"+                      ]+  cQueries <- queryParser inAuthorizer+  pure Check{..} -blockElementParser :: HasParsers 'InPredicate ctx => Parser (BlockElement' ctx)-blockElementParser = choice-  [ BlockRule    <$> ruleParser <* skipSpace <* char ';'-  , BlockFact    <$> predicateParser <* skipSpace <* char ';'-  , BlockCheck   <$> checkParser <* skipSpace <* char ';'-  , BlockComment <$  commentParser+policyParser :: Parser (Policy' 'Repr 'WithSlices)+policyParser = do+  policy <- l $ choice [ Allow <$ chunk "allow if"+                       , Deny  <$ chunk "deny if"+                       ]+  (policy, ) <$> queryParser True++blockElementParser :: Bool -> Parser (BlockElement' 'Repr 'WithSlices)+blockElementParser inAuthorizer = choice+  [ BlockCheck   <$> checkParser inAuthorizer <* C.char ';' <?> "check"+  , BlockRule    <$> ruleParser  inAuthorizer <* C.char ';' <?> "rule"+  , BlockFact    <$> factParser <* C.char ';' <?> "fact"   ] -authorizerElementParser :: HasParsers 'InPredicate ctx => Parser (AuthorizerElement' ctx)+authorizerElementParser :: Parser (AuthorizerElement' 'Repr 'WithSlices) authorizerElementParser = choice-  [ AuthorizerPolicy  <$> policyParser <* skipSpace <* char ';'-  , BlockElement    <$> blockElementParser+  [ AuthorizerPolicy  <$> policyParser <* C.char ';' <?> "policy"+  , BlockElement    <$> blockElementParser True   ] -authorizerParser :: ( HasParsers 'InPredicate ctx-                  , HasParsers 'InFact ctx-                  , Show (AuthorizerElement' ctx)-                  )-               => Parser (Authorizer' ctx)+blockParser :: Parser (Block' 'Repr 'WithSlices)+blockParser = do+  bScope <- option Set.empty $ l (scopeParser False <* C.char ';' <?> "scope annotation")+  elems <- many $ l $ blockElementParser False+  pure $ (foldMap elementToBlock elems) { bScope = bScope }++authorizerParser :: Parser (Authorizer' 'Repr 'WithSlices) authorizerParser = do-  elems <- many' (skipSpace *> authorizerElementParser)-  pure $ foldMap elementToAuthorizer elems+  bScope <- option Set.empty $ l (scopeParser True <* C.char ';' <?> "scope annotation")+  elems <- many $ l authorizerElementParser+  let addScope a = a { vBlock = (vBlock a) { bScope = bScope } }+  pure $ addScope $ foldMap elementToAuthorizer elems -blockParser :: ( HasParsers 'InPredicate ctx-               , HasParsers 'InFact ctx-               , Show (BlockElement' ctx)-               )-            => Parser (Block' ctx)-blockParser = do-  elems <- many' (skipSpace *> blockElementParser)-  pure $ foldMap elementToBlock elems+parseWithParams :: Parser (a 'WithSlices)+                -> (Map Text Value -> Map Text PublicKey -> a 'WithSlices -> Validation (NonEmpty Text) (a 'Representation))+                -> Text+                -> Map Text Value -> Map Text PublicKey+                -> Either (NonEmpty Text) (a 'Representation)+parseWithParams parser substitute input termMapping keyMapping = do+  withSlices <- first (pure . T.pack) $ run parser input+  validationToEither $ substitute termMapping keyMapping withSlices -policyParser :: HasParsers 'InPredicate ctx => Parser (Policy' ctx)-policyParser = do-  policy <- choice-              [ Allow <$ string "allow if"-              , Deny  <$ string "deny if"-              ]-  (policy, ) <$> queryParser+parseBlock :: Text -> Map Text Value -> Map Text PublicKey+           -> Either (NonEmpty Text) Block+parseBlock = parseWithParams blockParser substituteBlock -compileParser :: Lift a => Parser a -> String -> Q Exp-compileParser p str = case parseOnly (p <* skipSpace <* endOfInput) (pack str) of-  Right result -> [| result |]-  Left e       -> fail e+parseAuthorizer :: Text -> Map Text Value -> Map Text PublicKey+                -> Either (NonEmpty Text) Authorizer+parseAuthorizer = parseWithParams authorizerParser substituteAuthorizer +compileParser :: Lift a => Parser a -> (a -> Q Exp) -> String -> Q Exp+compileParser p build =+  either fail build . run p . T.pack+ -- | Quasiquoter for a rule expression. You can reference haskell variables--- like this: @${variableName}@.+-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. rule :: QuasiQuoter rule = QuasiQuoter-  { quoteExp = compileParser (ruleParser @'QuasiQuote)+  { quoteExp = compileParser (ruleParser False) $ \result -> [| result :: Rule |]   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"   }  -- | Quasiquoter for a predicate expression. You can reference haskell variables--- like this: @${variableName}@.+-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. predicate :: QuasiQuoter predicate = QuasiQuoter-  { quoteExp = compileParser (predicateParser @'InPredicate @'QuasiQuote)+  { quoteExp = compileParser predicateParser $ \result -> [| result :: Predicate |]   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"   }  -- | Quasiquoter for a fact expression. You can reference haskell variables--- like this: @${variableName}@.+-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. fact :: QuasiQuoter fact = QuasiQuoter-  { quoteExp = compileParser (predicateParser @'InFact @'QuasiQuote)+  { quoteExp = compileParser factParser $ \result -> [| result :: Fact |]   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"   }  -- | Quasiquoter for a check expression. You can reference haskell variables--- like this: @${variableName}@.+-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. check :: QuasiQuoter check = QuasiQuoter-  { quoteExp = compileParser (checkParser @'QuasiQuote)+  { quoteExp = compileParser (checkParser False) $ \result -> [| result :: Check |]   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"@@ -404,14 +459,14 @@ -- -- > let fileName = "data.pdf" -- >  in [block|--- >       // datalog can reference haskell variables with ${variableName}--- >       resource(${fileName});+-- >       // datalog can reference haskell variables with {variableName}+-- >       resource({fileName}); -- >       rule($variable) <- fact($value), other_fact($value); -- >       check if operation("read"); -- >     |] block :: QuasiQuoter block = QuasiQuoter-  { quoteExp = compileParser (blockParser @'QuasiQuote)+  { quoteExp = compileParser blockParser $ \result -> [| result :: Block |]   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"@@ -425,8 +480,8 @@ -- > do -- >   now <- getCurrentTime -- >   pure [authorizer|--- >          // datalog can reference haskell variables with ${variableName}--- >          current_time(${now});+-- >          // datalog can reference haskell variables with {variableName}+-- >          current_time({now}); -- >          // authorizers can contain facts, rules and checks like blocks, but -- >          // also declare policies. While every check has to pass for a biscuit to -- >          // be valid, policies are tried in order. The first one to match decides@@ -436,7 +491,7 @@ -- >        |] authorizer :: QuasiQuoter authorizer = QuasiQuoter-  { quoteExp = compileParser (authorizerParser @'QuasiQuote)+  { quoteExp = compileParser authorizerParser $ \result -> [| result :: Authorizer |]   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"@@ -450,7 +505,7 @@ -- > [query|user($user_id) or group($group_id)|] query :: QuasiQuoter query = QuasiQuoter-  { quoteExp = compileParser (queryParser @'QuasiQuote)+  { quoteExp = compileParser (queryParser False) $ \result -> [| result :: Query |]   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"

@@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE DuplicateRecordFields      #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE NamedFieldPuns             #-}@@ -16,19 +17,21 @@   , PureExecError (..)   , AuthorizationSuccess (..)   , getBindings-  , queryAuthorizerFacts+  , queryGeneratedFacts+  , queryAvailableFacts   , getVariableValues   , getSingleVariableValue   , FactGroup (..)+  , collectWorld   ) where -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                 (fold, traverse_)+import           Data.List                     (genericLength) import           Data.List.NonEmpty            (NonEmpty) import qualified Data.List.NonEmpty            as NE import           Data.Map                      (Map)@@ -41,6 +44,7 @@ import           Numeric.Natural               (Natural) import           Validation                    (Validation (..)) +import           Auth.Biscuit.Crypto           (PublicKey) import           Auth.Biscuit.Datalog.AST import           Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..),                                                 FactGroup (..), Limits (..),@@ -48,7 +52,6 @@                                                 ResultError (..), Scoped,                                                 checkCheck, checkPolicy,                                                 countFacts, defaultLimits,-                                                extractVariables,                                                 fromScopedFacts,                                                 getBindingsForRuleBody,                                                 getFactsForRule,@@ -56,7 +59,7 @@ import           Auth.Biscuit.Datalog.Parser   (fact) import           Auth.Biscuit.Timer            (timer) -type BlockWithRevocationId = (Block, ByteString)+type BlockWithRevocationId = (Block, ByteString, Maybe PublicKey)  -- | A subset of 'ExecutionError' that can only happen during fact generation data PureExecError = Facts | Iterations | BadRule@@ -83,7 +86,6 @@ getBindings :: AuthorizationSuccess -> Set Bindings getBindings AuthorizationSuccess{matchedAllowQuery=MatchedQuery{bindings}} = bindings - -- | Given a series of blocks and an authorizer, ensure that all -- the checks and policies match runAuthorizer :: BlockWithRevocationId@@ -118,14 +120,16 @@                     -> Set Fact mkRevocationIdFacts authority blocks =   let allIds :: [(Int, ByteString)]-      allIds = zip [0..] $ snd <$> authority : blocks-      mkFact (index, rid) = [fact|revocation_id(${index}, ${rid})|]+      allIds = zip [0..] $ snd' <$> authority : blocks+      snd' (_,b,_) = b+      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+  , sRules      :: Map Natural (Set EvalRule) -- readonly+  , sBlockCount :: Natural   -- state   , sIterations :: Int -- elapsed iterations   , sFacts      :: FactGroup -- facts generated so far@@ -134,16 +138,21 @@  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)+  let fst' (a,_,_) = a+      trd' (_,_,c) = c+      sBlockCount = 1 + genericLength blocks+      externalKeys = Nothing : (trd' <$> blocks)+      revocationWorld = (mempty, FactGroup $ Map.singleton (Set.singleton sBlockCount) $ mkRevocationIdFacts authority blocks)+      firstBlock = fst' authority+      otherBlocks = fst' <$> blocks+      allBlocks = zip [0..] (firstBlock : otherBlocks) <> [(sBlockCount, vBlock authorizer)]+      (sRules, sFacts) = revocationWorld <> fold (uncurry collectWorld . fmap (toEvaluation externalKeys) <$> allBlocks)    in ComputeState         { sLimits = limits         , sRules-        , sFacts+        , sBlockCount         , sIterations = 0+        , sFacts         }  runAuthorizerNoTimeout :: Limits@@ -152,16 +161,24 @@                        -> Authorizer                        -> Either ExecutionError AuthorizationSuccess runAuthorizerNoTimeout limits authority blocks authorizer = do-  let initState = mkInitState limits authority blocks authorizer+  let fst' (a,_,_) = a+      trd' (_,_,c) = c+      blockCount = 1 + genericLength blocks+      externalKeys = Nothing : (trd' <$> blocks)+      (<$$>) = fmap . fmap+      (<$$$>) = fmap . fmap . fmap+      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))+  let checks = bChecks <$$> ( zip [0..] (fst' <$> authority : blocks)+                           <> [(blockCount,vBlock authorizer)]+                            )       policies = vPolicies authorizer-      checkResults = checkChecks limits allFacts checks-      policyResults = checkPolicies limits allFacts policies+      checkResults = checkChecks limits blockCount allFacts (checkToEvaluation externalKeys <$$$> checks)+      policyResults = checkPolicies limits blockCount allFacts (policyToEvaluation externalKeys <$> policies)   case (checkResults, policyResults) of     (Success (), Left Nothing)  -> Left $ ResultError $ NoPoliciesMatched []     (Success (), Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p@@ -175,10 +192,10 @@  runStep :: StateT ComputeState (Either PureExecError) Int runStep = do-  state@ComputeState{sLimits,sFacts,sRules,sIterations} <- get+  state@ComputeState{sLimits,sFacts,sRules,sBlockCount,sIterations} <- get   let Limits{maxFacts, maxIterations} = sLimits       previousCount = countFacts sFacts-      newFacts = sFacts <> extend sLimits sRules sFacts+      newFacts = sFacts <> extend sLimits sBlockCount sRules sFacts       newCount = countFacts newFacts       -- counting the facts returned by `extend` is not equivalent to       -- comparing complete counts, as `extend` may return facts that@@ -192,7 +209,7 @@   return addedFactsCount  -- | Check if every variable from the head is present in the body-checkRuleHead :: Rule -> Bool+checkRuleHead :: EvalRule -> Bool checkRuleHead Rule{rhead, body} =   let headVars = extractVariables [rhead]       bodyVars = extractVariables body@@ -212,36 +229,36 @@  -- | 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 =+runFactGeneration :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> Either PureExecError FactGroup+runFactGeneration sLimits sBlockCount sRules sFacts =   let initState = ComputeState{sIterations = 0, ..}    in computeAllFacts initState -checkChecks :: Limits -> FactGroup -> [(Natural, [Check])] -> Validation (NonEmpty Check) ()-checkChecks limits allFacts =-  traverse_ (uncurry $ checkChecksForGroup limits allFacts)+checkChecks :: Limits -> Natural -> FactGroup -> [(Natural, [EvalCheck])] -> Validation (NonEmpty Check) ()+checkChecks limits blockCount allFacts =+  traverse_ (uncurry $ checkChecksForGroup limits blockCount allFacts) -checkChecksForGroup :: Limits -> FactGroup -> Natural -> [Check] -> Validation (NonEmpty Check) ()-checkChecksForGroup limits allFacts checksBlockId =-  traverse_ (checkCheck limits checksBlockId allFacts)+checkChecksForGroup :: Limits -> Natural -> FactGroup -> Natural -> [EvalCheck] -> Validation (NonEmpty Check) ()+checkChecksForGroup limits blockCount allFacts checksBlockId =+  traverse_ (checkCheck limits blockCount checksBlockId allFacts) -checkPolicies :: Limits -> FactGroup -> [Policy] -> Either (Maybe MatchedQuery) MatchedQuery-checkPolicies limits allFacts policies =-  let results = mapMaybe (checkPolicy limits allFacts) policies+checkPolicies :: Limits -> Natural -> FactGroup -> [EvalPolicy] -> Either (Maybe MatchedQuery) MatchedQuery+checkPolicies limits blockCount allFacts policies =+  let results = mapMaybe (checkPolicy limits blockCount allFacts) policies    in case results of         p : _ -> first Just p         []    -> Left Nothing  -- | 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)+extend :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> FactGroup+extend l blockCount rules facts =+  let buildFacts :: Natural -> Set EvalRule -> 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+        let extendRule :: EvalRule -> Set (Scoped Fact)+            extendRule r@Rule{scope} = getFactsForRule l (toScopedFacts $ keepAuthorized' False blockCount factGroup scope ruleBlockId) r          in foldMap extendRule ruleGroup -      extendRuleGroup :: Natural -> Set Rule -> FactGroup+      extendRuleGroup :: Natural -> Set EvalRule -> FactGroup       extendRuleGroup ruleBlockId ruleGroup =             -- todo pre-filter facts based on the weakest rule scope to avoid passing too many facts             -- to buildFacts@@ -252,32 +269,27 @@    in foldMap (uncurry extendRuleGroup) $ Map.toList rules  -collectWorld :: Natural -> Block -> (Map Natural (Set Rule), FactGroup)+collectWorld :: Natural -> EvalBlock -> (Map Natural (Set EvalRule), 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 }+      applyScope r@Rule{scope} = r { scope = if null scope then bScope else scope }    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.------ ⚠ Only the facts generated by the authority and authorizer blocks are queried.--- Block facts are not queried (since they can't be trusted).------ 💁 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{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+queryGeneratedFacts :: [Maybe PublicKey] -> AuthorizationSuccess -> Query -> Set Bindings+queryGeneratedFacts ePks AuthorizationSuccess{allFacts, limits} =+  queryAvailableFacts ePks allFacts limits++queryAvailableFacts :: [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Set Bindings+queryAvailableFacts ePks allFacts limits q =+  let blockCount = genericLength ePks+      getBindingsForQueryItem QueryItem{qBody,qExpressions,qScope} =+        let facts = toScopedFacts $ keepAuthorized' True blockCount allFacts qScope blockCount+         in Set.map snd $+            getBindingsForRuleBody limits facts qBody qExpressions+   in foldMap (getBindingsForQueryItem . toEvaluation ePks) q  -- | Extract a set of values from a matched variable for a specific type. -- Returning @Set Value@ allows to get all values, whatever their type.

@@ -5,24 +5,28 @@ import           Data.ByteString (ByteString) import           Data.Functor    (($>)) import           Data.Maybe      (fromMaybe)+import           Data.Text       (Text) import           Data.Time       (getCurrentTime)  import           Auth.Biscuit  privateKey' :: SecretKey-privateKey' = fromMaybe (error "Error parsing private key") $ parseSecretKeyHex "todo"+privateKey' = fromMaybe (error "Error parsing private key") $ parseSecretKeyHex "a2c4ead323536b925f3488ee83e0888b79c2761405ca7c0c9a018c7c1905eecc"  publicKey' :: PublicKey-publicKey' = fromMaybe (error "Error parsing public key") $ parsePublicKeyHex "todo"+publicKey' = fromMaybe (error "Error parsing public key") $ parsePublicKeyHex "24afd8171d2c0107ec6d5656aa36f8409184c2567649e0a7f66e629cc3dbfd70"  creation :: IO ByteString creation = do+  let allowedOperations = ["read", "write"] :: [Text]+      networkLocal = "192.168.0.1" :: Text   let authority = [block|-       // toto-       resource("file1");+       // this is a comment+       right("file1", {allowedOperations});+       check if source_ip($source_ip), ["127.0.0.1", {networkLocal}].contains($source_ip);        |]   biscuit <- mkBiscuit privateKey' authority-  let block1 = [block|check if current_time($time), $time < 2021-05-08T00:00:00Z;|]+  let block1 = [block|check if time($time), $time < 2025-05-08T00:00:00Z;|]   newBiscuit <- addBlock block1 biscuit   pure $ serializeB64 newBiscuit @@ -30,7 +34,11 @@ verification serialized = do   now <- getCurrentTime   biscuit <- either (fail . show) pure $ parseB64 publicKey' serialized-  let authorizer' = [authorizer|current_time(${now});|]+  let authorizer' = [authorizer|+        time({now});+        source_ip("127.0.0.1");+        allow if right("file1", $ops), $ops.contains("read");+      |]   result <- authorizeBiscuit biscuit authorizer'   case result of     Left e  -> print e $> False

@@ -16,10 +16,14 @@   , SignedBlock (..)   , PublicKey (..)   , Algorithm (..)+  , ExternalSig (..)   , Proof (..)   , Block (..)+  , Scope (..)+  , ScopeType (..)   , FactV2 (..)   , RuleV2 (..)+  , CheckKind (..)   , CheckV2 (..)   , PredicateV2 (..)   , TermV2 (..)@@ -32,12 +36,18 @@   , BinaryKind (..)   , OpTernary (..)   , TernaryKind (..)+  , ThirdPartyBlockContents (..)+  , ThirdPartyBlockRequest (..)   , getField   , putField   , decodeBlockList   , decodeBlock   , encodeBlockList   , encodeBlock+  , decodeThirdPartyBlockRequest+  , decodeThirdPartyBlockContents+  , encodeThirdPartyBlockRequest+  , encodeThirdPartyBlockContents   ) where  import           Data.ByteString      (ByteString)@@ -61,10 +71,18 @@   deriving (Generic, Show)   deriving anyclass (Decode, Encode) +data ExternalSig = ExternalSig+  { signature :: Required 1 (Value ByteString)+  , publicKey :: Required 2 (Message PublicKey)+  }+  deriving (Generic, Show)+  deriving anyclass (Decode, Encode)+ data SignedBlock = SignedBlock-  { block     :: Required 1 (Value ByteString)-  , nextKey   :: Required 2 (Message PublicKey)-  , signature :: Required 3 (Value ByteString)+  { block       :: Required 1 (Value ByteString)+  , nextKey     :: Required 2 (Message PublicKey)+  , signature   :: Required 3 (Value ByteString)+  , externalSig :: Optional 4 (Message ExternalSig)   }   deriving (Generic, Show)   deriving anyclass (Decode, Encode)@@ -86,9 +104,22 @@   , facts_v2  :: Repeated 4 (Message FactV2)   , rules_v2  :: Repeated 5 (Message RuleV2)   , checks_v2 :: Repeated 6 (Message CheckV2)-  } deriving (Generic, Show)+  , scope     :: Repeated 7 (Message Scope)+  , pksTable  :: Repeated 8 (Message PublicKey)+  } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) +data ScopeType =+    ScopeAuthority+  | ScopePrevious+  deriving stock (Show, Enum, Bounded)++data Scope =+    ScType  (Required 1 (Enumeration ScopeType))+  | ScBlock (Required 2 (Value Int64))+    deriving stock (Generic, Show)+    deriving anyclass (Decode, Encode)+ newtype FactV2 = FactV2   { predicate :: Required 1 (Message PredicateV2)   } deriving stock (Generic, Show)@@ -98,11 +129,18 @@   { head        :: Required 1 (Message PredicateV2)   , body        :: Repeated 2 (Message PredicateV2)   , expressions :: Repeated 3 (Message ExpressionV2)+  , scope       :: Repeated 4 (Message Scope)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -newtype CheckV2 = CheckV2+data CheckKind =+    One+  | All+  deriving stock (Show, Enum, Bounded)++data CheckV2 = CheckV2   { queries :: Repeated 1 (Message RuleV2)+  , kind    :: Optional 2 (Enumeration CheckKind)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) @@ -129,77 +167,6 @@   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -type CV2Id = Required 1 (Value Int32)-data ConstraintV2 =-    CV2Int    CV2Id (Required 2 (Message IntConstraintV2))-  | CV2String CV2Id (Required 3 (Message StringConstraintV2))-  | CV2Date   CV2Id (Required 4 (Message DateConstraintV2))-  | CV2Symbol CV2Id (Required 5 (Message SymbolConstraintV2))-  | CV2Bytes  CV2Id (Required 6 (Message BytesConstraintV2))-    deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--data IntConstraintV2 =-    ICV2LessThan       (Required 1 (Value Int64))-  | ICV2GreaterThan    (Required 2 (Value Int64))-  | ICV2LessOrEqual    (Required 3 (Value Int64))-  | ICV2GreaterOrEqual (Required 4 (Value Int64))-  | ICV2Equal          (Required 5 (Value Int64))-  | ICV2InSet          (Required 6 (Message IntSet))-  | ICV2NotInSet       (Required 7 (Message IntSet))-    deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--newtype IntSet = IntSet-  { set :: Packed 7 (Value Int64)-  } deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--data StringConstraintV2 =-    SCV2Prefix   (Required 1 (Value Text))-  | SCV2Suffix   (Required 2 (Value Text))-  | SCV2Equal    (Required 3 (Value Text))-  | SCV2InSet    (Required 4 (Message StringSet))-  | SCV2NotInSet (Required 5 (Message StringSet))-  | SCV2Regex    (Required 6 (Value Text))-    deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--newtype StringSet = StringSet-  { set :: Repeated 1 (Value Text)-  } deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--data DateConstraintV2 =-    DCV2Before (Required 1 (Value Int64))-  | DCV2After  (Required 2 (Value Int64))-    deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--data SymbolConstraintV2 =-    SyCV2InSet    (Required 1 (Message SymbolSet))-  | SyCV2NotInSet (Required 2 (Message SymbolSet))-    deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--newtype SymbolSet = SymbolSet-  { set :: Packed 1 (Value Int64)-  } deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)---data BytesConstraintV2 =-    BCV2Equal    (Required 1 (Value ByteString))-  | BCV2InSet    (Required 2 (Message BytesSet))-  | BCV2NotInSet (Required 3 (Message BytesSet))-    deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--newtype BytesSet = BytesSet-  { set :: Repeated 1 (Value ByteString)-  } deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)- newtype ExpressionV2 = ExpressionV2   { ops :: Repeated 1 (Message Op)   } deriving stock (Generic, Show)@@ -238,6 +205,9 @@   | Or   | Intersection   | Union+  | BitwiseAnd+  | BitwiseOr+  | BitwiseXor   deriving stock (Show, Enum, Bounded)  newtype OpBinary = OpBinary@@ -267,3 +237,29 @@  encodeBlock :: Block -> ByteString encodeBlock = runPut . encodeMessage++encodeThirdPartyBlockRequest :: ThirdPartyBlockRequest -> ByteString+encodeThirdPartyBlockRequest = runPut . encodeMessage++encodeThirdPartyBlockContents :: ThirdPartyBlockContents -> ByteString+encodeThirdPartyBlockContents = runPut . encodeMessage++decodeThirdPartyBlockRequest :: ByteString -> Either String ThirdPartyBlockRequest+decodeThirdPartyBlockRequest = runGet decodeMessage++decodeThirdPartyBlockContents :: ByteString -> Either String ThirdPartyBlockContents+decodeThirdPartyBlockContents = runGet decodeMessage++data ThirdPartyBlockRequest+  = ThirdPartyBlockRequest+  { previousPk :: Required 1 (Message PublicKey)+  , pkTable    :: Repeated 2 (Message PublicKey)+  } deriving stock (Generic, Show)+    deriving anyclass (Decode, Encode)++data ThirdPartyBlockContents+  = ThirdPartyBlockContents+  { payload     :: Required 1 (Value ByteString)+  , externalSig :: Required 2 (Message ExternalSig)+  } deriving stock (Generic, Show)+    deriving anyclass (Decode, Encode)

@@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeApplications  #-} {-|   Module      : Auth.Biscuit.Utils   Copyright   : © Clément Delafargue, 2021@@ -13,103 +14,158 @@ module Auth.Biscuit.ProtoBufAdapter   ( Symbols   , buildSymbolTable-  , extractSymbols   , pbToBlock   , blockToPb   , pbToSignedBlock   , signedBlockToPb   , pbToProof+  , pbToThirdPartyBlockRequest+  , thirdPartyBlockRequestToPb+  , pbToThirdPartyBlockContents+  , thirdPartyBlockContentsToPb   ) where  import           Control.Monad            (when)-import           Crypto.PubKey.Ed25519    (PublicKey)-import           Data.Bifunctor           (first)+import           Control.Monad.State      (StateT, get, lift, modify)+import           Data.Bitraversable       (bisequence)+import           Data.ByteString          (ByteString) import           Data.Int                 (Int64)+import qualified Data.List.NonEmpty       as NE+import           Data.Maybe               (isNothing) import qualified Data.Set                 as Set+import qualified Data.Text                as T import           Data.Time                (UTCTime) import           Data.Time.Clock.POSIX    (posixSecondsToUTCTime,                                            utcTimeToPOSIXSeconds) import           Data.Void                (absurd)+import           GHC.Records              (getField)+import           Validation               (Validation (..))  import qualified Auth.Biscuit.Crypto      as Crypto import           Auth.Biscuit.Datalog.AST import qualified Auth.Biscuit.Proto       as PB import           Auth.Biscuit.Symbols----- | Given existing symbols and a series of protobuf blocks,--- compute the complete symbol mapping-extractSymbols :: [PB.Block] -> Symbols-extractSymbols blocks =-  addFromBlocks (PB.getField . PB.symbols <$> blocks)+import           Auth.Biscuit.Utils       (maybeToRight) --- | 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 -> BlockSymbols buildSymbolTable existingSymbols block =   let allSymbols = listSymbolsInBlock block-   in addSymbols existingSymbols allSymbols+      allKeys = listPublicKeysInBlock block+   in addSymbols existingSymbols allSymbols allKeys -pbToPublicKey :: PB.PublicKey -> Either String PublicKey+pbToPublicKey :: PB.PublicKey -> Either String Crypto.PublicKey pbToPublicKey PB.PublicKey{..} =   let keyBytes = PB.getField key-      parseKey = Crypto.eitherCryptoError . Crypto.publicKey+      parseKey = Crypto.readEd25519PublicKey    in case PB.getField algorithm of-        PB.Ed25519 -> first (const "Invalid ed25519 public key") $ parseKey keyBytes+        PB.Ed25519 -> maybeToRight "Invalid ed25519 public key" $ parseKey keyBytes +pbToOptionalSignature :: PB.ExternalSig -> Either String (Crypto.Signature, Crypto.PublicKey)+pbToOptionalSignature PB.ExternalSig{..} = do+  let sig = Crypto.signature $ PB.getField signature+  pk  <- pbToPublicKey $ PB.getField publicKey+  pure (sig, pk)+ -- | Parse a protobuf signed block into a signed biscuit block pbToSignedBlock :: PB.SignedBlock -> Either String Crypto.SignedBlock pbToSignedBlock PB.SignedBlock{..} = do-  sig <- first (const "Invalid signature") $ Crypto.eitherCryptoError $ Crypto.signature $ PB.getField signature+  let sig = Crypto.signature $ PB.getField signature+  mSig <- traverse pbToOptionalSignature $ PB.getField externalSig   pk  <- pbToPublicKey $ PB.getField nextKey   pure ( PB.getField block        , sig        , pk+       , mSig        ) -publicKeyToPb :: PublicKey -> PB.PublicKey+publicKeyToPb :: Crypto.PublicKey -> PB.PublicKey publicKeyToPb pk = PB.PublicKey   { algorithm = PB.putField PB.Ed25519-  , key = PB.putField $ Crypto.convert pk+  , key = PB.putField $ Crypto.pkBytes pk   } +externalSigToPb :: (Crypto.Signature, Crypto.PublicKey) -> PB.ExternalSig+externalSigToPb (sig, pk) = PB.ExternalSig+  { signature = PB.putField $ Crypto.sigBytes sig+  , publicKey = PB.putField $ publicKeyToPb pk+  }+ signedBlockToPb :: Crypto.SignedBlock -> PB.SignedBlock-signedBlockToPb (block, sig, pk) = PB.SignedBlock+signedBlockToPb (block, sig, pk, eSig) = PB.SignedBlock   { block = PB.putField block-  , signature = PB.putField $ Crypto.convert sig+  , signature = PB.putField $ Crypto.sigBytes sig   , nextKey = PB.putField $ publicKeyToPb pk+  , externalSig = PB.putField $ externalSigToPb <$> eSig   }  pbToProof :: PB.Proof -> Either String (Either Crypto.Signature Crypto.SecretKey)-pbToProof (PB.ProofSignature rawSig) = Left  <$> first (const "Invalid signature proof") (Crypto.eitherCryptoError $ Crypto.signature $ PB.getField rawSig)-pbToProof (PB.ProofSecret    rawPk)  = Right <$> first (const "Invalid public key proof") (Crypto.eitherCryptoError $ Crypto.secretKey $ PB.getField rawPk)+pbToProof (PB.ProofSignature rawSig) = Left  <$> Right (Crypto.signature $ PB.getField rawSig)+pbToProof (PB.ProofSecret    rawPk)  = Right <$> maybeToRight "Invalid public key proof" (Crypto.readEd25519SecretKey $ PB.getField rawPk) --- | Parse a protobuf block into a proper biscuit block-pbToBlock :: Symbols -> PB.Block -> Either String Block-pbToBlock s PB.Block{..} = do+pbToBlock :: Maybe Crypto.PublicKey -> PB.Block -> StateT Symbols (Either String) Block+pbToBlock ePk PB.Block{..} = do+  blockPks <- lift $ traverse pbToPublicKey $ PB.getField pksTable+  let blockSymbols = PB.getField symbols+  -- third party blocks use an isolated symbol table,+  -- but use the global public keys table:+  --   symbols defined in 3rd party blocks are not visible+  --   to following blocks, but public keys are+  when (isNothing ePk) $ modify (registerNewSymbols blockSymbols)+  modify (registerNewPublicKeys $ foldMap pure ePk <> blockPks)+  currentSymbols <- get++  let symbolsForCurrentBlock =+        -- third party blocks use an isolated symbol table,+        -- but use the global public keys table.+        --   3rd party blocks don't see previously defined+        --   symbols, but see previously defined public keys+        if isNothing ePk then currentSymbols+                         else registerNewSymbols blockSymbols $ forgetSymbols currentSymbols   let bContext = PB.getField context       bVersion = PB.getField version-  bFacts <- traverse (pbToFact s) $ PB.getField facts_v2-  bRules <- traverse (pbToRule s) $ PB.getField rules_v2-  bChecks <- traverse (pbToCheck s) $ PB.getField checks_v2-  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{ .. }+  lift $ do+    let s = symbolsForCurrentBlock+    bFacts <- traverse (pbToFact s) $ PB.getField facts_v2+    bRules <- traverse (pbToRule s) $ PB.getField rules_v2+    bChecks <- traverse (pbToCheck s) $ PB.getField checks_v2+    bScope <- Set.fromList <$> traverse (pbToScope s) (PB.getField scope)+    let isV3 = isNothing ePk+            && Set.null bScope+            && all ruleHasNoScope bRules+            && all queryHasNoScope (cQueries <$> bChecks)+            && all isCheckOne bChecks+            && all ruleHasNoV4Operators bRules+            && all queryHasNoV4Operators (cQueries <$> bChecks)+    case (bVersion, isV3) of+      (Just 4, _) -> pure Block {..}+      (Just 3, True) -> pure Block {..}+      (Just 3, False) ->+        Left "Biscuit v4 fields are present, but the block version is 3."+      _ ->+        Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only versions 3 and 4 are supported"  -- | Turn a biscuit block into a protobuf block, for serialization, -- along with the newly defined symbols-blockToPb :: Symbols -> Block -> (BlockSymbols, PB.Block)-blockToPb existingSymbols b@Block{..} =-  let+blockToPb :: Bool -> Symbols -> Block -> (BlockSymbols, PB.Block)+blockToPb hasExternalPk existingSymbols b@Block{..} =+  let isV3 = not hasExternalPk+            && Set.null bScope+            && all ruleHasNoScope bRules+            && all queryHasNoScope (cQueries <$> bChecks)+            && all isCheckOne bChecks+            && all ruleHasNoV4Operators bRules+            && all queryHasNoV4Operators (cQueries <$> bChecks)       bSymbols = buildSymbolTable existingSymbols b       s = reverseSymbols $ addFromBlock existingSymbols bSymbols       symbols   = PB.putField $ getSymbolList bSymbols       context   = PB.putField bContext-      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+      scope     = PB.putField $ scopeToPb s <$> Set.toList bScope+      pksTable   = PB.putField $ publicKeyToPb <$> getPkList bSymbols+      version   = PB.putField $ if isV3 then Just 3+                                        else Just 4    in (bSymbols, PB.Block {..})  pbToFact :: Symbols -> PB.FactV2 -> Either String Fact@@ -134,11 +190,14 @@   let pbHead = PB.getField $ PB.head pbRule       pbBody = PB.getField $ PB.body pbRule       pbExpressions = PB.getField $ PB.expressions pbRule+      pbScope = PB.getField $ getField @"scope" pbRule   rhead       <- pbToPredicate s pbHead   body        <- traverse (pbToPredicate s) pbBody   expressions <- traverse (pbToExpression s) pbExpressions-  let scope = Nothing -- todo read it from PB-  pure Rule {..}+  scope       <- Set.fromList <$> traverse (pbToScope s) pbScope+  case makeRule rhead body expressions scope of+    Failure vs -> Left $ "Unbound variables in rule: " <> T.unpack (T.intercalate ", " $ NE.toList vs)+    Success r  -> pure r  ruleToPb :: ReverseSymbols -> Rule -> PB.RuleV2 ruleToPb s Rule{..} =@@ -146,16 +205,22 @@     { head = PB.putField $ predicateToPb s rhead     , body = PB.putField $ predicateToPb s <$> body     , expressions = PB.putField $ expressionToPb s <$> expressions+    , scope = PB.putField $ scopeToPb s <$> Set.toList scope     }  pbToCheck :: Symbols -> PB.CheckV2 -> Either String Check-pbToCheck s PB.CheckV2{queries} = do+pbToCheck s PB.CheckV2{queries,kind} = do   let toCheck Rule{body,expressions,scope} = QueryItem{qBody = body, qExpressions = expressions, qScope = scope}   rules <- traverse (pbToRule s) $ PB.getField queries-  pure $ toCheck <$> rules+  let cQueries = toCheck <$> rules+  let cKind = case PB.getField kind of+        Just PB.All -> All+        Just PB.One -> One+        Nothing     -> One+  pure Check{..}  checkToPb :: ReverseSymbols -> Check -> PB.CheckV2-checkToPb s items =+checkToPb s Check{..} =   let dummyHead = Predicate "query" []       toQuery QueryItem{..} =         ruleToPb s $ Rule { rhead = dummyHead@@ -163,9 +228,28 @@                           , expressions = qExpressions                           , scope = qScope                           }-   in PB.CheckV2 { queries = PB.putField $ toQuery <$> items }+      pbKind = case cKind of+        One -> Nothing+        All -> Just PB.All+   in PB.CheckV2 { queries = PB.putField $ toQuery <$> cQueries+                 , kind = PB.putField pbKind+                 } -pbToPredicate :: Symbols -> PB.PredicateV2 -> Either String (Predicate' 'InPredicate 'RegularString)+pbToScope :: Symbols -> PB.Scope -> Either String RuleScope+pbToScope s = \case+  PB.ScType e       -> case PB.getField e of+    PB.ScopeAuthority -> Right OnlyAuthority+    PB.ScopePrevious  -> Right Previous+  PB.ScBlock pkRef ->+    BlockId <$> getPublicKey' s (PublicKeyRef $ PB.getField pkRef)++scopeToPb :: ReverseSymbols -> RuleScope -> PB.Scope+scopeToPb s = \case+  OnlyAuthority -> PB.ScType $ PB.putField PB.ScopeAuthority+  Previous      -> PB.ScType $ PB.putField PB.ScopePrevious+  BlockId pk    -> PB.ScBlock $ PB.putField $ getPublicKeyCode s pk++pbToPredicate :: Symbols -> PB.PredicateV2 -> Either String (Predicate' 'InPredicate 'Representation) pbToPredicate s pbPredicate = do   let pbName  = PB.getField $ PB.name  pbPredicate       pbTerms = PB.getField $ PB.terms pbPredicate@@ -227,7 +311,7 @@   Variable v  -> absurd v   Antiquote v -> absurd v -pbToSetValue :: Symbols -> PB.TermV2 -> Either String (Term' 'WithinSet 'InFact 'RegularString)+pbToSetValue :: Symbols -> PB.TermV2 -> Either String (Term' 'WithinSet 'InFact 'Representation) pbToSetValue s = \case   PB.TermInteger  f -> pure $ LInteger $ fromIntegral $ PB.getField f   PB.TermString   f ->        LString  <$> getSymbol s (SymbolRef $ PB.getField f)@@ -237,7 +321,7 @@   PB.TermVariable _ -> Left "Variables can't appear in facts or sets"   PB.TermTermSet  _ -> Left "Sets can't be nested" -setValueToPb :: ReverseSymbols -> Term' 'WithinSet 'InFact 'RegularString -> PB.TermV2+setValueToPb :: ReverseSymbols -> Term' 'WithinSet 'InFact 'Representation -> PB.TermV2 setValueToPb s = \case   LInteger v  -> PB.TermInteger $ PB.putField $ fromIntegral v   LString  v  -> PB.TermString  $ PB.putField $ getSymbolRef $ getSymbolCode s v@@ -302,6 +386,9 @@   PB.Or             -> Or   PB.Intersection   -> Intersection   PB.Union          -> Union+  PB.BitwiseAnd     -> BitwiseAnd+  PB.BitwiseOr      -> BitwiseOr+  PB.BitwiseXor     -> BitwiseXor  binaryToPb :: Binary -> PB.OpBinary binaryToPb = PB.OpBinary . PB.putField . \case@@ -322,3 +409,35 @@   Or             -> PB.Or   Intersection   -> PB.Intersection   Union          -> PB.Union+  BitwiseAnd     -> PB.BitwiseAnd+  BitwiseOr      -> PB.BitwiseOr+  BitwiseXor     -> PB.BitwiseXor+++pbToThirdPartyBlockRequest :: PB.ThirdPartyBlockRequest -> Either String (Crypto.PublicKey, [Crypto.PublicKey])+pbToThirdPartyBlockRequest PB.ThirdPartyBlockRequest{previousPk, pkTable} = do+  bisequence+    ( pbToPublicKey $ PB.getField previousPk+    , traverse pbToPublicKey $ PB.getField pkTable+    )++thirdPartyBlockRequestToPb :: (Crypto.PublicKey, [Crypto.PublicKey]) -> PB.ThirdPartyBlockRequest+thirdPartyBlockRequestToPb (previousPk, pkTable) = PB.ThirdPartyBlockRequest+  { previousPk = PB.putField $ publicKeyToPb previousPk+  , pkTable = PB.putField $ publicKeyToPb <$> pkTable+  }++pbToThirdPartyBlockContents :: PB.ThirdPartyBlockContents -> Either String (ByteString, Crypto.Signature, Crypto.PublicKey)+pbToThirdPartyBlockContents PB.ThirdPartyBlockContents{payload,externalSig} = do+  (sig, pk) <- pbToOptionalSignature $ PB.getField externalSig+  pure ( PB.getField payload+       , sig+       , pk+       )++thirdPartyBlockContentsToPb :: (ByteString, Crypto.Signature, Crypto.PublicKey) -> PB.ThirdPartyBlockContents+thirdPartyBlockContentsToPb (payload, sig, pk) = PB.ThirdPartyBlockContents+  { PB.payload = PB.putField payload+  , PB.externalSig = PB.putField $ externalSigToPb (sig, pk)+  }+

@@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns             #-} {-# LANGUAGE OverloadedLists            #-} {-# LANGUAGE OverloadedStrings          #-} module Auth.Biscuit.Symbols@@ -7,89 +8,164 @@   , BlockSymbols   , ReverseSymbols   , SymbolRef (..)+  , PublicKeyRef (..)   , getSymbol+  , getPublicKey'   , addSymbols   , addFromBlock-  , addFromBlocks+  , registerNewSymbols+  , registerNewPublicKeys+  , forgetSymbols   , reverseSymbols   , getSymbolList+  , getPkList+  , getPkTable   , getSymbolCode+  , getPublicKeyCode   , 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.Crypto (PublicKey)+import           Data.Int            (Int64)+import           Data.List           ((\\))+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)+import           Auth.Biscuit.Utils  (maybeToRight)  newtype SymbolRef = SymbolRef { getSymbolRef :: Int64 }-  deriving stock (Eq)+  deriving stock (Eq, Ord)+  deriving newtype (Enum)  instance Show SymbolRef where   show = ("#" <>) . show . getSymbolRef -newtype Symbols = Symbols { getSymbols :: Map Int64 Text }-  deriving stock (Eq, Show)+newtype PublicKeyRef = PublicKeyRef { getPublicKeyRef :: Int64 }+  deriving stock (Eq, Ord)+  deriving newtype (Enum) -newtype BlockSymbols = BlockSymbols { getBlockSymbols :: Map Int64 Text }-  deriving stock (Eq, Show)-  deriving newtype (Semigroup)+instance Show PublicKeyRef where+  show = ("#" <>) . show . getPublicKeyRef -newtype ReverseSymbols = ReverseSymbols { getReverseSymbols :: Map Text Int64 }+data Symbols = Symbols+  { symbols    :: Map SymbolRef Text+  , publicKeys :: Map PublicKeyRef PublicKey+  } deriving stock (Eq, Show)++data BlockSymbols = BlockSymbols+  { blockSymbols    :: Map SymbolRef Text+  , blockPublicKeys :: Map PublicKeyRef PublicKey+  } deriving stock (Eq, Show)++instance Semigroup BlockSymbols where+  b <> b' = BlockSymbols+              { blockSymbols = blockSymbols b <> blockSymbols b'+              , blockPublicKeys = blockPublicKeys b <> blockPublicKeys b'+              }++data ReverseSymbols = ReverseSymbols+  { reverseSymbolMap    :: Map Text SymbolRef+  , reversePublicKeyMap :: Map PublicKey PublicKeyRef+  }   deriving stock (Eq, Show)-  deriving newtype (Semigroup) +instance Semigroup ReverseSymbols where+  b <> b' = ReverseSymbols+              { reverseSymbolMap = reverseSymbolMap b <> reverseSymbolMap b'+              , reversePublicKeyMap = reversePublicKeyMap b <> reversePublicKeyMap b'+              }++getNextOffset :: Symbols -> SymbolRef+getNextOffset (Symbols m _) =+  SymbolRef $ fromIntegral $ 1024 + (Map.size m - Map.size commonSymbols)++getNextPublicKeyOffset :: Symbols -> PublicKeyRef+getNextPublicKeyOffset (Symbols _ m) =+  PublicKeyRef $ fromIntegral $ Map.size m+ getSymbol :: Symbols -> SymbolRef -> Either String Text-getSymbol (Symbols m) (SymbolRef i) =-  maybeToRight ("Missing symbol at id #" <> show i) $ m !? i+getSymbol (Symbols m _) i =+  maybeToRight ("Missing symbol at id " <> show i) $ m !? i +getPublicKey' :: Symbols -> PublicKeyRef -> Either String PublicKey+getPublicKey' (Symbols _ m) 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)+addSymbols :: Symbols -> Set Text -> Set PublicKey -> BlockSymbols+addSymbols s@(Symbols sm pkm) bSymbols pks =+  let existingSymbols = Set.fromList (elems commonSymbols) `union` Set.fromList (elems sm)+      newSymbols = Set.toList $ bSymbols `difference` existingSymbols+      starting = getNextOffset s+      existingPks = Set.fromList (elems pkm)+      newPks = Set.toList $ pks `difference` existingPks+      startingPk = getNextPublicKeyOffset s+   in BlockSymbols+        { blockSymbols = Map.fromList (zip [starting..] newSymbols)+        , blockPublicKeys = Map.fromList (zip [startingPk..] newPks)+        }  getSymbolList :: BlockSymbols -> [Text]-getSymbolList (BlockSymbols m) = Map.elems m+getSymbolList (BlockSymbols m _) = Map.elems m +getPkList :: BlockSymbols -> [PublicKey]+getPkList (BlockSymbols _ m) = Map.elems m++getPkTable :: Symbols -> [PublicKey]+getPkTable (Symbols _ m) = Map.elems m+ newSymbolTable :: Symbols-newSymbolTable = Symbols commonSymbols+newSymbolTable = Symbols commonSymbols Map.empty  -- | 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+addFromBlock (Symbols sm pkm) (BlockSymbols bsm bpkm) =+   Symbols+     { symbols = sm <> bsm+     , publicKeys = pkm <> bpkm+     } --- | 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)+registerNewSymbols :: [Text] -> Symbols -> Symbols+registerNewSymbols newSymbols s@Symbols{symbols} =+  let newSymbolsMap = Map.fromList $ zip [getNextOffset s..] newSymbols+   in s { symbols = symbols <> newSymbolsMap } +registerNewPublicKeys :: [PublicKey] -> Symbols -> Symbols+registerNewPublicKeys newPks s@Symbols{publicKeys} =+  let newPkMap = Map.fromList $ zip [getNextPublicKeyOffset s..] (newPks \\ elems publicKeys)+   in s { publicKeys = publicKeys <> newPkMap }++forgetSymbols :: Symbols -> Symbols+forgetSymbols s = s { symbols = commonSymbols }+ -- | Reverse a symbol table reverseSymbols :: Symbols -> ReverseSymbols-reverseSymbols =+reverseSymbols (Symbols sm pkm) =   let swap (a,b) = (b,a)-   in ReverseSymbols . Map.fromList . fmap swap . Map.toList . getSymbols+      reverseMap :: (Ord a, Ord b) => Map a b -> Map b a+      reverseMap = Map.fromList . fmap swap . Map.toList+   in ReverseSymbols+       { reverseSymbolMap = reverseMap sm+       , reversePublicKeyMap = reverseMap pkm+       }  -- | 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+getSymbolCode (ReverseSymbols rm _) t = rm Map.! t +getPublicKeyCode :: ReverseSymbols -> PublicKey -> Int64+getPublicKeyCode (ReverseSymbols _ rm) t = getPublicKeyRef $ rm Map.! t+ -- | The common symbols defined in the biscuit spec-commonSymbols :: Map Int64 Text-commonSymbols = Map.fromList $ zip [0..]+commonSymbols :: Map SymbolRef Text+commonSymbols = Map.fromList $ zip [SymbolRef 0..]   [ "read"   , "write"   , "resource"

@@ -20,9 +20,12 @@   , blocks   , proof   , proofCheck+  , queryRawBiscuitFacts   , ParseError (..)   , ExistingBlock   , ParsedSignedBlock+  , AuthorizedBiscuit (..)+  , queryAuthorizerFacts   -- $openOrSealed   , OpenOrSealed   , Open@@ -33,6 +36,7 @@   , mkBiscuit   , mkBiscuitWith   , addBlock+  , addSignedBlock   , BiscuitEncoding (..)   , ParserConfig (..)   , parseBiscuitWith@@ -50,12 +54,19 @@   , getRevocationIds   , getVerifiedBiscuitPublicKey +  -- third party+  , mkThirdPartyBlockReq+  , mkThirdPartyBlock+  , applyThirdPartyBlock   ) where -import           Control.Monad                       (join, when)+import           Control.Monad                       (join, unless, when)+import           Control.Monad.State                 (lift, mapStateT,+                                                      runStateT) import           Data.Bifunctor                      (first) import           Data.ByteString                     (ByteString) import qualified Data.ByteString.Base64.URL          as B64+import           Data.Foldable                       (fold) import           Data.List.NonEmpty                  (NonEmpty ((:|))) import qualified Data.List.NonEmpty                  as NE import           Data.Set                            (Set)@@ -63,29 +74,41 @@  import           Auth.Biscuit.Crypto                 (PublicKey, SecretKey,                                                       Signature, SignedBlock,-                                                      convert,                                                       getSignatureProof,-                                                      signBlock, toPublic,+                                                      sigBytes,+                                                      sign3rdPartyBlock,+                                                      signBlock,+                                                      signExternalBlock,+                                                      skBytes, toPublic,                                                       verifyBlocks,+                                                      verifyExternalSig,                                                       verifySecretProof,                                                       verifySignatureProof)-import           Auth.Biscuit.Datalog.AST            (Authorizer, Block)-import           Auth.Biscuit.Datalog.Executor       (ExecutionError, Limits,-                                                      defaultLimits)+import           Auth.Biscuit.Datalog.AST            (Authorizer, Block, Query,+                                                      toEvaluation)+import           Auth.Biscuit.Datalog.Executor       (Bindings, ExecutionError,+                                                      Limits, defaultLimits) import           Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess,+                                                      collectWorld,+                                                      queryAvailableFacts,+                                                      queryGeneratedFacts,                                                       runAuthorizerWithLimits) import qualified Auth.Biscuit.Proto                  as PB-import           Auth.Biscuit.ProtoBufAdapter        (blockToPb, extractSymbols,-                                                      pbToBlock, pbToProof,+import           Auth.Biscuit.ProtoBufAdapter        (blockToPb, pbToBlock,+                                                      pbToProof,                                                       pbToSignedBlock,-                                                      signedBlockToPb)+                                                      pbToThirdPartyBlockContents,+                                                      pbToThirdPartyBlockRequest,+                                                      signedBlockToPb,+                                                      thirdPartyBlockContentsToPb,+                                                      thirdPartyBlockRequestToPb) 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 -- a new signature when adding a block. type ExistingBlock = (ByteString, Block)-type ParsedSignedBlock = (ExistingBlock, Signature, PublicKey)+type ParsedSignedBlock = (ExistingBlock, Signature, PublicKey, Maybe (Signature, PublicKey))  -- $openOrSealed --@@ -109,12 +132,14 @@ -- /open/ (capable of being attenuated further). In that case the proof is a secret -- key that can be used to sign a new block. newtype Open = Open SecretKey+  deriving stock (Eq, Show)  -- | This datatype represents the final proof of a biscuit statically known to be -- /sealed/ (not capable of being attenuated further). In that case the proof is a -- signature proving that the party who sealed the token did know the last secret -- key. newtype Sealed = Sealed Signature+  deriving stock (Eq, Show)  -- | This class allows functions working on both open and sealed biscuits to accept -- indifferently 'OpenOrSealed', 'Open' or 'Sealed' biscuits. It has no laws, it only@@ -178,6 +203,42 @@   }   deriving (Eq, Show) +-- | Query the facts contained in a biscuit, /before running authorization/. This function+-- should only be used to extract information needed to generate an authorizer. In other+-- cases, you likely want 'queryAuthorizerFacts' instead, which queries facts /after running+-- authorization/.+--+-- ⚠ Only facts directly contained in the biscuit are queried. Rules are not processed+-- at this point, so derived facts are not generated yet.+--+-- ⚠ By default, only facts from the authority block are queried,+-- like what happens in rules and checks. Facts from other blocks can be queried+-- with a @trusting@ annotation. Be careful with @trusting previous@, as it queries+-- facts from all blocks, even untrusted ones.+queryRawBiscuitFactsWithLimits :: Biscuit openOrSealed check -> Limits -> Query+                               -> Set Bindings+queryRawBiscuitFactsWithLimits b@Biscuit{authority,blocks} =+  let ePks = externalKeys b+      getBlock ((_, block), _, _, _) = block+      allBlocks = zip [0..] $ getBlock <$> authority : blocks+      (_, sFacts) = fold (uncurry collectWorld . fmap (toEvaluation ePks) <$> allBlocks)+   in queryAvailableFacts ePks sFacts++-- | 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.+--+-- ⚠ By default, only facts from the authority block and the authorizer are queried,+-- like what happens in rules and checks. Facts from other blocks can be queried+-- with a @trusting@ annotation. Be careful with @trusting previous@, as it queries+-- facts from all blocks, even untrusted ones.+--+-- 💁 If the facts you want to query are part of an allow query in the authorizer,+-- you can directly get values by calling 'getBindings' on 'AuthorizationSuccess'.+queryRawBiscuitFacts :: Biscuit openOrSealed check -> Query+                     -> Set Bindings+queryRawBiscuitFacts b = queryRawBiscuitFactsWithLimits b defaultLimits+ -- | Turn a 'Biscuit' statically known to be 'Open' into a more generic 'OpenOrSealed' 'Biscuit' -- (essentially /forgetting/ about the fact it's 'Open') fromOpen :: Biscuit Open check -> Biscuit OpenOrSealed check@@ -203,7 +264,7 @@   _           -> Nothing  toParsedSignedBlock :: Block -> SignedBlock -> ParsedSignedBlock-toParsedSignedBlock block (serializedBlock, sig, pk) = ((serializedBlock, block), sig, pk)+toParsedSignedBlock block (serializedBlock, sig, pk, eSig) = ((serializedBlock, block), sig, pk, eSig)  -- | Create a new biscuit with the provided authority block. Such a biscuit is 'Open' to -- further attenuation.@@ -214,8 +275,8 @@ -- 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+  let (authoritySymbols, authoritySerialized) = PB.encodeBlock <$> blockToPb False newSymbolTable authority+  (signedBlock, nextSk) <- signBlock sk authoritySerialized Nothing   pure Biscuit { rootKeyId                , authority = toParsedSignedBlock authority signedBlock                , blocks = []@@ -230,29 +291,103 @@          -> Biscuit Open check          -> IO (Biscuit Open check) addBlock block b@Biscuit{..} = do-  let (blockSymbols, blockSerialized) = PB.encodeBlock <$> blockToPb symbols block+  let (blockSymbols, blockSerialized) = PB.encodeBlock <$> blockToPb False symbols block       Open p = proof-  (signedBlock, nextSk) <- signBlock p blockSerialized+  (signedBlock, nextSk) <- signBlock p blockSerialized Nothing   pure $ b { blocks = blocks <> [toParsedSignedBlock block signedBlock]            , symbols = addFromBlock symbols blockSymbols            , proof = Open nextSk            } +-- | Directly append a third-party block to a token. Please use+-- 'mkThirdPartyBlockReq', 'mkThirdPartyBlock' and 'applyThirdPartyBlock'+-- instead if the party signing the block cannot have access to the token.+addSignedBlock :: SecretKey+               -> Block+               -> Biscuit Open check+               -> IO (Biscuit Open check)+addSignedBlock eSk block b@Biscuit{..} = do+  let symbolsForCurrentBlock = forgetSymbols $ registerNewPublicKeys [toPublic eSk] symbols+      (newSymbols, blockSerialized) = PB.encodeBlock <$> blockToPb True symbolsForCurrentBlock block+      lastBlock = NE.last (authority :| blocks)+      (_, _, lastPublicKey, _) = lastBlock+      Open p = proof+  (signedBlock, nextSk) <- signExternalBlock p eSk lastPublicKey blockSerialized+  pure $ b { blocks = blocks <> [toParsedSignedBlock block signedBlock]+           , symbols = registerNewPublicKeys (getPkList newSymbols) symbols+           , proof = Open nextSk+           }++mkThirdPartyBlock' :: SecretKey+                   -> [PublicKey]+                   -> PublicKey+                   -> Block+                   -> (ByteString, Signature, PublicKey)+mkThirdPartyBlock' eSk pkTable lastPublicKey block =+  let symbolsForCurrentBlock = registerNewPublicKeys [toPublic eSk] $+        registerNewPublicKeys pkTable newSymbolTable+      (_, payload) = PB.encodeBlock <$> blockToPb True symbolsForCurrentBlock block+      (eSig, ePk) = sign3rdPartyBlock eSk lastPublicKey payload+   in (payload, eSig, ePk)++-- | Given a third-party block request, generate a third-party block,+-- which can be then appended to a token with 'applyThirdPartyBlock'.+mkThirdPartyBlock :: SecretKey+                  -> ByteString+                  -> Block+                  -> Either String ByteString+mkThirdPartyBlock eSk req block = do+  (previousPk, pkTable) <- pbToThirdPartyBlockRequest =<< PB.decodeThirdPartyBlockRequest req+  pure $ PB.encodeThirdPartyBlockContents . thirdPartyBlockContentsToPb $ mkThirdPartyBlock' eSk pkTable previousPk block++-- | Generate a third-party block request. It can be used in+-- conjunction with 'mkThirdPartyBlock' to generate a+-- third-party block, which can be then appended to a token with+-- 'applyThirdPartyBlock'.+mkThirdPartyBlockReq :: Biscuit proof check -> ByteString+mkThirdPartyBlockReq Biscuit{authority,blocks,symbols} =+  let (_, _ , lastPk, _) = NE.last $ authority :| blocks+   in PB.encodeThirdPartyBlockRequest $ thirdPartyBlockRequestToPb (lastPk, getPkTable symbols)++-- | Given a base64-encoded third-party block, append it to a token.+applyThirdPartyBlock :: Biscuit Open check -> ByteString -> Either String (IO (Biscuit Open check))+applyThirdPartyBlock b@Biscuit{..} contents = do+  (payload, eSig, ePk) <- pbToThirdPartyBlockContents =<< PB.decodeThirdPartyBlockContents contents+  let Open p = proof+      addESig (a,b',c,_) = (a,b',c, Just (eSig, ePk))+      (_, _, lastPk, _) = NE.last $ authority :| blocks+  pbBlock <- PB.decodeBlock payload+  (block, newSymbols) <- (`runStateT` symbols) $ pbToBlock (Just ePk) pbBlock+  unless (verifyExternalSig lastPk (payload, eSig, ePk)) $+    Left "Invalid 3rd party signature"+  pure $ do+    (signedBlock, nextSk) <- signBlock p payload (Just (eSig, ePk))+    pure $ b { blocks = blocks <> [toParsedSignedBlock block (addESig signedBlock)]+             , proof = Open nextSk+             , symbols = newSymbols+             }++externalKeys :: Biscuit openOrSealed check -> [Maybe PublicKey]+externalKeys Biscuit{blocks} =+  let getEpk (_, _, _, Just (_, ePk)) = Just ePk+      getEpk _                        = Nothing+   in Nothing : (getEpk <$> blocks)+ -- | Turn an 'Open' biscuit into a 'Sealed' one, preventing it from being attenuated -- further. A 'Sealed' biscuit cannot be turned into an 'Open' one. seal :: Biscuit Open check -> Biscuit Sealed check seal b@Biscuit{..} =   let Open sk = proof-      ((lastPayload, _), lastSig, lastPk) = NE.last $ authority :| blocks-      newProof = Sealed $ getSignatureProof (lastPayload, lastSig, lastPk) sk+      ((lastPayload, _), lastSig, lastPk, eSig) = NE.last $ authority :| blocks+      newProof = Sealed $ getSignatureProof (lastPayload, lastSig, lastPk, eSig) sk    in b { proof = newProof }  -- | Serialize a biscuit to a raw bytestring serializeBiscuit :: BiscuitProof p => Biscuit p Verified -> ByteString serializeBiscuit Biscuit{..} =   let proofField = case toPossibleProofs proof of-          SealedProof sig -> PB.ProofSignature $ PB.putField (convert sig)-          OpenProof   sk  -> PB.ProofSecret $ PB.putField (convert sk)+          SealedProof sig -> PB.ProofSignature $ PB.putField (sigBytes sig)+          OpenProof   sk  -> PB.ProofSecret $ PB.putField (skBytes sk)    in PB.encodeBlockList PB.Biscuit         { rootKeyId = PB.putField $ fromIntegral <$> rootKeyId         , authority = PB.putField $ toPBSignedBlock authority@@ -261,7 +396,7 @@         }  toPBSignedBlock :: ParsedSignedBlock -> PB.SignedBlock-toPBSignedBlock ((block, _), sig, pk) = signedBlockToPb (block, sig, pk)+toPBSignedBlock ((block, _), sig, pk, eSig) = signedBlockToPb (block, sig, pk, eSig)  -- | Errors that can happen when parsing a biscuit. Since complete parsing of a biscuit -- requires a signature check, an invalid signature check is a parsing error@@ -272,8 +407,10 @@   -- ^ The provided ByteString is not base64-encoded   | InvalidProtobufSer Bool String   -- ^ The provided ByteString does not contain properly serialized protobuf values+  -- The boolean parameter is True if the error happened on the wrapper, False if it happened on a block   | InvalidProtobuf Bool String   -- ^ The bytestring was correctly deserialized from protobuf, but the values can't be turned into a proper biscuit+  -- The boolean parameter is True if the error happened on the wrapper, False if it happened on a block   | InvalidSignatures   -- ^ The signatures were invalid   | InvalidProof@@ -313,7 +450,7 @@                 -> BiscuitWrapper                 -> m (Either ParseError BiscuitWrapper) checkRevocation isRevoked bw@BiscuitWrapper{wAuthority,wBlocks} =-  let getRevocationId (_, sig, _) = convert sig+  let getRevocationId (_, sig, _, _) = sigBytes sig       revocationIds = getRevocationId <$> wAuthority :| wBlocks       keepIfNotRevoked True  = Left RevokedBiscuit       keepIfNotRevoked False = Right bw@@ -321,18 +458,15 @@  parseBlocks :: BiscuitWrapper -> Either ParseError (Symbols, NonEmpty ParsedSignedBlock) parseBlocks BiscuitWrapper{..} = do-  let toRawSignedBlock (payload, sig, pk') = do-        pbBlock <- first (InvalidProtobufSer False) $ PB.decodeBlock payload-        pure ((payload, pbBlock), sig, pk')--  rawAuthority <- toRawSignedBlock wAuthority-  rawBlocks    <- traverse toRawSignedBlock wBlocks+  let parseBlock (payload, sig, pk, eSig) = do+        pbBlock <- lift $ first (InvalidProtobufSer False) $ PB.decodeBlock payload+        block   <- mapStateT (first (InvalidProtobuf False)) $ pbToBlock (snd <$> eSig) pbBlock+        pure ((payload, block), sig, pk, eSig) -  let symbols = extractSymbols $ (\((_, p), _, _) -> p) <$> rawAuthority : rawBlocks+  (allBlocks, symbols) <- (`runStateT` newSymbolTable) $ do+     traverse parseBlock (wAuthority :| wBlocks) -  authority <- rawSignedBlockToParsedSignedBlock symbols rawAuthority-  blocks    <- traverse (rawSignedBlockToParsedSignedBlock symbols) rawBlocks-  pure (symbols, authority :| blocks)+  pure (symbols, allBlocks)  -- | Parse a biscuit without performing any signatures check. This function is intended to -- provide tooling (eg adding a block, or inspecting a biscuit) without having to verify@@ -374,7 +508,7 @@                        -> Either ParseError (Biscuit proof Verified) checkBiscuitSignatures getPublicKey b@Biscuit{..} = do   let pk = getPublicKey rootKeyId-      toSignedBlock ((payload, _), sig, nextPk) = (payload, sig, nextPk)+      toSignedBlock ((payload, _), sig, nextPk, eSig) = (payload, sig, nextPk, eSig)       allBlocks = toSignedBlock <$> (authority :| blocks)       blocksResult = verifyBlocks allBlocks pk       proofResult = case toPossibleProofs proof of@@ -415,30 +549,34 @@          in (parseBiscuit' pk =<<) <$> checkRevocation isRevoked w    in join <$> traverse wrapperToBiscuit parsedWrapper -rawSignedBlockToParsedSignedBlock :: Symbols-                                  -> ((ByteString, PB.Block), Signature, PublicKey)-                                  -> Either ParseError ParsedSignedBlock-rawSignedBlockToParsedSignedBlock s ((payload, pbBlock), sig, pk) = do-  block   <- first (InvalidProtobuf False) $ pbToBlock s pbBlock-  pure ((payload, block), sig, pk)- -- | Extract the list of revocation ids from a biscuit. -- To reject revoked biscuits, please use 'parseWith' instead. This function--- should only be used for debugging purposes.+-- should only be used for inspecting biscuits, not for deciding whether to+-- reject them or not. getRevocationIds :: Biscuit proof check -> NonEmpty ByteString getRevocationIds Biscuit{authority, blocks} =   let allBlocks = authority :| blocks-      getRevocationId (_, sig, _) = convert sig+      getRevocationId (_, sig, _, _) = sigBytes sig    in getRevocationId <$> allBlocks  -- | Generic version of 'authorizeBiscuitWithLimits' which takes custom 'Limits'.-authorizeBiscuitWithLimits :: Limits -> Biscuit a Verified -> Authorizer -> IO (Either ExecutionError AuthorizationSuccess)-authorizeBiscuitWithLimits l Biscuit{..} authorizer =-  let toBlockWithRevocationId ((_, block), sig, _) = (block, convert sig)-   in runAuthorizerWithLimits l-        (toBlockWithRevocationId authority)-        (toBlockWithRevocationId <$> blocks)-        authorizer+authorizeBiscuitWithLimits :: Limits -> Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof))+authorizeBiscuitWithLimits l biscuit@Biscuit{..} authorizer =+  let toBlockWithRevocationId ((_, block), sig, _, eSig) = (block, sigBytes sig, snd <$> eSig)+      -- the authority block can't be externally signed. If it carries a signature, it won't be+      -- verified. So we need to make sure there is none, to avoid having facts trusted without+      -- a proper signature check+      dropExternalPk (b, rid, _) = (b, rid, Nothing)+      withBiscuit authorizationSuccess =+        AuthorizedBiscuit+          { authorizedBiscuit = biscuit+          , authorizationSuccess+          }+   in fmap withBiscuit <$>+        runAuthorizerWithLimits l+          (dropExternalPk $ toBlockWithRevocationId authority)+          (toBlockWithRevocationId <$> blocks)+          authorizer  -- | Given a biscuit with a verified signature and an authorizer (a set of facts, rules, checks -- and policies), verify a biscuit:@@ -453,7 +591,7 @@ -- -- Specific runtime limits can be specified by using 'authorizeBiscuitWithLimits'. 'authorizeBiscuit' -- uses a set of defaults defined in 'defaultLimits'.-authorizeBiscuit :: Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError AuthorizationSuccess)+authorizeBiscuit :: Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof)) authorizeBiscuit = authorizeBiscuitWithLimits defaultLimits  -- | Retrieve the `PublicKey` which was used to verify the `Biscuit` signatures@@ -461,3 +599,30 @@ getVerifiedBiscuitPublicKey Biscuit{proofCheck} =   let Verified pk = proofCheck    in pk++-- | The results of authorization, along with the biscuit that was authorized.+data AuthorizedBiscuit p+  = AuthorizedBiscuit+  { authorizedBiscuit    :: Biscuit p Verified+  , authorizationSuccess :: AuthorizationSuccess+  }+  deriving (Eq, Show)++-- | Query the facts generated during authorization. This can be used in conjuction+-- with 'getVariableValues' and 'getSingleVariableValue' to retrieve actual values.+--+-- ⚠ By default, only facts from the authority block and the authorizer are queried,+-- like what happens in rules and checks. Facts from other blocks can be queried+-- with a @trusting@ annotation. Be careful with @trusting previous@, as it queries+-- facts from all blocks, even untrusted ones.+--+-- 💁 If the facts you want to query are part of an allow query in the authorizer,+-- you can directly get values by calling 'getBindings' on 'AuthorizationSuccess'.+--+-- 💁 If you are trying to extract facts from a biscuit in order to generate an+-- authorizer, have a look at 'queryRawBiscuitFacts' instead.+queryAuthorizerFacts :: AuthorizedBiscuit p -> Query+                     -> Set Bindings+queryAuthorizerFacts AuthorizedBiscuit{authorizedBiscuit, authorizationSuccess} =+  let ePks = externalKeys authorizedBiscuit+   in queryGeneratedFacts ePks authorizationSuccess

@@ -6,9 +6,15 @@ -} module Auth.Biscuit.Utils   ( maybeToRight+  , rightToMaybe   ) where  -- | Exactly like `maybeToRight` from the `either` package, -- but without the dependency footprint maybeToRight :: b -> Maybe a -> Either b a maybeToRight b = maybe (Left b) Right++-- | Exactly like `rightToMaybe` from the `either` package,+-- but without the dependency footprint+rightToMaybe :: Either b a -> Maybe a+rightToMaybe = either (const Nothing) Just

@@ -3,7 +3,6 @@ {-# LANGUAGE QuasiQuotes       #-} module Spec.Executor (specs) where -import           Data.Attoparsec.Text                (parseOnly) import           Data.Map.Strict                     as Map import           Data.Set                            as Set import           Data.Text                           (Text, unpack)@@ -19,6 +18,7 @@ import           Auth.Biscuit.Datalog.Parser         (expressionParser, fact,                                                       rule) import           Auth.Biscuit.Datalog.ScopedExecutor hiding (limits)+import           Spec.Parser                         (parseExpression)  specs :: TestTree specs = testGroup "Datalog evaluation"@@ -35,9 +35,12 @@ authGroup :: Set Fact -> FactGroup authGroup = FactGroup . Map.singleton (Set.singleton 0) -authRulesGroup :: Set Rule -> Map Natural (Set Rule)-authRulesGroup = Map.singleton 0+authRulesGroup :: Set Rule -> Map Natural (Set EvalRule)+authRulesGroup = Map.singleton 0 . adaptRules +adaptRules :: Set Rule -> Set EvalRule+adaptRules = Set.map (toEvaluation [])+ grandparent :: TestTree grandparent = testCase "Basic grandparent rule" $   let rules = authRulesGroup $ Set.fromList@@ -48,7 +51,7 @@                 , [fact|parent("bob", "jean-pierre")|]                 , [fact|parent("alice", "toto")|]                 ]-   in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList+   in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList         [ [fact|parent("alice", "bob")|]         , [fact|parent("bob", "jean-pierre")|]         , [fact|parent("alice", "toto")|]@@ -66,7 +69,7 @@                 , [fact|parent("bob", "jean-pierre")|]                 , [fact|parent("alice", "toto")|]                 ]-   in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList+   in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList         [ [fact|parent("alice", "bob")|]         , [fact|parent("bob", "jean-pierre")|]         , [fact|parent("alice", "toto")|]@@ -77,7 +80,7 @@         ])  expr :: Text -> Expression-expr = either error id . parseOnly expressionParser+expr = either error id . parseExpression  exprEval :: TestTree exprEval = do@@ -188,7 +191,7 @@                    , [fact|resource("file1")|]                    , [fact|resource("file2")|]                    ]-   in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList+   in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList         [ [fact|time(2019-12-04T01:00:00Z)|]         , [fact|resource("file1")|]         , [fact|resource("file2")|]@@ -203,7 +206,7 @@       facts = authGroup $ Set.fromList                    [ [fact|test("whatever", "notNothing")|]                    ]-   in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList+   in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList         [ [fact|test("whatever", "notNothing")|]         ]) @@ -223,36 +226,71 @@       iterLimits = defaultLimits { maxIterations = 2 }    in testGroup "Facts generation limits"         [ testCase "max facts" $-            runFactGeneration factLimits rules facts @?= Left Facts+            runFactGeneration factLimits 1 rules facts @?= Left Facts         , testCase "max iterations" $-            runFactGeneration iterLimits rules facts @?= Left Iterations+            runFactGeneration iterLimits 1 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")|] ])-        ])+scopedRules = testGroup "Rules and facts in different scopes"+  [ testCase "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 3 (adaptRules <$> 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")|] ])+            ])+  , testCase "with explicit scoping for rules (authority)" $+      let rules :: Map Natural (Set Rule)+          rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b) trusting authority |] ])+                  , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b) trusting authority |] ])+                  , (2, [ [rule|family($a,$b) <- parent($a,$b) trusting authority |] ])+                  ]+          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 3 (adaptRules <$> 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")|]+                      , [fact|family("toto", "toto")|]+                      ])+            , ([0,2], [ [fact|family("alice", "bob")|]+                      , [fact|family("bob", "trudy")|]+                      ])+            ])+  ]

@@ -5,15 +5,14 @@ {- HLINT ignore "Reduce duplication" -} module Spec.NewCrypto (specs) where -import           Data.ByteString       (ByteString)-import           Data.List.NonEmpty    (NonEmpty ((:|)))-import qualified Data.List.NonEmpty    as NE-import           Data.Maybe            (isJust)+import           Data.ByteString     (ByteString)+import           Data.List.NonEmpty  (NonEmpty ((:|)))+import qualified Data.List.NonEmpty  as NE+import           Data.Maybe          (isJust) import           Test.Tasty import           Test.Tasty.HUnit  import           Auth.Biscuit.Crypto-import           Crypto.PubKey.Ed25519  -- This test module is only there to test the crypto layer of biscuits, -- so we define a custom token type that only cares about the envelope,@@ -30,7 +29,7 @@  signToken :: ByteString -> SecretKey -> IO Token signToken p sk = do-  (signedBlock, privKey) <- signBlock sk p+  (signedBlock, privKey) <- signBlock sk p Nothing   pure Token     { payload = pure signedBlock     , privKey@@ -41,12 +40,21 @@  append :: Token -> ByteString -> IO Token append t@Token{payload} p = do-  (signedBlock, privKey) <- signBlock (privKey t) p+  (signedBlock, privKey) <- signBlock (privKey t) p Nothing   pure Token     { payload = snocNE payload signedBlock     , privKey     } +appendSigned :: Token -> SecretKey -> ByteString -> IO Token+appendSigned t@Token{payload} eSk p = do+  let (_, _, lastPk, _) = NE.last payload+  (signedBlock, privKey) <- signExternalBlock (privKey t) eSk lastPk p+  pure Token+    { payload = snocNE payload signedBlock+    , privKey+    }+ seal :: Token -> SealedToken seal Token{payload,privKey} =   let lastBlock = NE.last payload@@ -89,6 +97,10 @@       , tamperedBlockSealed       , removedBlockSealed       ]+  , testGroup "external signatures"+      [ multiBlockRoundtripWithExternal+      , invalidExternalSig+      ]   ]  singleBlockRoundtrip :: TestTree@@ -110,6 +122,36 @@   let res = verifyToken attenuated pk   res @?= True +multiBlockRoundtripWithExternal :: TestTree+multiBlockRoundtripWithExternal = testCase "Multi block with external signatures roundtrip" $ do+  sk <- generateSecretKey+  eSk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- appendSigned token eSk "block1"+  let res = verifyToken attenuated pk+  res @?= True++invalidExternalSig :: TestTree+invalidExternalSig = testCase "Invalid external signature" $ do+  sk <- generateSecretKey+  eSk <- generateSecretKey+  let pk = toPublic sk+      ePk = toPublic eSk+      content = "content"+  token <- signToken content sk+  attenuated <- appendSigned token eSk "block1"+  let bogusSignature = sign eSk ePk ("yolo yolo" :: ByteString)+      replaceExternalSig :: SignedBlock -> SignedBlock+      replaceExternalSig (p, s, pk, Just (_, ePk)) = (p, s, pk, Just (bogusSignature, ePk))+      replaceExternalSig sb = sb+      tamper :: Blocks -> Blocks+      tamper = fmap replaceExternalSig+      tampered = alterPayload tamper attenuated+  let res = verifyToken tampered pk+  res @?= False+ alterPayload :: (Blocks -> Blocks)              -> Token              -> Token@@ -122,7 +164,7 @@       content = "content"   token <- signToken content sk   attenuated <- append token "block1"-  let tamper ((_, s, pk) :| o) = ("tampered", s, pk) :| o+  let tamper ((_, s, pk, eS) :| o) = ("tampered", s, pk, eS) :| o       tampered = alterPayload tamper attenuated   let res = verifyToken tampered pk   res @?= False@@ -134,7 +176,7 @@       content = "content"   token <- signToken content sk   attenuated <- append token "block1"-  let tamper (h :| ((_, s, pk): t)) = h :| (("tampered", s, pk) : t)+  let tamper (h :| ((_, s, pk, eS): t)) = h :| (("tampered", s, pk, eS) : t)       tampered = alterPayload tamper attenuated   let res = verifyToken tampered pk   res @?= False@@ -182,7 +224,7 @@       content = "content"   token <- signToken content sk   attenuated <- seal <$> append token "block1"-  let tamper ((_, s, pk) :| o) = ("tampered", s, pk) :| o+  let tamper ((_, s, pk, eS) :| o) = ("tampered", s, pk, eS) :| o       tampered = alterPayloadSealed tamper attenuated   let res = verifySealedToken tampered pk   res @?= False@@ -194,7 +236,7 @@       content = "content"   token <- signToken content sk   attenuated <- seal <$> append token "block1"-  let tamper (h :| ((_, s, pk): t)) = h :| (("tampered", s, pk) : t)+  let tamper (h :| ((_, s, pk, eS): t)) = h :| (("tampered", s, pk, eS) : t)       tampered = alterPayloadSealed tamper attenuated   let res = verifySealedToken tampered pk   res @?= False

@@ -1,44 +1,69 @@ {-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}-module Spec.Parser (specs) where+module Spec.Parser (specs, parseExpression, parseBlock, parseAuthorizer) where -import           Data.Attoparsec.Text        (parseOnly)+import           Control.Monad               ((<=<))+import           Data.Bifunctor              (first)+import           Data.Either                 (isLeft)+import           Data.List.NonEmpty          (NonEmpty)+import           Data.Maybe                  (fromJust) import qualified Data.Set                    as Set import           Data.Text                   (Text) import           Test.Tasty import           Test.Tasty.HUnit+import           Validation                  (Validation, validationToEither) +import           Auth.Biscuit                (PublicKey, parsePublicKeyHex) import           Auth.Biscuit.Datalog.AST-import           Auth.Biscuit.Datalog.Parser (authorizerParser, checkParser,+import           Auth.Biscuit.Datalog.Parser (Parser, authorizerParser,+                                              blockParser, checkParser,                                               expressionParser, policyParser,-                                              predicateParser, ruleParser,-                                              termParser)+                                              predicateParser,+                                              predicateTermParser, ruleParser,+                                              run) +pk1, pk2, pk3, pk4, pk5 :: PublicKey+pk1 = fromJust $ parsePublicKeyHex "a1b712761c609039f878edad694d762652f1548a68acccc96735b3196a240e8b"+pk2 = fromJust $ parsePublicKeyHex "b82c748be51784a58496675752e04cc48009a7e78bcfae8cad51fba959102af1"+pk3 = fromJust $ parsePublicKeyHex "083aae4ba29a9a3781cdee7a800f4f8ab90591f65ca983fc429687628311aedd"+pk4 = fromJust $ parsePublicKeyHex "c6864578bc03596d52878bd70025ec966c95c60727cb6573198453e82132510d"+pk5 = fromJust $ parsePublicKeyHex "a0d3dc7ab62a0a2732ba267e0d57894170458ec1659ca1226240b99764554a2e"++runWithNoParams :: Parser a+                -> (a -> Validation (NonEmpty Text) b)+                -> Text+                -> Either String b+runWithNoParams p s = validationToEither . first show . s <=< run p+ parseTerm :: Text -> Either String Term-parseTerm = parseOnly termParser+parseTerm = runWithNoParams predicateTermParser $ substitutePTerm mempty  parseTermQQ :: Text -> Either String QQTerm-parseTermQQ = parseOnly termParser+parseTermQQ = run predicateTermParser  parsePredicate :: Text -> Either String Predicate-parsePredicate = parseOnly predicateParser+parsePredicate = runWithNoParams predicateParser $ substitutePredicate mempty  parseRule :: Text -> Either String Rule-parseRule = parseOnly ruleParser+parseRule = runWithNoParams (ruleParser False) $ substituteRule mempty mempty  parseExpression :: Text -> Either String Expression-parseExpression = parseOnly expressionParser+parseExpression = runWithNoParams expressionParser $ substituteExpression mempty  parseCheck :: Text -> Either String Check-parseCheck = parseOnly checkParser+parseCheck = runWithNoParams (checkParser False) $ substituteCheck mempty mempty  parseAuthorizer :: Text -> Either String Authorizer-parseAuthorizer = parseOnly authorizerParser+parseAuthorizer = runWithNoParams authorizerParser $ substituteAuthorizer mempty mempty  parsePolicy :: Text -> Either String Policy-parsePolicy = parseOnly policyParser+parsePolicy = runWithNoParams policyParser $ substitutePolicy mempty mempty +parseBlock :: Text -> Either String Block+parseBlock = runWithNoParams blockParser $ substituteBlock mempty mempty+ specs :: TestTree specs = testGroup "datalog parser"   [ factWithDate@@ -51,9 +76,12 @@   , constraints   , constrainedRule   , constrainedRuleOrdering+  , ruleVariables+  , ruleWithScopeParsing   , checkParsing   , policyParsing   , authorizerParsing+  , blockParsing   ]  termsGroup :: TestTree@@ -64,7 +92,7 @@   , testCase "Date" $ parseTerm "2019-12-02T13:49:53Z" @?=         Right (LDate $ read "2019-12-02 13:49:53 UTC")   , testCase "Variable" $ parseTerm "$1" @?= Right (Variable "1")-  , testCase "Antiquote" $ parseTerm "${toto}" @?= Left "Failed reading: empty"+  , testCase "Antiquote" $ isLeft (parseTerm "{toto}") @? "Unsubstituted parameters triggers an error"   ]  termsGroupQQ :: TestTree@@ -75,7 +103,14 @@   , testCase "Date" $ parseTermQQ "2019-12-02T13:49:53Z" @?=         Right (LDate $ read "2019-12-02 13:49:53 UTC")   , testCase "Variable" $ parseTermQQ "$1" @?= Right (Variable "1")-  , testCase "Antiquote" $ parseTermQQ "${toto}" @?= Right (Antiquote "toto")+  , testGroup "Antiquote"+     [ testCase "Variable name" $ parseTermQQ "{toto2_'}" @?= Right (Antiquote "toto2_'")+     , testCase "Leading underscore" $ parseTermQQ "{_toto}" @?= Right (Antiquote "_toto")+     , testCase "`_` is reserved" $ parseTermQQ "{_}" @?= Left "1:3:\n  |\n1 | {_}\n  |   ^\nunexpected '}'\nexpecting letter\n"+     , testCase "Variables are lower-cased" $ parseTermQQ "{Toto}" @?= Left "1:2:\n  |\n1 | {Toto}\n  |  ^\nunexpected 'T'\nexpecting '_' or lowercase letter\n"+     , testCase "_ is lower-case" $ parseTermQQ "{_Toto}" @?= Right (Antiquote "_Toto")+     , testCase "unicode is allowed" $ parseTermQQ "{éllo}" @?= Right (Antiquote "éllo")+     ]   ]  simpleFact :: TestTree@@ -89,9 +124,13 @@     Right (Predicate "a" [LInteger 12])  factWithDate :: TestTree-factWithDate = testCase "Parse fact containing a date" $+factWithDate = testCase "Parse fact containing a date" $ do   parsePredicate "date(2019-12-02T13:49:53Z)" @?=     Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53 UTC"])+  parsePredicate "date(2019-12-02T13:49:53.001Z)" @?=+    Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53.001 UTC"])+  parsePredicate "date(2019-12-02T13:49:53+00:00)" @?=+    Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53 UTC"])  simpleRule :: TestTree simpleRule = testCase "Parse simple rule" $@@ -99,7 +138,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 +146,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 +158,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 +170,7 @@                 [ EBinary LessOrEqual                     (EValue $ Variable "0")                     (EValue $ LDate $ read "2019-12-04 09:46:41 UTC")-                ] Nothing)+                ] [])  constraints :: TestTree constraints = testGroup "Parse expressions"@@ -227,6 +266,18 @@                     (EValue (TermSet $ Set.fromList [LString "abc", LString "def"]))                     (EValue (Variable "0"))                     ))+  , testCase "arithmetic operation that looks like the beginning of a RFC3339 date" $+      parseExpression "2022-12-10==2000" @?=+        Right (EBinary Equal+                 (EBinary Sub+                    (EBinary Sub+                       (EValue $ LInteger 2022)+                       (EValue $ LInteger 12)+                    )+                    (EValue $ LInteger 10)+                 )+                 (EValue $ LInteger 2000)+              )   , operatorPrecedences   ] @@ -276,35 +327,138 @@                  )                  (EValue $ LInteger 3)               )+  , testCase "+ & | *" $+      parseExpression "1 + 2 | 4 * 3 & 4" @?=+        Right (EBinary BitwiseOr+                  (EBinary Add+                    (EValue $ LInteger 1)+                    (EValue $ LInteger 2)+                  )+                  (EBinary BitwiseAnd+                    (EBinary Mul+                      (EValue $ LInteger 4)+                      (EValue $ LInteger 3)+                    )+                    (EValue $ LInteger 4)+                  )+              )   ] +ruleVariables :: TestTree+ruleVariables = testGroup "Make sure rule & query variables are correctly introduced"+  [ testCase "Head variables are correctly introduced" $+      parseRule "head($unbound) <- body(true)" @?=+        Left "1:1:\n  |\n1 | head($unbound) <- body(true)\n  | ^\nUnbound variables: unbound\n"+  , testCase "Expression variables are correctly introduced (rule)" $+      parseRule "head(true) <- body(true), $unbound" @?=+        Left "1:1:\n  |\n1 | head(true) <- body(true), $unbound\n  | ^\nUnbound variables: unbound\n"+  , testCase "Expression variables are correctly introduced (check)" $+      parseCheck "check if body(true), $unbound" @?=+        Left "1:10:\n  |\n1 | check if body(true), $unbound\n  |          ^\nUnbound variables: unbound\n"+  , testCase "Expression variables are correctly introduced (allow policy)" $+      parsePolicy "allow if body(true), $unbound" @?=+        Left "1:10:\n  |\n1 | allow if body(true), $unbound\n  |          ^\nUnbound variables: unbound\n"+  , testCase "Expression variables are correctly introduced (deny policy)" $+      parsePolicy "deny if body(true), $unbound" @?=+        Left "1:9:\n  |\n1 | deny if body(true), $unbound\n  |         ^\nUnbound variables: unbound\n"+  ]++ruleWithScopeParsing :: TestTree+ruleWithScopeParsing = testCase "Parse constained rule with scope annotation" $+  parseRule "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2019-12-04T09:46:41+00:00 trusting previous" @?=+    Right (Rule (Predicate "valid_date" [LString "file1"])+                [ Predicate "time" [Variable "0"]+                , Predicate "resource" [LString "file1"]+                ]+                [ EBinary LessOrEqual+                    (EValue $ Variable "0")+                    (EValue $ LDate $ read "2019-12-04 09:46:41 UTC")+                ] [Previous])+ checkParsing :: TestTree checkParsing = testGroup "check blocks"   [ testCase "Simple check" $       parseCheck "check if true" @?=-        Right [QueryItem [] [EValue $ LBool True] Nothing]+        Right Check+          { cQueries = [QueryItem [] [EValue $ LBool True] []]+          , cKind = One+          }+  , testCase "Simple check all" $+      parseCheck "check all true" @?=+        Right Check+          { cQueries = [QueryItem [] [EValue $ LBool True] []]+          , cKind = All+          }   , testCase "Multiple groups" $       parseCheck         "check if fact($var), $var == true or \         \other($var), $var == 2" @?=-          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-            ]+          Right Check+            { cQueries =+                [ QueryItem [Predicate "fact" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+                            []+                , QueryItem [Predicate "other" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+                            []+                ]+            , cKind = One+            }+  , testCase "Multiple check all groups" $+      parseCheck+        "check all fact($var), $var == true or \+        \other($var), $var == 2" @?=+          Right Check+            { cQueries =+                [ QueryItem [Predicate "fact" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+                            []+                , QueryItem [Predicate "other" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+                            []+                ]+            , cKind = All+            }+  , testCase "Multiple groups, scoped" $+      parseCheck+        "check if fact($var), $var == true trusting previous or \+        \other($var), $var == 2 trusting authority" @?=+          Right Check+            { cQueries =+                [ QueryItem [Predicate "fact" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+                            [Previous]+                , QueryItem [Predicate "other" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+                            [OnlyAuthority]+                ]+            , cKind = One+            }+  , testCase "Multiple check all groups, scoped" $+      parseCheck+        "check all fact($var), $var == true trusting previous or \+        \other($var), $var == 2 trusting authority" @?=+          Right Check+            { cQueries =+                [ QueryItem [Predicate "fact" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+                            [Previous]+                , QueryItem [Predicate "other" [Variable "var"]]+                            [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+                            [OnlyAuthority]+                ]+            , cKind = All+            }   ]  policyParsing :: TestTree policyParsing = testGroup "policy blocks"   [ testCase "Simple allow policy" $       parsePolicy "allow if true" @?=-        Right (Allow, [QueryItem [] [EValue $ LBool True] Nothing])+        Right (Allow, [QueryItem [] [EValue $ LBool True] []])   , testCase "Simple deny policy" $       parsePolicy "deny if true" @?=-        Right (Deny, [QueryItem [] [EValue $ LBool True] Nothing])+        Right (Deny, [QueryItem [] [EValue $ LBool True] []])   , testCase "Allow with multiple groups" $       parsePolicy         "allow if fact($var), $var == true or \@@ -313,10 +467,10 @@             ( Allow             , [ 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+                          []               ]             )   , testCase "Deny with multiple groups" $@@ -327,47 +481,74 @@             ( Deny             , [ 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+                          []               ]             )   , testCase "Deny with multiple groups, multiline" $       parsePolicy         "deny if\n\-           \fact($var), $var == true or\n\+           \fact($var), $var == true or //comment\n\            \other($var), $var == 2" @?=           Right             ( Deny             , [ 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+                          []               ]             )+  , testCase "Allow with multiple groups, scoped" $+      parsePolicy+        "allow if fact($var), $var == true trusting authority or \+        \other($var), $var == 2 trusting ed25519/a1b712761c609039f878edad694d762652f1548a68acccc96735b3196a240e8b,ed25519/083aae4ba29a9a3781cdee7a800f4f8ab90591f65ca983fc429687628311aedd,ed25519/c6864578bc03596d52878bd70025ec966c95c60727cb6573198453e82132510d " @?=+          Right+            ( Allow+            , [ QueryItem [Predicate "fact" [Variable "var"]]+                          [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+                          [OnlyAuthority]+              , QueryItem [Predicate "other" [Variable "var"]]+                          [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+                          [BlockId pk1, BlockId pk3, BlockId pk4]+              ]+            )   ]  authorizerParsing :: TestTree authorizerParsing = testGroup "Simple authorizers"   [ testCase "Just a deny" $       parseAuthorizer "deny if true;" @?=-        Right (Authorizer [(Deny, [QueryItem [] [EValue (LBool True)] Nothing])] mempty+        Right (Authorizer [(Deny, [QueryItem [] [EValue (LBool True)] []])] mempty               )   , testCase "Allow and deny" $       parseAuthorizer "allow if operation(\"read\");\n deny if true;" @?=         Right (Authorizer-                 [  (Allow, [QueryItem [Predicate "operation" [LString "read"]] [] Nothing])-                 , (Deny, [QueryItem [] [EValue (LBool True)] Nothing])+                 [  (Allow, [QueryItem [Predicate "operation" [LString "read"]] [] []])+                 , (Deny, [QueryItem [] [EValue (LBool True)] []])                  ]                  mempty               )+  , testCase "Previous is denied at the top level" $+      parseAuthorizer "trusting previous; allow if true;" @?=+        Left "1:10:\n  |\n1 | trusting previous; allow if true;\n  |          ^\n'previous' can't appear in an authorizer scope\n"+  , testCase "Previous is denied in rules" $+      parseAuthorizer "head(true) <- tail(true) trusting previous;" @?=+        Left "1:35:\n  |\n1 | head(true) <- tail(true) trusting previous;\n  |                                   ^\n'previous' can't appear in an authorizer scope\n"+  , testCase "Previous is denied in checks" $+      parseAuthorizer "check if true trusting previous;" @?=+        Left "1:24:\n  |\n1 | check if true trusting previous;\n  |                        ^\n'previous' can't appear in an authorizer scope\n"+  , testCase "Previous is denied in policies" $+      parseAuthorizer "allow if true trusting previous;" @?=+        Left "1:24:\n  |\n1 | allow if true trusting previous;\n  |                        ^\n'previous' can't appear in an authorizer scope\n"   , testCase "Complete authorizer" $ do       let spec :: Text           spec =-            "// the owner has all rights\n\+            " trusting authority;\n\+            \// the owner has all rights\n\             \right($blog_id, $article_id, $operation) <-\n\             \    article($blog_id, $article_id),\n\             \    operation($operation),\n\@@ -416,13 +597,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]@@ -430,23 +611,86 @@                    , p "member" [vUserId, vTeamId]                    , p "team_role" [vTeamId, vBlogId, sContributor]                    ] [EBinary Contains (EValue (TermSet $ Set.fromList [sRead, sWrite]))-                                       (EValue vOp)] Nothing+                                       (EValue vOp)] []            ]           bFacts = []           bChecks = []           bContext = Nothing-          bScope = Nothing+          bScope = [OnlyAuthority]           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]-                                 ] [] Nothing])-            , (Deny, [QueryItem [] [EValue (LBool True)] Nothing])+                                 ] [] []])+            , (Deny, [QueryItem [] [EValue (LBool True)] []])             ]       parseAuthorizer spec @?= Right Authorizer{vBlock = Block{..}, ..}   ]++blockParsing :: TestTree+blockParsing = testCase "Full block" $ do+  let spec :: Text+      spec =+        " trusting ed25519/b82c748be51784a58496675752e04cc48009a7e78bcfae8cad51fba959102af1,ed25519/083aae4ba29a9a3781cdee7a800f4f8ab90591f65ca983fc429687628311aedd,ed25519/a0d3dc7ab62a0a2732ba267e0d57894170458ec1659ca1226240b99764554a2e;\n\+        \// the owner has all rights\n\+        \right($blog_id, $article_id, $operation) <-\n\+        \    article($blog_id, $article_id),\n\+        \    operation($operation),\n\+        \    user($user_id),\n\+        \    owner($user_id, $blog_id);\n\+        \// premium users can access some restricted articles\n\+        \right($blog_id, $article_id, \"read\") <-\n\+        \  article($blog_id, $article_id),\n\+        \  premium_readable($blog_id, $article_id),\n\+        \  user($user_id),\n\+        \  premium_user($user_id, $blog_id);\n\+        \// define teams and roles\n\+        \right($blog_id, $article_id, $operation) <-\n\+        \  article($blog_id, $article_id),\n\+        \  operation($operation),\n\+        \  user($user_id),\n\+        \  member($user_id, $team_id),\n\+        \  team_role($team_id, $blog_id, \"contributor\"),\n\+        \  [\"read\", \"write\"].contains($operation);\n\+        \ "+      p = Predicate+      sRead = LString "read"+      sWrite = LString "write"+      sContributor = LString "contributor"+      vBlogId = Variable "blog_id"+      vArticleId = Variable "article_id"+      vUserId = Variable "user_id"+      vTeamId = Variable "team_id"+      vOp = Variable "operation"+      bRules =+        [ Rule (p "right" [vBlogId, vArticleId, vOp])+               [ p "article" [vBlogId, vArticleId]+               , p "operation" [vOp]+               , p "user" [vUserId]+               , p "owner" [vUserId, vBlogId]+               ] [] []+        , Rule (p "right" [vBlogId, vArticleId, sRead])+               [ p "article" [vBlogId, vArticleId]+               , p "premium_readable" [vBlogId, vArticleId]+               , p "user" [vUserId]+               , p "premium_user" [vUserId, vBlogId]+               ] [] []+        , Rule (p "right" [vBlogId, vArticleId, vOp])+               [ p "article" [vBlogId, vArticleId]+               , p "operation" [vOp]+               , p "user" [vUserId]+               , p "member" [vUserId, vTeamId]+               , p "team_role" [vTeamId, vBlogId, sContributor]+               ] [EBinary Contains (EValue (TermSet $ Set.fromList [sRead, sWrite]))+                                   (EValue vOp)] []+       ]+      bFacts = []+      bChecks = []+      bContext = Nothing+      bScope = Set.fromList $ BlockId <$> [pk2,pk3,pk5]+  parseBlock spec @?= Right Block{..}

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-} module Spec.Quasiquoter (specs) where@@ -34,14 +35,14 @@     Rule (Predicate "right" [Variable "0", LString "read"])          [ Predicate "resource" [Variable "0"]          , Predicate "operation" [LString "read"]-         ] [] Nothing+         ] [] []  antiquotedFact :: TestTree antiquotedFact = testCase "Sliced fact" $-  let toto :: Text-      toto = "test"+  let toto2' :: Text+      toto2' = "test"       actual :: Fact-      actual = [fact|right(${toto}, "read")|]+      actual = [fact|right({toto2'}, "read")|]    in actual @?=     Predicate "right" [ LString "test"                       , LString "read"@@ -52,9 +53,9 @@   let toto :: Text       toto = "test"       actual :: Rule-      actual = [rule|right($0, "read") <- resource( $0), operation("read", ${toto})|]+      actual = [rule|right($0, "read") <- resource( $0), operation("read", {toto})|]    in actual @?=     Rule (Predicate "right" [Variable "0", LString "read"])          [ Predicate "resource" [Variable "0"]          , Predicate "operation" [LString "read", LString "test"]-         ] [] Nothing+         ] [] []

@@ -2,10 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections     #-} module Spec.Roundtrip   ( specs   ) where +import           Control.Arrow       ((&&&)) import           Data.ByteString     (ByteString) import           Data.List.NonEmpty  (NonEmpty ((:|))) import           Test.Tasty@@ -21,6 +23,7 @@   [ testGroup "Raw serde"       [ singleBlock    (serialize, parse)       , multipleBlocks (serialize, parse)+      , thirdPartyBlocks (serialize, parse)       ]   , testGroup "B64 serde"       [ singleBlock    (serializeB64, parseB64)@@ -39,21 +42,56 @@ roundtrip :: Roundtrip           -> NonEmpty Block           -> Assertion-roundtrip (s,p) i@(authority' :| blocks') = do+roundtrip r bs = roundtrip' r $ (Nothing,) <$> bs++roundtrip' :: Roundtrip+           -> NonEmpty (Maybe SecretKey, Block)+           -> Assertion+roundtrip' (s,p) i@(authority' :| blocks') = do   let addBlocks bs biscuit = case bs of-        (b:rest) -> addBlocks rest =<< addBlock b biscuit-        []       -> pure biscuit+        ((Just sk, b):rest) -> addBlocks rest =<< addSignedBlock sk b biscuit+        ((Nothing, b):rest) -> addBlocks rest =<< addBlock b biscuit+        []                  -> pure biscuit   sk <- generateSecretKey   let pk = toPublic sk-  init' <- mkBiscuitWith (Just 1) sk authority'+  init' <- mkBiscuitWith (Just 1) sk (snd authority')   final <- addBlocks blocks' init'   let serialized = s final       parsed = p pk serialized-      getBlock ((_, b), _, _) = b+      getBlock ((_, b), _, _, _) = b       getBlocks b = getBlock <$> authority b :| blocks b-  getBlocks <$> parsed @?= Right i+  getBlocks <$> parsed @?= Right (snd <$> i)   rootKeyId <$> parsed @?= Right (Just 1) +roundtrip'' :: Bool+            -> Roundtrip+            -> NonEmpty (Maybe SecretKey, Block)+            -> Assertion+roundtrip'' direct (s,p) i@(authority' :| blocks') = do+  let addSignedBlock' :: SecretKey -> Block -> Biscuit Open check -> IO (Biscuit Open check)+      addSignedBlock' sk block biscuit = do+        if direct+          then+            addSignedBlock sk block biscuit+          else do+            let req = mkThirdPartyBlockReq biscuit+            thirdPartyBlock <- either (fail . ("req " <>)) pure $ mkThirdPartyBlock sk req block+            either (fail . ("apply " <>)) id $ applyThirdPartyBlock biscuit thirdPartyBlock+      addBlocks bs biscuit = case bs of+        ((Just sk, b):rest) -> addBlocks rest =<< addSignedBlock' sk b biscuit+        ((Nothing, b):rest) -> addBlocks rest =<< addBlock b biscuit+        []                  -> pure biscuit+  sk <- generateSecretKey+  let pk = toPublic sk+  init' <- mkBiscuitWith (Just 1) sk (snd 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 (snd <$> i)+  rootKeyId <$> parsed @?= Right (Just 1)+ singleBlock :: Roundtrip -> TestTree singleBlock r = testCase "Single block" $ roundtrip r $ pure   [block|@@ -116,6 +154,40 @@       check if time($date), $date <= 2018-12-20T00:00:00+00:00;     |]   ]++thirdPartyBlocks :: Roundtrip -> TestTree+thirdPartyBlocks r =+  let mkBlocks = do+        (sk1, pkOne) <- (id &&& toPublic) <$> generateSecretKey+        (sk2, pkTwo) <- (id &&& toPublic) <$> generateSecretKey+        (sk3, pkThree) <- (id &&& toPublic) <$> generateSecretKey+        pure $ (Nothing, [block|+                   query("authority");+                   right("file1", "read");+                   right("file2", "read");+                   right("file1", "write");+                   check if true trusting previous, {pkOne};+               |]) :|+               [ (Just sk1, [block|+                   query("block1");+                   check if right("file2", "read") trusting {pkTwo};+                   check if right("file3", "read") trusting {pkOne};+                 |])+               , (Just sk2, [block|+                   query("block2");+                   check if right("file2", "read") trusting {pkTwo};+                   check if right("file3", "read") trusting {pkOne};+                 |])+               , (Nothing, [block|+                   query("block3");+                   check if right("file2", "read") trusting {pkTwo};+                   check if right("file3", "read") trusting {pkThree};+                 |])+               ]+   in testGroup "Third party blocks"+        [ testCase "Direct append" $ roundtrip'' True r =<< mkBlocks+        , testCase "Indirect append" $ roundtrip'' False r =<< mkBlocks+        ]  secret :: TestTree secret = testGroup "Secret key serde"

@@ -10,45 +10,46 @@ {-# LANGUAGE RecordWildCards    #-} module Spec.SampleReader where -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.Foldable                 (fold, traverse_) import           Data.List.NonEmpty            (NonEmpty (..), toList) import           Data.Map.Strict               (Map) import qualified Data.Map.Strict               as Map-import           Data.Maybe                    (isJust, isNothing)+import           Data.Maybe                    (fromJust, isJust, isNothing) import           Data.Text                     (Text, pack, unpack) import           Data.Text.Encoding            (decodeUtf8, encodeUtf8)+import           Data.Traversable              (for) import           GHC.Generics                  (Generic)  import           Test.Tasty                    hiding (Timeout) import           Test.Tasty.HUnit  import           Auth.Biscuit+import           Auth.Biscuit.Datalog.AST      (renderAuthorizer, renderBlock) import           Auth.Biscuit.Datalog.Executor (ExecutionError (..),                                                 ResultError (..)) import           Auth.Biscuit.Datalog.Parser   (authorizerParser, blockParser) import           Auth.Biscuit.Token +import           Spec.Parser                   (parseAuthorizer, parseBlock)+ getB :: ParsedSignedBlock -> Block-getB ((_, b), _, _) = b+getB ((_, b), _, _, _) = b -getAuthority :: Biscuit OpenOrSealed Verified -> Block+getAuthority :: Biscuit p Verified -> Block getAuthority = getB . authority -getBlocks :: Biscuit OpenOrSealed Verified -> [Block]+getBlocks :: Biscuit p Verified -> [Block] getBlocks = fmap getB . blocks  instance FromJSON SecretKey where@@ -58,6 +59,9 @@         notSk = typeMismatch "Ed25519 secret key" (String t)     maybe notSk pure res +instance ToJSON SecretKey where+  toJSON = toJSON . decodeUtf8 . serializeSecretKeyHex+ instance FromJSON PublicKey where   parseJSON = withText "Ed25519 public key" $ \t -> do     let bs = encodeUtf8 t@@ -65,17 +69,17 @@         notPk = typeMismatch "Ed25519 public key" (String t)     maybe notPk pure res +instance ToJSON PublicKey where+  toJSON = toJSON . decodeUtf8 . serializePublicKeyHex+ instance FromJSON Authorizer where   parseJSON = withText "authorizer" $ \t -> do     let res = parseAuthorizer t         notAuthorizer e = typeMismatch e (String t)     either notAuthorizer pure res -parseAuthorizer :: Text -> Either String Authorizer-parseAuthorizer = parseOnly authorizerParser--parseBlock :: Text -> Either String Block-parseBlock = parseOnly blockParser+instance ToJSON Authorizer where+  toJSON = toJSON . renderAuthorizer  data SampleFile a   = SampleFile@@ -84,7 +88,7 @@   , testcases        :: [TestCase a]   }   deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable)-  deriving anyclass FromJSON+  deriving anyclass (FromJSON, ToJSON)  data RustResult e a   = Err e@@ -100,6 +104,10 @@    parseJSON = genericParseJSON $      defaultOptions { sumEncoding = ObjectWithSingleField } +instance (ToJSON e, ToJSON a) => ToJSON (RustResult e a) where+   toJSON = genericToJSON $+     defaultOptions { sumEncoding = ObjectWithSingleField }+ type RustError = Value  data ValidationR@@ -109,8 +117,7 @@   , authorizer_code :: Authorizer   , revocation_ids  :: [Text]   } deriving stock (Eq, Show, Generic)-    deriving anyclass FromJSON-+    deriving anyclass (FromJSON, ToJSON)  checkResult :: Show a             => (a -> RustError -> Assertion)@@ -132,7 +139,7 @@   , validations :: Map String ValidationR   }   deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable)-  deriving anyclass FromJSON+  deriving anyclass (FromJSON, ToJSON)  data BlockDesc   = BlockDesc@@ -140,7 +147,7 @@   , code    :: Text   }   deriving stock (Eq, Show, Generic)-  deriving anyclass FromJSON+  deriving anyclass (FromJSON, ToJSON)  data WorldDesc   =  WorldDesc@@ -150,15 +157,26 @@   , policies :: [Text]   }   deriving stock (Eq, Show, Generic)-  deriving anyclass FromJSON+  deriving anyclass (FromJSON, ToJSON) +instance Semigroup WorldDesc where+  a <> b = WorldDesc+    { facts = facts a <> facts b+    , rules = rules a <> rules b+    , checks = checks a <> checks b+    , policies = policies a <> policies b+    }++instance Monoid WorldDesc where+  mempty = WorldDesc [] [] [] []+ readBiscuits :: SampleFile FilePath -> IO (SampleFile (FilePath, ByteString)) readBiscuits =-   traverse $ traverse (BS.readFile . ("test/samples/v2/" <>)) . join (&&&) id+   traverse $ traverse (BS.readFile . ("test/samples/current/" <>)) . join (&&&) id  readSamplesFile :: IO (SampleFile (FilePath, ByteString)) readSamplesFile = do-  Just f <- decodeFileStrict' "test/samples/v2/samples.json"+  f <- either fail pure =<< eitherDecodeFileStrict' "test/samples/current/samples.json"   readBiscuits f  checkTokenBlocks :: (String -> IO ())@@ -174,35 +192,45 @@ processTestCase :: (String -> IO ())                 -> PublicKey -> TestCase (FilePath, ByteString)                 -> Assertion-processTestCase step rootPk TestCase{..} = do-  step "Parsing "-  let vList = Map.toList validations-  case parse rootPk (snd filename) of-    Left parseError -> traverse_ (processFailedValidation step parseError) vList-    Right biscuit   -> do-      checkTokenBlocks step biscuit token-      traverse_ (processValidation step biscuit) vList+processTestCase step rootPk TestCase{..} =+  if fst filename == "test018_unbound_variables_in_rule.bc"+  then+    step "Skipping for now (unbound variables are now caught before evaluation)"+  else do+    step "Parsing "+    let vList = Map.toList validations+    case parse rootPk (snd filename) of+      Left parseError -> traverse_ (processFailedValidation step parseError) vList+      Right biscuit   -> do+        checkTokenBlocks step biscuit token+        traverse_ (processValidation step biscuit) vList  compareParseErrors :: ParseError -> RustError -> Assertion compareParseErrors pe re =-  let mustMatch p = assertBool (show re) $ isJust $ re ^? p+  let mustMatch p = assertBool (show (re,pe)) $ isJust $ re ^? p+      mustMatchEither ps = assertBool (show (re, pe)) $ any isJust $ (re ^?) <$> ps    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"+          mustMatch $ key "Format" . key "DeserializationError"         InvalidProtobuf True s ->           mustMatch $ key "Format" . key "DeserializationError"+        InvalidProtobufSer False s ->+          mustMatch $ key "Format" . key "BlockDeserializationError"         InvalidProtobuf False s ->           mustMatch $ key "Format" . key "BlockDeserializationError"+        -- the signature size is now verified just before verifying the+        -- signature itself, not at deserialization time, since we want+        -- to interpret signatures only relative to the verifying public+        -- key.         InvalidSignatures ->-          mustMatch $ key "Format" . key "Signature" . key "InvalidSignature"+          mustMatchEither+            [ key "Format" . key "Signature" . key "InvalidSignature"+            , key "Format" . key "InvalidSignatureSize"+            ]         InvalidProof ->           assertFailure $ "InvalidProof can't appear here " <> show re         RevokedBiscuit ->@@ -236,11 +264,11 @@                   -> Assertion processValidation step b (name, ValidationR{..}) = do   when (name /= "") $ step ("Checking " <> name)-  w    <- maybe (assertFailure "missing authorizer contents") pure world+  let w = fold world   pols <- either (assertFailure . show) pure $ parseAuthorizer $ foldMap (<> ";") (policies w)   res <- authorizeBiscuit b (authorizer_code <> pols)   checkResult compareExecErrors result res-  let revocationIds = decodeUtf8 . Hex.encode <$> toList (getRevocationIds b)+  let revocationIds = Hex.encodeBase16 <$> toList (getRevocationIds b)   step "Comparing revocation ids"   revocation_ids @?= revocationIds @@ -252,9 +280,6 @@   SampleFile{..} <- readSamplesFile   traverse_ (processTestCase step root_public_key) testcases -specs :: TestTree-specs = testCaseSteps "Biscuit samples - compliance checks" runTests- mkTestCase :: PublicKey -> TestCase (FilePath, ByteString) -> TestTree mkTestCase root_public_key tc@TestCase{filename} =   testCaseSteps (fst filename) (\step -> processTestCase step root_public_key tc)@@ -264,3 +289,34 @@   SampleFile{..} <- readSamplesFile   pure $ testGroup "Biscuit samples - compliance checks"        $ mkTestCase root_public_key <$> testcases+mkTestCaseFromBiscuit+  :: String+  -> FilePath+  -> Biscuit Open Verified+  -> [(String, Authorizer)]+  -> IO (TestCase FilePath)+mkTestCaseFromBiscuit title filename biscuit authorizers = do+  let mkBlockDesc :: Block -> BlockDesc+      mkBlockDesc b = BlockDesc+        { code = renderBlock b+        , symbols = []+        }+      mkValidation :: Authorizer -> IO ValidationR+      mkValidation authorizer = do+        Right success <- authorizeBiscuit biscuit authorizer+        pure ValidationR+          { world = Just $ WorldDesc+             { facts = []+             , rules = []+             , checks = []+             , policies = []+             }+          , result = Ok 0+          , authorizer_code = authorizer+          , revocation_ids = Hex.encodeBase16 <$> toList (getRevocationIds biscuit)+          }+  BS.writeFile ("test/samples/current/" <> filename) (serialize biscuit)+  let token = mkBlockDesc <$> getAuthority biscuit :| getBlocks biscuit+  validations <- Map.fromList <$> traverse (traverse mkValidation) authorizers++  pure TestCase{..}

@@ -3,20 +3,27 @@ {- HLINT ignore "Reduce duplication" -} module Spec.ScopedExecutor (specs) where -import           Data.Attoparsec.Text                (parseOnly)+import           Control.Arrow                       ((&&&))+import           Data.Either                         (isRight) import           Data.Map.Strict                     as Map import           Data.Set                            as Set import           Data.Text                           (Text, unpack) import           Test.Tasty import           Test.Tasty.HUnit +import           Auth.Biscuit                        (addBlock, addSignedBlock,+                                                      authorizeBiscuit,+                                                      mkBiscuit, newSecret,+                                                      queryAuthorizerFacts,+                                                      queryRawBiscuitFacts)+import           Auth.Biscuit.Crypto import           Auth.Biscuit.Datalog.AST import           Auth.Biscuit.Datalog.Executor       (ExecutionError (..),                                                       Limits (..),                                                       ResultError (..),                                                       defaultLimits) import           Auth.Biscuit.Datalog.Parser         (authorizer, block, check,-                                                      query)+                                                      query, run) import           Auth.Biscuit.Datalog.ScopedExecutor  specs :: TestTree@@ -26,11 +33,13 @@   , block1OnlySeesAuthorityAndAuthorizer   , block2OnlySeesAuthorityAndAuthorizer   , block1SeesAuthorityAndAuthorizer+  , thirdPartyBlocks   , iterationCountWorks   , maxFactsCountWorks   , allChecksAreCollected   , revocationIdsAreInjected-  , factsAreQueried+  , authorizerFactsAreQueried+  , biscuitFactsAreQueried   ]  authorizerOnlySeesAuthority :: TestTree@@ -47,7 +56,7 @@        [authorizer|          allow if is_allowed(1234, "file1", "write");        |]-  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError (NoPoliciesMatched []))+  runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError (NoPoliciesMatched []))  authorityOnlySeesItselfAndAuthorizer :: TestTree authorityOnlySeesItselfAndAuthorizer = testCase "Authority rules only see authority and authorizer facts" $ do@@ -64,7 +73,7 @@        [authorizer|          allow if is_allowed(1234, "file1");        |]-  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError (NoPoliciesMatched []))+  runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError (NoPoliciesMatched []))  block1OnlySeesAuthorityAndAuthorizer :: TestTree block1OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do@@ -85,7 +94,7 @@        [authorizer|          allow if true;        |]-  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |]))+  runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |]))  block1SeesAuthorityAndAuthorizer :: TestTree block1SeesAuthorityAndAuthorizer = testCase "Arbitrary blocks see previous blocks" $ do@@ -102,7 +111,7 @@       verif =        [authorizer| allow if false;        |]-  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError $ NoPoliciesMatched [])+  runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched [])  block2OnlySeesAuthorityAndAuthorizer :: TestTree block2OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do@@ -123,8 +132,38 @@        [authorizer|          allow if true;        |]-  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |]))+  runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) +thirdPartyBlocks :: TestTree+thirdPartyBlocks = testCase "Third party blocks are correctly scoped" $ do+    (sk1, pkOne) <- (id &&& toPublic) <$> generateSecretKey+    let authority =+          [block|+            user(1234);+            check if from3rd(1, true) trusting {pkOne};+            check if from3rd(2, true) trusting {pkOne};+          |]+        block1 =+          [block|+          from3rd(1, true);+          |]+        block2 =+          [block|+          from3rd(2, true);+          |]+        verif =+          [authorizer|+            deny if from3rd(1, true);+            allow if from3rd(1, true), from3rd(2, true) trusting {pkOne};+          |]+    let result = runAuthorizerNoTimeout defaultLimits+                   (authority, "", Nothing)+                   [ (block1, "", Just pkOne)+                   , (block2, "", Just pkOne)+                   ]+                   verif+    isRight result @?= True+ iterationCountWorks :: TestTree iterationCountWorks = testCase "ScopedExecutions stops when hitting the iterations threshold" $ do   let limits = defaultLimits { maxIterations = 8 }@@ -151,7 +190,7 @@        [authorizer|          allow if true;        |]-  runAuthorizerNoTimeout limits (authority, "") [(block1, "")] verif @?= Left TooManyIterations+  runAuthorizerNoTimeout limits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left TooManyIterations  maxFactsCountWorks :: TestTree maxFactsCountWorks = testCase "ScopedExecutions stops when hitting the facts threshold" $ do@@ -179,7 +218,7 @@        [authorizer|          allow if true;        |]-  runAuthorizerNoTimeout limits (authority, "") [(block1, "")] verif @?= Left TooManyFacts+  runAuthorizerNoTimeout limits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left TooManyFacts  allChecksAreCollected :: TestTree allChecksAreCollected = testCase "ScopedExecutions collects all facts results even after a failure" $ do@@ -199,7 +238,7 @@        [authorizer|          allow if user(4567);        |]-  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError $ NoPoliciesMatched [[check|check if false|], [check|check if false|]])+  runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched [[check|check if false|], [check|check if false|]])  revocationIdsAreInjected :: TestTree revocationIdsAreInjected = testCase "ScopedExecutions injects revocation ids" $ do@@ -217,16 +256,77 @@                   revocation_id(1, hex:62),                   revocation_id(2, hex:63);        |]-  runAuthorizerNoTimeout defaultLimits (authority, "a") [(block1, "b"), (block2, "c")] verif @?= Left (ResultError $ NoPoliciesMatched [])+  runAuthorizerNoTimeout defaultLimits (authority, "a", Nothing) [(block1, "b", Nothing), (block2, "c", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched []) -factsAreQueried :: TestTree-factsAreQueried = testCase "AuthorizationSuccess can be queried" $ do-  let authority = [block|user(1234);|]-      block1 = [block|user("tampered value");|]-      verif = [authorizer|allow if true;|]-      result = runAuthorizerNoTimeout defaultLimits (authority, "a") [(block1, "b")] verif-      getUser s = queryAuthorizerFacts s [query|user($user)|]-      expected = Set.singleton $ Map.fromList-        [ ("user", LInteger 1234)-        ]-  getUser <$> result @?= Right expected+authorizerFactsAreQueried :: TestTree+authorizerFactsAreQueried = testGroup "AuthorizedBiscuit can be queried"+  [ testCase "Attenuation blocks are ignored" $ do+      (p,s) <- (toPublic &&& id) <$> newSecret+      b <- mkBiscuit s [block|user(1234);|]+      b1 <- addBlock [block|user("tampered value");|] b+      result <- authorizeBiscuit b1 [authorizer|allow if true;|]+      let getUser s = queryAuthorizerFacts s [query|user($user)|]+          expected = Set.singleton $ Map.fromList+            [ ("user", LInteger 1234)+            ]+      getUser <$> result @?= Right expected+  , testCase "Attenuation blocks can be accessed if asked nicely" $ do+      (p,s) <- (toPublic &&& id) <$> newSecret+      b <- mkBiscuit s [block|user(1234);|]+      b1 <- addBlock [block|user("tampered value");|] b+      result <- authorizeBiscuit b1 [authorizer|allow if true;|]+      let getUser s = queryAuthorizerFacts s [query|user($user) trusting previous|]+          expected = Set.fromList+            [ Map.fromList [("user", LInteger 1234)]+            , Map.fromList [("user", LString "tampered value")]+            ]+      getUser <$> result @?= Right expected+  , testCase "Signed blocks can be accessed if asked nicely" $ do+      (p,s) <- (toPublic &&& id) <$> newSecret+      (p1,s1) <- (toPublic &&& id) <$> newSecret+      b <- mkBiscuit s [block|user(1234);|]+      b1 <- addBlock [block|user("tampered value");|] b+      b2 <- addSignedBlock s1 [block|user("from signed");|] b1+      result <- authorizeBiscuit b2 [authorizer|allow if true;|]+      let getUser s = queryAuthorizerFacts s [query|user($user) trusting authority, {p1}|]+          expected = Set.fromList+            [ Map.fromList [("user", LInteger 1234)]+            , Map.fromList [("user", LString "from signed")]+            ]+      getUser <$> result @?= Right expected+  ]++biscuitFactsAreQueried :: TestTree+biscuitFactsAreQueried = testGroup "Biscuit can be queried"+  [ testCase "Attenuation blocks are ignored" $ do+      (p,s) <- (toPublic &&& id) <$> newSecret+      b <- mkBiscuit s [block|user(1234);|]+      b1 <- addBlock [block|user("tampered value");|] b+      let user = queryRawBiscuitFacts b1 [query|user($user)|]+          expected = Set.singleton $ Map.fromList+            [ ("user", LInteger 1234)+            ]+      user @?= expected+  , testCase "Attenuation blocks can be accessed if asked nicely" $ do+      (p,s) <- (toPublic &&& id) <$> newSecret+      b <- mkBiscuit s [block|user(1234);|]+      b1 <- addBlock [block|user("tampered value");|] b+      let user = queryRawBiscuitFacts b1 [query|user($user) trusting previous|]+          expected = Set.fromList+            [ Map.fromList [("user", LInteger 1234)]+            , Map.fromList [("user", LString "tampered value")]+            ]+      user @?= expected+  , testCase "Signed blocks can be accessed if asked nicely" $ do+      (p,s) <- (toPublic &&& id) <$> newSecret+      (p1,s1) <- (toPublic &&& id) <$> newSecret+      b <- mkBiscuit s [block|user(1234);|]+      b1 <- addBlock [block|user("tampered value");|] b+      b2 <- addSignedBlock s1 [block|user("from signed");|] b1+      let user = queryRawBiscuitFacts b2 [query|user($user) trusting authority, {p1}|]+          expected = Set.fromList+            [ Map.fromList [("user", LInteger 1234)]+            , Map.fromList [("user", LString "from signed")]+            ]+      user @?= expected+  ]

@@ -11,8 +11,12 @@ import           Test.Tasty.HUnit  import           Auth.Biscuit-import           Auth.Biscuit.Datalog.AST      (Expression' (..), Query,-                                                QueryItem' (..), Term' (..))+import           Auth.Biscuit.Datalog.AST      (Block' (..), Check, Check' (..),+                                                CheckKind (..),+                                                Expression' (..),+                                                Predicate' (..), Query,+                                                QueryItem' (..), Rule' (..),+                                                Term' (..)) import           Auth.Biscuit.Datalog.Executor (MatchedQuery (..),                                                 ResultError (..)) import qualified Auth.Biscuit.Datalog.Executor as Executor@@ -21,6 +25,7 @@ specs :: TestTree specs = testGroup "Datalog checks"   [ singleBlock+  , checkAll   , errorAccumulation   , unboundVarRule   , symbolRestrictions@@ -38,16 +43,29 @@   , bindings = Set.singleton mempty   } -ifFalse' :: Query-ifFalse' = matchedQuery ifFalse+ifFalse' :: Check+ifFalse' = Check+  { cQueries = matchedQuery ifFalse+  , cKind = One+  } +checkAll' :: Check+checkAll' = [check|check all fact($value), $value|]+ singleBlock :: TestTree singleBlock = testCase "Single block" $ do   secret <- newSecret   biscuit <- mkBiscuit secret [block|right("file1", "read");|]   res <- authorizeBiscuit biscuit [authorizer|check if right("file1", "read");allow if true;|]-  matchedAllowQuery <$> res @?= Right ifTrue+  matchedAllowQuery . authorizationSuccess <$> res @?= Right ifTrue +checkAll :: TestTree+checkAll = testCase "Check all" $ do+  secret <- newSecret+  biscuit <- mkBiscuit secret [block|fact(true); fact(false);|]+  res <- authorizeBiscuit biscuit [authorizer|check all fact($value), $value;allow if true;|]+  res @?= Left (ResultError $ FailedChecks $ pure checkAll')+ errorAccumulation :: TestTree errorAccumulation = testGroup "Error accumulation"   [ testCase "Only checks" $ do@@ -71,7 +89,27 @@ unboundVarRule = testCase "Rule with unbound variable" $ do   secret <- newSecret   b1 <- mkBiscuit secret [block|check if operation("read");|]-  b2 <- addBlock [block|operation($unbound, "read") <- operation($any1, $any2);|] b1+  -- rules with unbound variables don't parse, so we have+  -- to manually construct a broken rule+  let brokenRuleBlock = Block {+        bRules = [Rule{+          rhead = Predicate{+            name = "operation",+            terms = [Variable"unbound", LString "read"]+          },+          body = [Predicate{+            name = "operation",+            terms = Variable <$> ["any1", "any2"]+          }],+          expressions = mempty,+          scope = mempty+        }],+        bFacts = mempty,+        bChecks = mempty,+        bScope = mempty,+        bContext = mempty+  }+  b2 <- addBlock brokenRuleBlock b1   res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|]   res @?= Left InvalidRule 

@@ -0,0 +1,1587 @@+{+  "root_private_key": "12aca40167fbdd1a11037e9fd440e3d510d9d9dea70a6646aa4aaf84d718d75a",+  "root_public_key": "acdd6d5b53bfee478bf689f8e012fe7988bf755e3d7c5152947abc149bc20189",+  "testcases": [+    {+      "title": "basic token",+      "filename": "test001_basic.bc",+      "token": [+        {+          "symbols": [+            "file1",+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "resource(\"file1\")",+              "right(\"file1\", \"read\")",+              "right(\"file1\", \"write\")",+              "right(\"file2\", \"read\")"+            ],+            "rules": [],+            "checks": [+              "check if resource($0), operation(\"read\"), right($0, \"read\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 1,+                        "check_id": 0,+                        "rule": "check if resource($0), operation(\"read\"), right($0, \"read\")"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file1\");\n\nallow if true;\n",+          "revocation_ids": [+            "3ee1c0f42ba69ec63b1f39a6b3c57d25a4ccec452233ca6d40530ecfe83af4918fa78d9346f8b7c498545b54663960342b9ed298b2c8bbe2085b80c237b56f09",+            "e16ccf0820b02092adb531e36c2e82884c6c6c647b1c85184007f2ace601648afb71faa261b11f9ab352093c96187870f868588b664579c8018864b306bd5007"+          ]+        }+      }+    },+    {+      "title": "different root key",+      "filename": "test002_different_root_key.bc",+      "token": [+        {+          "symbols": [+            "file1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": null,+          "result": {+            "Err": {+              "Format": {+                "Signature": {+                  "InvalidSignature": "signature error: Verification equation was not satisfied"+                }+              }+            }+          },+          "authorizer_code": "",+          "revocation_ids": []+        }+      }+    },+    {+      "title": "invalid signature format",+      "filename": "test003_invalid_signature_format.bc",+      "token": [+        {+          "symbols": [+            "file1",+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": null,+          "result": {+            "Err": {+              "Format": {+                "InvalidSignatureSize": 16+              }+            }+          },+          "authorizer_code": "",+          "revocation_ids": []+        }+      }+    },+    {+      "title": "random block",+      "filename": "test004_random_block.bc",+      "token": [+        {+          "symbols": [+            "file1",+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": null,+          "result": {+            "Err": {+              "Format": {+                "Signature": {+                  "InvalidSignature": "signature error: Verification equation was not satisfied"+                }+              }+            }+          },+          "authorizer_code": "",+          "revocation_ids": []+        }+      }+    },+    {+      "title": "invalid signature",+      "filename": "test005_invalid_signature.bc",+      "token": [+        {+          "symbols": [+            "file1",+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": null,+          "result": {+            "Err": {+              "Format": {+                "Signature": {+                  "InvalidSignature": "signature error: Verification equation was not satisfied"+                }+              }+            }+          },+          "authorizer_code": "",+          "revocation_ids": []+        }+      }+    },+    {+      "title": "reordered blocks",+      "filename": "test006_reordered_blocks.bc",+      "token": [+        {+          "symbols": [+            "file1",+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        },+        {+          "symbols": [],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource(\"file1\");\n"+        }+      ],+      "validations": {+        "": {+          "world": null,+          "result": {+            "Err": {+              "Format": {+                "Signature": {+                  "InvalidSignature": "signature error: Verification equation was not satisfied"+                }+              }+            }+          },+          "authorizer_code": "",+          "revocation_ids": []+        }+      }+    },+    {+      "title": "scoped rules",+      "filename": "test007_scoped_rules.bc",+      "token": [+        {+          "symbols": [+            "user_id",+            "alice",+            "file1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "user_id(\"alice\");\nowner(\"alice\", \"file1\");\n"+        },+        {+          "symbols": [+            "0",+            "1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right($0, \"read\") <- resource($0), user_id($1), owner($1, $0);\ncheck if resource($0), operation(\"read\"), right($0, \"read\");\n"+        },+        {+          "symbols": [+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "owner(\"alice\", \"file2\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "owner(\"alice\", \"file1\")",+              "owner(\"alice\", \"file2\")",+              "resource(\"file2\")",+              "user_id(\"alice\")"+            ],+            "rules": [+              "right($0, \"read\") <- resource($0), user_id($1), owner($1, $0)"+            ],+            "checks": [+              "check if resource($0), operation(\"read\"), right($0, \"read\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 1,+                        "check_id": 0,+                        "rule": "check if resource($0), operation(\"read\"), right($0, \"read\")"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\nallow if true;\n",+          "revocation_ids": [+            "02d287b0e5b22780192f8351538583c17f7d0200e064b32a1fcf07899e64ffb10e4de324f5c5ebc72c89a63e424317226cf555eb42dae81b2fd4639cf7591108",+            "22e75ea200cf7b2b62b389298fe0dec973b7f9c7e54e76c3c41811d72ea82c68227bc9079b7d05986de17ef9301cccdc08f5023455386987d1e6ee4391b19f06",+            "140a3631fecae550b51e50b9b822b947fb485c80070b34482fa116cdea560140164a1d0a959b40fed8a727e2f62c0b57635760c488c8bf0eda80ee591558c409"+          ]+        }+      }+    },+    {+      "title": "scoped checks",+      "filename": "test008_scoped_checks.bc",+      "token": [+        {+          "symbols": [+            "file1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        },+        {+          "symbols": [+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file2\", \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "resource(\"file2\")",+              "right(\"file1\", \"read\")",+              "right(\"file2\", \"read\")"+            ],+            "rules": [],+            "checks": [+              "check if resource($0), operation(\"read\"), right($0, \"read\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 1,+                        "check_id": 0,+                        "rule": "check if resource($0), operation(\"read\"), right($0, \"read\")"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\nallow if true;\n",+          "revocation_ids": [+            "567682495bf002eb84c46491e40fad8c55943d918c65e2c110b1b88511bf393072c0305a243e3d632ca5f1e9b0ace3e3582de84838c3a258480657087c267f02",+            "71f0010b1034dbc62c53f67a23947b92ccba46495088567ac7ad5c4d7d65476964bee42053a6a35088110c5918f9c9606057689271fef89d84253cf98e6d4407",+            "6d00d5f2a5d25dbfaa19152a81b44328b368e8fb8300b25e36754cfe8b2ce1eb2d1452ce9b1502e6f377a23aa87098fb05b5b073541624a8815ba0610f793005"+          ]+        }+      }+    },+    {+      "title": "expired token",+      "filename": "test009_expired_token.bc",+      "token": [+        {+          "symbols": [],+          "public_keys": [],+          "external_key": null,+          "code": ""+        },+        {+          "symbols": [+            "file1",+            "expiration"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource(\"file1\");\ncheck if time($time), $time <= 2018-12-20T00:00:00Z;\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "resource(\"file1\")",+              "time(2020-12-21T09:23:12Z)"+            ],+            "rules": [],+            "checks": [+              "check if resource(\"file1\")",+              "check if time($time), $time <= 2018-12-20T00:00:00Z"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 1,+                        "check_id": 1,+                        "rule": "check if time($time), $time <= 2018-12-20T00:00:00Z"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file1\");\noperation(\"read\");\ntime(2020-12-21T09:23:12Z);\n\nallow if true;\n",+          "revocation_ids": [+            "b2474f3e0a5788cdeff811f2599497a04d1ad71ca48dbafb90f20a950d565dda0b86bd6c9072a727c19b6b20a1ae10d8cb88155186550b77016ffd1dca9a6203",+            "0d12152670cbefe2fa504af9a92b513f1a48ae460ae5e66aaac4ed9f7dc3cc1c4c510693312b351465062169a2169fc520ce4e17e548d21982c81a74c66a3c0c"+          ]+        }+      }+    },+    {+      "title": "authorizer scope",+      "filename": "test010_authorizer_scope.bc",+      "token": [+        {+          "symbols": [+            "file1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\n"+        },+        {+          "symbols": [+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file2\", \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "resource(\"file2\")",+              "right(\"file1\", \"read\")",+              "right(\"file2\", \"read\")"+            ],+            "rules": [],+            "checks": [+              "check if right($0, $1), resource($0), operation($1)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Authorizer": {+                        "check_id": 0,+                        "rule": "check if right($0, $1), resource($0), operation($1)"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\ncheck if right($0, $1), resource($0), operation($1);\n\nallow if true;\n",+          "revocation_ids": [+            "b9ecf192ecb1bbb10e45320c1c86661f0c6b6bd28e89fdd8fa838fe0ab3f754229f7fbbf92ad978d36f744c345c69bc156a2a91a2979a3c235a9d936d401b404",+            "839728735701e589c2612e655afa2b53f573480e6a0477ae68ed71587987d1af398a31296bdec0b6eccee9348f4b4c23ca1031e809991626c579fef80b1d380d"+          ]+        }+      }+    },+    {+      "title": "authorizer authority checks",+      "filename": "test011_authorizer_authority_caveats.bc",+      "token": [+        {+          "symbols": [+            "file1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "resource(\"file2\")",+              "right(\"file1\", \"read\")"+            ],+            "rules": [],+            "checks": [+              "check if right($0, $1), resource($0), operation($1)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Authorizer": {+                        "check_id": 0,+                        "rule": "check if right($0, $1), resource($0), operation($1)"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\ncheck if right($0, $1), resource($0), operation($1);\n\nallow if true;\n",+          "revocation_ids": [+            "593d273d141bf23a3e89b55fffe1b3f96f683a022bb763e78f4e49f31a7cf47668c3fd5e0f580727ac9113ede302d34264597f6f1e6c6dd4167836d57aedf504"+          ]+        }+      }+    },+    {+      "title": "authority checks",+      "filename": "test012_authority_caveats.bc",+      "token": [+        {+          "symbols": [+            "file1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource(\"file1\");\n"+        }+      ],+      "validations": {+        "file1": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "resource(\"file1\")"+            ],+            "rules": [],+            "checks": [+              "check if resource(\"file1\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "resource(\"file1\");\noperation(\"read\");\n\nallow if true;\n",+          "revocation_ids": [+            "0a1d14a145debbb0a2f4ce0631d3a0a48a2e0eddabefda7fabb0414879ec6be24b9ae7295c434609ada3f8cc47b8845bbd5a0d4fba3d96748ff1b824496e0405"+          ]+        },+        "file2": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "resource(\"file2\")"+            ],+            "rules": [],+            "checks": [+              "check if resource(\"file1\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 0,+                        "check_id": 0,+                        "rule": "check if resource(\"file1\")"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\nallow if true;\n",+          "revocation_ids": [+            "0a1d14a145debbb0a2f4ce0631d3a0a48a2e0eddabefda7fabb0414879ec6be24b9ae7295c434609ada3f8cc47b8845bbd5a0d4fba3d96748ff1b824496e0405"+          ]+        }+      }+    },+    {+      "title": "block rules",+      "filename": "test013_block_rules.bc",+      "token": [+        {+          "symbols": [+            "file1",+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\n"+        },+        {+          "symbols": [+            "valid_date",+            "0",+            "1"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2030-12-31T12:59:59Z;\nvalid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59Z, ![\"file1\"].contains($1);\ncheck if valid_date($0), resource($0);\n"+        }+      ],+      "validations": {+        "file1": {+          "world": {+            "facts": [+              "resource(\"file1\")",+              "right(\"file1\", \"read\")",+              "right(\"file2\", \"read\")",+              "time(2020-12-21T09:23:12Z)",+              "valid_date(\"file1\")"+            ],+            "rules": [+              "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2030-12-31T12:59:59Z",+              "valid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59Z, ![\"file1\"].contains($1)"+            ],+            "checks": [+              "check if valid_date($0), resource($0)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "resource(\"file1\");\ntime(2020-12-21T09:23:12Z);\n\nallow if true;\n",+          "revocation_ids": [+            "d251352efd4e4c72e8a1609fce002f558f1a0bb5e36cd3d8b3a6c6599e3960880f21bea6fe1857f4ecbc2c399dd77829b154e75f1323e9dec413aad70f97650d",+            "9de4f51e6019540598a957515dad52f5403e5c6cd8d2adbca1bff42a4fbc0eb8c6adab499da2fe894a8a9c9c581276bfb0fdc3d35ab2ff9f920a2c4690739903"+          ]+        },+        "file2": {+          "world": {+            "facts": [+              "resource(\"file2\")",+              "right(\"file1\", \"read\")",+              "right(\"file2\", \"read\")",+              "time(2020-12-21T09:23:12Z)"+            ],+            "rules": [+              "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2030-12-31T12:59:59Z",+              "valid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59Z, ![\"file1\"].contains($1)"+            ],+            "checks": [+              "check if valid_date($0), resource($0)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 1,+                        "check_id": 0,+                        "rule": "check if valid_date($0), resource($0)"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file2\");\ntime(2020-12-21T09:23:12Z);\n\nallow if true;\n",+          "revocation_ids": [+            "d251352efd4e4c72e8a1609fce002f558f1a0bb5e36cd3d8b3a6c6599e3960880f21bea6fe1857f4ecbc2c399dd77829b154e75f1323e9dec413aad70f97650d",+            "9de4f51e6019540598a957515dad52f5403e5c6cd8d2adbca1bff42a4fbc0eb8c6adab499da2fe894a8a9c9c581276bfb0fdc3d35ab2ff9f920a2c4690739903"+          ]+        }+      }+    },+    {+      "title": "regex_constraint",+      "filename": "test014_regex_constraint.bc",+      "token": [+        {+          "symbols": [+            "0",+            "file[0-9]+.txt"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), $0.matches(\"file[0-9]+.txt\");\n"+        }+      ],+      "validations": {+        "file1": {+          "world": {+            "facts": [+              "resource(\"file1\")"+            ],+            "rules": [],+            "checks": [+              "check if resource($0), $0.matches(\"file[0-9]+.txt\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 0,+                        "check_id": 0,+                        "rule": "check if resource($0), $0.matches(\"file[0-9]+.txt\")"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "resource(\"file1\");\n\nallow if true;\n",+          "revocation_ids": [+            "1c158e1e12c8670d3f4411597276fe1caab17b7728adb7f7e9c44eeec3e3d85676e6ebe2d28c287e285a45912386cfa53e1752997630bd7a4ca6c2cd9f143500"+          ]+        },+        "file123": {+          "world": {+            "facts": [+              "resource(\"file123.txt\")"+            ],+            "rules": [],+            "checks": [+              "check if resource($0), $0.matches(\"file[0-9]+.txt\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "resource(\"file123.txt\");\n\nallow if true;\n",+          "revocation_ids": [+            "1c158e1e12c8670d3f4411597276fe1caab17b7728adb7f7e9c44eeec3e3d85676e6ebe2d28c287e285a45912386cfa53e1752997630bd7a4ca6c2cd9f143500"+          ]+        }+      }+    },+    {+      "title": "multi queries checks",+      "filename": "test015_multi_queries_caveats.bc",+      "token": [+        {+          "symbols": [+            "must_be_present",+            "hello"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "must_be_present(\"hello\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "must_be_present(\"hello\")"+            ],+            "rules": [],+            "checks": [+              "check if must_be_present($0) or must_be_present($0)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "check if must_be_present($0) or must_be_present($0);\n\nallow if true;\n",+          "revocation_ids": [+            "d3eee8a74eacec9c51d4d1eb29b479727dfaafa9df7d4c651d07c493c56f3a5f037a51139ebd036f50d1159d12bccec3e377bbd32db90a39dd52c4776757ad0b"+          ]+        }+      }+    },+    {+      "title": "check head name should be independent from fact names",+      "filename": "test016_caveat_head_name.bc",+      "token": [+        {+          "symbols": [+            "hello"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource(\"hello\");\n"+        },+        {+          "symbols": [+            "test"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "query(\"test\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "query(\"test\")"+            ],+            "rules": [],+            "checks": [+              "check if resource(\"hello\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 0,+                        "check_id": 0,+                        "rule": "check if resource(\"hello\")"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "allow if true;\n",+          "revocation_ids": [+            "e79679e019f1d7d3a9f9a309673aceadc7b2b2d67c0df3e7a1dccec25218e9b5935b9c8f8249243446406e3cdd86c1b35601a21cf1b119df48ca5e897cc6cd0d",+            "2042ea2dca41ba3eb31196f49b211e615dcba46067be126e6035b8549bb57cdfeb24d07f2b44241bc0f70cc8ddc31e30772116d785b82bc91be8440dfdab500f"+          ]+        }+      }+    },+    {+      "title": "test expression syntax and all available operations",+      "filename": "test017_expressions.bc",+      "token": [+        {+          "symbols": [+            "hello world",+            "hello",+            "world",+            "aaabde",+            "a*c?.e",+            "abd",+            "aaa",+            "b",+            "de",+            "abcD12",+            "abc",+            "def"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if true;\ncheck if !false;\ncheck if !false && true;\ncheck if false or true;\ncheck if (true || false) && true;\ncheck if 1 < 2;\ncheck if 2 > 1;\ncheck if 1 <= 2;\ncheck if 1 <= 1;\ncheck if 2 >= 1;\ncheck if 2 >= 2;\ncheck if 3 == 3;\ncheck if 1 + 2 * 3 - 4 / 2 == 5;\ncheck if 1 | 2 ^ 3 == 0;\ncheck if \"hello world\".starts_with(\"hello\") && \"hello world\".ends_with(\"world\");\ncheck if \"aaabde\".matches(\"a*c?.e\");\ncheck if \"aaabde\".contains(\"abd\");\ncheck if \"aaabde\" == \"aaa\" + \"b\" + \"de\";\ncheck if \"abcD12\" == \"abcD12\";\ncheck if 2019-12-04T09:46:41Z < 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z > 2019-12-04T09:46:41Z;\ncheck if 2019-12-04T09:46:41Z <= 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z >= 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z >= 2019-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z >= 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z == 2020-12-04T09:46:41Z;\ncheck if hex:12ab == hex:12ab;\ncheck if [1, 2].contains(2);\ncheck if [2019-12-04T09:46:41Z, 2020-12-04T09:46:41Z].contains(2020-12-04T09:46:41Z);\ncheck if [false, true].contains(true);\ncheck if [\"abc\", \"def\"].contains(\"abc\");\ncheck if [hex:12ab, hex:34de].contains(hex:34de);\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [],+            "rules": [],+            "checks": [+              "check if !false",+              "check if !false && true",+              "check if \"aaabde\" == \"aaa\" + \"b\" + \"de\"",+              "check if \"aaabde\".contains(\"abd\")",+              "check if \"aaabde\".matches(\"a*c?.e\")",+              "check if \"abcD12\" == \"abcD12\"",+              "check if \"hello world\".starts_with(\"hello\") && \"hello world\".ends_with(\"world\")",+              "check if (true || false) && true",+              "check if 1 + 2 * 3 - 4 / 2 == 5",+              "check if 1 < 2",+              "check if 1 <= 1",+              "check if 1 <= 2",+              "check if 1 | 2 ^ 3 == 0",+              "check if 2 > 1",+              "check if 2 >= 1",+              "check if 2 >= 2",+              "check if 2019-12-04T09:46:41Z < 2020-12-04T09:46:41Z",+              "check if 2019-12-04T09:46:41Z <= 2020-12-04T09:46:41Z",+              "check if 2020-12-04T09:46:41Z == 2020-12-04T09:46:41Z",+              "check if 2020-12-04T09:46:41Z > 2019-12-04T09:46:41Z",+              "check if 2020-12-04T09:46:41Z >= 2019-12-04T09:46:41Z",+              "check if 2020-12-04T09:46:41Z >= 2020-12-04T09:46:41Z",+              "check if 3 == 3",+              "check if [\"abc\", \"def\"].contains(\"abc\")",+              "check if [1, 2].contains(2)",+              "check if [2019-12-04T09:46:41Z, 2020-12-04T09:46:41Z].contains(2020-12-04T09:46:41Z)",+              "check if [false, true].contains(true)",+              "check if [hex:12ab, hex:34de].contains(hex:34de)",+              "check if false or true",+              "check if hex:12ab == hex:12ab",+              "check if true"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "allow if true;\n",+          "revocation_ids": [+            "1472c34b2854a24f5023f5c9a2ecead444b1ddb9c94ffc42f3ed1f062745d3983e8392cd0a94ec3b00e355f00fa5980e187bb86a625e289e2e723f373e3bcd05"+          ]+        }+      }+    },+    {+      "title": "invalid block rule with unbound_variables",+      "filename": "test018_unbound_variables_in_rule.bc",+      "token": [+        {+          "symbols": [],+          "public_keys": [],+          "external_key": null,+          "code": "check if operation(\"read\");\n"+        },+        {+          "symbols": [+            "unbound",+            "any1",+            "any2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "operation($unbound, \"read\") <- operation($any1, $any2);\n"+        }+      ],+      "validations": {+        "": {+          "world": null,+          "result": {+            "Err": {+              "FailedLogic": {+                "InvalidBlockRule": [+                  0,+                  "operation($unbound, \"read\") <- operation($any1, $any2)"+                ]+              }+            }+          },+          "authorizer_code": "",+          "revocation_ids": [+            "c536d07f08f6f73da69a2f49310045168e059b8c07e3ddf25afd524df358a0397744b31a139eced043cb5f7a29dacbe3a510ce449fc792e53623186767cefc0c",+            "8588c74c3701e8d4be770769b4e1054dbb5ea5f231a89d205000802b8718859ea1d596af207a41b1b0f7d05959180c227ea8954e903f13ade3ce3384d1e6a70a"+          ]+        }+      }+    },+    {+      "title": "invalid block rule generating an #authority or #ambient symbol with a variable",+      "filename": "test019_generating_ambient_from_variables.bc",+      "token": [+        {+          "symbols": [],+          "public_keys": [],+          "external_key": null,+          "code": "check if operation(\"read\");\n"+        },+        {+          "symbols": [+            "any"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "operation(\"read\") <- operation($any);\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "operation(\"write\")"+            ],+            "rules": [+              "operation(\"read\") <- operation($any)"+            ],+            "checks": [+              "check if operation(\"read\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 0,+                        "check_id": 0,+                        "rule": "check if operation(\"read\")"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "operation(\"write\");\n\nallow if true;\n",+          "revocation_ids": [+            "4819e7360fdb840e54e94afcbc110e9b0652894dba2b8bf3b8b8f2254aaf00272bba7eb603c153c7e50cca0e5bb8e20449d70a1b24e7192e902c64f94848a703",+            "4a4c59354354d2f91b3a2d1e7afa2c5eeaf8be9f7b163c6b9091817551cc8661f0f3e0523b525ef9a5e597c0dd1f32e09e97ace531c150dba335bb3e1d329d00"+          ]+        }+      }+    },+    {+      "title": "sealed token",+      "filename": "test020_sealed.bc",+      "token": [+        {+          "symbols": [+            "file1",+            "file2"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n"+        },+        {+          "symbols": [+            "0"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "operation(\"read\")",+              "resource(\"file1\")",+              "right(\"file1\", \"read\")",+              "right(\"file1\", \"write\")",+              "right(\"file2\", \"read\")"+            ],+            "rules": [],+            "checks": [+              "check if resource($0), operation(\"read\"), right($0, \"read\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "resource(\"file1\");\noperation(\"read\");\n\nallow if true;\n",+          "revocation_ids": [+            "b279f8c6fee5ea3c3fcb5109d8c6b35ba3fecea64d83a4dc387102b9401633a1558ac6ac50ddd7fd9e9877f936f9f4064abd467faeca2bef3114b9695eb0580e",+            "e1f0aca12704c1a3b9bb6292504ca6070462d9e043756dd209e625084e7d4053078bd4e55b6eebebbeb771d26d7794aa95f6b39ff949431548b32585a7379f0c"+          ]+        }+      }+    },+    {+      "title": "parsing",+      "filename": "test021_parsing.bc",+      "token": [+        {+          "symbols": [+            "ns::fact_123",+            "hello é\t😁"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "ns::fact_123(\"hello é\t😁\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "ns::fact_123(\"hello é\t😁\")"+            ],+            "rules": [],+            "checks": [+              "check if ns::fact_123(\"hello é\t😁\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "check if ns::fact_123(\"hello é\t😁\");\n\nallow if true;\n",+          "revocation_ids": [+            "4797a528328c8b5fb7939cc8956d8cda2513f552466eee501e26ea13a6cf6b4a381fd74ae547a9b50b627825142287d899b9d7bd1b5cfb18664a1be78320ea06"+          ]+        }+      }+    },+    {+      "title": "default_symbols",+      "filename": "test022_default_symbols.bc",+      "token": [+        {+          "symbols": [],+          "public_keys": [],+          "external_key": null,+          "code": "read(0);\nwrite(1);\nresource(2);\noperation(3);\nright(4);\ntime(5);\nrole(6);\nowner(7);\ntenant(8);\nnamespace(9);\nuser(10);\nteam(11);\nservice(12);\nadmin(13);\nemail(14);\ngroup(15);\nmember(16);\nip_address(17);\nclient(18);\nclient_ip(19);\ndomain(20);\npath(21);\nversion(22);\ncluster(23);\nnode(24);\nhostname(25);\nnonce(26);\nquery(27);\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "admin(13)",+              "client(18)",+              "client_ip(19)",+              "cluster(23)",+              "domain(20)",+              "email(14)",+              "group(15)",+              "hostname(25)",+              "ip_address(17)",+              "member(16)",+              "namespace(9)",+              "node(24)",+              "nonce(26)",+              "operation(3)",+              "owner(7)",+              "path(21)",+              "query(27)",+              "read(0)",+              "resource(2)",+              "right(4)",+              "role(6)",+              "service(12)",+              "team(11)",+              "tenant(8)",+              "time(5)",+              "user(10)",+              "version(22)",+              "write(1)"+            ],+            "rules": [],+            "checks": [+              "check if read(0), write(1), resource(2), operation(3), right(4), time(5), role(6), owner(7), tenant(8), namespace(9), user(10), team(11), service(12), admin(13), email(14), group(15), member(16), ip_address(17), client(18), client_ip(19), domain(20), path(21), version(22), cluster(23), node(24), hostname(25), nonce(26), query(27)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "check if read(0), write(1), resource(2), operation(3), right(4), time(5), role(6), owner(7), tenant(8), namespace(9), user(10), team(11), service(12), admin(13), email(14), group(15), member(16), ip_address(17), client(18), client_ip(19), domain(20), path(21), version(22), cluster(23), node(24), hostname(25), nonce(26), query(27);\n\nallow if true;\n",+          "revocation_ids": [+            "38094260b324eff92db2ef79e715d88c18503c0dafa400bff900399f2ab0840cedc5ac25bdd3e97860b3f9e78ca5e0df67a113eb87be50265d49278efb13210f"+          ]+        }+      }+    },+    {+      "title": "execution scope",+      "filename": "test023_execution_scope.bc",+      "token": [+        {+          "symbols": [+            "authority_fact"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "authority_fact(1);\n"+        },+        {+          "symbols": [+            "block1_fact"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "block1_fact(1);\n"+        },+        {+          "symbols": [+            "var"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "check if authority_fact($var);\ncheck if block1_fact($var);\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "authority_fact(1)",+              "block1_fact(1)"+            ],+            "rules": [],+            "checks": [+              "check if authority_fact($var)",+              "check if block1_fact($var)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 2,+                        "check_id": 1,+                        "rule": "check if block1_fact($var)"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "allow if true;\n",+          "revocation_ids": [+            "6a3606836bc63b858f96ce5000c9bead8eda139ab54679a2a8d7a9984c2e5d864b93280acc1b728bed0be42b5b1c3be10f48a13a4dbd05fd5763de5be3855108",+            "5f1468fc60999f22c4f87fa088a83961188b4e654686c5b04bdc977b9ff4666d51a3d8be5594f4cef08054d100f31d1637b50bb394de7cccafc643c9b650390b",+            "3eda05ddb65ee90d715cefc046837c01de944d8c4a7ff67e3d9a9d8470b5e214a20a8b9866bfe5e0d385e530b75ec8fcfde46b7dd6d4d6647d1e955c9d2fb90d"+          ]+        }+      }+    },+    {+      "title": "third party",+      "filename": "test024_third_party.bc",+      "token": [+        {+          "symbols": [],+          "public_keys": [+            "ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25"+          ],+          "external_key": null,+          "code": "right(\"read\");\ncheck if group(\"admin\") trusting ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25;\n"+        },+        {+          "symbols": [],+          "public_keys": [],+          "external_key": "ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25",+          "code": "group(\"admin\");\ncheck if right(\"read\");\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "group(\"admin\")",+              "right(\"read\")"+            ],+            "rules": [],+            "checks": [+              "check if group(\"admin\") trusting ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25",+              "check if right(\"read\")"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "allow if true;\n",+          "revocation_ids": [+            "4f61f2f2f9cefdcad03a82803638e459bef70d6fd72dbdf2bdcab78fbd23f33146e4ff9700e23acb547b820b871fa9b9fd3bb6d7a1a755afce47e9907c65600c",+            "683b23943b73f53f57f473571ba266f79f1fca0633be249bc135054371a11ffb101c57150ab2f1b9a6a160b45d09567a314b7dbc84224edf6188afd5b86d9305"+          ]+        }+      }+    },+    {+      "title": "block rules",+      "filename": "test025_check_all.bc",+      "token": [+        {+          "symbols": [+            "allowed_operations",+            "A",+            "B",+            "op",+            "allowed"+          ],+          "public_keys": [],+          "external_key": null,+          "code": "allowed_operations([\"A\", \"B\"]);\ncheck all operation($op), allowed_operations($allowed), $allowed.contains($op);\n"+        }+      ],+      "validations": {+        "A, B": {+          "world": {+            "facts": [+              "allowed_operations([ \"A\", \"B\"])",+              "operation(\"A\")",+              "operation(\"B\")"+            ],+            "rules": [],+            "checks": [+              "check all operation($op), allowed_operations($allowed), $allowed.contains($op)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Ok": 0+          },+          "authorizer_code": "operation(\"A\");\noperation(\"B\");\n\nallow if true;\n",+          "revocation_ids": [+            "b4ee591001e4068a7ee8efb7a0586c3ca3a785558f34d1fa8dbfa21b41ace70de0b670ac49222c7413066d0d83e6d9edee94fb0fda4b27ea11e837304dfb4b0b"+          ]+        },+        "A, invalid": {+          "world": {+            "facts": [+              "allowed_operations([ \"A\", \"B\"])",+              "operation(\"A\")",+              "operation(\"invalid\")"+            ],+            "rules": [],+            "checks": [+              "check all operation($op), allowed_operations($allowed), $allowed.contains($op)"+            ],+            "policies": [+              "allow if true"+            ]+          },+          "result": {+            "Err": {+              "FailedLogic": {+                "Unauthorized": {+                  "policy": {+                    "Allow": 0+                  },+                  "checks": [+                    {+                      "Block": {+                        "block_id": 0,+                        "check_id": 0,+                        "rule": "check all operation($op), allowed_operations($allowed), $allowed.contains($op)"+                      }+                    }+                  ]+                }+              }+            }+          },+          "authorizer_code": "operation(\"A\");\noperation(\"invalid\");\n\nallow if true;\n",+          "revocation_ids": [+            "b4ee591001e4068a7ee8efb7a0586c3ca3a785558f34d1fa8dbfa21b41ace70de0b670ac49222c7413066d0d83e6d9edee94fb0fda4b27ea11e837304dfb4b0b"+          ]+        }+      }+    },+    {+      "title": "public keys interning",+      "filename": "test026_public_keys_interning.bc",+      "token": [+        {+          "symbols": [],+          "public_keys": [+            "ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59"+          ],+          "external_key": null,+          "code": "query(0);\ncheck if true trusting previous, ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n"+        },+        {+          "symbols": [],+          "public_keys": [+            "ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee"+          ],+          "external_key": "ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59",+          "code": "query(1);\nquery(1, 2) <- query(1), query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n"+        },+        {+          "symbols": [],+          "public_keys": [],+          "external_key": "ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee",+          "code": "query(2);\ncheck if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n"+        },+        {+          "symbols": [],+          "public_keys": [],+          "external_key": "ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee",+          "code": "query(3);\ncheck if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n"+        },+        {+          "symbols": [],+          "public_keys": [+            "ed25519/2e0118e63beb7731dab5119280ddb117234d0cdc41b7dd5dc4241bcbbb585d14"+          ],+          "external_key": null,+          "code": "query(4);\ncheck if query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(4) trusting ed25519/2e0118e63beb7731dab5119280ddb117234d0cdc41b7dd5dc4241bcbbb585d14;\n"+        }+      ],+      "validations": {+        "": {+          "world": {+            "facts": [+              "query(0)",+              "query(1)",+              "query(1, 2)",+              "query(2)",+              "query(3)",+              "query(4)"+            ],+            "rules": [+              "query(1, 2) <- query(1), query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee"+            ],+            "checks": [+              "check if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59",+              "check if query(1, 2) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59, ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee",+              "check if query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee",+              "check if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee",+              "check if query(4) trusting ed25519/2e0118e63beb7731dab5119280ddb117234d0cdc41b7dd5dc4241bcbbb585d14",+              "check if true trusting previous, ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59"+            ],+            "policies": [+              "allow if true",+              "deny if query(0) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59",+              "deny if query(1, 2)",+              "deny if query(3)"+            ]+          },+          "result": {+            "Ok": 3+          },+          "authorizer_code": "check if query(1, 2) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59, ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\n\ndeny if query(3);\ndeny if query(1, 2);\ndeny if query(0) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\nallow if true;\n",+          "revocation_ids": [+            "bc144fef824b7ba4b266eac53e9b4f3f2d3cd443c6963833f2f8d4073bef9553f92034c2350fdd50966a9f0c09db35b142d61e0476b0133429885c787052060b",+            "aba1631f8d0bea1c81447e73269f560973d03287c2b44325d1b42d10a496156dc8e78648b946bc7db7a3111d787a10c1a9da8d53fc066b1f207de7415a2e9b0b",+            "539cff0f5c311dcac843a9e6c8bb445aff0d6510bfa9b17d5350747be92dc365217e89e1d733f3ead1ecc05f287f312c41831338708e788503b55517af3ad000",+            "5b10f7a7b4487f4421cf7f7f6d00b24a7a71939037b65b2e44241909564082a3e1e70cf7d866eb96f0a5119b9ea395adb772faaa33252fa62a579eb15a108a0b",+            "3905351588cdfc4433b510cc1ed9c11ca5c1a7bd7d9cef338bcd3f6d374c711f34edd83dd0d53c25b63bf05b49fc78addceb47905d5495580c2fd36c11bc1e0a"+          ]+        }+      }+    }+  ]+}