biscuit-haskell 0.1.1.0 → 0.2.0.0

raw patch · 27 files changed

+2784/−1745 lines, 27 filesdep +aesondep +criteriondep +cryptonitedep −libsodiumdep −primitivedep ~basedep ~base16-bytestringdep ~randomPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, criterion, cryptonite, memory

Dependencies removed: libsodium, primitive

Dependency ranges changed: base, base16-bytestring, random

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−1
• README.md +109/−1
• benchmarks/Bench.hs +23/−0
• biscuit-haskell.cabal +24/−14
• src/Auth/Biscuit.hs +283/−96
• src/Auth/Biscuit/Crypto.hs +106/−0
• src/Auth/Biscuit/Datalog/AST.hs +139/−109
• src/Auth/Biscuit/Datalog/Executor.hs +84/−237
• src/Auth/Biscuit/Datalog/Parser.hs +77/−47
• src/Auth/Biscuit/Datalog/ScopedExecutor.hs +312/−0
• src/Auth/Biscuit/Example.hs +10/−10
• src/Auth/Biscuit/Proto.hs +103/−110
• src/Auth/Biscuit/ProtoBufAdapter.hs +126/−93
• src/Auth/Biscuit/Sel.hs +0/−334
• src/Auth/Biscuit/Token.hs +402/−162
• test/Spec.hs +23/−18
• test/Spec/Crypto.hs +0/−129
• test/Spec/Executor.hs +36/−37
• test/Spec/NewCrypto.hs +212/−0
• test/Spec/Parser.hs +107/−118
• test/Spec/Quasiquoter.hs +14/−16
• test/Spec/RevocationIds.hs +42/−19
• test/Spec/Roundtrip.hs +40/−38
• test/Spec/SampleReader.hs +234/−0
• test/Spec/Samples.hs +0/−103
• test/Spec/ScopedExecutor.hs +211/−0
• test/Spec/Verification.hs +60/−53

@@ -1,3 +1,9 @@ # Changelog for biscuit-haskell -## Unreleased changes+## 0.1.1.0++Bugfix for `serializeB64` and `serializeHex`.++## 0.1.0.0++Basic biscuit support.

@@ -1,1 +1,109 @@-# biscuit-haskell+# biscuit-haskell [![CI-badge][CI-badge]][CI-url] [![Hackage][hackage]][hackage-url]++<img src="https://raw.githubusercontent.com/divarvel/biscuit-haskell/main/assets/biscuit-logo.png" align=right>++Main library for biscuit tokens support, providing minting and signature verification of biscuit tokens, as well as a datalog engine allowing to compute the validity of a token in a given context.++## Supported biscuit versions++The core library supports [`v2` biscuits][v2spec] (both open and sealed).++## How to use this library++This library was designed with the use of [`QuasiQuotes`][quasiquotes] in mind.++A [minimal example][biscuitexample] is provided in the library itself, and the [package documentation][packagedoc] contains comprehensive examples and explanations for all the library features.++Familiarity with biscuit tokens will make the examples easier to follow.+Reading the [biscuit presentation][biscuit] and the [biscuit tutorial][biscuittutorial] is advised.++### Checking a biscuit token++To make sure a biscuit token is valid, two checks have to take place:++- a signature check with a public key, making sure the token is authentic+- a datalog check making sure the token is authorized for the given context++```haskell+-- public keys are typically serialized as hex-encoded strings.+-- In most cases they will be read from a config file or an environment+-- variable+publicKey' :: PublicKey+publicKey' = case parsePublicKeyHex "todo" of+  Nothing -> error "Error parsing public key"+  Just k  -> k++-- this function takes a base64-encoded biscuit in a bytestring, parses it,+-- checks it signature and its validity. Here the provided context is just+-- the current time (useful for TTL checks). In most cases, the provided context+-- will carry a permissions check for the endpoint being accessed.+verification :: ByteString -> IO Bool+verification serialized = do+  now <- getCurrentTime+  -- biscuits are typically serialized as base64 bytestrings. The publicKey is needed+  -- to check the biscuit integrity before completely deserializing it+  biscuit <- either (fail . show) pure $ parseB64 publicKey' serialized+  -- the verifier can carry facts (like here), but also checks or policies.+  -- 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});+                                allow if true;+                               |]+  -- `authorizeBiscuit` only works on valid biscuits, and runs the datalog verifications+  -- ensuring the biscuit is authorized in a given context+  result <- authorizeBiscuit biscuit authorizer'+  case result of+    Left e  -> print e $> False+    Right _ -> pure True+```++### Creating (and attenuating) biscuit tokens++Biscuit tokens are created from a secret key, and can be attenuated without it.++```haskell+-- secret keys are typically serialized as hex-encoded strings.+-- In most cases they will be read from a config file or an environment+-- variable (env vars or another secret management system are favored,+-- since the secret key is sensitive information).+-- A random secret key can be generated with `generateSecretKey`+secretKey' :: SecretKey+secretKey' = case parseSecretPrivateKeyHex "todo" of+  Nothing -> error "Error parsing secret key"+  Just k  -> k++creation :: IO ByteString+creation = do+  -- biscuit tokens carry an authority block, which contents are guaranteed by the+  -- secret key.+  -- Blocks are defined inline, directly in datalog, through the `block`+  -- quasiquoter. datalog parsing and validation happens at compile time, but+  -- can still reference haskell variables.+  let authority = [block|+       // toto+       resource("file1");+       |]+  biscuit <- mkBiscuit secretKey authority+  -- biscuits can be attenuated with blocks. blocks are not guaranteed by the secret key and+  -- should only restrict the token use. This property is guaranteed by the datalog evaluation:+  -- facts and rules declared in a block cannot interact with previous blocks.+  -- Here, the block only adds a TTL check.+  let block1 = [block|check if time($time), $time < 2021-05-08T00:00:00Z;|]+  -- `addBlock` only takes a block and a biscuit, the secret key is not needed:+  -- any biscuit can be attenuated by its holder.+  newBiscuit <- addBlock block1 biscuit+  pure $ serializeB64 newBiscuit+```++[CI-badge]: https://img.shields.io/github/workflow/status/Divarvel/biscuit-haskell/CI?style=flat-square+[CI-url]: https://github.com/Divarvel/biscuit-haskell/actions+[Hackage]: https://img.shields.io/hackage/v/biscuit-haskell?color=purple&style=flat-square+[hackage-url]: https://hackage.haskell.org/package/biscuit-haskell+[gcouprie]: https://github.com/geal+[biscuit]: https://www.clever-cloud.com/blog/engineering/2021/04/12/introduction-to-biscuit/+[biscuittutorial]: https://www.clever-cloud.com/blog/engineering/2021/04/15/biscuit-tutorial/+[v2spec]: https://github.com/CleverCloud/biscuit/blob/2.0/SPECIFICATIONS.md+[quasiquotes]: https://wiki.haskell.org/Quasiquotation+[biscuitexample]: https://github.com/divarvel/biscuit-haskell/blob/main/biscuit/src/Auth/Biscuit/Example.hs+[packagedoc]: https://hackage.haskell.org/package/biscuit-haskell-0.1.0.0/docs/Auth-Biscuit.html

@@ -0,0 +1,23 @@+{-# LANGUAGE QuasiQuotes #-}+import           Criterion.Main++import           Auth.Biscuit+import           Data.Maybe     (fromJust)++buildToken :: SecretKey -> IO (Biscuit Open Verified)+buildToken sk = do+  mkBiscuit sk [block|user_id("user_1234");|]++-- Our benchmark harness.+main = do+  sk <- newSecret+  biscuit <- buildToken sk+  let pk = toPublic sk+  let biscuitBs = serialize biscuit+  defaultMain [+    bgroup "biscuit" [ bench "mkBiscuit"  $ whnfIO (buildToken sk)+                     , bench "parse"      $ whnf (parse pk) biscuitBs+                     , bench "serialize"  $ whnf serialize biscuit+                     , bench "verify"     $ whnfIO (authorizeBiscuit biscuit [authorizer|allow if user_id("user_1234");|])+                     ]+    ]

@@ -1,7 +1,7 @@ cabal-version: 2.0  name:           biscuit-haskell-version:        0.1.1.0+version:        0.2.0.0 category:       Security synopsis:       Library support for the Biscuit security token description:    Please see the README on GitHub at <https://github.com/divarvel/biscuit-haskell#readme>@@ -25,13 +25,14 @@   exposed-modules:       Auth.Biscuit       Auth.Biscuit.Utils+      Auth.Biscuit.Crypto       Auth.Biscuit.Datalog.AST       Auth.Biscuit.Datalog.Executor       Auth.Biscuit.Datalog.Parser+      Auth.Biscuit.Datalog.ScopedExecutor       Auth.Biscuit.Example       Auth.Biscuit.Proto       Auth.Biscuit.ProtoBufAdapter-      Auth.Biscuit.Sel       Auth.Biscuit.Timer       Auth.Biscuit.Token   other-modules:@@ -44,20 +45,20 @@   build-depends:     base                 >= 4.7 && <5,     async                ^>= 2.2,-    base16-bytestring    ^>= 0.1.0,+    base16-bytestring    ^>= 1.0,     bytestring           ^>= 0.10,     text                 ^>= 1.2,     containers           ^>= 0.6,+    cryptonite           >= 0.27 && < 0.30,+    memory               ^>= 0.15,     template-haskell     ^>= 2.16,     attoparsec           ^>= 0.13,-    primitive            ^>= 0.7,     base64               ^>= 0.4,     cereal               ^>= 0.5,-    libsodium            ^>= 1.0,     mtl                  ^>= 2.2,     parser-combinators   ^>= 1.2,     protobuf             ^>= 0.2,-    random               ^>= 1.1,+    random               >= 1.0 && < 1.3,     regex-tdfa           ^>= 1.3,     th-lift-instances    ^>= 0.1,     time                 ^>= 1.9,@@ -75,16 +76,14 @@       async     , attoparsec     , base >=4.7 && <5-    , base16-bytestring ^>=0.1.0+    , base16-bytestring ^>=1.0     , base64     , biscuit-haskell     , bytestring     , cereal     , containers-    , libsodium     , mtl     , parser-combinators-    , primitive     , protobuf     , random     , template-haskell@@ -98,13 +97,14 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      Spec.Crypto+      Spec.NewCrypto       Spec.Executor       Spec.Parser       Spec.Quasiquoter       Spec.RevocationIds       Spec.Roundtrip-      Spec.Samples+      Spec.SampleReader+      Spec.ScopedExecutor       Spec.Verification       Paths_biscuit_haskell   hs-source-dirs:@@ -112,18 +112,18 @@   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:       async+    , aeson     , attoparsec     , base >=4.7 && <5-    , base16-bytestring ^>=0.1+    , base16-bytestring ^>=1.0     , base64     , biscuit-haskell     , bytestring     , cereal     , containers-    , libsodium+    , cryptonite     , mtl     , parser-combinators-    , primitive     , protobuf     , random     , tasty@@ -134,3 +134,13 @@     , time     , validation-selective   default-language: Haskell2010++benchmark biscuit-bench+  type:                exitcode-stdio-1.0+  main-is:             Bench.hs+  hs-source-dirs:      benchmarks+  default-language:    Haskell2010+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T+  build-depends:       base+                     , criterion+                     , biscuit-haskell

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds         #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-|@@ -13,178 +14,364 @@   -- $biscuitOverview    -- * Creating keypairs-    newKeypair-  , fromPrivateKey-  , PrivateKey+  -- $keypairs+    newSecret+  , toPublic+  , SecretKey   , PublicKey-  , Keypair (..)    -- ** Parsing and serializing keypairs-  , serializePrivateKeyHex+  , serializeSecretKeyHex   , serializePublicKeyHex-  , parsePrivateKeyHex+  , parseSecretKeyHex   , parsePublicKeyHex-  , serializePrivateKey+  , serializeSecretKey   , serializePublicKey-  , parsePrivateKey+  , parseSecretKey   , parsePublicKey    -- * Creating a biscuit+  -- $biscuitBlocks+  , mkBiscuit   , block   , blockContext-  , mkBiscuit-  , addBlock   , Biscuit+  , OpenOrSealed+  , Open+  , Sealed+  , Verified+  , Unverified+  , BiscuitProof   , Block   -- ** Parsing and serializing biscuits-  , serializeB64   , parseB64   , parse+  , parseWith+  , parseBiscuitUnverified+  , checkBiscuitSignatures+  , BiscuitEncoding (..)+  , ParserConfig (..)+  , fromRevocationList+  , serializeB64   , serialize-  , parseHex-  , serializeHex+  , fromHex+  -- ** Attenuating biscuits+  -- $attenuatingBiscuits+  , addBlock+  -- $sealedBiscuits+  , seal+  , fromOpen+  , fromSealed+  , asOpen+  , asSealed    -- * Verifying a biscuit-  , verifier-  , verifyBiscuit-  , verifyBiscuitWithLimits-  , checkBiscuitSignature+  -- $verifying+  , authorizer+  , Authorizer+  , authorizeBiscuit+  , authorizeBiscuitWithLimits+  , Limits (..)   , defaultLimits-  , Verifier   , ParseError (..)-  , VerificationError (..)   , ExecutionError (..)-  , Limits (..)+  , AuthorizationSuccess (..)+  , MatchedQuery (..)+  , query+  , queryAuthorizerFacts+  , getBindings+  , getVariableValues+  , getSingleVariableValue+  , ToTerm (..)+  , FromValue (..)+  , Term+  , Term' (..)++  -- * Retrieving information from a biscuit+  , getRevocationIds+  , getVerifiedBiscuitPublicKey   ) where -import           Control.Monad                 ((<=<))-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.Text                     (Text)+import           Control.Monad                       ((<=<))+import           Control.Monad.Identity              (runIdentity)+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           Auth.Biscuit.Datalog.AST      (Block, Verifier, bContext)-import           Auth.Biscuit.Datalog.Executor (ExecutionError (..),-                                                Limits (..), defaultLimits)-import           Auth.Biscuit.Datalog.Parser   (block, verifier)-import           Auth.Biscuit.Sel              (Keypair (..), PrivateKey,-                                                PublicKey, fromPrivateKey,-                                                newKeypair, parsePrivateKey,-                                                parsePublicKey,-                                                serializePrivateKey,-                                                serializePublicKey)-import           Auth.Biscuit.Token            (Biscuit, ParseError (..),-                                                VerificationError (..),-                                                addBlock, checkBiscuitSignature,-                                                mkBiscuit, parseBiscuit,-                                                serializeBiscuit, verifyBiscuit,-                                                verifyBiscuitWithLimits)-import           Auth.Biscuit.Utils            (maybeToRight)+import           Auth.Biscuit.Crypto                 (PublicKey, SecretKey,+                                                      convert,+                                                      generateSecretKey,+                                                      maybeCryptoError,+                                                      publicKey, secretKey,+                                                      toPublic)+import           Auth.Biscuit.Datalog.AST            (Authorizer, Block,+                                                      FromValue (..), Term,+                                                      Term' (..), ToTerm (..),+                                                      bContext)+import           Auth.Biscuit.Datalog.Executor       (ExecutionError (..),+                                                      Limits (..),+                                                      MatchedQuery (..),+                                                      defaultLimits)+import           Auth.Biscuit.Datalog.Parser         (authorizer, block, query)+import           Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess (..),+                                                      getBindings,+                                                      getSingleVariableValue,+                                                      getVariableValues,+                                                      queryAuthorizerFacts)+import           Auth.Biscuit.Token                  (Biscuit,+                                                      BiscuitEncoding (..),+                                                      BiscuitProof (..), Open,+                                                      OpenOrSealed,+                                                      ParseError (..),+                                                      ParserConfig (..), Sealed,+                                                      Unverified, Verified,+                                                      addBlock, asOpen,+                                                      asSealed,+                                                      authorizeBiscuit,+                                                      authorizeBiscuitWithLimits,+                                                      checkBiscuitSignatures,+                                                      fromOpen, fromSealed,+                                                      getRevocationIds,+                                                      getVerifiedBiscuitPublicKey,+                                                      mkBiscuit,+                                                      parseBiscuitUnverified,+                                                      parseBiscuitWith, seal,+                                                      serializeBiscuit) + -- $biscuitOverview -- -- <https://github.com/CleverCloud/biscuit/blob/master/SUMMARY.md Biscuit> is a /bearer token/,--- allowing /offline attenuation/ (meaning that anyone having a token can restrict its use),--- and /public key verification/. Token rights and attenuation are expressed using a logic language.+-- 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+-- language, derived from <todo datalog>. Such a language can describe facts (things we know+-- about the world), rules (describing how to derive new facts from existing ones) and checks+-- (ensuring that facts hold). Facts and checks let you describe access control rules, while+-- rules make them modular. /Authorizer policies/ lets the verifying party ensure that a+-- provided biscuit grants access to the required operations. -- -- Here's how to create a biscuit token: ----- > buildToken :: Keypair -> IO Biscuit+-- > -- Biscuit Open Verified means the token has valid signatures+-- > -- and is open to further restriction+-- > buildToken :: Keypair -> IO (Biscuit Open Verified) -- > buildToken keypair =+-- >   -- the logic language has its own syntax, which can be typed directly in haskell+-- >   -- source code thanks to QuasiQuotes. The datalog snippets are parsed at compile+-- >   -- time, so a datalog error results in a compilation error, not a runtime error -- >   mkBiscuit keypair [block|+-- >       // the two first lines describe facts: -- >       // the token holder is identified as `user_1234`--- >       user(#authority, "user_1234");+-- >       user("user_1234"); -- >       // the token holder is granted access to resource `file1`--- >       resource(#authority, "file1");+-- >       resource("file1");+-- >       // this last line defines a restriction: properties that need+-- >       // to be verified for the token to be verified: -- >       // the token can only be used before a specified date--- >       check if time(#ambient, $time), $time < 2021-05-08T00:00:00Z;+-- >       check if time($time), $time < 2021-05-08T00:00:00Z; -- >    |] -- -- Here's how to attenuate a biscuit token: ----- > restrictToken :: Biscuit -> IO Biscuit+-- > restrictToken :: Biscuit Open Verified -> IO Biscuit Open Verified -- > restrictToken = -- >   addBlock [block| -- >       // restrict the token to local use only--- >       check if user_ip_address(#ambient, "127.0.0.1");+-- >       check if user_ip_address("127.0.0.1"); -- >    |] ----- Here's how to verify a biscuit token:+-- To verify a biscuit token, we need two things: ----- > verifyToken :: PublicKey -> Biscuit -> IO Bool--- > verifyToken publicKey biscuit = do--- >   now <- getCurrentTime--- >   let verif = [verifier|--- >            // the datalog snippets can reference haskell variables--- >            current_time(#ambient, ${now});--- >--- >            // policies are tried in order--- >            allow if resource(#authority, "file1");--- >            // catch-all policy if the previous ones did not match--- >            deny if true;--- >         |]--- >   result <- verifyBiscuit biscuit [verifier|current_time()|]--- >   case result of+--  - a public key, that will let us verify the token has been emitted by+--    a trusted authority+--  - an authorizer, that will make sure all the checks declared in the token are fulfilled,+--    as well as providing its own checks, and policies which decide if the token is+--    verified or not+--+-- Here's how to verify a base64-serialized biscuit token:+--+-- > verifyToken :: PublicKey -> ByteString -> IO Bool+-- > verifyToken publicKey token = do+-- >   -- complete parsing is only attempted if signatures can be verified,+-- >   -- that's the reason why 'parseB64' takes a public key as a parameter+-- >   parseResult <- parseB64 publicKey token+-- >   case parseResult of -- >     Left e -> print e $> False--- >     Right _ -> pure True+-- >     Right biscuit -> do+-- >       now <- getCurrentTime+-- >       let verif = [authorizer|+-- >                // the datalog snippets can reference haskell variables+-- >                // 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()|]+-- >       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, -- so you'll need an explicit call to `blockContext` to add it ----- >     [block|check if time(#ambient, $t), $t < 2021-01-01;|]+-- >     [block|check if time($t), $t < 2021-01-01;|] -- >  <> blockContext "ttl-check" blockContext :: Text -> Block blockContext c = mempty { bContext = Just c }  -- | Decode a base16-encoded bytestring, reporting errors via `MonadFail` fromHex :: MonadFail m => ByteString -> m ByteString-fromHex input = do-  (decoded, "") <- pure $ Hex.decode input-  pure decoded+fromHex = either fail pure . Hex.decode --- | Get an hex bytestring from a private key-serializePrivateKeyHex :: PrivateKey -> ByteString-serializePrivateKeyHex = Hex.encode . serializePrivateKey+-- $keypairs+--+-- Biscuits rely on public key cryptography: biscuits are signed with a secret key only known+-- to the party which emits it. Verifying a biscuit, on the other hand, can be done with a+-- public key that can be widely distributed. A private key and its corresponding public key+-- is called a keypair, but since a public key can be deterministically computed from a+-- private key, owning a private key is the same as owning a keypair. --- | Get an hex bytestring from a public key+-- | Generate a new random 'SecretKey'+newSecret :: IO SecretKey+newSecret = generateSecretKey++-- | Serialize a 'SecretKey' to raw bytes, without any encoding+serializeSecretKey :: SecretKey -> ByteString+serializeSecretKey = convert++-- | Serialize a 'PublicKey' to raw bytes, without any encoding+serializePublicKey :: PublicKey -> ByteString+serializePublicKey = convert++-- | Serialize a 'SecretKey' to a hex-encoded bytestring+serializeSecretKeyHex :: SecretKey -> ByteString+serializeSecretKeyHex = Hex.encode . convert++-- | Serialize a 'PublicKey' to a hex-encoded bytestring serializePublicKeyHex :: PublicKey -> ByteString-serializePublicKeyHex = Hex.encode . serializePublicKey+serializePublicKeyHex = Hex.encode . convert --- | Read a private key from an hex bytestring-parsePrivateKeyHex :: ByteString -> Maybe PrivateKey-parsePrivateKeyHex = parsePrivateKey <=< fromHex+-- | Read a 'SecretKey' from raw bytes+parseSecretKey :: ByteString -> Maybe SecretKey+parseSecretKey = maybeCryptoError . secretKey --- | Read a public key from an hex bytestring+-- | Read a 'SecretKey' from an hex bytestring+parseSecretKeyHex :: ByteString -> Maybe SecretKey+parseSecretKeyHex = parseSecretKey <=< fromHex++-- | Read a 'PublicKey' from raw bytes+parsePublicKey :: ByteString -> Maybe PublicKey+parsePublicKey = maybeCryptoError . publicKey++-- | Read a 'PublicKey' from an hex bytestring parsePublicKeyHex :: ByteString -> Maybe PublicKey parsePublicKeyHex = parsePublicKey <=< fromHex  -- | Parse a biscuit from a raw bytestring. If you want to parse -- from a URL-compatible base 64 bytestring, consider using `parseB64`--- instead-parse :: ByteString -> Either ParseError Biscuit-parse = parseBiscuit+-- instead.+-- The biscuit signature is verified with the provided 'PublicKey' before+-- completely decoding blocks+-- The revocation ids are /not/ verified before completely decoding blocks.+-- If you need to check revocation ids before decoding blocks, use 'parseWith'+-- (or 'parseB64With' instead).+parse :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)+parse pk = runIdentity . parseBiscuitWith ParserConfig+  { encoding = RawBytes+  , isRevoked = const $ pure False+  , getPublicKey = pure pk+  }  -- | Parse a biscuit from a URL-compatible base 64 encoded bytestring-parseB64 :: ByteString -> Either ParseError Biscuit-parseB64 = parse <=< first (const InvalidB64Encoding) . B64.decodeBase64+parseB64 :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)+parseB64 pk = runIdentity . parseBiscuitWith ParserConfig+  { encoding = UrlBase64+  , isRevoked = const $ pure False+  , getPublicKey = pure pk+  } --- | Parse a biscuit from an hex-encoded bytestring-parseHex :: ByteString -> Either ParseError Biscuit-parseHex = parse <=< maybeToRight InvalidHexEncoding . fromHex+-- | Parse a biscuit, with explicitly supplied parsing options:+--+--   - encoding ('RawBytes' or 'UrlBase64')+--   - revocation check+--   - public key (based on the token's @rootKeyId@ field)+--+-- If you don't need dynamic public key selection or revocation checks, you can use+-- 'parse' or 'parseB64' instead.+--+-- The biscuit signature is verified with the selected 'PublicKey' before+-- completely decoding blocks+parseWith :: Applicative m+          => ParserConfig m+          -> ByteString+          -> m (Either ParseError (Biscuit OpenOrSealed Verified))+parseWith = parseBiscuitWith +-- | Helper for building a revocation check from a static list, suitable for use with+-- 'parseWith' and 'ParserConfig'.+fromRevocationList :: (Applicative m, Foldable t)+                   => t ByteString+                   -> Set ByteString+                   -> m Bool+fromRevocationList revokedIds tokenIds =+  pure . not . null $ Set.intersection (Set.fromList $ toList revokedIds) tokenIds+ -- | Serialize a biscuit to a binary format. If you intend to send--- the biscuit over a text channel, consider using `serializeB64` or--- `serializeHex` instead-serialize :: Biscuit -> ByteString+-- the biscuit over a text channel, consider using `serializeB64` instead+serialize :: BiscuitProof p => Biscuit p Verified -> ByteString serialize = serializeBiscuit  -- | Serialize a biscuit to URL-compatible base 64, as recommended by the spec-serializeB64 :: Biscuit -> ByteString+serializeB64 :: BiscuitProof p => Biscuit p Verified -> ByteString serializeB64 = B64.encodeBase64' . serialize --- | Serialize a biscuit to a hex (base 16) string. Be advised that the specs--- recommends base 64 instead.-serializeHex :: Biscuit -> ByteString-serializeHex = Hex.encode . serialize+-- $biscuitBlocks+--+-- The core of a biscuit is its authority block. This block declares facts and rules and+-- is signed by its creator with a secret key. In addition to this trusted, authority+-- block, a biscuit may carry extra blocks that can only restrict what it can do. By+-- default, biscuits can be restricted, but it's possible to seal a biscuit and prevent+-- further modifications.+--+-- Blocks are defined with a logic language (datalog) that can be used directly from haskell+-- with the `QuasiQuotes` extension.++-- $attenuatingBiscuits+--+-- 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.++-- $sealedBiscuits+--+-- An 'Open' biscuit can be turned into a 'Sealed' one, meaning it won't be possible+-- to attenuate it further.+--+-- 'mkBiscuit' creates 'Open' biscuits, while 'parse' returns an 'OpenOrSealed' biscuit (since+-- when you're verifying a biscuit, you're not caring about whether it can be extended further+-- or not). 'authorizeBiscuit' does not care whether a biscuit is 'Open' or 'Sealed' and can be+-- used with both. 'addBlock' and 'seal' only work with 'Open' biscuits.++-- $verifying+--+-- Verifying a biscuit requires providing a list of policies (/allow/ or /deny/), which will+-- decide if the biscuit is accepted. Policies are tried in order, and the first one to match+-- decides whether the biscuit is accepted.+--+-- In addition to policies, an authorizer typically provides facts (such as the current time) so+-- that checks and policies can be verified.+--+-- The authorizer checks and policies only see the content of the authority (first) block. Extra+-- blocks can only carry restrictions and cannot interfere with the authority facts.+

@@ -0,0 +1,106 @@+module Auth.Biscuit.Crypto+  ( SignedBlock+  , Blocks+  , signBlock+  , verifyBlocks+  , verifySecretProof+  , verifySignatureProof+  , getSignatureProof++  -- Ed25519 reexports+  , PublicKey+  , SecretKey+  , Signature+  , convert+  , publicKey+  , secretKey+  , signature+  , eitherCryptoError+  , maybeCryptoError+  , generateSecretKey+  , toPublic+  ) 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 qualified Auth.Biscuit.Proto    as PB+import qualified Data.Serialize        as PB++type SignedBlock = (ByteString, Signature, PublicKey)+type Blocks = NonEmpty SignedBlock++-- | Biscuit 2.0 allows multiple signature algorithms.+-- For now this lib only supports Ed25519, but the spec mandates flagging+-- each publicKey with an algorithm identifier when serializing it. The+-- serializing itself is handled by protobuf, but we still need to manually+-- serialize keys when we include them in something we want sign (block+-- signatures, and the final signature for sealed tokens).+serializePublicKey :: PublicKey -> ByteString+serializePublicKey pk =+  let keyBytes = convert pk+      algId :: Int32+      algId = fromIntegral $ fromEnum PB.Ed25519+      -- The spec mandates that we serialize the algorithm id as a little-endian int32+      algBytes = PB.runPut $ PB.putInt32le algId+   in algBytes <> keyBytes++signBlock :: SecretKey+          -> ByteString+          -> IO (SignedBlock, SecretKey)+signBlock sk payload = do+  let pk = toPublic sk+  (nextPk, nextSk) <- (toPublic &&& id) <$> generateSecretKey+  let toSign = payload <> serializePublicKey nextPk+      sig = sign sk pk toSign+  pure ((payload, sig, nextPk), nextSk)++getSignatureProof :: SignedBlock -> SecretKey -> Signature+getSignatureProof (lastPayload, lastSig, lastPk) nextSecret =+  let sk = nextSecret+      pk = toPublic nextSecret+      toSign = lastPayload <> serializePublicKey lastPk <> convert lastSig+   in sign sk pk toSign++getToSig :: (ByteString, a, PublicKey) -> ByteString+getToSig (p, _, nextPk) =+    p <> serializePublicKey nextPk++getSignature :: SignedBlock -> Signature+getSignature (_, sig, _) = sig++getPublicKey :: SignedBlock -> PublicKey+getPublicKey (_, _, pk) = pk++verifyBlocks :: Blocks+             -> PublicKey+             -> Bool+verifyBlocks blocks rootPk =+  let attachKey pk (payload, sig) = (pk, payload, sig)+      uncurry3 f (a, b, c) = f a b c+      sigs = getSignature <$> blocks+      toSigs = getToSig <$> blocks+      -- key for block 0 is the root key+      -- key for block n is the key from block (n - 1)+      keys = rootPk :| NE.init (getPublicKey <$> blocks)+      keysPayloadsSigs = NE.zipWith attachKey keys (NE.zip toSigs sigs)+   in all (uncurry3 verify) keysPayloadsSigs++verifySecretProof :: SecretKey+                  -> SignedBlock+                  -> Bool+verifySecretProof nextSecret (_, _, lastPk) =+  lastPk == toPublic nextSecret++verifySignatureProof :: Signature+                     -> SignedBlock+                     -> Bool+verifySignatureProof extraSig (lastPayload, lastSig, lastPk) =+  let toSign = lastPayload <> serializePublicKey lastPk <> convert lastSig+   in verify lastPk toSign extraSig

@@ -31,8 +31,10 @@   , Expression   , Expression' (..)   , Fact-  , ID-  , ID' (..)+  , ToTerm (..)+  , FromValue (..)+  , Term+  , Term' (..)   , IsWithinSet (..)   , Op (..)   , ParsedAs (..)@@ -42,7 +44,7 @@   , Predicate   , Predicate' (..)   , PredicateOrFact (..)-  , QQID+  , QQTerm   , Query   , Query'   , QueryItem' (..)@@ -54,11 +56,11 @@   , Unary (..)   , Value   , VariableType-  , Verifier-  , Verifier' (..)-  , VerifierElement' (..)+  , Authorizer+  , Authorizer' (..)+  , AuthorizerElement' (..)   , elementToBlock-  , elementToVerifier+  , elementToAuthorizer   , fromStack   , listSymbolsInBlock   , renderBlock@@ -96,7 +98,7 @@   deriving newtype (Eq, Show, Ord, IsString)  instance Lift Slice where-  lift (Slice name) = [| toLiteralId $(varE $ mkName name) |]+  lift (Slice name) = [| toTerm $(varE $ mkName name) |]   liftTyped = unsafeTExpCoerce . lift  type family SliceType (ctx :: ParsedAs) where@@ -104,16 +106,14 @@   SliceType 'QuasiQuote    = Slice  type family SetType (inSet :: IsWithinSet) (ctx :: ParsedAs) where-  SetType 'NotWithinSet ctx = Set (ID' 'WithinSet 'InFact ctx)+  SetType 'NotWithinSet ctx = Set (Term' 'WithinSet 'InFact ctx)   SetType 'WithinSet    ctx = Void  -- | 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 ID' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: ParsedAs) =-    Symbol Text-  -- ^ A symbol (eg. @#authority@)-  | Variable (VariableType inSet pof)+data Term' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: ParsedAs) =+    Variable (VariableType inSet pof)   -- ^ A variable (eg. @$0@)   | LInteger Int   -- ^ An integer literal (eg. @42@)@@ -133,33 +133,32 @@ deriving instance ( Eq (VariableType inSet pof)                   , Eq (SliceType ctx)                   , Eq (SetType inSet ctx)-                  ) => Eq (ID' inSet pof ctx)+                  ) => Eq (Term' inSet pof ctx)  deriving instance ( Ord (VariableType inSet pof)                   , Ord (SliceType ctx)                   , Ord (SetType inSet ctx)-                  ) => Ord (ID' inSet pof ctx)+                  ) => Ord (Term' inSet pof ctx)  deriving instance ( Show (VariableType inSet pof)                   , Show (SliceType ctx)                   , Show (SetType inSet ctx)-                  ) => Show (ID' inSet pof ctx)+                  ) => Show (Term' inSet pof ctx)  -- | In a regular AST, slices have already been eliminated-type ID = ID' 'NotWithinSet 'InPredicate 'RegularString+type Term = Term' 'NotWithinSet 'InPredicate 'RegularString -- | In an AST parsed from a QuasiQuoter, there might be references to haskell variables-type QQID = ID' 'NotWithinSet 'InPredicate 'QuasiQuote+type QQTerm = Term' 'NotWithinSet 'InPredicate 'QuasiQuote -- | A term that is not a variable-type Value = ID' 'NotWithinSet 'InFact 'RegularString+type Value = Term' 'NotWithinSet 'InFact 'RegularString -- | An element of a set-type SetValue = ID' 'WithinSet 'InFact 'RegularString+type SetValue = Term' 'WithinSet 'InFact 'RegularString  instance  ( Lift (VariableType inSet pof)           , Lift (SetType inSet ctx)           , Lift (SliceType ctx)           )-         => Lift (ID' inSet pof ctx) where-  lift (Symbol n)      = [| Symbol n |]+         => Lift (Term' inSet pof ctx) where   lift (Variable n)    = [| Variable n |]   lift (LInteger i)    = [| LInteger i |]   lift (LString s)     = [| LString s |]@@ -173,47 +172,76 @@  -- | 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 ToLiteralId t where+class ToTerm t where   -- | How to turn a value into a datalog item-  toLiteralId :: t -> ID' inSet pof 'RegularString+  toTerm :: t -> Term' inSet pof 'RegularString -instance ToLiteralId Int where-  toLiteralId = LInteger+-- | This class describes how to turn a datalog value into a regular haskell value.+class FromValue t where+  fromValue :: Value -> Maybe t -instance ToLiteralId Integer where-  toLiteralId = LInteger . fromIntegral+instance ToTerm Int where+  toTerm = LInteger -instance ToLiteralId Text where-  toLiteralId = LString+instance FromValue Int where+  fromValue (LInteger v) = Just v+  fromValue _            = Nothing -instance ToLiteralId Bool where-  toLiteralId = LBool+instance ToTerm Integer where+  toTerm = LInteger . fromIntegral -instance ToLiteralId ByteString where-  toLiteralId = LBytes+instance FromValue Integer where+  fromValue (LInteger v) = Just (fromIntegral v)+  fromValue _            = Nothing -instance ToLiteralId UTCTime where-  toLiteralId = LDate+instance ToTerm Text where+  toTerm = LString +instance FromValue Text where+  fromValue (LString t) = Just t+  fromValue _           = Nothing++instance ToTerm Bool where+  toTerm = LBool++instance FromValue Bool where+  fromValue (LBool b) = Just b+  fromValue _         = Nothing++instance ToTerm ByteString where+  toTerm = LBytes++instance FromValue ByteString where+  fromValue (LBytes bs) = Just bs+  fromValue _           = Nothing++instance ToTerm UTCTime where+  toTerm = LDate++instance FromValue UTCTime where+  fromValue (LDate t) = Just t+  fromValue _         = Nothing++instance FromValue Value where+  fromValue = Just+ toSetTerm :: Value-          -> Maybe (ID' 'WithinSet 'InFact 'RegularString)+          -> Maybe (Term' 'WithinSet 'InFact 'RegularString) toSetTerm = \case-  Symbol i -> Just $ Symbol i-  LInteger i -> Just $ LInteger i-  LString i -> Just $ LString i-  LDate i -> Just $ LDate i-  LBytes i -> Just $ LBytes i-  LBool i -> Just $ LBool i-  TermSet _ -> Nothing-  Variable v -> absurd v+  LInteger i  -> Just $ LInteger i+  LString i   -> Just $ LString i+  LDate i     -> Just $ LDate i+  LBytes i    -> Just $ LBytes i+  LBool i     -> Just $ LBool i+  TermSet _   -> Nothing+  Variable v  -> absurd v   Antiquote v -> absurd v  renderId' :: (VariableType inSet pof -> Text)           -> (SetType inSet ctx -> Text)           -> (SliceType ctx -> Text)-          -> ID' inSet pof ctx -> Text+          -> Term' inSet pof ctx -> Text renderId' var set slice = \case-  Symbol name   -> "#" <> name   Variable name -> var name   LInteger int  -> pack $ show int   LString str   -> pack $ show str@@ -225,20 +253,20 @@   Antiquote v   -> slice v  renderSet :: (SliceType ctx -> Text)-          -> Set (ID' 'WithinSet 'InFact ctx)+          -> Set (Term' 'WithinSet 'InFact ctx)           -> Text renderSet slice terms =   "[" <> intercalate "," (renderId' absurd absurd slice <$> Set.toList terms) <> "]" -renderId :: ID -> Text+renderId :: Term -> Text renderId = renderId' ("$" <>) (renderSet absurd) absurd -renderFactId :: ID' 'NotWithinSet 'InFact 'RegularString -> Text+renderFactId :: Term' 'NotWithinSet 'InFact 'RegularString -> Text renderFactId = renderId' absurd (renderSet absurd) absurd -listSymbolsInTerm :: ID -> Set.Set Text+listSymbolsInTerm :: Term -> Set.Set Text listSymbolsInTerm = \case-  Symbol name   -> Set.singleton name+  LString  v    -> Set.singleton v   Variable name -> Set.singleton name   TermSet terms -> foldMap listSymbolsInSetValue terms   Antiquote v   -> absurd v@@ -246,7 +274,7 @@  listSymbolsInValue :: Value -> Set.Set Text listSymbolsInValue = \case-  Symbol name   -> Set.singleton name+  LString  v    -> Set.singleton v   TermSet terms -> foldMap listSymbolsInSetValue terms   Variable  v   -> absurd v   Antiquote v   -> absurd v@@ -254,25 +282,25 @@  listSymbolsInSetValue :: SetValue -> Set.Set Text listSymbolsInSetValue = \case-  Symbol name   -> Set.singleton name-  TermSet   v   -> absurd v-  Variable  v   -> absurd v-  Antiquote v   -> absurd v-  _             -> mempty+  LString  v  -> Set.singleton v+  TermSet   v -> absurd v+  Variable  v -> absurd v+  Antiquote v -> absurd v+  _           -> mempty  data Predicate' (pof :: PredicateOrFact) (ctx :: ParsedAs) = Predicate   { name  :: Text-  , terms :: [ID' 'NotWithinSet pof ctx]+  , terms :: [Term' 'NotWithinSet pof ctx]   } -deriving instance ( Eq (ID' 'NotWithinSet pof ctx)+deriving instance ( Eq (Term' 'NotWithinSet pof ctx)                   ) => Eq (Predicate' pof ctx)-deriving instance ( Ord (ID' 'NotWithinSet pof ctx)+deriving instance ( Ord (Term' 'NotWithinSet pof ctx)                   ) => Ord (Predicate' pof ctx)-deriving instance ( Show (ID' 'NotWithinSet pof ctx)+deriving instance ( Show (Term' 'NotWithinSet pof ctx)                   ) => Show (Predicate' pof ctx) -deriving instance Lift (ID' 'NotWithinSet pof ctx) => Lift (Predicate' pof ctx)+deriving instance Lift (Term' 'NotWithinSet pof ctx) => Lift (Predicate' pof ctx)  type Predicate = Predicate' 'InPredicate 'RegularString type Fact = Predicate' 'InFact 'RegularString@@ -403,25 +431,25 @@   deriving (Eq, Ord, Show, Lift)  data Expression' (ctx :: ParsedAs) =-    EValue (ID' 'NotWithinSet 'InPredicate ctx)+    EValue (Term' 'NotWithinSet 'InPredicate ctx)   | EUnary Unary (Expression' ctx)   | EBinary Binary (Expression' ctx) (Expression' ctx) -deriving instance Eq   (ID' 'NotWithinSet 'InPredicate ctx) => Eq (Expression' ctx)-deriving instance Ord  (ID' 'NotWithinSet 'InPredicate ctx) => Ord (Expression' ctx)-deriving instance Lift (ID' 'NotWithinSet 'InPredicate ctx) => Lift (Expression' ctx)-deriving instance Show (ID' 'NotWithinSet 'InPredicate ctx) => Show (Expression' ctx)+deriving instance Eq   (Term' 'NotWithinSet 'InPredicate ctx) => Eq (Expression' ctx)+deriving instance Ord  (Term' 'NotWithinSet 'InPredicate ctx) => Ord (Expression' ctx)+deriving instance Lift (Term' 'NotWithinSet 'InPredicate ctx) => Lift (Expression' ctx)+deriving instance Show (Term' 'NotWithinSet 'InPredicate ctx) => Show (Expression' ctx)  type Expression = Expression' 'RegularString  listSymbolsInExpression :: Expression -> Set.Set Text listSymbolsInExpression = \case-  EValue t -> listSymbolsInTerm t-  EUnary _ e -> listSymbolsInExpression e+  EValue t       -> listSymbolsInTerm t+  EUnary _ e     -> listSymbolsInExpression e   EBinary _ e e' -> foldMap listSymbolsInExpression [e, e']  data Op =-    VOp ID+    VOp Term   | UOp Unary   | BOp Binary @@ -457,35 +485,37 @@                <> renderExpression e'                <> ")"    in \case-        EValue t -> renderId t-        EUnary Negate e -> "!" <> renderExpression e-        EUnary Parens e -> "(" <> renderExpression e <> ")"-        EUnary Length e -> renderExpression e <> ".length()"+        EValue t                    -> renderId t+        EUnary Negate e             -> "!" <> renderExpression e+        EUnary Parens e             -> "(" <> renderExpression e <> ")"+        EUnary Length e             -> renderExpression e <> ".length()"         EBinary LessThan e e'       -> rOp "<" e e'         EBinary GreaterThan e e'    -> rOp ">" e e'         EBinary LessOrEqual e e'    -> rOp "<=" e e'         EBinary GreaterOrEqual e e' -> rOp ">=" e e'         EBinary Equal e e'          -> rOp "==" e e'-        EBinary Contains e e' -> rm "contains" e e'-        EBinary Prefix e e'   -> rm "starts_with" e e'-        EBinary Suffix e e'   -> rm "ends_with" e e'-        EBinary Regex e e'    -> rm "matches" e e'-        EBinary Intersection e e' -> rm "intersection" e e'-        EBinary Union e e'        -> rm "union" e e'-        EBinary Add e e' -> rOp "+" e e'-        EBinary Sub e e' -> rOp "-" e e'-        EBinary Mul e e' -> rOp "*" e e'-        EBinary Div e e' -> rOp "/" e e'-        EBinary And e e' -> rOp "&&" e e'-        EBinary Or e e'  -> rOp "||" e e'+        EBinary Contains e e'       -> rm "contains" e e'+        EBinary Prefix e e'         -> rm "starts_with" e e'+        EBinary Suffix e e'         -> rm "ends_with" e e'+        EBinary Regex e e'          -> rm "matches" e e'+        EBinary Intersection e e'   -> rm "intersection" e e'+        EBinary Union e e'          -> rm "union" e e'+        EBinary Add e e'            -> rOp "+" e e'+        EBinary Sub e e'            -> rOp "-" e e'+        EBinary Mul e e'            -> rOp "*" e e'+        EBinary Div e e'            -> rOp "/" e e'+        EBinary And e e'            -> rOp "&&" e e'+        EBinary Or e e'             -> rOp "||" e e'  -- | A biscuit block, containing facts, rules and checks. ----- 'Block' has a 'Monoid' instance, this is the expected way+-- 'Block' has a 'Monoid' instance, which is the expected way -- to build composite blocks (eg if you need to generate a list of facts): ----- > -- build a block containing a list of facts `value("a"); value("b"); value("c");`.--- > foldMap (\v -> [block| value(${v}) |]) ["a", "b", "c"]+-- > -- build a block from multiple variables v1, v2, v3+-- > [block| value(${v1}); |] <>+-- > [block| value(${v2}); |] <>+-- > [block| value(${v3}); |] type Block = Block' 'RegularString  -- | A biscuit block, that may or may not contain slices referencing@@ -543,40 +573,40 @@   , foldMap listSymbolsInCheck bChecks   ] --- | A biscuit verifier, containing, facts, rules, checks and policies-type Verifier = Verifier' 'RegularString+-- | A biscuit authorizer, containing, facts, rules, checks and policies+type Authorizer = Authorizer' 'RegularString  -- | The context in which a biscuit policies and checks are verified.--- A verifier may add policies (`deny if` / `allow if` conditions), as well as rules, facts, and checks.--- A verifier may or may not contain slices referencing haskell variables.-data Verifier' (ctx :: ParsedAs) = Verifier+-- 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]   -- ^ the allow / deny policies.   , vBlock    :: Block' ctx   -- ^ the facts, rules and checks   } -instance Semigroup (Verifier' ctx) where-  v1 <> v2 = Verifier { vPolicies = vPolicies v1 <> vPolicies v2+instance Semigroup (Authorizer' ctx) where+  v1 <> v2 = Authorizer { vPolicies = vPolicies v1 <> vPolicies v2                       , vBlock = vBlock v1 <> vBlock v2                       } -instance Monoid (Verifier' ctx) where-  mempty = Verifier { vPolicies = []+instance Monoid (Authorizer' ctx) where+  mempty = Authorizer { vPolicies = []                     , vBlock = mempty                     }  deriving instance ( Eq (Block' ctx)                   , Eq (QueryItem' ctx)-                  ) => Eq (Verifier' ctx)+                  ) => Eq (Authorizer' ctx)  deriving instance ( Show (Block' ctx)                   , Show (QueryItem' ctx)-                  ) => Show (Verifier' ctx)+                  ) => Show (Authorizer' ctx)  deriving instance ( Lift (Block' ctx)                   , Lift (QueryItem' ctx)-                  ) => Lift (Verifier' ctx)+                  ) => Lift (Authorizer' ctx)  data BlockElement' ctx   = BlockFact (Predicate' 'InFact ctx)@@ -596,16 +626,16 @@    BlockCheck c -> Block [] [] [c] Nothing    BlockComment -> mempty -data VerifierElement' ctx-  = VerifierPolicy (Policy' ctx)+data AuthorizerElement' ctx+  = AuthorizerPolicy (Policy' ctx)   | BlockElement (BlockElement' ctx)  deriving instance ( Show (Predicate' 'InFact ctx)                   , Show (Rule' ctx)                   , Show (QueryItem' ctx)-                  ) => Show (VerifierElement' ctx)+                  ) => Show (AuthorizerElement' ctx) -elementToVerifier :: VerifierElement' ctx -> Verifier' ctx-elementToVerifier = \case-  VerifierPolicy p -> Verifier [p] mempty-  BlockElement be  -> Verifier [] (elementToBlock be)+elementToAuthorizer :: AuthorizerElement' ctx -> Authorizer' ctx+elementToAuthorizer = \case+  AuthorizerPolicy p -> Authorizer [p] mempty+  BlockElement be    -> Authorizer [] (elementToBlock be)

@@ -3,8 +3,6 @@ {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-} {-|   Module      : Auth.Biscuit.Datalog.Executor   Copyright   : © Clément Delafargue, 2021@@ -13,44 +11,42 @@   The Datalog engine, tasked with deriving new facts from existing facts and rules, as well as matching available facts against checks and policies -} module Auth.Biscuit.Datalog.Executor-  ( BlockWithRevocationIds (..)-  , ExecutionError (..)+  ( ExecutionError (..)   , Limits (..)   , ResultError (..)-  , World (..)   , Bindings   , Name-  , computeAllFacts+  , MatchedQuery (..)   , defaultLimits   , evaluateExpression-  , runVerifier-  , runVerifierWithLimits++  --+  , getFactsForRule+  , checkCheck+  , checkPolicy+  , getBindingsForRuleBody   ) where -import           Control.Monad               (join, mfilter, when)-import           Data.Bifunctor              (first)-import           Data.Bitraversable          (bitraverse)-import           Data.ByteString             (ByteString)-import qualified Data.ByteString             as ByteString-import           Data.Foldable               (traverse_)-import           Data.List.NonEmpty          (NonEmpty)-import qualified Data.List.NonEmpty          as NE-import           Data.Map.Strict             (Map, (!?))-import qualified Data.Map.Strict             as Map-import           Data.Maybe                  (isJust, mapMaybe)-import           Data.Set                    (Set)-import qualified Data.Set                    as Set-import           Data.Text                   (Text, intercalate, unpack)-import qualified Data.Text                   as Text-import           Data.Void                   (absurd)-import qualified Text.Regex.TDFA             as Regex-import qualified Text.Regex.TDFA.Text        as Regex-import           Validation                  (Validation (..), failure)+import           Control.Monad            (join, mfilter, zipWithM)+import           Data.Bitraversable       (bitraverse)+import qualified Data.ByteString          as ByteString+import           Data.Foldable            (fold)+import           Data.List.NonEmpty       (NonEmpty)+import qualified Data.List.NonEmpty       as NE+import           Data.Map.Strict          (Map, (!?))+import qualified Data.Map.Strict          as Map+import           Data.Maybe               (isJust, mapMaybe)+import           Data.Set                 (Set)+import qualified Data.Set                 as Set+import           Data.Text                (Text)+import qualified Data.Text                as Text+import           Data.Void                (absurd)+import qualified Text.Regex.TDFA          as Regex+import qualified Text.Regex.TDFA.Text     as Regex+import           Validation               (Validation (..), failure)  import           Auth.Biscuit.Datalog.AST-import           Auth.Biscuit.Datalog.Parser (fact)-import           Auth.Biscuit.Timer          (timer)-import           Auth.Biscuit.Utils          (maybeToRight)+import           Auth.Biscuit.Utils       (maybeToRight)  -- | A variable name type Name = Text@@ -58,6 +54,15 @@ -- | A list of bound variables, with the associated value type Bindings  = Map Name Value +-- | A datalog query that was matched, along with the values+-- that matched+data MatchedQuery+  = MatchedQuery+  { matchedQuery :: Query+  , bindings     :: Set Bindings+  }+  deriving (Eq, Show)+ -- | The result of matching the checks and policies against all the available -- facts. data ResultError@@ -65,11 +70,14 @@   -- ^ No policy matched. additionally some checks may have failed   | FailedChecks      (NonEmpty Check)   -- ^ An allow rule matched, but at least one check failed-  | DenyRuleMatched   [Check] Query+  | DenyRuleMatched   [Check] MatchedQuery   -- ^ A deny rule matched. additionally some checks may have failed   deriving (Eq, Show) --- | The result of running verification+-- | An error that can happen while running a datalog verification.+-- The datalog computation itself can be aborted by runtime failsafe+-- mechanisms, or it can run to completion but fail to fullfil checks+-- and policies ('ResultError'). data ExecutionError   = Timeout   -- ^ Verification took too much time@@ -80,31 +88,34 @@   | FactsInBlocks   -- ^ Some blocks contained either rules or facts while it was forbidden   | ResultError ResultError-  -- ^ The checks and policies were not fulfilled after evaluation+  -- ^ The evaluation ran to completion, but checks and policies were not+  -- fulfilled.   deriving (Eq, Show) --- | Settings for the executor restrictions+-- | Settings for the executor runtime restrictions. -- See `defaultLimits` for default values. data Limits   = Limits-  { maxFacts          :: Int-  -- ^ maximum number of facts that can be produced (else `TooManyFacts` is thrown)-  , maxIterations     :: Int+  { maxFacts        :: Int+  -- ^ maximum number of facts that can be produced before throwing `TooManyFacts`+  , maxIterations   :: Int   -- ^ maximum number of iterations before throwing `TooManyIterations`-  , maxTime           :: Int+  , maxTime         :: Int   -- ^ maximum duration the verification can take (in μs)-  , allowRegexes      :: Bool-  -- ^ whether or not allowing `.matches()` during verification-  , allowBlockFacts   :: Bool-  -- ^ wheter or not accept facts and rules in blocks. Even when they are enabled, they-  -- can’t give rise to facts containing `#authority` or `#ambient` symbols-  , checkRevocationId :: ByteString -> IO (Either () ())-  -- ^ how to check for token revocation `Left ()` means that the given id is revoked,-  -- `Right ()` means it’s not revoked.+  , allowRegexes    :: Bool+  -- ^ whether or not allowing `.matches()` during verification (untrusted regex computation+  -- can enable DoS attacks). This security risk is mitigated by the 'maxTime' setting.+  , allowBlockFacts :: Bool+  -- ^ whether or not accept facts and rules in blocks   }+  deriving (Eq, Show)  -- | Default settings for the executor restrictions.--- (1000 facts, 100 iterations, 1000μs max, regexes are allowed, facts and rules are allowed in blocks)+--   - 1000 facts+--   - 100 iterations+--   - 1000μs max+--   - regexes are allowed+--   - facts and rules are allowed in blocks defaultLimits :: Limits defaultLimits = Limits   { maxFacts = 1000@@ -112,189 +123,29 @@   , maxTime = 1000   , allowRegexes = True   , allowBlockFacts = True-  , checkRevocationId = const . pure $ Right ()   } --- | A parsed block, along with the associated revocation ids.-data BlockWithRevocationIds-  = BlockWithRevocationIds-  { bBlock              :: Block-  -- ^ The parsed block-  , genericRevocationId :: ByteString-  -- ^ Generic revocation id (depends on the block contents and its primary key)-  , uniqueRevocationId  :: ByteString-  -- ^ Unique revocation id (specific to the token)-  }---- | A collection of facts  and rules used to derive new facts.--- Rules coming from blocks are stored separately since they are subject to specific--- restrictions regarding the facts they can generate.-data World- = World- { rules      :: Set Rule- , blockRules :: Set Rule- , facts      :: Set Fact- }--instance Semigroup World where-  w1 <> w2 = World-               { rules = rules w1 <> rules w2-               , blockRules = blockRules w1 <> blockRules w2-               , facts = facts w1 <> facts w2-               }--instance Monoid World where-  mempty = World mempty mempty mempty--instance Show World where-  show World{..} = unpack . intercalate "\n" $ join-    [ [ "Authority & Verifier Rules" ]-    , renderRule <$> Set.toList rules-    , [ "Block Rules" ]-    , renderRule <$> Set.toList blockRules-    , [ "Facts" ]-    , renderFact <$> Set.toList facts-    ]---- | Is the fact "restricted" (meaning it is not allowed to come from a block, or generated by a block rule).--- In practice, only authority blocks can contain the symbols `#ambient` and `#authority`-isRestricted :: Fact -> Bool-isRestricted Predicate{terms} =-  let restrictedSymbol (Symbol s ) = s == "ambient" || s == "authority"-      restrictedSymbol _           = False-   in any restrictedSymbol terms---- | Expose the block revocation ids through facts-revocationIdFacts :: Integer-                  -- ^ The block index (0 for authority, 1-n for blocks)-                  -> BlockWithRevocationIds-                  -> [Fact]-revocationIdFacts index BlockWithRevocationIds{genericRevocationId, uniqueRevocationId} =-  [ [fact|revocation_id(${index}, ${genericRevocationId})|]-  , [fact|unique_revocation_id(${index}, ${uniqueRevocationId})|]-  ]--collectWorld :: Limits -> Verifier -> BlockWithRevocationIds -> [BlockWithRevocationIds] -> World-collectWorld Limits{allowBlockFacts} Verifier{vBlock} authority blocks =-  let getRules = bRules . bBlock-      getFacts = bFacts . bBlock-      revocationIds = join $ zipWith revocationIdFacts [0..] (authority : blocks)-   in World-        { rules = Set.fromList $ bRules vBlock <> getRules authority-        , blockRules = if allowBlockFacts-                       then Set.fromList $ foldMap getRules blocks-                       else mempty-        , facts = Set.fromList $-                  bFacts vBlock-               <> getFacts authority-               <> filter ((allowBlockFacts &&) . not . isRestricted) (getFacts =<< blocks)-               <> revocationIds-        }---- | Given a series of blocks and a verifier, ensure that all--- the checks and policies match-runVerifier :: BlockWithRevocationIds-            -- ^ The authority block-            -> [BlockWithRevocationIds]-            -- ^ The extra blocks-            -> Verifier-            -- ^ A verifier-            -> IO (Either ExecutionError Query)-runVerifier = runVerifierWithLimits defaultLimits---- | Given a series of blocks and a verifier, ensure that all--- the checks and policies match, with provided execution--- constraints-runVerifierWithLimits :: Limits-                      -- ^ custom limits-                      -> BlockWithRevocationIds-                      -- ^ The authority block-                      -> [BlockWithRevocationIds]-                      -- ^ The extra blocks-                      -> Verifier-                      -- ^ A verifier-                      -> IO (Either ExecutionError Query)-runVerifierWithLimits l@Limits{..} authority blocks v = do-  resultOrTimeout <- timer maxTime $ runVerifier' l authority blocks v-  pure $ case resultOrTimeout of-    Nothing -> Left Timeout-    Just r  -> r--runVerifier' :: Limits-             -> BlockWithRevocationIds-             -> [BlockWithRevocationIds]-             -> Verifier-             -> IO (Either ExecutionError Query)-runVerifier' l authority blocks v@Verifier{..} = do-  let initialWorld = collectWorld l v authority blocks-      allFacts' = computeAllFacts l initialWorld-  case allFacts' of-      Left e -> pure $ Left e-      Right allFacts -> do-        let allChecks = foldMap bChecks $ vBlock : (bBlock <$> authority : blocks)-            checkResults = traverse_ (checkCheck l allFacts) allChecks-            policiesResults = mapMaybe (checkPolicy l allFacts) vPolicies-            policyResult = case policiesResults of-              p : _ -> first Just p-              []    -> Left Nothing-        pure $ case (checkResults, policyResult) of-          (Success (), Right p)       -> Right p-          (Success (), Left Nothing)  -> Left $ ResultError $ NoPoliciesMatched []-          (Success (), Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p-          (Failure cs, Left Nothing)  -> Left $ ResultError $ NoPoliciesMatched (NE.toList cs)-          (Failure cs, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched (NE.toList cs) p-          (Failure cs, Right _)       -> Left $ ResultError $ FailedChecks cs- checkCheck :: Limits -> Set Fact -> Check -> Validation (NonEmpty Check) () checkCheck l facts items =-  if any (isQueryItemSatisfied l facts) items+  if any (isJust . isQueryItemSatisfied l facts) items   then Success ()   else failure items -checkPolicy :: Limits -> Set Fact -> Policy -> Maybe (Either Query Query)-checkPolicy l facts (pType, items) =-  if any (isQueryItemSatisfied l facts) items-  then Just $ case pType of-    Allow -> Right items-    Deny  -> Left items-  else Nothing+checkPolicy :: Limits -> Set Fact -> Policy -> Maybe (Either MatchedQuery MatchedQuery)+checkPolicy l facts (pType, query) =+  let bindings = fold $ mapMaybe (isQueryItemSatisfied l facts) query+   in if not (null bindings)+      then Just $ case pType of+        Allow -> Right $ MatchedQuery{matchedQuery = query, bindings}+        Deny  -> Left $ MatchedQuery{matchedQuery = query, bindings}+      else Nothing -isQueryItemSatisfied :: Limits -> Set Fact -> QueryItem' 'RegularString -> Bool+isQueryItemSatisfied :: Limits -> Set Fact -> QueryItem' 'RegularString -> Maybe (Set Bindings) isQueryItemSatisfied l facts QueryItem{qBody, qExpressions} =   let bindings = getBindingsForRuleBody l facts qBody qExpressions-   in Set.size bindings > 0---- | Compute all possible facts, recursively calling itself--- until it can't generate new facts or a limit is reached-computeAllFacts :: Limits-                -- ^ The maximum amount of iterations that can be reached-                -> World-                -- ^ The initial rules and facts-                -> Either ExecutionError (Set Fact)-computeAllFacts l@Limits{..} = computeAllFacts' l maxIterations----- | Compute all possible facts, recursively calling itself--- until it can't generate new facts or a limit is reached-computeAllFacts' :: Limits-                 -> Int-                 -> World-                 -> Either ExecutionError (Set Fact)-computeAllFacts' l@Limits{..} remainingIterations w@World{facts} = do-  let newFacts = extend l w-      allFacts = facts <> newFacts-  when (Set.size allFacts >= maxFacts) $ Left TooManyFacts-  when (remainingIterations - 1 <= 0) $ Left TooManyIterations-  if null newFacts-  then pure allFacts-  else computeAllFacts' l (remainingIterations - 1) (w { facts = allFacts })--extend :: Limits -> World -> Set Fact-extend l World{..} =-  let buildFacts = foldMap (getFactsForRule l facts)-      allNewFacts = buildFacts rules-      allNewBlockFacts = Set.filter (not . isRestricted) $ buildFacts blockRules-   in Set.difference (allNewFacts <> allNewBlockFacts) facts+   in if Set.size bindings > 0+      then Just bindings+      else Nothing  getFactsForRule :: Limits -> Set Fact -> Rule -> Set Fact getFactsForRule l facts Rule{rhead, body, expressions} =@@ -319,7 +170,7 @@ extractVariables predicates =   let keepVariable = \case         Variable name -> Just name-        _ -> Nothing+        _             -> Nothing       extractVariables' Predicate{terms} = mapMaybe keepVariable terms    in Set.fromList $ extractVariables' =<< predicates @@ -327,9 +178,8 @@ applyBindings :: Predicate -> Bindings -> Maybe Fact applyBindings p@Predicate{terms} bindings =   let newTerms = traverse replaceTerm terms-      replaceTerm :: ID -> Maybe Value+      replaceTerm :: Term -> Maybe Value       replaceTerm (Variable n)  = Map.lookup n bindings-      replaceTerm (Symbol t)    = Just $ Symbol t       replaceTerm (LInteger t)  = Just $ LInteger t       replaceTerm (LString t)   = Just $ LString t       replaceTerm (LDate t)     = Just $ LDate t@@ -372,8 +222,7 @@        keepFacts p = mapMaybeS (factMatchesPredicate p) facts     in keepFacts <$> predicates -isSame :: ID -> Value -> Bool-isSame (Symbol t)   (Symbol t')   = t == t'+isSame :: Term -> Value -> Bool isSame (LInteger t) (LInteger t') = t == t' isSame (LString t)  (LString t')  = t == t' isSame (LDate t)    (LDate t')    = t == t'@@ -387,8 +236,8 @@                      Predicate{name = factName, terms = factTerms } =   let namesMatch = predicateName == factName       lengthsMatch = length predicateTerms == length factTerms-      allMatches = sequenceA $ zipWith yolo predicateTerms factTerms-      yolo :: ID -> Value -> Maybe Bindings+      allMatches = zipWithM yolo predicateTerms factTerms+      yolo :: Term -> Value -> Maybe Bindings       yolo (Variable vname) value = Just (Map.singleton vname value)       yolo t t' | isSame t t' = Just mempty                 | otherwise   = Nothing@@ -397,17 +246,16 @@       else Nothing  applyVariable :: Bindings-              -> ID+              -> Term               -> Either String Value applyVariable bindings = \case-  Variable n -> maybeToRight "Unbound variable" $ bindings !? n-  Symbol t   -> Right $ Symbol t-  LInteger t -> Right $ LInteger t-  LString t  -> Right $ LString t-  LDate t    -> Right $ LDate t-  LBytes t   -> Right $ LBytes t-  LBool t    -> Right $ LBool t-  TermSet t  -> Right $ TermSet t+  Variable n  -> maybeToRight "Unbound variable" $ bindings !? n+  LInteger t  -> Right $ LInteger t+  LString t   -> Right $ LString t+  LDate t     -> Right $ LDate t+  LBytes t    -> Right $ LBytes t+  LBool t     -> Right $ LBool t+  TermSet t   -> Right $ TermSet t   Antiquote v -> absurd v  evalUnary :: Unary -> Value -> Either String Value@@ -421,7 +269,6 @@  evalBinary :: Limits -> Binary -> Value -> Value -> Either String Value -- eq / ord operations-evalBinary _ Equal (Symbol s) (Symbol s')     = pure $ LBool (s == s') evalBinary _ Equal (LInteger i) (LInteger i') = pure $ LBool (i == i') evalBinary _ Equal (LString t) (LString t')   = pure $ LBool (t == t') evalBinary _ Equal (LDate t) (LDate t')       = pure $ LBool (t == t')

@@ -21,7 +21,8 @@   , fact   , predicate   , rule-  , verifier+  , authorizer+  , query   -- these are only exported for testing purposes   , checkParser   , expressionParser@@ -29,7 +30,8 @@   , predicateParser   , ruleParser   , termParser-  , verifierParser+  , blockParser+  , authorizerParser   , HasParsers   , HasTermParsers   ) where@@ -37,14 +39,15 @@ import           Control.Applicative            (liftA2, optional, (<|>)) import qualified Control.Monad.Combinators.Expr as Expr import           Data.Attoparsec.Text+import qualified Data.Attoparsec.Text           as A import           Data.ByteString                (ByteString) import           Data.ByteString.Base16         as Hex-import           Data.Char                      (isSpace)+import           Data.Char                      (isAlphaNum, isLetter, isSpace) import           Data.Either                    (partitionEithers) import           Data.Foldable                  (fold) import           Data.Functor                   (void, ($>)) import qualified Data.Set                       as Set-import           Data.Text                      (Text, pack, unpack)+import           Data.Text                      (Text, pack, singleton, unpack) import           Data.Text.Encoding             (encodeUtf8) import           Data.Time                      (UTCTime, defaultTimeLocale,                                                  parseTimeM)@@ -84,10 +87,16 @@   ) type HasParsers pof ctx = HasTermParsers 'NotWithinSet pof ctx --- | Parser for an identifier (predicate name, variable name, symbol name, …)-nameParser :: Parser Text-nameParser = takeWhile1 $ inClass "a-zA-Z0-9_"+-- | 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 +variableNameParser :: Parser Text+variableNameParser = char '$' *> takeWhile1 (\c -> c == '_' || c == ':' || isAlphaNum c)+ delimited :: Parser x           -> Parser y           -> Parser a@@ -108,7 +117,7 @@ predicateParser :: HasParsers pof ctx => Parser (Predicate' pof ctx) predicateParser = do   skipSpace-  name <- nameParser+  name <- predicateNameParser   skipSpace   terms <- parens (commaList termParser)   pure Predicate{name,terms}@@ -204,8 +213,7 @@ hexBsParser :: Parser ByteString hexBsParser = do   void $ string "hex:"-  (digits, "") <- Hex.decode . encodeUtf8 <$> takeWhile1 (inClass "0-9a-fA-F")-  pure digits+  either fail pure =<< Hex.decode . encodeUtf8 <$> takeWhile1 (inClass "0-9a-fA-F")  litStringParser :: Parser Text litStringParser =@@ -236,12 +244,11 @@ termParser :: forall inSet pof ctx             . ( HasTermParsers inSet pof ctx               )-           => Parser (ID' inSet pof ctx)+           => Parser (Term' inSet pof ctx) termParser = skipSpace *> choice   [ Antiquote <$> ifPresent "slice" (Slice <$> (string "${" *> many1 letter <* char '}'))-  , Variable <$> ifPresent "var" (char '$' *> nameParser)+  , Variable <$> ifPresent "var" variableNameParser   , TermSet <$> parseSet @inSet @ctx-  , Symbol <$> (char '#' *> nameParser)   , LBytes <$> hexBsParser   , LDate <$> rfc3339DateParser   , LInteger <$> signed decimal@@ -256,7 +263,7 @@ ruleHeadParser :: HasParsers 'InPredicate ctx => Parser (Predicate' 'InPredicate ctx) ruleHeadParser = do   skipSpace-  name <- nameParser+  name <- predicateNameParser   skipSpace   terms <- parens (commaList0 termParser)   pure Predicate{name,terms}@@ -304,20 +311,20 @@   , BlockComment <$  commentParser   ] -verifierElementParser :: HasParsers 'InPredicate ctx => Parser (VerifierElement' ctx)-verifierElementParser = choice-  [ VerifierPolicy  <$> policyParser <* skipSpace <* char ';'+authorizerElementParser :: HasParsers 'InPredicate ctx => Parser (AuthorizerElement' ctx)+authorizerElementParser = choice+  [ AuthorizerPolicy  <$> policyParser <* skipSpace <* char ';'   , BlockElement    <$> blockElementParser   ] -verifierParser :: ( HasParsers 'InPredicate ctx+authorizerParser :: ( HasParsers 'InPredicate ctx                   , HasParsers 'InFact ctx-                  , Show (VerifierElement' ctx)+                  , Show (AuthorizerElement' ctx)                   )-               => Parser (Verifier' ctx)-verifierParser = do-  elems <- many1 (skipSpace *> verifierElementParser)-  pure $ foldMap elementToVerifier elems+               => Parser (Authorizer' ctx)+authorizerParser = do+  elems <- many' (skipSpace *> authorizerElementParser)+  pure $ foldMap elementToAuthorizer elems  blockParser :: ( HasParsers 'InPredicate ctx                , HasParsers 'InFact ctx@@ -325,7 +332,7 @@                )             => Parser (Block' ctx) blockParser = do-  elems <- many1 (skipSpace *> blockElementParser)+  elems <- many' (skipSpace *> blockElementParser)   pure $ foldMap elementToBlock elems  policyParser :: HasParsers 'InPredicate ctx => Parser (Policy' ctx)@@ -337,14 +344,14 @@   (policy, ) <$> queryParser  compileParser :: Lift a => Parser a -> String -> Q Exp-compileParser p str = case parseOnly p (pack str) of+compileParser p str = case parseOnly (p <* skipSpace <* endOfInput) (pack str) of   Right result -> [| result |]   Left e       -> fail e  -- | Quasiquoter for a rule expression. You can reference haskell variables -- like this: @${variableName}@. ----- You most likely want to directly use 'block' or 'verifier' instead.+-- You most likely want to directly use 'block' or 'authorizer' instead. rule :: QuasiQuoter rule = QuasiQuoter   { quoteExp = compileParser (ruleParser @'QuasiQuote)@@ -356,7 +363,7 @@ -- | Quasiquoter for a predicate expression. You can reference haskell variables -- like this: @${variableName}@. ----- You most likely want to directly use 'block' or 'verifier' instead.+-- You most likely want to directly use 'block' or 'authorizer' instead. predicate :: QuasiQuoter predicate = QuasiQuoter   { quoteExp = compileParser (predicateParser @'InPredicate @'QuasiQuote)@@ -368,7 +375,7 @@ -- | Quasiquoter for a fact expression. You can reference haskell variables -- like this: @${variableName}@. ----- You most likely want to directly use 'block' or 'verifier' instead.+-- You most likely want to directly use 'block' or 'authorizer' instead. fact :: QuasiQuoter fact = QuasiQuoter   { quoteExp = compileParser (predicateParser @'InFact @'QuasiQuote)@@ -380,7 +387,7 @@ -- | Quasiquoter for a check expression. You can reference haskell variables -- like this: @${variableName}@. ----- You most likely want to directly use 'block' or 'verifier' instead.+-- You most likely want to directly use 'block' or 'authorizer' instead. check :: QuasiQuoter check = QuasiQuoter   { quoteExp = compileParser (checkParser @'QuasiQuote)@@ -389,16 +396,18 @@   , quoteDec = error "not supported"   } --- | Quasiquoter for a block expression. You can reference haskell variables--- like this: @${variableName}@.+-- | Compile-time parser for a block expression, intended to be used with the+-- @QuasiQuotes@ extension. -- -- A typical use of 'block' looks like this: ----- > [block|--- >   resource(#authority, ${fileName});--- >   rule($variable) <- fact($value), other_fact($value);--- >   check if operation(#ambient, #read);--- > |]+-- > let fileName = "data.pdf"+-- >  in [block|+-- >       // 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)@@ -407,19 +416,40 @@   , quoteDec = error "not supported"   } --- | Quasiquoter for a verifier expression. You can reference haskell variables--- like this: @${variableName}@.+-- | Compile-time parser for an authorizer expression, intended to be used with the+-- @QuasiQuotes@ extension. ----- A typical use of 'block' looks like this:+-- A typical use of 'authorizer' looks like this: ----- > [verifier|--- >   current_time(#ambient, ${now});--- >   allow if resource(#authority, "file1");--- >   deny if true;--- > |]-verifier :: QuasiQuoter-verifier = QuasiQuoter-  { quoteExp = compileParser (verifierParser @'QuasiQuote)+-- > do+-- >   now <- getCurrentTime+-- >   pure [authorizer|+-- >          // 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+-- >          // if the token is valid or not+-- >          allow if resource("file1");+-- >          deny if true;+-- >        |]+authorizer :: QuasiQuoter+authorizer = QuasiQuoter+  { quoteExp = compileParser (authorizerParser @'QuasiQuote)+  , quotePat = error "not supported"+  , quoteType = error "not supported"+  , quoteDec = error "not supported"+  }++-- | Compile-time parser for a query expression, intended to be used with the+-- @QuasiQuotes@ extension.+--+-- A typical use of 'query' looks like this:+--+-- > [query|user($user_id) or group($group_id)|]+query :: QuasiQuoter+query = QuasiQuoter+  { quoteExp = compileParser (queryParser @'QuasiQuote)   , quotePat = error "not supported"   , quoteType = error "not supported"   , quoteDec = error "not supported"

@@ -0,0 +1,312 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}+module Auth.Biscuit.Datalog.ScopedExecutor+  ( BlockWithRevocationId+  , runAuthorizer+  , runAuthorizerWithLimits+  , runAuthorizerNoTimeout+  , World (..)+  , computeAllFacts+  , runFactGeneration+  , PureExecError (..)+  , AuthorizationSuccess (..)+  , getBindings+  , queryAuthorizerFacts+  , getVariableValues+  , getSingleVariableValue+  ) where++import           Control.Monad                 (join, when)+import           Control.Monad.State           (StateT (..), get, lift, modify,+                                                put, runStateT)+import           Data.Bifunctor                (first)+import           Data.ByteString               (ByteString)+import           Data.Foldable                 (traverse_)+import           Data.List.NonEmpty            (NonEmpty, nonEmpty)+import qualified Data.List.NonEmpty            as NE+import           Data.Map.Strict               ((!?))+import           Data.Maybe                    (mapMaybe)+import           Data.Set                      (Set)+import qualified Data.Set                      as Set+import           Data.Text                     (Text, intercalate, unpack)+import           Validation                    (Validation (..), validation)++import           Auth.Biscuit.Datalog.AST+import           Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..),+                                                Limits (..), MatchedQuery (..),+                                                ResultError (..), checkCheck,+                                                checkPolicy, defaultLimits,+                                                getBindingsForRuleBody,+                                                getFactsForRule)+import           Auth.Biscuit.Datalog.Parser   (fact)+import           Auth.Biscuit.Timer            (timer)++type BlockWithRevocationId = (Block, ByteString)++-- | A subset of 'ExecutionError' that can only happen during fact generation+data PureExecError = Facts | Iterations+  deriving (Eq, Show)++-- | State maintained by the datalog computation.+data ComputeState+  = ComputeState+  { sFacts          :: Set Fact+  -- ^ All the facts generated so far+  , sAuthorityFacts :: Set Fact+  -- ^ Facts generated by the authority block (and the authorizer). Those are kept separate+  -- because they are provided by a trusted party (the one which has the root 'SecretKey').+  -- Block facts are not as trustworthy as they can be added by anyone.+  , sIterations     :: Int+  -- ^ The current count of iterations+  , sLimits         :: Limits+  -- ^ The configured limits for this computation. This field is effectively read-only+  , sFailedChecks   :: [Check]+  -- ^ The failed checks gathered so far. The computation carries on even if some checks+  -- fail, in order to be able to report all the failing checks in one go+  , sPolicyResult   :: Either (Maybe MatchedQuery) MatchedQuery+  -- ^ The result of the authorizer-defined policies. 'Left' represents failure:+  --  - @Left Nothing@ if no policies matched+  --  - @Left (Just q)@ if a deny policy matched+  --  - @Right q@ if an allow policy matched+  }++mkInitState :: Limits -> ComputeState+mkInitState sLimits = ComputeState+  { sFacts = Set.empty -- no facts have been generated yet+  , sAuthorityFacts = Set.empty -- no authority facts have been generated yet+  , sIterations = 0    -- no evaluation iteration has taken place yet+  , sLimits            -- this field is read-only+  , sFailedChecks = [] -- no checks have failed yet+  , sPolicyResult = Left Nothing -- no policies have matched yet+  }++data World+  = World+  { facts :: Set Fact+  , rules :: Set Rule+  }++instance Semigroup World where+  w1 <> w2 = World+               { rules = rules w1 <> rules w2+               , facts = facts w1 <> facts w2+               }++instance Monoid World where+  mempty = World mempty mempty++instance Show World where+  show World{..} = unpack . intercalate "\n" $ join+    [ [ "Block Rules" ]+    , renderRule <$> Set.toList rules+    , [ "Facts" ]+    , renderFact <$> Set.toList facts+    ]++-- | Proof that a biscuit was authorized successfully. In addition to the matched+-- @allow query@, the generated facts are kept around for further querying.+-- Since only authority facts can be trusted, they are kept separate.+data AuthorizationSuccess+  = AuthorizationSuccess+  { matchedAllowQuery :: MatchedQuery+  -- ^ The allow query that matched+  , authorityFacts    :: Set Fact+  -- ^ All the facts generated by the authority block (and the authorizer)+  , allGeneratedFacts :: Set Fact+  -- ^ All the facts that were generated by the biscuit. Be careful, the+  -- biscuit signature check only guarantees that 'authorityFacts' are+  -- signed with the corresponding 'SecretKey'.+  , limits            :: Limits+  -- ^ Limits used when running datalog. It is kept around to allow further+  -- datalog computation when querying facts+  }+  deriving (Eq, Show)++-- | Get the matched variables from the @allow@ query used to authorize the biscuit.+-- This can be used in conjuction with 'getVariableValues' or 'getSingleVariableValue'+-- to extract the actual values+getBindings :: AuthorizationSuccess -> Set Bindings+getBindings AuthorizationSuccess{matchedAllowQuery=MatchedQuery{bindings}} = bindings++withFacts :: World -> Set Fact -> World+withFacts w@World{facts} newFacts = w { facts = newFacts <> facts }++-- | Given a series of blocks and an authorizer, ensure that all+-- the checks and policies match+runAuthorizer :: BlockWithRevocationId+            -- ^ The authority block+            -> [BlockWithRevocationId]+            -- ^ The extra blocks+            -> Authorizer+            -- ^ A authorizer+            -> IO (Either ExecutionError AuthorizationSuccess)+runAuthorizer = runAuthorizerWithLimits defaultLimits++-- | Given a series of blocks and an authorizer, ensure that all+-- the checks and policies match, with provided execution+-- constraints+runAuthorizerWithLimits :: Limits+                      -- ^ custom limits+                      -> BlockWithRevocationId+                      -- ^ The authority block+                      -> [BlockWithRevocationId]+                      -- ^ The extra blocks+                      -> Authorizer+                      -- ^ A authorizer+                      -> IO (Either ExecutionError AuthorizationSuccess)+runAuthorizerWithLimits l@Limits{..} authority blocks v = do+  resultOrTimeout <- timer maxTime $ pure $ runAuthorizerNoTimeout l authority blocks v+  pure $ case resultOrTimeout of+    Nothing -> Left Timeout+    Just r  -> r+++runAllBlocks :: BlockWithRevocationId+             -> [BlockWithRevocationId]+             -> Authorizer+             -> StateT ComputeState (Either PureExecError) ()+runAllBlocks authority blocks authorizer = do+  modify $ \state -> state { sFacts = mkRevocationIdFacts authority blocks }+  runAuthority authority authorizer+  traverse_ runBlock blocks++mkRevocationIdFacts :: BlockWithRevocationId -> [BlockWithRevocationId]+                    -> Set Fact+mkRevocationIdFacts authority blocks =+  let allIds :: [(Int, ByteString)]+      allIds = zip [0..] $ snd <$> authority : blocks+      mkFact (index, rid) = [fact|revocation_id(${index}, ${rid})|]+   in Set.fromList $ mkFact <$> allIds++runAuthorizerNoTimeout :: Limits+                     -> BlockWithRevocationId+                     -> [BlockWithRevocationId]+                     -> Authorizer+                     -> Either ExecutionError AuthorizationSuccess+runAuthorizerNoTimeout limits authority blocks authorizer = do+  let result = (`runStateT` mkInitState limits) $ runAllBlocks authority blocks authorizer+  case result of+    Left Facts      -> Left TooManyFacts+    Left Iterations -> Left TooManyIterations+    Right ((), ComputeState{..}) -> case (nonEmpty sFailedChecks, sPolicyResult) of+      (Nothing, Right p)       -> Right $ AuthorizationSuccess { matchedAllowQuery = p+                                                               , authorityFacts = sAuthorityFacts+                                                               , allGeneratedFacts = sFacts+                                                               , limits+                                                               }+      (Nothing, Left Nothing)  -> Left $ ResultError $ NoPoliciesMatched []+      (Nothing, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p+      (Just cs, Left Nothing)  -> Left $ ResultError $ NoPoliciesMatched (NE.toList cs)+      (Just cs, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched (NE.toList cs) p+      (Just cs, Right _)       -> Left $ ResultError $ FailedChecks cs+++runFactGeneration :: Limits -> World -> Either PureExecError (Set Fact)+runFactGeneration limits w =+  let getFacts = sFacts . snd+   in getFacts <$> runStateT (computeAllFacts w) (mkInitState limits)++runAuthority :: BlockWithRevocationId+             -> Authorizer+             -> StateT ComputeState (Either PureExecError) ()+runAuthority (block, _rid) Authorizer{..} = do+  let world = collectWorld block <> collectWorld vBlock+  computeAllFacts world+  -- store the facts generated by the authority block (and the authorizer)+  -- in a dedicated `sAuthorityFacts` so that they can be queried independently+  -- later: we trust the authority facts, not the block facts+  modify $ \c@ComputeState{sFacts} -> c { sAuthorityFacts = sFacts }+  state@ComputeState{sFacts, sLimits} <- get+  let checkResults = checkChecks sLimits (bChecks block <> bChecks vBlock) sFacts+  let policyResult = checkPolicies sLimits vPolicies sFacts+  put state { sPolicyResult = policyResult+            , sFailedChecks = validation NE.toList mempty checkResults+            }++runBlock :: BlockWithRevocationId+         -> StateT ComputeState (Either PureExecError) ()+runBlock (block@Block{bChecks}, _rid) = do+  let world = collectWorld block+  computeAllFacts world+  state@ComputeState{sFacts, sLimits, sFailedChecks} <- get+  let checkResults = checkChecks sLimits bChecks sFacts+  put state { sFailedChecks = validation NE.toList mempty checkResults <> sFailedChecks+            }++checkChecks :: Limits -> [Check] -> Set Fact -> Validation (NonEmpty Check) ()+checkChecks limits checks facts = traverse_ (checkCheck limits facts) checks++checkPolicies :: Limits -> [Policy] -> Set Fact -> Either (Maybe MatchedQuery) MatchedQuery+checkPolicies limits policies facts =+  let results = mapMaybe (checkPolicy limits facts) policies+   in case results of+        p : _ -> first Just p+        []    -> Left Nothing++computeAllFacts :: World+                -> StateT ComputeState (Either PureExecError) ()+computeAllFacts world = do+  state@ComputeState{..} <- get+  let Limits{..} = sLimits+  let newFacts = extend sLimits (world `withFacts` sFacts)+      allFacts = sFacts <> facts world <> newFacts+  when (Set.size allFacts >= maxFacts) $ lift $ Left Facts+  when (sIterations >= maxIterations)  $ lift $ Left Iterations+  put $ state { sIterations = sIterations + 1+              , sFacts = allFacts+              }+  if null newFacts+  then pure ()+  else computeAllFacts world++extend :: Limits -> World -> Set Fact+extend l World{..} =+  let buildFacts = foldMap (getFactsForRule l facts)+      allNewFacts = buildFacts rules+   in Set.difference allNewFacts facts++collectWorld :: Block -> World+collectWorld Block{..} = World+  { facts = Set.fromList bFacts+  , rules = Set.fromList bRules+  }++-- | 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{authorityFacts, limits} q =+  let getBindingsForQueryItem QueryItem{qBody,qExpressions} =+        getBindingsForRuleBody limits authorityFacts qBody qExpressions+   in foldMap getBindingsForQueryItem 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.+getVariableValues :: (Ord t, FromValue t)+                  => Set Bindings+                  -> Text+                  -> Set t+getVariableValues bindings variableName =+  let mapMaybeS f = foldMap (foldMap Set.singleton . f)+      getVar vars = fromValue =<< vars !? variableName+   in mapMaybeS getVar bindings++-- | Extract exactly one value from a matched variable. If the variable has 0+-- matches or more than one match, 'Nothing' will be returned+getSingleVariableValue :: (Ord t, FromValue t)+                       => Set Bindings+                       -> Text+                       -> Maybe t+getSingleVariableValue bindings variableName =+  let values = getVariableValues bindings variableName+   in case Set.toList values of+        [v] -> Just v+        _   -> Nothing

@@ -4,34 +4,34 @@  import           Data.ByteString (ByteString) import           Data.Functor    (($>))+import           Data.Maybe      (fromMaybe) import           Data.Time       (getCurrentTime)  import           Auth.Biscuit -privateKey' :: PrivateKey-privateKey' = maybe (error "Error parsing private key") id $ parsePrivateKeyHex "todo"+privateKey' :: SecretKey+privateKey' = fromMaybe (error "Error parsing private key") $ parseSecretKeyHex "todo"  publicKey' :: PublicKey-publicKey' = maybe (error "Error parsing public key") id $ parsePublicKeyHex "todo"+publicKey' = fromMaybe (error "Error parsing public key") $ parsePublicKeyHex "todo"  creation :: IO ByteString creation = do   let authority = [block|        // toto-       resource(#authority,"file1");+       resource("file1");        |]-  keypair <- fromPrivateKey privateKey'-  biscuit <- mkBiscuit keypair authority-  let block1 = [block|check if current_time(#ambient, $time), $time < 2021-05-08T00:00:00Z;|]+  biscuit <- mkBiscuit privateKey' authority+  let block1 = [block|check if current_time($time), $time < 2021-05-08T00:00:00Z;|]   newBiscuit <- addBlock block1 biscuit   pure $ serializeB64 newBiscuit  verification :: ByteString -> IO Bool verification serialized = do   now <- getCurrentTime-  biscuit <- either (fail . show) pure $ parseB64 serialized-  let verifier' = [verifier|current_time(#ambient, ${now});|]-  result <- verifyBiscuit biscuit verifier' publicKey'+  biscuit <- either (fail . show) pure $ parseB64 publicKey' serialized+  let authorizer' = [authorizer|current_time(${now});|]+  result <- authorizeBiscuit biscuit authorizer'   case result of     Left e  -> print e $> False     Right _ -> pure True

@@ -13,20 +13,25 @@  module Auth.Biscuit.Proto   ( Biscuit (..)-  , Signature (..)+  , SignedBlock (..)+  , PublicKey (..)+  , Algorithm (..)+  , Proof (..)   , Block (..)-  , FactV1 (..)-  , RuleV1 (..)-  , CheckV1 (..)-  , PredicateV1 (..)-  , IDV1 (..)-  , ExpressionV1 (..)-  , IDSet (..)+  , FactV2 (..)+  , RuleV2 (..)+  , CheckV2 (..)+  , PredicateV2 (..)+  , TermV2 (..)+  , ExpressionV2 (..)+  , TermSet (..)   , Op (..)   , OpUnary (..)   , UnaryKind (..)   , OpBinary (..)   , BinaryKind (..)+  , OpTernary (..)+  , TernaryKind (..)   , getField   , putField   , decodeBlockList@@ -43,107 +48,105 @@ import           GHC.Generics         (Generic)  data Biscuit = Biscuit-  { authority :: Required 1 (Value ByteString)-  , blocks    :: Repeated 2 (Value ByteString)-  , keys      :: Repeated 3 (Value ByteString)-  , signature :: Required 4 (Message Signature)+  { rootKeyId :: Optional 1 (Value Int32)+  , authority :: Required 2 (Message SignedBlock)+  , blocks    :: Repeated 3 (Message SignedBlock)+  , proof     :: Required 4 (Message Proof)   } deriving (Generic, Show)     deriving anyclass (Decode, Encode) -data CBiscuit = CBiscuit-  { cAuthority :: Required 1 (Message Block)-  , cBlocks    :: Repeated 2 (Message Block)-  , cKeys      :: Repeated 3 (Value ByteString)-  , cSignature :: Required 4 (Message Signature)-  } deriving (Generic, Show)-    deriving anyclass (Decode, Encode)+data Proof =+    ProofSecret    (Required 1 (Value ByteString))+  | ProofSignature (Required 2 (Value ByteString))+  deriving (Generic, Show)+  deriving anyclass (Decode, Encode) -data SealedBiscuit = SealedBiscuit-  { sAuthority :: Required 1 (Value ByteString)-  , sBlocks    :: Repeated 2 (Value ByteString)-  , sSignature :: Required 3 (Value ByteString)-  } 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)+  }+  deriving (Generic, Show)+  deriving anyclass (Decode, Encode) -data Signature = Signature-  { parameters :: Repeated 1 (Value ByteString)-  , z          :: Required 2 (Value ByteString)-  } deriving (Generic, Show)-    deriving anyclass (Decode, Encode)+data Algorithm = Ed25519+  deriving stock (Show, Enum, Bounded) +data PublicKey = PublicKey+  { algorithm :: Required 1 (Enumeration Algorithm)+  , key       :: Required 2 (Value ByteString)+  }+  deriving (Generic, Show)+  deriving anyclass (Decode, Encode)+ data Block = Block {-    index     :: Required 1 (Value Int32)-  , symbols   :: Repeated 2 (Value Text)-  -- , facts_v0   :: Repeated 3 (Message FactV0)-  -- , rules_v0   :: Repeated 4 (Message RuleV0)-  -- , caveats_v0 :: Repeated 5 (Message CaveatV0)-  , context   :: Optional 6 (Value Text)-  , version   :: Optional 7 (Value Int32)-  , facts_v1  :: Repeated 8 (Message FactV1)-  , rules_v1  :: Repeated 9 (Message RuleV1)-  , checks_v1 :: Repeated 10 (Message CheckV1)+    symbols   :: Repeated 1 (Value Text)+  , context   :: Optional 2 (Value Text)+  , version   :: Optional 3 (Value Int32)+  , facts_v2  :: Repeated 4 (Message FactV2)+  , rules_v2  :: Repeated 5 (Message RuleV2)+  , checks_v2 :: Repeated 6 (Message CheckV2)   } deriving (Generic, Show)     deriving anyclass (Decode, Encode) -newtype FactV1 = FactV1-  { predicate :: Required 1 (Message PredicateV1)+newtype FactV2 = FactV2+  { predicate :: Required 1 (Message PredicateV2)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -data RuleV1 = RuleV1-  { head        :: Required 1 (Message PredicateV1)-  , body        :: Repeated 2 (Message PredicateV1)-  , expressions :: Repeated 3 (Message ExpressionV1)+data RuleV2 = RuleV2+  { head        :: Required 1 (Message PredicateV2)+  , body        :: Repeated 2 (Message PredicateV2)+  , expressions :: Repeated 3 (Message ExpressionV2)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -newtype CheckV1 = CheckV1-  { queries :: Repeated 1 (Message RuleV1)+newtype CheckV2 = CheckV2+  { queries :: Repeated 1 (Message RuleV2)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -data PredicateV1 = PredicateV1-  { name :: Required 1 (Value Int64)-  , ids  :: Repeated 2 (Message IDV1)+data PredicateV2 = PredicateV2+  { name  :: Required 1 (Value Int64)+  , terms :: Repeated 2 (Message TermV2)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -data IDV1 =-    IDSymbol (Required 1 (Value Int64))-  | IDVariable (Required 2 (Value Int32))-  | IDInteger (Required 3 (Value Int64))-  | IDString (Required 4 (Value Text))-  | IDDate (Required 5 (Value Int64))-  | IDBytes (Required 6 (Value ByteString))-  | IDBool (Required 7 (Value Bool))-  | IDIDSet (Required 8 (Message IDSet))+data TermV2 =+    TermVariable (Required 1 (Value Int32))+  | TermInteger  (Required 2 (Value Int64))+  | TermString   (Required 3 (Value Int64))+  | TermDate     (Required 4 (Value Int64))+  | TermBytes    (Required 5 (Value ByteString))+  | TermBool     (Required 6 (Value Bool))+  | TermTermSet  (Required 7 (Message TermSet))     deriving stock (Generic, Show)     deriving anyclass (Decode, Encode)  -newtype IDSet = IDSet-  { set :: Repeated 1 (Message IDV1)+newtype TermSet = TermSet+  { set :: Repeated 1 (Message TermV2)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -type CV1Id = Required 1 (Value Int32)-data ConstraintV1 =-    CV1Int    CV1Id (Required 2 (Message IntConstraintV1))-  | CV1String CV1Id (Required 3 (Message StringConstraintV1))-  | CV1Date   CV1Id (Required 4 (Message DateConstraintV1))-  | CV1Symbol CV1Id (Required 5 (Message SymbolConstraintV1))-  | CV1Bytes  CV1Id (Required 6 (Message BytesConstraintV1))+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 IntConstraintV1 =-    ICV1LessThan       (Required 1 (Value Int64))-  | ICV1GreaterThan    (Required 2 (Value Int64))-  | ICV1LessOrEqual    (Required 3 (Value Int64))-  | ICV1GreaterOrEqual (Required 4 (Value Int64))-  | ICV1Equal          (Required 5 (Value Int64))-  | ICV1InSet          (Required 6 (Message IntSet))-  | ICV1NotInSet       (Required 7 (Message IntSet))+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) @@ -152,13 +155,13 @@   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -data StringConstraintV1 =-    SCV1Prefix   (Required 1 (Value Text))-  | SCV1Suffix   (Required 2 (Value Text))-  | SCV1Equal    (Required 3 (Value Text))-  | SCV1InSet    (Required 4 (Message StringSet))-  | SCV1NotInSet (Required 5 (Message StringSet))-  | SCV1Regex    (Required 6 (Value Text))+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) @@ -167,15 +170,15 @@   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -data DateConstraintV1 =-    DCV1Before (Required 1 (Value Int64))-  | DCV1After  (Required 2 (Value Int64))+data DateConstraintV2 =+    DCV2Before (Required 1 (Value Int64))+  | DCV2After  (Required 2 (Value Int64))     deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -data SymbolConstraintV1 =-    SyCV1InSet    (Required 1 (Message SymbolSet))-  | SyCV1NotInSet (Required 2 (Message SymbolSet))+data SymbolConstraintV2 =+    SyCV2InSet    (Required 1 (Message SymbolSet))+  | SyCV2NotInSet (Required 2 (Message SymbolSet))     deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) @@ -185,10 +188,10 @@     deriving anyclass (Decode, Encode)  -data BytesConstraintV1 =-    BCV1Equal    (Required 1 (Value ByteString))-  | BCV1InSet    (Required 2 (Message BytesSet))-  | BCV1NotInSet (Required 3 (Message BytesSet))+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) @@ -197,13 +200,13 @@   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -newtype ExpressionV1 = ExpressionV1+newtype ExpressionV2 = ExpressionV2   { ops :: Repeated 1 (Message Op)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode)  data Op =-    OpVValue  (Required 1 (Message IDV1))+    OpVValue  (Required 1 (Message TermV2))   | OpVUnary  (Required 2 (Message OpUnary))   | OpVBinary (Required 3 (Message OpBinary))     deriving stock (Generic, Show)@@ -242,22 +245,12 @@   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) -data PolicyKind = Allow | Deny+data TernaryKind =+    VerifyEd25519Signature   deriving stock (Show, Enum, Bounded) -data Policy = Policy-  { queries :: Repeated 1 (Message RuleV1)-  , kind    :: Required 2 (Enumeration PolicyKind)-  } deriving stock (Generic, Show)-    deriving anyclass (Decode, Encode)--data VerifierPolicies = VerifierPolicies-  { symbols  :: Repeated 1 (Value Text)-  , version  :: Optional 2 (Value Int32)-  , facts    :: Repeated 3 (Message FactV1)-  , rules    :: Repeated 4 (Message RuleV1)-  , checks   :: Repeated 5 (Message CheckV1)-  , policies :: Repeated 6 (Message Policy)+newtype OpTernary = OpTernary+  { kind :: Required 1 (Enumeration TernaryKind)   } deriving stock (Generic, Show)     deriving anyclass (Decode, Encode) 

@@ -17,9 +17,14 @@   , buildSymbolTable   , pbToBlock   , blockToPb+  , pbToSignedBlock+  , signedBlockToPb+  , pbToProof   ) where  import           Control.Monad            (when)+import           Crypto.PubKey.Ed25519    (PublicKey)+import           Data.Bifunctor           (first) import           Data.Int                 (Int32, Int64) import           Data.Map.Strict          (Map) import qualified Data.Map.Strict          as Map@@ -30,6 +35,7 @@                                            utcTimeToPOSIXSeconds) import           Data.Void                (absurd) +import qualified Auth.Biscuit.Crypto      as Crypto import           Auth.Biscuit.Datalog.AST import qualified Auth.Biscuit.Proto       as PB import           Auth.Biscuit.Utils       (maybeToRight)@@ -77,51 +83,84 @@ getSymbolCode :: Integral i => ReverseSymbols -> Text -> i getSymbolCode = (fromIntegral .) . (Map.!) +pbToPublicKey :: PB.PublicKey -> Either String PublicKey+pbToPublicKey PB.PublicKey{..} =+  let keyBytes = PB.getField key+      parseKey = Crypto.eitherCryptoError . Crypto.publicKey+   in case PB.getField algorithm of+        PB.Ed25519 -> first (const "Invalid ed25519 public key") $ parseKey keyBytes++-- | 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+  pk  <- pbToPublicKey $ PB.getField nextKey+  pure ( PB.getField block+       , sig+       , pk+       )++publicKeyToPb :: PublicKey -> PB.PublicKey+publicKeyToPb pk = PB.PublicKey+  { algorithm = PB.putField PB.Ed25519+  , key = PB.putField $ Crypto.convert pk+  }++signedBlockToPb :: Crypto.SignedBlock -> PB.SignedBlock+signedBlockToPb (block, sig, pk) = PB.SignedBlock+  { block = PB.putField block+  , signature = PB.putField $ Crypto.convert sig+  , nextKey = PB.putField $ publicKeyToPb pk+  }++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)+ -- | Parse a protobuf block into a proper biscuit block pbToBlock :: Symbols -> PB.Block -> Either String Block pbToBlock s PB.Block{..} = do   let bContext = PB.getField context       bVersion = PB.getField version-  bFacts <- traverse (pbToFact s) $ PB.getField facts_v1-  bRules <- traverse (pbToRule s) $ PB.getField rules_v1-  bChecks <- traverse (pbToCheck s) $ PB.getField checks_v1-  when (bVersion /= Just 1) $ Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only version 1 is supported"+  bFacts <- traverse (pbToFact s) $ PB.getField facts_v2+  bRules <- traverse (pbToRule s) $ PB.getField rules_v2+  bChecks <- traverse (pbToCheck s) $ PB.getField checks_v2+  when (bVersion /= Just 2) $ Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only version 2 is supported"   pure Block{ .. }  -- | Turn a biscuit block into a protobuf block, for serialization, -- along with the newly defined symbols-blockToPb :: Symbols -> Int -> Block -> (Symbols, PB.Block)-blockToPb existingSymbols bIndex b@Block{..} =+blockToPb :: Symbols -> Block -> (Symbols, PB.Block)+blockToPb existingSymbols b@Block{..} =   let       bSymbols = buildSymbolTable existingSymbols b       s = reverseSymbols $ existingSymbols <> bSymbols-      index     = PB.putField $ fromIntegral bIndex       symbols   = PB.putField $ Map.elems bSymbols       context   = PB.putField bContext-      version   = PB.putField $ Just 1-      facts_v1  = PB.putField $ factToPb s <$> bFacts-      rules_v1  = PB.putField $ ruleToPb s <$> bRules-      checks_v1 = PB.putField $ checkToPb s <$> bChecks+      version   = PB.putField $ Just 2+      facts_v2  = PB.putField $ factToPb s <$> bFacts+      rules_v2  = PB.putField $ ruleToPb s <$> bRules+      checks_v2 = PB.putField $ checkToPb s <$> bChecks    in (bSymbols, PB.Block {..}) -pbToFact :: Symbols -> PB.FactV1 -> Either String Fact-pbToFact s PB.FactV1{predicate} = do-  let pbName = PB.getField $ PB.name $ PB.getField predicate-      pbIds  = PB.getField $ PB.ids  $ PB.getField predicate+pbToFact :: Symbols -> PB.FactV2 -> Either String Fact+pbToFact s PB.FactV2{predicate} = do+  let pbName  = PB.getField $ PB.name  $ PB.getField predicate+      pbTerms = PB.getField $ PB.terms $ PB.getField predicate   name <- getSymbol s pbName-  terms <- traverse (pbToValue s) pbIds+  terms <- traverse (pbToValue s) pbTerms   pure Predicate{..} -factToPb :: ReverseSymbols -> Fact -> PB.FactV1+factToPb :: ReverseSymbols -> Fact -> PB.FactV2 factToPb s Predicate{..} =   let-      predicate = PB.PredicateV1-        { name = PB.putField $ getSymbolCode s name-        , ids  = PB.putField $ valueToPb s <$> terms+      predicate = PB.PredicateV2+        { name  = PB.putField $ getSymbolCode s name+        , terms = PB.putField $ valueToPb s <$> terms         }-   in PB.FactV1{predicate = PB.putField predicate}+   in PB.FactV2{predicate = PB.putField predicate} -pbToRule :: Symbols -> PB.RuleV1 -> Either String Rule+pbToRule :: Symbols -> PB.RuleV2 -> Either String Rule pbToRule s pbRule = do   let pbHead = PB.getField $ PB.head pbRule       pbBody = PB.getField $ PB.body pbRule@@ -131,134 +170,128 @@   expressions <- traverse (pbToExpression s) pbExpressions   pure Rule {..} -ruleToPb :: ReverseSymbols -> Rule -> PB.RuleV1+ruleToPb :: ReverseSymbols -> Rule -> PB.RuleV2 ruleToPb s Rule{..} =-  PB.RuleV1+  PB.RuleV2     { head = PB.putField $ predicateToPb s rhead     , body = PB.putField $ predicateToPb s <$> body     , expressions = PB.putField $ expressionToPb s <$> expressions     } -pbToCheck :: Symbols -> PB.CheckV1 -> Either String Check-pbToCheck s PB.CheckV1{queries} = do+pbToCheck :: Symbols -> PB.CheckV2 -> Either String Check+pbToCheck s PB.CheckV2{queries} = do   let toCheck Rule{body,expressions} = QueryItem{qBody = body, qExpressions = expressions }   rules <- traverse (pbToRule s) $ PB.getField queries   pure $ toCheck <$> rules -checkToPb :: ReverseSymbols -> Check -> PB.CheckV1+checkToPb :: ReverseSymbols -> Check -> PB.CheckV2 checkToPb s items =   let dummyHead = Predicate "query" []       toQuery QueryItem{..} =         ruleToPb s $ Rule dummyHead qBody qExpressions-   in PB.CheckV1 { queries = PB.putField $ toQuery <$> items }+   in PB.CheckV2 { queries = PB.putField $ toQuery <$> items }  getSymbol :: (Show i, Integral i) => Symbols -> i -> Either String Text getSymbol s i = maybeToRight ("Missing symbol at id " <> show i) $ Map.lookup (fromIntegral i) s -pbToPredicate :: Symbols -> PB.PredicateV1 -> Either String (Predicate' 'InPredicate 'RegularString)+pbToPredicate :: Symbols -> PB.PredicateV2 -> Either String (Predicate' 'InPredicate 'RegularString) pbToPredicate s pbPredicate = do-  let pbName = PB.getField $ PB.name pbPredicate-      pbIds  = PB.getField $ PB.ids  pbPredicate+  let pbName  = PB.getField $ PB.name  pbPredicate+      pbTerms = PB.getField $ PB.terms pbPredicate   name <- getSymbol s pbName-  terms <- traverse (pbToTerm s) pbIds+  terms <- traverse (pbToTerm s) pbTerms   pure Predicate{..} -predicateToPb :: ReverseSymbols -> Predicate -> PB.PredicateV1+predicateToPb :: ReverseSymbols -> Predicate -> PB.PredicateV2 predicateToPb s Predicate{..} =-  PB.PredicateV1-    { name = PB.putField $ getSymbolCode s name-    , ids  = PB.putField $ termToPb s <$> terms+  PB.PredicateV2+    { name  = PB.putField $ getSymbolCode s name+    , terms = PB.putField $ termToPb s <$> terms     }  pbTimeToUtcTime :: Int64 -> UTCTime pbTimeToUtcTime = posixSecondsToUTCTime . fromIntegral -pbToTerm :: Symbols -> PB.IDV1 -> Either String ID+pbToTerm :: Symbols -> PB.TermV2 -> Either String Term pbToTerm s = \case-  PB.IDSymbol   f ->        Symbol  <$> getSymbol s (PB.getField f)-  PB.IDInteger  f -> pure $ LInteger $ fromIntegral $ PB.getField f-  PB.IDString   f -> pure $ LString  $ PB.getField f-  PB.IDDate     f -> pure $ LDate    $ pbTimeToUtcTime $ PB.getField f-  PB.IDBytes    f -> pure $ LBytes   $ PB.getField f-  PB.IDBool     f -> pure $ LBool    $ PB.getField f-  PB.IDVariable f -> Variable <$> getSymbol s (PB.getField f)-  PB.IDIDSet    f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f)+  PB.TermInteger  f -> pure $ LInteger $ fromIntegral $ PB.getField f+  PB.TermString   f ->        LString <$> getSymbol s (PB.getField f)+  PB.TermDate     f -> pure $ LDate    $ pbTimeToUtcTime $ PB.getField f+  PB.TermBytes    f -> pure $ LBytes   $ PB.getField f+  PB.TermBool     f -> pure $ LBool    $ PB.getField f+  PB.TermVariable f -> Variable <$> getSymbol s (PB.getField f)+  PB.TermTermSet  f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f) -termToPb :: ReverseSymbols -> ID -> PB.IDV1+termToPb :: ReverseSymbols -> Term -> PB.TermV2 termToPb s = \case-  Variable n -> PB.IDVariable $ PB.putField $ getSymbolCode s n-  Symbol   n -> PB.IDSymbol   $ PB.putField $ getSymbolCode s n-  LInteger v -> PB.IDInteger  $ PB.putField $ fromIntegral v-  LString  v -> PB.IDString   $ PB.putField v-  LDate    v -> PB.IDDate     $ PB.putField $ round $ utcTimeToPOSIXSeconds v-  LBytes   v -> PB.IDBytes    $ PB.putField v-  LBool    v -> PB.IDBool     $ PB.putField v-  TermSet vs -> PB.IDIDSet    $ PB.putField $ PB.IDSet $ PB.putField $ setValueToPb s <$> Set.toList vs+  Variable n -> PB.TermVariable $ PB.putField $ getSymbolCode s n+  LInteger v -> PB.TermInteger  $ PB.putField $ fromIntegral v+  LString  v -> PB.TermString   $ PB.putField $ getSymbolCode s v+  LDate    v -> PB.TermDate     $ PB.putField $ round $ utcTimeToPOSIXSeconds v+  LBytes   v -> PB.TermBytes    $ PB.putField v+  LBool    v -> PB.TermBool     $ PB.putField v+  TermSet vs -> PB.TermTermSet  $ PB.putField $ PB.TermSet $ PB.putField $ setValueToPb s <$> Set.toList vs    Antiquote v -> absurd v -pbToValue :: Symbols -> PB.IDV1 -> Either String Value+pbToValue :: Symbols -> PB.TermV2 -> Either String Value pbToValue s = \case-  PB.IDSymbol   f ->        Symbol  <$> getSymbol s (PB.getField f)-  PB.IDInteger  f -> pure $ LInteger $ fromIntegral $ PB.getField f-  PB.IDString   f -> pure $ LString  $ PB.getField f-  PB.IDDate     f -> pure $ LDate    $ pbTimeToUtcTime $ PB.getField f-  PB.IDBytes    f -> pure $ LBytes   $ PB.getField f-  PB.IDBool     f -> pure $ LBool    $ PB.getField f-  PB.IDVariable _ -> Left "Variables can't appear in facts"-  PB.IDIDSet    f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f)+  PB.TermInteger  f -> pure $ LInteger $ fromIntegral $ PB.getField f+  PB.TermString   f ->        LString <$> getSymbol s (PB.getField f)+  PB.TermDate     f -> pure $ LDate    $ pbTimeToUtcTime $ PB.getField f+  PB.TermBytes    f -> pure $ LBytes   $ PB.getField f+  PB.TermBool     f -> pure $ LBool    $ PB.getField f+  PB.TermVariable _ -> Left "Variables can't appear in facts"+  PB.TermTermSet  f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f) -valueToPb :: ReverseSymbols -> Value -> PB.IDV1+valueToPb :: ReverseSymbols -> Value -> PB.TermV2 valueToPb s = \case-  Symbol   n -> PB.IDSymbol  $ PB.putField $ getSymbolCode s n-  LInteger v -> PB.IDInteger $ PB.putField $ fromIntegral v-  LString  v -> PB.IDString  $ PB.putField v-  LDate    v -> PB.IDDate    $ PB.putField $ round $ utcTimeToPOSIXSeconds v-  LBytes   v -> PB.IDBytes   $ PB.putField v-  LBool    v -> PB.IDBool    $ PB.putField v-  TermSet vs -> PB.IDIDSet   $ PB.putField $ PB.IDSet $ PB.putField $ setValueToPb s <$> Set.toList vs+  LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v+  LString  v -> PB.TermString  $ PB.putField $ getSymbolCode s v+  LDate    v -> PB.TermDate    $ PB.putField $ round $ utcTimeToPOSIXSeconds v+  LBytes   v -> PB.TermBytes   $ PB.putField v+  LBool    v -> PB.TermBool    $ PB.putField v+  TermSet vs -> PB.TermTermSet $ PB.putField $ PB.TermSet $ PB.putField $ setValueToPb s <$> Set.toList vs    Variable v  -> absurd v   Antiquote v -> absurd v -pbToSetValue :: Symbols -> PB.IDV1 -> Either String (ID' 'WithinSet 'InFact 'RegularString)+pbToSetValue :: Symbols -> PB.TermV2 -> Either String (Term' 'WithinSet 'InFact 'RegularString) pbToSetValue s = \case-  PB.IDSymbol   f ->        Symbol   <$> getSymbol s (PB.getField f)-  PB.IDInteger  f -> pure $ LInteger $ fromIntegral $ PB.getField f-  PB.IDString   f -> pure $ LString  $ PB.getField f-  PB.IDDate     f -> pure $ LDate    $ pbTimeToUtcTime $ PB.getField f-  PB.IDBytes    f -> pure $ LBytes   $ PB.getField f-  PB.IDBool     f -> pure $ LBool    $ PB.getField f-  PB.IDVariable _ -> Left "Variables can't appear in facts or sets"-  PB.IDIDSet    _ -> Left "Sets can't be nested"+  PB.TermInteger  f -> pure $ LInteger $ fromIntegral $ PB.getField f+  PB.TermString   f ->        LString  <$> getSymbol s (PB.getField f)+  PB.TermDate     f -> pure $ LDate    $ pbTimeToUtcTime $ PB.getField f+  PB.TermBytes    f -> pure $ LBytes   $ PB.getField f+  PB.TermBool     f -> pure $ LBool    $ PB.getField f+  PB.TermVariable _ -> Left "Variables can't appear in facts or sets"+  PB.TermTermSet  _ -> Left "Sets can't be nested" -setValueToPb :: ReverseSymbols -> ID' 'WithinSet 'InFact 'RegularString -> PB.IDV1+setValueToPb :: ReverseSymbols -> Term' 'WithinSet 'InFact 'RegularString -> PB.TermV2 setValueToPb s = \case-  Symbol   n -> PB.IDSymbol  $ PB.putField $ getSymbolCode s n-  LInteger v -> PB.IDInteger $ PB.putField $ fromIntegral v-  LString  v -> PB.IDString  $ PB.putField v-  LDate    v -> PB.IDDate    $ PB.putField $ round $ utcTimeToPOSIXSeconds v-  LBytes   v -> PB.IDBytes   $ PB.putField v-  LBool    v -> PB.IDBool    $ PB.putField v+  LInteger v  -> PB.TermInteger $ PB.putField $ fromIntegral v+  LString  v  -> PB.TermString  $ PB.putField $ getSymbolCode s v+  LDate    v  -> PB.TermDate    $ PB.putField $ round $ utcTimeToPOSIXSeconds v+  LBytes   v  -> PB.TermBytes   $ PB.putField v+  LBool    v  -> PB.TermBool    $ PB.putField v    TermSet   v -> absurd v   Variable  v -> absurd v   Antiquote v -> absurd v -pbToExpression :: Symbols -> PB.ExpressionV1 -> Either String Expression-pbToExpression s PB.ExpressionV1{ops} = do+pbToExpression :: Symbols -> PB.ExpressionV2 -> Either String Expression+pbToExpression s PB.ExpressionV2{ops} = do   parsedOps <- traverse (pbToOp s) $ PB.getField ops   fromStack parsedOps -expressionToPb :: ReverseSymbols -> Expression -> PB.ExpressionV1+expressionToPb :: ReverseSymbols -> Expression -> PB.ExpressionV2 expressionToPb s e =   let ops = opToPb s <$> toStack e-   in PB.ExpressionV1 { ops = PB.putField ops }+   in PB.ExpressionV2 { ops = PB.putField ops }  pbToOp :: Symbols -> PB.Op -> Either String Op pbToOp s = \case-  PB.OpVValue v -> VOp <$> pbToTerm s (PB.getField v)-  PB.OpVUnary v -> pure . UOp . pbToUnary $ PB.getField v+  PB.OpVValue v  -> VOp <$> pbToTerm s (PB.getField v)+  PB.OpVUnary v  -> pure . UOp . pbToUnary $ PB.getField v   PB.OpVBinary v -> pure . BOp . pbToBinary $ PB.getField v  opToPb :: ReverseSymbols -> Op -> PB.Op

@@ -1,334 +0,0 @@-{-# LANGUAGE DerivingStrategies         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE RecordWildCards            #-}-{- HLINT ignore "Reduce duplication" -}-{-|-  Module      : Auth.Biscuit.Sel-  Copyright   : © Clément Delafargue, 2021-  License     : MIT-  Maintainer  : clement@delafargue.name-  Cryptographic primitives necessary to sign and verify biscuit tokens--}-module Auth.Biscuit.Sel-  ( Keypair (..)-  , PrivateKey-  , PublicKey-  , Signature (..)-  , parsePrivateKey-  , parsePublicKey-  , serializePrivateKey-  , serializePublicKey-  , newKeypair-  , fromPrivateKey-  , signBlock-  , aggregate-  , verifySignature-  , hashBytes-  ) where--import           Control.Monad.Cont     (ContT (..), runContT)-import           Control.Monad.IO.Class (MonadIO, liftIO)-import           Data.ByteString        (ByteString, packCStringLen,-                                         useAsCStringLen)-import qualified Data.ByteString        as BS-import           Data.ByteString.Base16 as Hex-import           Data.Foldable          (for_)-import           Data.Functor           (void)-import           Data.List.NonEmpty     (NonEmpty)-import           Data.Primitive.Ptr     (copyPtr)-import           Foreign.C.Types-import           Foreign.Marshal.Alloc-import           Foreign.Ptr-import           Libsodium---- | A private key used to generate a biscuit-newtype PrivateKey = PrivateKey ByteString-  deriving newtype (Eq, Ord)--instance Show PrivateKey where-  show (PrivateKey bs) = show $ Hex.encode bs---- | Parse a private key from raw bytes.--- This returns `Nothing` if the raw bytes don't have the expected length-parsePrivateKey :: ByteString -> Maybe PrivateKey-parsePrivateKey bs = if BS.length bs == cs2int crypto_core_ristretto255_scalarbytes-                     then Just (PrivateKey bs)-                     else Nothing---- | Serialize a private key to raw bytes-serializePrivateKey :: PrivateKey -> ByteString-serializePrivateKey (PrivateKey bs) = bs---- | A public key used to generate a biscuit-newtype PublicKey = PublicKey ByteString-  deriving newtype (Eq, Ord)---- | Parse a public key from raw bytes.--- This returns `Nothing` if the raw bytes don't have the expected length-parsePublicKey :: ByteString -> Maybe PublicKey-parsePublicKey bs = if BS.length bs == cs2int crypto_core_ristretto255_bytes-                     then Just (PublicKey bs)-                     else Nothing---- | Serialize a public key to raw bytes-serializePublicKey :: PublicKey -> ByteString-serializePublicKey (PublicKey bs) = bs--instance Show PublicKey where-  show (PublicKey bs) = show $ Hex.encode bs---- | A keypair containing both a private key and a public key-data Keypair-  = Keypair-  { privateKey :: PrivateKey-  -- ^ the private key-  , publicKey  :: PublicKey-  -- ^ the public key-  } deriving (Eq, Ord)--instance Show Keypair where-  show Keypair{privateKey, publicKey} =-    show privateKey <> "/" <> show publicKey--keypairFromScalar :: Scalar -> CIO a Keypair-keypairFromScalar scalarBuf = do-  pointBuf <- scalarToPoint scalarBuf-  privateKey <- PrivateKey <$> scalarToByteString scalarBuf-  publicKey <-  PublicKey <$> pointToByteString pointBuf-  pure Keypair{..}---- | Generate a random keypair-newKeypair :: IO Keypair-newKeypair = runCIO $ do-  scalar <- randomScalar-  keypairFromScalar scalar---- | Construct a keypair from a private key-fromPrivateKey :: PrivateKey -> IO Keypair-fromPrivateKey (PrivateKey privBs) = runCIO $ do-  (privBuf, _) <- withBSLen privBs-  keypairFromScalar privBuf---- | The signature of a series of blocks (raw bytestrings)-data Signature-  = Signature-  { parameters :: [ByteString]-  -- ^ the list of parameters used to sign each block-  , z          :: ByteString-  -- ^ the aggregated signature-  } deriving (Eq, Show)--type Scalar = Ptr CUChar-type Point = Ptr CUChar---- | Pointer allocations are written in a continuation passing style,--- this type alias allows to use monadic notation instead of nesting--- callbacks-type CIO a = ContT a IO---- | Run a continuation to get back an IO value.-runCIO :: ContT a IO a -> IO a-runCIO = (`runContT` pure)--voidIO :: IO a -> CIO b ()-voidIO = void . liftIO--scalarToByteString :: MonadIO m => Ptr CUChar -> m ByteString-scalarToByteString ptr =-  let scalarIntSize = cs2int crypto_core_ristretto255_scalarbytes-   in liftIO $ packCStringLen (castPtr ptr, scalarIntSize)--pointToByteString :: MonadIO m => Ptr CUChar -> m ByteString-pointToByteString ptr =-  let pointIntSize = cs2int crypto_core_ristretto255_bytes-   in liftIO $ packCStringLen (castPtr ptr, pointIntSize)--randomScalar :: CIO a Scalar-randomScalar = do-  scalarBuf <- withScalar-  liftIO $ crypto_core_ristretto255_scalar_random scalarBuf-  pure scalarBuf--withScalar :: CIO a Scalar-withScalar =-  let intScalarSize = cs2int crypto_core_ristretto255_scalarbytes-   in ContT $ allocaBytes intScalarSize--withPoint :: CIO a Point-withPoint =-  let intPointSize = cs2int crypto_core_ristretto255_bytes-   in ContT $ allocaBytes intPointSize--scalarToPoint :: Scalar-              -> CIO a Point-scalarToPoint scalar = do-  pointBuf <- withPoint-  voidIO $ crypto_scalarmult_ristretto255_base pointBuf scalar-  pure pointBuf--withBSLen :: ByteString-          -> ContT a IO (Ptr CUChar, CULLong)-withBSLen bs = do-  (buf, int) <- ContT $ useAsCStringLen bs-  pure (castPtr buf, toEnum int)--scalarAdd :: Scalar -> Scalar -> CIO a Scalar-scalarAdd x y = do-  z <- withScalar-  liftIO $ crypto_core_ristretto255_scalar_add z x y-  pure z--scalarAddBs :: ByteString -> ByteString -> CIO a ByteString-scalarAddBs xBs yBs = do-  (x, _) <- withBSLen xBs-  (y, _) <- withBSLen yBs-  z <- scalarAdd x y-  scalarToByteString z--scalarMul :: Scalar -> Scalar -> CIO a Scalar-scalarMul x y = do-  z <- withScalar-  z <$ liftIO (crypto_core_ristretto255_scalar_mul z x y)--scalarSub :: Scalar -> Scalar -> CIO a Scalar-scalarSub x y = do-  z <- withScalar-  z <$ liftIO (crypto_core_ristretto255_scalar_sub z x y)--scalarReduce :: Ptr CUChar -> CIO a Scalar-scalarReduce bytes = do-  z <- withScalar-  z <$ liftIO (crypto_core_ristretto255_scalar_reduce z bytes)--scalarMulPoint :: Scalar -> Point -> CIO a Point-scalarMulPoint p q = do-  n <- withScalar-  n <$ liftIO (crypto_scalarmult_ristretto255 n p q)--pointAdd :: Point -> Point -> CIO a Point-pointAdd p q = do-  r <- withPoint-  r <$ liftIO (crypto_core_ristretto255_add r p q)--pointSub :: Point -> Point -> CIO a Point-pointSub p q = do-  r <- withPoint-  r <$ liftIO (crypto_core_ristretto255_sub r p q)--zeroPoint :: CIO a Point-zeroPoint = do-  p <- withPoint-  p <$ zeroizePoint p--zeroizePoint :: MonadIO m => Point -> m ()-zeroizePoint p = liftIO $ sodium_memzero p crypto_core_ristretto255_bytes--isZeroPoint :: MonadIO m => Point -> m Bool-isZeroPoint p = liftIO $-  (== 1) <$> sodium_is_zero p crypto_core_ristretto255_scalarbytes---- | Hash a bytestring with SHA256-hashBytes :: ByteString-          -> IO ByteString-hashBytes message = runCIO $ do-  out <- ContT $ allocaBytes $ cs2int crypto_hash_sha256_bytes-  (buf, len) <- withBSLen message-  voidIO $ crypto_hash_sha256 out buf len-  liftIO $ packCStringLen (castPtr out, cs2int crypto_hash_sha256_bytes)--hashPoint :: Point-           -> ContT a IO Scalar-hashPoint point = do-  hash   <- ContT $ allocaBytes (cs2int crypto_hash_sha512_bytes)-  voidIO $ crypto_hash_sha512 hash point (fromInteger $ toInteger crypto_core_ristretto255_bytes)-  scalarReduce hash--copyPointFrom :: Point -> Point -> IO ()-copyPointFrom to from = copyPtr to from (cs2int crypto_core_ristretto255_bytes)--hashMessage :: ByteString-            -> ByteString-            -> CIO a Scalar-hashMessage publicKey message = do-  (kpBuf, kpLen) <- withBSLen publicKey-  (msgBuf, msgLen) <- withBSLen message-  state <- liftIO crypto_hash_sha512_state'malloc-  statePtr <- ContT $ crypto_hash_sha512_state'ptr state-  voidIO $ crypto_hash_sha512_init statePtr-  voidIO $ crypto_hash_sha512_update statePtr kpBuf kpLen-  voidIO $ crypto_hash_sha512_update statePtr msgBuf msgLen-  hash <- ContT $ allocaBytes (cs2int crypto_hash_sha512_bytes)-  voidIO $ crypto_hash_sha512_final statePtr hash-  scalar <- withScalar-  voidIO $ crypto_core_ristretto255_scalar_reduce scalar hash-  pure scalar---- | Sign a single block with the given keypair-signBlock :: Keypair -> ByteString -> IO Signature-signBlock Keypair{publicKey,privateKey} message = do-  let PublicKey pubBs = publicKey-      PrivateKey prvBs = privateKey-  (`runContT` pure) $ do-     (pk, _) <- withBSLen prvBs--     r   <- randomScalar-     aa  <- scalarToPoint r-     d   <- hashPoint aa-     e   <- hashMessage pubBs message-     rd  <- scalarMul r d-     epk <- scalarMul e pk-     z   <- scalarSub rd epk-     aaBs <- pointToByteString aa-     zBs  <- scalarToByteString z-     pure Signature { parameters = [aaBs]-                    , z = zBs-                    }---- | Aggregate two signatures into a single one-aggregate :: Signature -> Signature -> IO Signature-aggregate first second = runCIO $ do-  z <- scalarAddBs (z first) (z second)-  pure Signature-    { parameters = parameters first <> parameters second-    , z-    }---- | Verify a signature, given a list of messages and associated--- public keys-verifySignature :: NonEmpty (PublicKey, ByteString)-                -> Signature-                -> IO Bool-verifySignature messagesAndPks Signature{parameters,z} = runCIO $ do-  zP      <- scalarToPoint . fst  =<< withBSLen z-  eiXiRes <- computeHashMSums messagesAndPks-  diAiRes <- computeHashPSums parameters-  resTmp  <- pointAdd zP eiXiRes-  res     <- pointSub resTmp diAiRes-  isZeroPoint res--computeHashMSums :: NonEmpty (PublicKey, ByteString)-                 -> ContT a IO Point-computeHashMSums messagesAndPks = do-  eiXiRes <- zeroPoint-  for_ messagesAndPks $ \(PublicKey publicKey, message) -> do-    ei         <- hashMessage publicKey message-    eiXi       <- scalarMulPoint ei . fst =<< withBSLen publicKey-    eiXiResTmp <- pointAdd eiXiRes eiXi-    liftIO $ copyPointFrom eiXiRes eiXiResTmp-  pure eiXiRes--computeHashPSums :: [ByteString] -- parameters-                 -> ContT a IO Point-computeHashPSums parameters = do-  diAiRes <- zeroPoint-  for_ parameters $ \aa -> do-    (aaBuf, _) <- withBSLen aa-    di         <- hashPoint aaBuf-    diAi       <- scalarMulPoint di aaBuf-    diAiResTmp <- pointAdd diAiRes diAi-    liftIO $ copyPointFrom diAiRes diAiResTmp-  pure diAiRes--cs2int :: CSize -> Int-cs2int = fromInteger . toInteger

@@ -1,6 +1,10 @@-{-# LANGUAGE NamedFieldPuns  #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE KindSignatures     #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE RecordWildCards    #-}+{- HLINT ignore "Reduce duplication" -} {-|   Module      : Auth.Biscuit.Token   Copyright   : © Clément Delafargue, 2021@@ -9,210 +13,446 @@   Module defining the main biscuit-related operations -} module Auth.Biscuit.Token-  ( Biscuit (..)+  ( Biscuit+  , rootKeyId+  , symbols+  , authority+  , blocks+  , proof+  , proofCheck   , ParseError (..)-  , VerificationError (..)   , ExistingBlock+  , ParsedSignedBlock+  -- $openOrSealed+  , OpenOrSealed+  , Open+  , Sealed+  , BiscuitProof (..)+  , Verified+  , Unverified   , mkBiscuit   , addBlock-  , checkBiscuitSignature-  , parseBiscuit+  , BiscuitEncoding (..)+  , ParserConfig (..)+  , parseBiscuitWith+  , parseBiscuitUnverified+  , checkBiscuitSignatures   , serializeBiscuit-  , verifyBiscuit-  , verifyBiscuitWithLimits+  , authorizeBiscuit+  , authorizeBiscuitWithLimits+  , fromOpen+  , fromSealed+  , asOpen+  , asSealed+  , seal -  , BlockWithRevocationIds (..)   , getRevocationIds+  , getVerifiedBiscuitPublicKey+   ) where -import           Control.Monad                 (when)-import           Control.Monad.Except          (runExceptT, throwError)-import           Control.Monad.IO.Class        (liftIO)-import           Data.Bifunctor                (first)-import           Data.ByteString               (ByteString)-import           Data.List.NonEmpty            (NonEmpty ((:|)))-import qualified Data.List.NonEmpty            as NE+import           Control.Monad                       (join, when)+import           Data.Bifunctor                      (first)+import           Data.ByteString                     (ByteString)+import qualified Data.ByteString.Base64.URL          as B64+import           Data.List.NonEmpty                  (NonEmpty ((:|)))+import qualified Data.List.NonEmpty                  as NE+import           Data.Set                            (Set)+import qualified Data.Set                            as Set -import           Auth.Biscuit.Datalog.AST      (Block, Query, Verifier)-import           Auth.Biscuit.Datalog.Executor (BlockWithRevocationIds (..),-                                                ExecutionError, Limits,-                                                defaultLimits,-                                                runVerifierWithLimits)-import qualified Auth.Biscuit.Proto            as PB-import           Auth.Biscuit.ProtoBufAdapter  (Symbols, blockToPb,-                                                commonSymbols, extractSymbols,-                                                pbToBlock)-import           Auth.Biscuit.Sel              (Keypair (publicKey), PublicKey,-                                                Signature (..), aggregate,-                                                hashBytes, newKeypair,-                                                parsePublicKey,-                                                serializePublicKey, signBlock,-                                                verifySignature)-import           Auth.Biscuit.Utils            (maybeToRight)+import           Auth.Biscuit.Crypto                 (PublicKey, SecretKey,+                                                      Signature, SignedBlock,+                                                      convert,+                                                      getSignatureProof,+                                                      signBlock, toPublic,+                                                      verifyBlocks,+                                                      verifySecretProof,+                                                      verifySignatureProof)+import           Auth.Biscuit.Datalog.AST            (Authorizer, Block)+import           Auth.Biscuit.Datalog.Executor       (ExecutionError, Limits,+                                                      defaultLimits)+import           Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess,+                                                      runAuthorizerWithLimits)+import qualified Auth.Biscuit.Proto                  as PB+import           Auth.Biscuit.ProtoBufAdapter        (Symbols, blockToPb,+                                                      commonSymbols,+                                                      extractSymbols, pbToBlock,+                                                      pbToProof,+                                                      pbToSignedBlock,+                                                      signedBlockToPb)  -- | 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) --- | A parsed biscuit-data Biscuit+-- $openOrSealed+--+-- Biscuit tokens can be /open/ (capable of being attenuated further) or+-- /sealed/ (not capable of being attenuated further). Some operations+-- like verification work on both kinds, while others (like attenuation)+-- only work on a single kind. The 'OpenOrSealed', 'Open' and 'Sealed' trio+-- represents the different possibilities. 'OpenOrSealed' is usually obtained+-- through parsing, while 'Open' is obtained by creating a new biscuit (or+-- attenuating an existing one), and 'Sealed' is obtained by sealing an open+-- biscuit++-- | This datatype represents the final proof of a biscuit, which can be either+-- /open/ or /sealed/. This is the typical state of a biscuit that's been parsed.+data OpenOrSealed+  = SealedProof Signature+  | OpenProof SecretKey+  deriving (Eq, Show)++-- | This datatype represents the final proof of a biscuit statically known to be+-- /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++-- | 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++-- | 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+-- projects 'Open' and 'Sealed' to the general 'OpenOrSealed' case.+class BiscuitProof a where+  toPossibleProofs :: a -> OpenOrSealed++instance BiscuitProof OpenOrSealed where+  toPossibleProofs = id+instance BiscuitProof Sealed where+  toPossibleProofs (Sealed sig) = SealedProof sig+instance BiscuitProof Open where+  toPossibleProofs (Open sk) = OpenProof sk++-- $verifiedOrUnverified+--+-- The default parsing mechanism for biscuits checks the signature before parsing the blocks+-- contents (this reduces the attack surface, as only biscuits with a valid signature are parsed).+-- In some cases, we still want to operate on biscuits without knowing the public key necessary+-- to check signatures (eg for inspection, or for generically adding attenuation blocks). In that+-- case, we can have parsed tokens which signatures have /not/ been verified. In order to+-- accidentally forgetting to check signatures, parsed biscuits keep track of whether the+-- signatures have been verified with a dedicated type parameter, which can be instantiated with+-- two types: 'Verified' and 'Unverified'. 'Verified' additionally keeps track of the 'PublicKey'+-- that has been used to verify the signatures.++-- | Proof that a biscuit had its signatures verified with the carried root 'PublicKey'+newtype Verified = Verified PublicKey+  deriving stock (Eq, Show)++-- | Marker that a biscuit was parsed without having its signatures verified. Such a biscuit+-- cannot be trusted yet.+data Unverified = Unverified+  deriving stock (Eq, Show)++-- | A parsed biscuit. The @proof@ type param can be one of 'Open', 'Sealed' or 'OpenOrSealed'.+-- It describes whether a biscuit is open to further attenuation, or sealed and not modifyable+-- further.+--+-- The @check@ type param can be either 'Verified' or 'Unverified' and keeps track of whether+-- the blocks signatures (and final proof) have been verified with a given root 'PublicKey'.+--+-- The constructor is not exposed in order to ensure that 'Biscuit' values can only be created+-- by trusted code paths.+data Biscuit proof check   = Biscuit-  { symbols   :: Symbols+  { rootKeyId  :: Maybe Int+  -- ^ an optional identifier for the expected public key+  , symbols    :: Symbols   -- ^ The symbols already defined in the contained blocks-  , authority :: (PublicKey, ExistingBlock)+  , authority  :: ParsedSignedBlock   -- ^ The authority block, along with the associated public key. The public key   -- is kept around since it's embedded in the serialized biscuit, but should not   -- be used for verification. An externally provided public key should be used instead.-  , blocks    :: [(PublicKey, ExistingBlock)]+  , blocks     :: [ParsedSignedBlock]   -- ^ The extra blocks, along with the public keys needed-  , signature :: Signature+  , proof      :: proof+  -- ^ The final proof allowing to check the validity of a biscuit+  , proofCheck :: check+  -- ^ A value that keeps track of whether the biscuit signatures have been verified or not.   }   deriving (Eq, Show) --- | Create a new biscuit with the provided authority block-mkBiscuit :: Keypair -> Block -> IO Biscuit-mkBiscuit keypair authority = do-  let authorityPub = publicKey keypair-      (s, authoritySerialized) = PB.encodeBlock <$> blockToPb commonSymbols 0 authority-  signature <- signBlock keypair authoritySerialized-  pure $ Biscuit { authority = (authorityPub, (authoritySerialized, authority))-                 , blocks = []-                 , symbols = commonSymbols <> s-                 , signature-                 }+-- | 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+fromOpen b@Biscuit{proof = Open p } = b { proof = OpenProof p } --- | Add a block to an existing biscuit. The block will be signed--- with a randomly-generated keypair-addBlock :: Block -> Biscuit -> IO Biscuit-addBlock newBlock b@Biscuit{..} = do-  let (s, newBlockSerialized) = PB.encodeBlock <$> blockToPb symbols (length blocks) newBlock-  keypair <- newKeypair-  newSig <- signBlock keypair newBlockSerialized-  endSig <- aggregate signature newSig-  pure $ b { blocks = blocks <> [(publicKey keypair, (newBlockSerialized, newBlock))]-           , symbols = symbols <> s-           , signature = endSig+-- | Turn a 'Biscuit' statically known to be 'Sealed' into a more generic 'OpenOrSealed' 'Biscuit'+-- (essentially /forgetting/ about the fact it's 'Sealed')+fromSealed :: Biscuit Sealed check -> Biscuit OpenOrSealed check+fromSealed b@Biscuit{proof = Sealed p } = b { proof = SealedProof p }++-- | Try to turn a 'Biscuit' that may be open or sealed into a biscuit that's statically known+-- to be 'Sealed'.+asSealed :: Biscuit OpenOrSealed check -> Maybe (Biscuit Sealed check)+asSealed b@Biscuit{proof} = case proof of+  SealedProof p -> Just $ b { proof = Sealed p }+  _             -> Nothing++-- | Try to turn a 'Biscuit' that may be open or sealed into a biscuit that's statically known+-- to be 'Open'.+asOpen :: Biscuit OpenOrSealed check -> Maybe (Biscuit Open check)+asOpen b@Biscuit{proof}   = case proof of+  OpenProof p -> Just $ b { proof = Open p }+  _           -> Nothing++toParsedSignedBlock :: Block -> SignedBlock -> ParsedSignedBlock+toParsedSignedBlock block (serializedBlock, sig, pk) = ((serializedBlock, block), sig, pk)++-- | Create a new biscuit with the provided authority block. Such a biscuit is 'Open' to+-- further attenuation.+mkBiscuit :: SecretKey -> Block -> IO (Biscuit Open Verified)+mkBiscuit sk authority = do+  let (authoritySymbols, authoritySerialized) = PB.encodeBlock <$> blockToPb commonSymbols authority+  (signedBlock, nextSk) <- signBlock sk authoritySerialized+  pure Biscuit { rootKeyId = Nothing+               , authority = toParsedSignedBlock authority signedBlock+               , blocks = []+               , symbols = commonSymbols <> authoritySymbols+               , proof = Open nextSk+               , proofCheck = Verified $ toPublic sk+               }++-- | Add a block to an existing biscuit. Only 'Open' biscuits can be attenuated; the+-- newly created biscuit is 'Open' as well.+addBlock :: Block+         -> Biscuit Open check+         -> IO (Biscuit Open check)+addBlock block b@Biscuit{..} = do+  let (blockSymbols, blockSerialized) = PB.encodeBlock <$> blockToPb symbols block+      Open p = proof+  (signedBlock, nextSk) <- signBlock p blockSerialized+  pure $ b { blocks = blocks <> [toParsedSignedBlock block signedBlock]+           , symbols = symbols <> blockSymbols+           , proof = Open nextSk            } --- | Only check a biscuit signature. This can be used to perform an early check, before--- bothering with constructing a verifier.-checkBiscuitSignature :: Biscuit -> PublicKey -> IO Bool-checkBiscuitSignature Biscuit{..} publicKey =-  let publicKeysAndMessages = (publicKey, fst $ snd authority) :| (fmap fst <$> blocks)-   in verifySignature publicKeysAndMessages signature+-- | 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+   in b { proof = newProof } --- | Errors that can happen when parsing a biscuit+-- | 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)+   in PB.encodeBlockList PB.Biscuit+        { rootKeyId = PB.putField Nothing -- TODO+        , authority = PB.putField $ toPBSignedBlock authority+        , blocks    = PB.putField $ toPBSignedBlock <$> blocks+        , proof     = PB.putField proofField+        }++toPBSignedBlock :: ParsedSignedBlock -> PB.SignedBlock+toPBSignedBlock ((block, _), sig, pk) = signedBlockToPb (block, sig, pk)++-- | 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 data ParseError   = InvalidHexEncoding   -- ^ The provided ByteString is not hex-encoded   | InvalidB64Encoding   -- ^ The provided ByteString is not base64-encoded-  | InvalidProtobufSer String+  | InvalidProtobufSer Bool String   -- ^ The provided ByteString does not contain properly serialized protobuf values-  | InvalidProtobuf String+  | InvalidProtobuf Bool String   -- ^ The bytestring was correctly deserialized from protobuf, but the values can't be turned into a proper biscuit+  | InvalidSignatures+  -- ^ The signatures were invalid+  | InvalidProof+  -- ^ The biscuit final proof was invalid+  | RevokedBiscuit+  -- ^ The biscuit has been revoked   deriving (Eq, Show) --- | Parse a biscuit from a raw bytestring.-parseBiscuit :: ByteString -> Either ParseError Biscuit-parseBiscuit bs = do-  blockList <- first InvalidProtobufSer $ PB.decodeBlockList bs-  let pbBlocks    = PB.getField $ PB.blocks    blockList-      pbKeys      = PB.getField $ PB.keys      blockList-      pbAuthority = PB.getField $ PB.authority blockList-      pbSignature = PB.getField $ PB.signature blockList-  when (length pbBlocks + 1 /= length pbKeys) $ Left (InvalidProtobufSer $ "Length mismatch " <> show (length pbBlocks, length pbKeys))-  rawAuthority <- first InvalidProtobufSer $ PB.decodeBlock pbAuthority-  rawBlocks    <- traverse (first InvalidProtobufSer . PB.decodeBlock) pbBlocks-  let s = extractSymbols commonSymbols $ rawAuthority : rawBlocks+data BiscuitWrapper+  = BiscuitWrapper+  { wAuthority :: SignedBlock+  , wBlocks    :: [SignedBlock]+  , wProof     :: OpenOrSealed+  , wRootKeyId :: Maybe Int+  } +parseBiscuitWrapper :: ByteString -> Either ParseError BiscuitWrapper+parseBiscuitWrapper bs = do+  blockList <- first (InvalidProtobufSer True) $ PB.decodeBlockList bs+  let rootKeyId = fromEnum <$> PB.getField (PB.rootKeyId blockList)+  signedAuthority <- first (InvalidProtobuf True) $ pbToSignedBlock $ PB.getField $ PB.authority blockList+  signedBlocks    <- first (InvalidProtobuf True) $ traverse pbToSignedBlock $ PB.getField $ PB.blocks blockList+  proof         <- first (InvalidProtobuf True) $ pbToProof $ PB.getField $ PB.proof blockList -  parsedAuthority <- (pbAuthority,) <$> blockFromPB s rawAuthority-  parsedBlocks    <- zip pbBlocks <$> traverse (blockFromPB s) rawBlocks-  parsedKeys      <- maybeToRight (InvalidProtobufSer "Invalid pubkeys") $ traverse parsePublicKey pbKeys-  let blocks = zip (drop 1 parsedKeys) parsedBlocks-      authority = (head parsedKeys, parsedAuthority)-      symbols = s-      signature = Signature { parameters = PB.getField $ PB.parameters pbSignature-                            , z = PB.getField $ PB.z pbSignature-                            }-  pure Biscuit{..}+  pure $ BiscuitWrapper+    { wAuthority = signedAuthority+    , wBlocks = signedBlocks+    , wProof  = either SealedProof+                       OpenProof+                       proof+    , wRootKeyId = rootKeyId+    , ..+    } --- | Serialize a biscuit to a raw bytestring-serializeBiscuit :: Biscuit -> ByteString-serializeBiscuit Biscuit{..} =-  let authorityBs = fst $ snd authority-      blocksBs = fst . snd <$> blocks-      keys = serializePublicKey . fst <$> authority : blocks-      Signature{..} = signature-      sigPb = PB.Signature-                { parameters = PB.putField parameters-                , z = PB.putField z-                }-   in PB.encodeBlockList PB.Biscuit-       { authority = PB.putField authorityBs-       , blocks    = PB.putField blocksBs-       , keys      = PB.putField keys-       , signature = PB.putField sigPb-       }+checkRevocation :: Applicative m+                => (Set ByteString -> m Bool)+                -> BiscuitWrapper+                -> m (Either ParseError BiscuitWrapper)+checkRevocation isRevoked bw@BiscuitWrapper{wAuthority,wBlocks} =+  let getRevocationId (_, sig, _) = convert sig+      revocationIds = getRevocationId <$> wAuthority :| wBlocks+      keepIfNotRevoked True  = Left RevokedBiscuit+      keepIfNotRevoked False = Right bw+   in keepIfNotRevoked <$> isRevoked (Set.fromList $ NE.toList revocationIds) --- | Parse a single block from a protobuf value-blockFromPB :: Symbols -> PB.Block -> Either ParseError Block-blockFromPB s pbBlock  = first InvalidProtobuf $ pbToBlock s pbBlock+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') --- | An error that can happen when verifying a biscuit-data VerificationError-  = SignatureError-  -- ^ The signature is invalid-  | DatalogError ExecutionError-  -- ^ The checks and policies could not be verified-  deriving (Eq, Show)+  rawAuthority <- toRawSignedBlock wAuthority+  rawBlocks    <- traverse toRawSignedBlock wBlocks --- | Given a provided verifier (a set of facts, rules, checks and policies),--- and a public key, verify a biscuit:------ - make sure the biscuit has been signed with the private key associated to the public key--- - make sure the biscuit is valid for the provided verifier-verifyBiscuitWithLimits :: Limits -> Biscuit -> Verifier -> PublicKey -> IO (Either VerificationError Query)-verifyBiscuitWithLimits l b verifier pub = runExceptT $ do-  sigCheck <- liftIO $ checkBiscuitSignature b pub-  when (not sigCheck) $ throwError SignatureError-  authorityBlock :| attBlocks <- liftIO $ getRevocationIds b-  verifResult <- liftIO $ runVerifierWithLimits l authorityBlock attBlocks verifier-  case verifResult of-    Left e  -> throwError $ DatalogError e-    Right p -> pure p+  let symbols = extractSymbols commonSymbols $ (\((_, p), _, _) -> p) <$> rawAuthority : rawBlocks --- | Same as `verifyBiscuitWithLimits`, but with default limits (1ms timeout, max 1000 facts, max 100 iterations)-verifyBiscuit :: Biscuit -> Verifier -> PublicKey -> IO (Either VerificationError Query)-verifyBiscuit = verifyBiscuitWithLimits defaultLimits+  authority <- rawSignedBlockToParsedSignedBlock symbols rawAuthority+  blocks    <- traverse (rawSignedBlockToParsedSignedBlock symbols) rawBlocks+  pure (symbols, authority :| blocks) --- | Get the components needed to compute revocation ids-getRidComponents :: (PublicKey, ExistingBlock) -> ByteString-                 -> ((ByteString, ByteString), Block)-getRidComponents (pub, (blockBs, block)) param =-  ( ( blockBs <> serializePublicKey pub-    , blockBs <> serializePublicKey pub <> param-    )-  , block-  )+-- | 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+-- its signatures. Running an 'Authorizer' is not possible without checking signatures.+-- 'checkBiscuitSignatures' allows a delayed signature check. For normal auth workflows,+-- please use 'parseWith' (or 'parse', or 'parseB64') instead, as they check signatures+-- before completely parsing the biscuit.+parseBiscuitUnverified :: ByteString -> Either ParseError (Biscuit OpenOrSealed Unverified)+parseBiscuitUnverified bs = do+  w@BiscuitWrapper{..} <- parseBiscuitWrapper bs+  (symbols, authority :| blocks) <- parseBlocks w+  pure $ Biscuit { rootKeyId = wRootKeyId+                 , proof = wProof+                 , proofCheck = Unverified+                 , .. } --- | Given revocation ids components and a block, compute the revocation ids--- and attach them to the block-mkBRID :: ((ByteString, ByteString), Block) -> IO BlockWithRevocationIds-mkBRID ((g,u), bBlock) = do-  genericRevocationId <- hashBytes g-  uniqueRevocationId  <- hashBytes u-  pure BlockWithRevocationIds{..}+parseBiscuit' :: PublicKey -> BiscuitWrapper -> Either ParseError (Biscuit OpenOrSealed Verified)+parseBiscuit' pk w@BiscuitWrapper{..} = do+  let allBlocks = wAuthority :| wBlocks+  let blocksResult = verifyBlocks allBlocks pk+  let proofResult = case wProof of+        SealedProof sig -> verifySignatureProof sig (NE.last allBlocks)+        OpenProof   sk  -> verifySecretProof sk     (NE.last allBlocks)+  when (not blocksResult || not proofResult) $ Left InvalidSignatures --- | Compute the revocation ids for a given biscuit-getRevocationIds :: Biscuit -> IO (NonEmpty BlockWithRevocationIds)-getRevocationIds Biscuit{..} = do-   params <- maybe (fail "") pure . NE.nonEmpty $ parameters signature-   let allBlocks = authority :| blocks-       blocksAndParams = NE.zipWith getRidComponents allBlocks params-       conc ((g1, u1), _) ((g2, u2), b) = ((g1 <> g2, u1 <> u2), b)-       withPreviousBlocks :: NonEmpty ((ByteString, ByteString), Block)-       withPreviousBlocks = NE.scanl1 conc blocksAndParams-   traverse mkBRID withPreviousBlocks+  (symbols, authority :| blocks) <- parseBlocks w+  pure $ Biscuit { rootKeyId = wRootKeyId+                 , proof = wProof+                 , proofCheck = Verified pk+                 , .. }++-- | Check the signatures (and final proof) of an already parsed biscuit. These checks normally+-- happen during the parsing phase, but can be delayed (or even ignored) in some cases. This+-- fuction allows to turn a 'Unverified' 'Biscuit' into a 'Verified' one after it has been parsed+-- with 'parseBiscuitUnverified'.+checkBiscuitSignatures :: BiscuitProof proof+                       => (Maybe Int -> PublicKey)+                       -> Biscuit proof Unverified+                       -> Either ParseError (Biscuit proof Verified)+checkBiscuitSignatures getPublicKey b@Biscuit{..} = do+  let pk = getPublicKey rootKeyId+      toSignedBlock ((payload, _), sig, nextPk) = (payload, sig, nextPk)+      allBlocks = toSignedBlock <$> (authority :| blocks)+      blocksResult = verifyBlocks allBlocks pk+      proofResult = case toPossibleProofs proof of+        SealedProof sig -> verifySignatureProof sig (NE.last allBlocks)+        OpenProof   sk  -> verifySecretProof sk     (NE.last allBlocks)+  when (not blocksResult || not proofResult) $ Left InvalidSignatures+  pure $ b { proofCheck = Verified pk }++-- | Biscuits can be transmitted as raw bytes, or as base64-encoded text. This datatype+-- lets the parser know about the expected encoding.+data BiscuitEncoding+  = RawBytes+  | UrlBase64++-- | Parsing a biscuit involves various steps. This data type allows configuring those steps.+data ParserConfig m+  = ParserConfig+  { encoding     :: BiscuitEncoding+  -- ^ Is the biscuit base64-encoded, or is it raw binary?+  , isRevoked    :: Set ByteString -> m Bool+  -- ^ Has one of the token blocks been revoked?+  -- 'fromRevocationList' lets you build this function from a static revocation list+  , getPublicKey :: Maybe Int -> PublicKey+  -- ^ How to select the public key based on the token 'rootKeyId'+  }++parseBiscuitWith :: Applicative m+                 => ParserConfig m+                 -> ByteString+                 -> m (Either ParseError (Biscuit OpenOrSealed Verified))+parseBiscuitWith ParserConfig{..} bs =+  let input = case encoding of+        RawBytes  -> Right bs+        UrlBase64 -> first (const InvalidB64Encoding) . B64.decodeBase64 $ bs+      parsedWrapper = parseBiscuitWrapper =<< input+      wrapperToBiscuit w@BiscuitWrapper{wRootKeyId} =+        let pk = getPublicKey wRootKeyId+         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.+getRevocationIds :: Biscuit proof check -> NonEmpty ByteString+getRevocationIds Biscuit{authority, blocks} =+  let allBlocks = authority :| blocks+      getRevocationId (_, sig, _) = convert 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++-- | Given a biscuit with a verified signature and an authorizer (a set of facts, rules, checks+-- and policies), verify a biscuit:+--+-- - all the checks declared in the biscuit and authorizer must pass+-- - an allow policy provided by the authorizer has to match (policies are tried in order)+-- - the datalog computation must happen in an alloted time, with a capped number of generated+--   facts and a capped number of iterations+--+-- checks and policies declared in the authorizer only operate on the authority block. Facts+-- declared by extra blocks cannot interfere with previous blocks.+--+-- 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 = authorizeBiscuitWithLimits defaultLimits++-- | Retrieve the `PublicKey` which was used to verify the `Biscuit` signatures+getVerifiedBiscuitPublicKey :: Biscuit a Verified -> PublicKey+getVerifiedBiscuitPublicKey Biscuit{proofCheck} =+  let Verified pk = proofCheck+   in pk

@@ -2,23 +2,28 @@  import           Test.Tasty -import qualified Spec.Crypto        as Crypto-import qualified Spec.Executor      as Executor-import qualified Spec.Parser        as Parser-import qualified Spec.Quasiquoter   as Quasiquoter-import qualified Spec.RevocationIds as RevocationIds-import qualified Spec.Roundtrip     as Roundtrip-import qualified Spec.Samples       as Samples-import qualified Spec.Verification  as Verification+import qualified Spec.Executor       as Executor+import qualified Spec.NewCrypto      as NewCrypto+import qualified Spec.Parser         as Parser+import qualified Spec.Quasiquoter    as Quasiquoter+import qualified Spec.RevocationIds  as RevocationIds+import qualified Spec.Roundtrip      as Roundtrip+import qualified Spec.SampleReader   as SampleReader+import qualified Spec.ScopedExecutor as ScopedExecutor+import qualified Spec.Verification   as Verification  main :: IO ()-main = defaultMain $ testGroup "biscuit-haskell"-  [ Crypto.specs-  , Executor.specs-  , Parser.specs-  , Quasiquoter.specs-  , RevocationIds.specs-  , Roundtrip.specs-  , Samples.specs-  , Verification.specs-  ]+main = do+  sampleReader <- SampleReader.getSpecs+  defaultMain $ testGroup "biscuit-haskell"+    [+      NewCrypto.specs+    , Executor.specs+    , Parser.specs+    , Quasiquoter.specs+    , RevocationIds.specs+    , Roundtrip.specs+    , Verification.specs+    , ScopedExecutor.specs+    , sampleReader+    ]

@@ -1,129 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{- HLINT ignore "Reduce duplication" -}-module Spec.Crypto (specs) where--import           Data.ByteString    (ByteString)-import           Data.List.NonEmpty (NonEmpty ((:|)))-import           Test.Tasty-import           Test.Tasty.HUnit--import           Auth.Biscuit-import qualified Auth.Biscuit.Sel   as Sel-import           Auth.Biscuit.Token (Biscuit (..))--specs :: TestTree-specs = testGroup "biscuit crypto"-  [ testGroup "signature algorithm"-      [ singleBlockRoundtrip-      , multiBlockRoundtrip-      , tamperedAuthority-      , tamperedBlock-      ]-  , testGroup "high-level functions"-      [ singleBlockRoundtrip'-      , multiBlockRoundtrip'-      , tamperedAuthority'-      , tamperedBlock'-      ]-  ]--singleBlockRoundtrip :: TestTree-singleBlockRoundtrip = testCase "Single block roundtrip" $ do-  rootKp <- newKeypair-  let pub = publicKey rootKp-      content = "content"-      token = (pub, content) :| []-  sig <- Sel.signBlock rootKp content-  result <- Sel.verifySignature token sig-  result @?= True--multiBlockRoundtrip :: TestTree-multiBlockRoundtrip = testCase "Multi block roundtrip" $ do-  kp' <- newKeypair-  kp <- newKeypair-  let pub = publicKey kp-      pub' = publicKey kp'-      content = "content"-      content' = "block"-      token = (pub, content) :| [(pub', content')]-  sig    <- Sel.signBlock kp content-  sig'   <- Sel.aggregate sig =<< Sel.signBlock kp' content'-  result <- Sel.verifySignature token sig'-  result @?= True--tamperedAuthority :: TestTree-tamperedAuthority = testCase "Tampered authority" $ do-  kp' <- newKeypair-  kp <- newKeypair-  let pub = publicKey kp-      pub' = publicKey kp'-      content = "content"-      content' = "block"-      token  = (pub, "modified") :| []-      token' = (pub, "modified") :| [(pub', content')]-  sig    <- Sel.signBlock kp content-  sig'   <- Sel.aggregate sig =<< Sel.signBlock kp' content'-  result <- Sel.verifySignature token sig'-  result @?= False-  result' <- Sel.verifySignature token' sig'-  result' @?= False--tamperedBlock :: TestTree-tamperedBlock = testCase "Tampered block" $ do-  kp' <- newKeypair-  kp <- newKeypair-  let pub = publicKey kp-      pub' = publicKey kp'-      content = "content"-      content' = "block"-      token = (pub, content) :| [(pub', "modified")]-  sig    <- Sel.signBlock kp content-  sig'   <- Sel.aggregate sig =<< Sel.signBlock kp' content'-  result <- Sel.verifySignature token sig'-  result @?= False--singleBlockRoundtrip' :: TestTree-singleBlockRoundtrip' = testCase "Single block roundtrip" $ do-  rootKp <- newKeypair-  let pub = publicKey rootKp-  b <- mkBiscuit rootKp [block|right(#authority,#read);|]-  result <- checkBiscuitSignature b pub-  result @?= True--multiBlockRoundtrip' :: TestTree-multiBlockRoundtrip' = testCase "Multi block roundtrip" $ do-  kp <- newKeypair-  let pub = publicKey kp-  b <- mkBiscuit kp [block|right(#authority,#read);|]-  b' <- addBlock [block|check if true;|] b-  result <- checkBiscuitSignature b' pub-  result @?= True--tamper :: (PublicKey, (ByteString, Block))-       -> (PublicKey, (ByteString, Block))-tamper (pk, (_, b)) = (pk, ("tampered", b))--tamperedAuthority' :: TestTree-tamperedAuthority' = testCase "Tampered authority" $ do-  kp <- newKeypair-  let pub = publicKey kp-  b <- mkBiscuit kp [block|right(#authority,#read);|]-  b' <- addBlock [block|check if true;|] b-  let modified = b'-        { authority = tamper $ authority b-        }-  result <- checkBiscuitSignature modified pub-  result @?= False--tamperedBlock' :: TestTree-tamperedBlock' = testCase "Tampered block" $ do-  kp <- newKeypair-  let pub = publicKey kp-  b <- mkBiscuit kp [block|right(#authority,#read);|]-  b' <- addBlock [block|check if true;|] b-  let modified = b'-        { blocks = tamper <$> blocks b-        }-  result <- checkBiscuitSignature modified pub-  result @?= False

@@ -2,16 +2,21 @@ {-# 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)+import           Data.Attoparsec.Text                (parseOnly)+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.Datalog.AST-import           Auth.Biscuit.Datalog.Executor-import           Auth.Biscuit.Datalog.Parser   (expressionParser, fact, rule)+import           Auth.Biscuit.Datalog.Executor       (ExecutionError (..),+                                                      Limits (..),+                                                      defaultLimits,+                                                      evaluateExpression)+import           Auth.Biscuit.Datalog.Parser         (expressionParser, fact,+                                                      rule)+import           Auth.Biscuit.Datalog.ScopedExecutor hiding (limits)  specs :: TestTree specs = testGroup "Datalog evaluation"@@ -29,14 +34,13 @@         { rules = Set.fromList                    [ [rule|grandparent($a,$b) <- parent($a,$c), parent($c,$b)|]                    ]-        , blockRules = mempty         , facts = Set.fromList                    [ [fact|parent("alice", "bob")|]                    , [fact|parent("bob", "jean-pierre")|]                    , [fact|parent("alice", "toto")|]                    ]         }-   in computeAllFacts defaultLimits world @?= Right (Set.fromList+   in runFactGeneration defaultLimits world @?= Right (Set.fromList         [ [fact|parent("alice", "bob")|]         , [fact|parent("bob", "jean-pierre")|]         , [fact|parent("alice", "toto")|]@@ -66,9 +70,7 @@     , ("\"test\".length()", LInteger 4)     , ("hex:ababab.length()", LInteger 3)     , ("[].length()", LInteger 0)-    , ("[#test, #test].length()", LInteger 1)-    , ("#toto == #toto", LBool True)-    , ("#toto == #truc", LBool False)+    , ("[\"test\", \"test\"].length()", LInteger 1)     , ("1 == 1", LBool True)     , ("2 == 1", LBool False)     , ("\"toto\" == \"toto\"", LBool True)@@ -119,14 +121,14 @@     , ("true || false", LBool True)     , ("false || true", LBool True)     , ("false || false", LBool False)-    , ("[#test].contains([#test])", LBool True)-    , ("[#test].contains(#test)", LBool True)-    , ("[].contains(#test)", LBool False)-    , ("[\"test\"].contains(#test)", LBool False)-    , ("[#test].intersection([#test])", TermSet (Set.fromList [Symbol "test"]))-    , ("[#test].intersection([\"test\"])", TermSet (Set.fromList []))-    , ("[#test].union([#test])", TermSet (Set.fromList [Symbol "test"]))-    , ("[#test].union([\"test\"])", TermSet (Set.fromList [Symbol "test", LString "test"]))+    , ("[1].contains([1])", LBool True)+    , ("[1].contains(1)", LBool True)+    , ("[].contains(1)", LBool False)+    , ("[\"test\"].contains(2)", LBool False)+    , ("[1].intersection([1])", TermSet (Set.fromList [LInteger 1]))+    , ("[1].intersection([\"test\"])", TermSet (Set.fromList []))+    , ("[1].union([1])", TermSet (Set.fromList [LInteger 1]))+    , ("[1].union([\"test\"])", TermSet (Set.fromList [LInteger 1, LString "test"]))     ]  exprEvalError :: TestTree@@ -147,20 +149,19 @@ rulesWithConstraints = testCase "Rule with constraints" $   let world = World         { rules = Set.fromList-                   [ [rule|valid_date("file1") <- time(#ambient, $0), resource(#ambient, "file1"), $0 <= 2019-12-04T09:46:41+00:00|]-                   , [rule|valid_date("file2") <- time(#ambient, $0), resource(#ambient, "file2"), $0 <= 2010-12-04T09:46:41+00:00|]+                   [ [rule|valid_date("file1") <- time($0), resource("file1"), $0 <= 2019-12-04T09:46:41+00:00|]+                   , [rule|valid_date("file2") <- time($0), resource("file2"), $0 <= 2010-12-04T09:46:41+00:00|]                    ]-        , blockRules = mempty         , facts = Set.fromList-                   [ [fact|time(#ambient, 2019-12-04T01:00:00Z)|]-                   , [fact|resource(#ambient, "file1")|]-                   , [fact|resource(#ambient, "file2")|]+                   [ [fact|time(2019-12-04T01:00:00Z)|]+                   , [fact|resource("file1")|]+                   , [fact|resource("file2")|]                    ]         }-   in computeAllFacts defaultLimits world @?= Right (Set.fromList-        [ [fact|time(#ambient, 2019-12-04T01:00:00Z)|]-        , [fact|resource(#ambient, "file1")|]-        , [fact|resource(#ambient, "file2")|]+   in runFactGeneration defaultLimits world @?= Right (Set.fromList+        [ [fact|time(2019-12-04T01:00:00Z)|]+        , [fact|resource("file1")|]+        , [fact|resource("file2")|]         , [fact|valid_date("file1")|]         ]) @@ -168,15 +169,14 @@ ruleHeadWithNoVars = testCase "Rule head with no variables" $   let world = World         { rules = Set.fromList-                   [ [rule|operation(#authority,#read) <- test($yolo, #nothing)|]+                   [ [rule|operation("authority", "read") <- test($yolo, "nothing")|]                    ]-        , blockRules = mempty         , facts = Set.fromList-                   [ [fact|test(#whatever, #notNothing)|]+                   [ [fact|test("whatever", "notNothing")|]                    ]         }-   in computeAllFacts defaultLimits world @?= Right (Set.fromList-        [ [fact|test(#whatever, #notNothing)|]+   in runFactGeneration defaultLimits world @?= Right (Set.fromList+        [ [fact|test("whatever", "notNothing")|]         ])  limits :: TestTree@@ -186,7 +186,6 @@                    [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|]                    , [rule|ancestor($a,$b) <- parent($a,$b)|]                    ]-        , blockRules = mempty         , facts = Set.fromList                    [ [fact|parent("alice", "bob")|]                    , [fact|parent("bob", "jean-pierre")|]@@ -198,7 +197,7 @@       iterLimits = defaultLimits { maxIterations = 2 }    in testGroup "Facts generation limits"         [ testCase "max facts" $-            computeAllFacts factLimits world @?= Left TooManyFacts+            runFactGeneration factLimits world @?= Left Facts         , testCase "max iterations" $-            computeAllFacts iterLimits world @?= Left TooManyIterations+            runFactGeneration iterLimits world @?= Left Iterations         ]

@@ -0,0 +1,212 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{- 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           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,+-- not the actual payload+data Token = Token+  { payload :: Blocks+  , privKey :: SecretKey+  }++data SealedToken = SealedToken+  { payload :: Blocks+  , sig     :: Signature+  }++signToken :: ByteString -> SecretKey -> IO Token+signToken p sk = do+  (signedBlock, privKey) <- signBlock sk p+  pure Token+    { payload = pure signedBlock+    , privKey+    }++snocNE :: NonEmpty a -> a -> NonEmpty a+snocNE (h :| t) e = h :| (t <> [e])++append :: Token -> ByteString -> IO Token+append t@Token{payload} p = do+  (signedBlock, privKey) <- signBlock (privKey t) p+  pure Token+    { payload = snocNE payload signedBlock+    , privKey+    }++seal :: Token -> SealedToken+seal Token{payload,privKey} =+  let lastBlock = NE.last payload+   in SealedToken+        { sig = getSignatureProof lastBlock privKey+        , payload+        }++verifyToken :: Token+            -> PublicKey+            -> Bool+verifyToken Token{payload, privKey} rootPk =+  let blocks = payload+      sigChecks = verifyBlocks blocks rootPk+      lastCheck = verifySecretProof privKey (NE.last payload)+  in sigChecks && lastCheck++verifySealedToken :: SealedToken+                  -> PublicKey+                  -> Bool+verifySealedToken SealedToken{payload, sig} rootPk =+  let blocks = payload+      sigChecks = verifyBlocks blocks rootPk+      lastCheck = verifySignatureProof sig (NE.last payload)+  in sigChecks && lastCheck++specs :: TestTree+specs = testGroup "new biscuit crypto"+  [ testGroup "signature algorithm - normal"+      [ singleBlockRoundtrip+      , multiBlockRoundtrip+      , tamperedAuthority+      , tamperedBlock+      , removedBlock+      ]+  , testGroup "signature algorithm - sealed"+      [ singleBlockRoundtripSealed+      , multiBlockRoundtripSealed+      , tamperedAuthoritySealed+      , tamperedBlockSealed+      , removedBlockSealed+      ]+  ]++singleBlockRoundtrip :: TestTree+singleBlockRoundtrip = testCase "Single block roundtrip" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  let res = verifyToken token pk+  res @?= True++multiBlockRoundtrip :: TestTree+multiBlockRoundtrip = testCase "Multi block roundtrip" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- append token "block1"+  let res = verifyToken attenuated pk+  res @?= True++alterPayload :: (Blocks -> Blocks)+             -> Token+             -> Token+alterPayload f Token{..} = Token { payload = f payload, ..}++tamperedAuthority :: TestTree+tamperedAuthority = testCase "Tampered authority" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- append token "block1"+  let tamper ((_, s, pk) :| o) = ("tampered", s, pk) :| o+      tampered = alterPayload tamper attenuated+  let res = verifyToken tampered pk+  res @?= False++tamperedBlock :: TestTree+tamperedBlock = testCase "Tampered block" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- append token "block1"+  let tamper (h :| ((_, s, pk): t)) = h :| (("tampered", s, pk) : t)+      tampered = alterPayload tamper attenuated+  let res = verifyToken tampered pk+  res @?= False++removedBlock :: TestTree+removedBlock = testCase "Removed block" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- append token "block1"+  let tamper (h :| _) = h :| []+      tampered = alterPayload tamper attenuated+  let res = verifyToken tampered pk+  res @?= False++singleBlockRoundtripSealed :: TestTree+singleBlockRoundtripSealed = testCase "Single block roundtrip" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- seal <$> signToken content sk+  let res = verifySealedToken token pk+  res @?= True++multiBlockRoundtripSealed :: TestTree+multiBlockRoundtripSealed = testCase "Multi block roundtrip" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- seal <$> append token "block1"+  let res = verifySealedToken attenuated pk+  res @?= True++alterPayloadSealed :: (Blocks -> Blocks)+                   -> SealedToken+                   -> SealedToken+alterPayloadSealed f SealedToken{..} = SealedToken { payload = f payload, ..}++tamperedAuthoritySealed :: TestTree+tamperedAuthoritySealed = testCase "Tampered authority" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- seal <$> append token "block1"+  let tamper ((_, s, pk) :| o) = ("tampered", s, pk) :| o+      tampered = alterPayloadSealed tamper attenuated+  let res = verifySealedToken tampered pk+  res @?= False++tamperedBlockSealed :: TestTree+tamperedBlockSealed = testCase "Tampered block" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- seal <$> append token "block1"+  let tamper (h :| ((_, s, pk): t)) = h :| (("tampered", s, pk) : t)+      tampered = alterPayloadSealed tamper attenuated+  let res = verifySealedToken tampered pk+  res @?= False++removedBlockSealed :: TestTree+removedBlockSealed = testCase "Removed block" $ do+  sk <- generateSecretKey+  let pk = toPublic sk+      content = "content"+  token <- signToken content sk+  attenuated <- seal <$> append token "block1"+  let tamper (h :| _) = h :| []+      tampered = alterPayloadSealed tamper attenuated+  let res = verifySealedToken tampered pk+  res @?= False

@@ -13,12 +13,12 @@ import           Auth.Biscuit.Datalog.Parser (checkParser, expressionParser,                                               policyParser, predicateParser,                                               ruleParser, termParser,-                                              verifierParser)+                                              authorizerParser) -parseTerm :: Text -> Either String ID+parseTerm :: Text -> Either String Term parseTerm = parseOnly termParser -parseTermQQ :: Text -> Either String QQID+parseTermQQ :: Text -> Either String QQTerm parseTermQQ = parseOnly termParser  parsePredicate :: Text -> Either String Predicate@@ -33,8 +33,8 @@ parseCheck :: Text -> Either String Check parseCheck = parseOnly checkParser -parseVerifier :: Text -> Either String Verifier-parseVerifier = parseOnly verifierParser+parseAuthorizer :: Text -> Either String Authorizer+parseAuthorizer = parseOnly authorizerParser  parsePolicy :: Text -> Either String Policy parsePolicy = parseOnly policyParser@@ -43,6 +43,7 @@ specs = testGroup "datalog parser"   [ factWithDate   , simpleFact+  , oneLetterFact   , simpleRule   , multilineRule   , termsGroup@@ -52,13 +53,12 @@   , constrainedRuleOrdering   , checkParsing   , policyParsing-  , verifierParsing+  , authorizerParsing   ]  termsGroup :: TestTree termsGroup = testGroup "Parse terms"-  [ testCase "Symbol" $ parseTerm "#ambient" @?= Right (Symbol "ambient")-  , testCase "String" $ parseTerm "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")+  [ testCase "String" $ parseTerm "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")   , testCase "Positive integer" $ parseTerm "123" @?= Right (LInteger 123)   , testCase "Negative integer" $ parseTerm "-42" @?= Right (LInteger (-42))   , testCase "Date" $ parseTerm "2019-12-02T13:49:53Z" @?=@@ -69,8 +69,7 @@  termsGroupQQ :: TestTree termsGroupQQ = testGroup "Parse terms (in a QQ setting)"-  [ testCase "Symbol" $ parseTermQQ "#ambient" @?= Right (Symbol "ambient")-  , testCase "String" $ parseTermQQ "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")+  [ testCase "String" $ parseTermQQ "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")   , testCase "Positive integer" $ parseTermQQ "123" @?= Right (LInteger 123)   , testCase "Negative integer" $ parseTermQQ "-42" @?= Right (LInteger (-42))   , testCase "Date" $ parseTermQQ "2019-12-02T13:49:53Z" @?=@@ -81,36 +80,41 @@  simpleFact :: TestTree simpleFact = testCase "Parse simple fact" $-  parsePredicate "right(#authority, \"file1\", #read)" @?=-    Right (Predicate "right" [Symbol "authority", LString "file1", Symbol "read"])+  parsePredicate "right(\"file1\", \"read\")" @?=+    Right (Predicate "right" [LString "file1", LString "read"]) +oneLetterFact :: TestTree+oneLetterFact = testCase "Parse one-letter fact" $+  parsePredicate "a(12)" @?=+    Right (Predicate "a" [LInteger 12])+ factWithDate :: TestTree factWithDate = testCase "Parse fact containing a date" $-  parsePredicate "date(#ambient,2019-12-02T13:49:53Z)" @?=-    Right (Predicate "date" [Symbol "ambient", LDate $ read "2019-12-02 13:49:53 UTC"])+  parsePredicate "date(2019-12-02T13:49:53Z)" @?=+    Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53 UTC"])  simpleRule :: TestTree simpleRule = testCase "Parse simple rule" $-  parseRule "right(#authority, $0, #read) <- resource( #ambient, $0), operation(#ambient, #read)" @?=-    Right (Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])-                [ Predicate "resource" [Symbol "ambient", Variable "0"]-                , Predicate "operation" [Symbol "ambient", Symbol "read"]+  parseRule "right($0, \"read\") <- resource( $0), operation(\"read\")" @?=+    Right (Rule (Predicate "right" [Variable "0", LString "read"])+                [ Predicate "resource" [Variable "0"]+                , Predicate "operation" [LString "read"]                 ] [])  multilineRule :: TestTree multilineRule = testCase "Parse multiline rule" $-  parseRule "right(#authority, $0, #read) <-\n resource( #ambient, $0),\n operation(#ambient, #read)" @?=-    Right (Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])-                [ Predicate "resource" [Symbol "ambient", Variable "0"]-                , Predicate "operation" [Symbol "ambient", Symbol "read"]+  parseRule "right($0, \"read\") <-\n resource( $0),\n operation(\"read\")" @?=+    Right (Rule (Predicate "right" [Variable "0", LString "read"])+                [ Predicate "resource" [Variable "0"]+                , Predicate "operation" [LString "read"]                 ] [])  constrainedRule :: TestTree constrainedRule = testCase "Parse constained rule" $-  parseRule "valid_date(\"file1\") <- time(#ambient, $0), resource(#ambient, \"file1\"), $0 <= 2019-12-04T09:46:41+00:00" @?=+  parseRule "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2019-12-04T09:46:41+00:00" @?=     Right (Rule (Predicate "valid_date" [LString "file1"])-                [ Predicate "time" [Symbol "ambient", Variable "0"]-                , Predicate "resource" [Symbol "ambient", LString "file1"]+                [ Predicate "time" [Variable "0"]+                , Predicate "resource" [LString "file1"]                 ]                 [ EBinary LessOrEqual                     (EValue $ Variable "0")@@ -119,10 +123,10 @@  constrainedRuleOrdering :: TestTree constrainedRuleOrdering = testCase "Parse constained rule (interleaved)" $-  parseRule "valid_date(\"file1\") <- time(#ambient, $0), $0 <= 2019-12-04T09:46:41+00:00, resource(#ambient, \"file1\")" @?=+  parseRule "valid_date(\"file1\") <- time($0), $0 <= 2019-12-04T09:46:41+00:00, resource(\"file1\")" @?=     Right (Rule (Predicate "valid_date" [LString "file1"])-                [ Predicate "time" [Symbol "ambient", Variable "0"]-                , Predicate "resource" [Symbol "ambient", LString "file1"]+                [ Predicate "time" [Variable "0"]+                , Predicate "resource" [LString "file1"]                 ]                 [ EBinary LessOrEqual                     (EValue $ Variable "0")@@ -223,19 +227,6 @@                     (EValue (TermSet $ Set.fromList [LString "abc", LString "def"]))                     (EValue (Variable "0"))                     ))-  , testCase "symbol set operation" $-      parseExpression "[#abc, #def].contains($0)" @?=-        Right (EBinary Contains-                 (EValue (TermSet $ Set.fromList [Symbol "abc", Symbol "def"]))-                 (EValue (Variable "0"))-                 )-  , testCase "negated symbol set operation" $-      parseExpression "![#abc, #def].contains($0)" @?=-        Right (EUnary Negate-                 (EBinary Contains-                    (EValue (TermSet $ Set.fromList [Symbol "abc", Symbol "def"]))-                    (EValue (Variable "0"))-                    ))   , operatorPrecedences   ] @@ -294,12 +285,12 @@         Right [QueryItem [] [EValue $ LBool True]]   , testCase "Multiple groups" $       parseCheck-        "check if fact(#ambient, $var), $var == true or \-        \other(#authority, $var), $var == 2" @?=+        "check if fact($var), $var == true or \+        \other($var), $var == 2" @?=           Right-            [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+            [ QueryItem [Predicate "fact" [Variable "var"]]                         [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]-            , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+            , QueryItem [Predicate "other" [Variable "var"]]                         [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]             ]   ]@@ -314,124 +305,122 @@         Right (Deny, [QueryItem [] [EValue $ LBool True]])   , testCase "Allow with multiple groups" $       parsePolicy-        "allow if fact(#ambient, $var), $var == true or \-        \other(#authority, $var), $var == 2" @?=+        "allow if fact($var), $var == true or \+        \other($var), $var == 2" @?=           Right             ( Allow-            , [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+            , [ QueryItem [Predicate "fact" [Variable "var"]]                         [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]-              , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+              , QueryItem [Predicate "other" [Variable "var"]]                           [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]               ]             )   , testCase "Deny with multiple groups" $       parsePolicy-        "deny if fact(#ambient, $var), $var == true or \-        \other(#authority, $var), $var == 2" @?=+        "deny if fact($var), $var == true or \+        \other($var), $var == 2" @?=           Right             ( Deny-            , [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+            , [ QueryItem [Predicate "fact" [Variable "var"]]                         [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]-              , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+              , QueryItem [Predicate "other" [Variable "var"]]                           [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]               ]             )   , testCase "Deny with multiple groups, multiline" $       parsePolicy         "deny if\n\-           \fact(#ambient, $var), $var == true or\n\-           \other(#authority, $var), $var == 2" @?=+           \fact($var), $var == true or\n\+           \other($var), $var == 2" @?=           Right             ( Deny-            , [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+            , [ QueryItem [Predicate "fact" [Variable "var"]]                         [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]-              , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+              , QueryItem [Predicate "other" [Variable "var"]]                           [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]               ]             )   ] -verifierParsing :: TestTree-verifierParsing = testGroup "Simple verifiers"+authorizerParsing :: TestTree+authorizerParsing = testGroup "Simple authorizers"   [ testCase "Just a deny" $-      parseVerifier "deny if true;" @?=-        Right (Verifier [(Deny, [QueryItem [] [EValue (LBool True)]])] mempty+      parseAuthorizer "deny if true;" @?=+        Right (Authorizer [(Deny, [QueryItem [] [EValue (LBool True)]])] mempty               )   , testCase "Allow and deny" $-      parseVerifier "allow if operation(#ambient, #read);\n deny if true;" @?=-        Right (Verifier-                 [  (Allow, [QueryItem [Predicate "operation" [Symbol "ambient", Symbol "read"]] []])+      parseAuthorizer "allow if operation(\"read\");\n deny if true;" @?=+        Right (Authorizer+                 [  (Allow, [QueryItem [Predicate "operation" [LString "read"]] []])                  , (Deny, [QueryItem [] [EValue (LBool True)]])                  ]                  mempty               )-  , testCase "Complete verifier" $ do+  , testCase "Complete authorizer" $ do       let spec :: Text           spec =             "// the owner has all rights\n\-            \right(#authority, $blog_id, $article_id, $operation) <-\n\-            \    article(#ambient, $blog_id, $article_id),\n\-            \    operation(#ambient, $operation),\n\-            \    user(#authority, $user_id),\n\-            \    owner(#authority, $user_id, $blog_id);\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(#authority, $blog_id, $article_id, #read) <-\n\-            \  article(#ambient, $blog_id, $article_id),\n\-            \  premium_readable(#authority, $blog_id, $article_id),\n\-            \  user(#authority, $user_id),\n\-            \  premium_user(#authority, $user_id, $blog_id);\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(#authority, $blog_id, $article_id, $operation) <-\n\-            \  article(#ambient, $blog_id, $article_id),\n\-            \  operation(#ambient, $operation),\n\-            \  user(#authority, $user_id),\n\-            \  member(#authority, $user_id, $team_id),\n\-            \  team_role(#authority, $team_id, $blog_id, #contributor),\n\-            \  [#read, #write].contains($operation);\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\             \// unauthenticated users have read access on published articles\n\             \allow if\n\-            \  operation(#ambient, #read),\n\-            \  article(#ambient, $blog_id, $article_id),\n\-            \  readable(#authority, $blog_id, $article_id);\n\+            \  operation(\"read\"),\n\+            \  article($blog_id, $article_id),\n\+            \  readable($blog_id, $article_id);\n\             \// authorize if got the rights on this blog and article\n\             \allow if\n\-            \  blog(#ambient, $blog_id),\n\-            \  article(#ambient, $blog_id, $article_id),\n\-            \  operation(#ambient, $operation),\n\-            \  right(#authority, $blog_id, $article_id, $operation);\n\+            \  blog($blog_id),\n\+            \  article($blog_id, $article_id),\n\+            \  operation($operation),\n\+            \  right($blog_id, $article_id, $operation);\n\             \// catch all rule in case the allow did not match\n\             \deny if true;\             \ "           p = Predicate-          sAuth = Symbol "authority"-          sAmb = Symbol "ambient"-          sRead = Symbol "read"-          sWrite = Symbol "write"-          sContributor = Symbol "contributor"+          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" [sAuth, vBlogId, vArticleId, vOp])-                   [ p "article" [sAmb, vBlogId, vArticleId]-                   , p "operation" [sAmb, vOp]-                   , p "user" [sAuth, vUserId]-                   , p "owner" [sAuth, vUserId, vBlogId]+            [ Rule (p "right" [vBlogId, vArticleId, vOp])+                   [ p "article" [vBlogId, vArticleId]+                   , p "operation" [vOp]+                   , p "user" [vUserId]+                   , p "owner" [vUserId, vBlogId]                    ] []-            , Rule (p "right" [sAuth, vBlogId, vArticleId, sRead])-                   [ p "article" [sAmb, vBlogId, vArticleId]-                   , p "premium_readable" [sAuth, vBlogId, vArticleId]-                   , p "user" [sAuth, vUserId]-                   , p "premium_user" [sAuth, 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" [sAuth, vBlogId, vArticleId, vOp])-                   [ p "article" [sAmb, vBlogId, vArticleId]-                   , p "operation" [sAmb, vOp]-                   , p "user" [sAuth, vUserId]-                   , p "member" [sAuth, vUserId, vTeamId]-                   , p "team_role" [sAuth, vTeamId, vBlogId, sContributor]+            , 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)]            ]@@ -439,16 +428,16 @@           bChecks = []           bContext = Nothing           vPolicies =-            [ (Allow, [QueryItem [ p "operation" [sAmb, sRead]-                                 , p "article"   [sAmb, vBlogId, vArticleId]-                                 , p "readable"  [sAuth, vBlogId, vArticleId]+            [ (Allow, [QueryItem [ p "operation" [sRead]+                                 , p "article"   [vBlogId, vArticleId]+                                 , p "readable"  [vBlogId, vArticleId]                                  ] []])-            , (Allow, [QueryItem [ p "blog" [sAmb, vBlogId]-                                 , p "article" [sAmb, vBlogId, vArticleId]-                                 , p "operation" [sAmb, vOp]-                                 , p "right" [sAuth, vBlogId, vArticleId, vOp]+            , (Allow, [QueryItem [ p "blog" [vBlogId]+                                 , p "article" [vBlogId, vArticleId]+                                 , p "operation" [vOp]+                                 , p "right" [vBlogId, vArticleId, vOp]                                  ] []])             , (Deny, [QueryItem [] [EValue (LBool True)]])             ]-      parseVerifier spec @?= Right Verifier{vBlock = Block{..}, ..}+      parseAuthorizer spec @?= Right Authorizer{vBlock = Block{..}, ..}   ]

@@ -20,21 +20,20 @@ basicFact :: TestTree basicFact = testCase "Basic fact" $   let actual :: Fact-      actual = [fact|right(#authority, "file1", #read)|]+      actual = [fact|right("file1", "read")|]    in actual @?=-    Predicate "right" [ Symbol "authority"-                      , LString "file1"-                      , Symbol "read"+    Predicate "right" [ LString "file1"+                      , LString "read"                       ]  basicRule :: TestTree basicRule = testCase "Basic rule" $   let actual :: Rule-      actual = [rule|right(#authority, $0, #read) <- resource( #ambient, $0), operation(#ambient, #read)|]+      actual = [rule|right($0, "read") <- resource( $0), operation("read")|]    in actual @?=-    Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])-         [ Predicate "resource" [Symbol "ambient", Variable "0"]-         , Predicate "operation" [Symbol "ambient", Symbol "read"]+    Rule (Predicate "right" [Variable "0", LString "read"])+         [ Predicate "resource" [Variable "0"]+         , Predicate "operation" [LString "read"]          ] []  antiquotedFact :: TestTree@@ -42,11 +41,10 @@   let toto :: Text       toto = "test"       actual :: Fact-      actual = [fact|right(#authority, ${toto}, #read)|]+      actual = [fact|right(${toto}, "read")|]    in actual @?=-    Predicate "right" [ Symbol "authority"-                      , LString "test"-                      , Symbol "read"+    Predicate "right" [ LString "test"+                      , LString "read"                       ]  antiquotedRule :: TestTree@@ -54,9 +52,9 @@   let toto :: Text       toto = "test"       actual :: Rule-      actual = [rule|right(#authority, $0, #read) <- resource( #ambient, $0), operation(#ambient, #read, ${toto})|]+      actual = [rule|right($0, "read") <- resource( $0), operation("read", ${toto})|]    in actual @?=-    Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])-         [ Predicate "resource" [Symbol "ambient", Variable "0"]-         , Predicate "operation" [Symbol "ambient", Symbol "read", LString "test"]+    Rule (Predicate "right" [Variable "0", LString "read"])+         [ Predicate "resource" [Variable "0"]+         , Predicate "operation" [LString "read", LString "test"]          ] []

@@ -1,5 +1,5 @@+{-# LANGUAGE DataKinds         #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-} module Spec.RevocationIds   ( specs   ) where@@ -7,48 +7,71 @@ import           Data.ByteString        (ByteString) import qualified Data.ByteString        as ByteString import qualified Data.ByteString.Base16 as Hex+import           Data.Functor           (void)+import           Data.List              (intersect) import qualified Data.List.NonEmpty     as NE+import           Data.Maybe             (mapMaybe) import           Test.Tasty import           Test.Tasty.HUnit  import           Auth.Biscuit-import           Auth.Biscuit.Token     (BlockWithRevocationIds (..),-                                         getRevocationIds)+import           Auth.Biscuit.Token     (getRevocationIds) -readFromFile :: FilePath -> IO Biscuit+pk :: PublicKey+pk = maybe undefined id $ parsePublicKeyHex "acdd6d5b53bfee478bf689f8e012fe7988bf755e3d7c5152947abc149bc20189"++readFromFile :: FilePath -> IO (Biscuit OpenOrSealed Verified) readFromFile path = do-  result <- parse <$> ByteString.readFile ("test/samples/" <> path)+  result <- parse pk <$> ByteString.readFile ("test/samples/v2/" <> path)   case result of     Left x  -> fail $ show x     Right b -> pure b -getHex :: Biscuit -> IO [ByteString]-getHex b = do-  let gi BlockWithRevocationIds{..} =-         Hex.encode genericRevocationId-  rids <- getRevocationIds b-  pure . NE.toList $ gi <$> rids+readFromFileCheckRevocation :: [ByteString]+                            -> FilePath+                            -> IO (Either ParseError (Biscuit OpenOrSealed Verified))+readFromFileCheckRevocation revokedIds path =+  let parser = parseWith ParserConfig { encoding = RawBytes+                                      , getPublicKey = const pk+                                      , isRevoked = fromRevocationList revokedIds+                                      }+   in parser =<< ByteString.readFile ("test/samples/v2/" <> path) +getHex :: Biscuit OpenOrSealed Verified -> [ByteString]+getHex = NE.toList . fmap Hex.encode . getRevocationIds+ specs :: TestTree specs = testGroup "Revocation ids"-  [ token1-  , token16+  [ testGroup "Computation"+      [ token1+      , token16+      ]+  , parseTimeCheck   ]  token1 :: TestTree token1 = testCase "Token 1" $ do   b <- readFromFile "test1_basic.bc"-  rids <- getHex b+  let rids = getHex b   rids @?=-    [ "596a24631a8eeec5cbc0d84fc6c22fec1a524c7367bc8926827201ddd218f4bb"-    , "dec4e0a7f817fe6c5964a18e9f0eae5564c12531b05dc4525f553570519baa87"+    [ "9d3e984bd0447eea9f31a56df51ba606160c66102063dd29410a2c85601a2139ce0cd212daf755ed0b8fe1f0e9388a89074b009b7169499e51df83c308e8d20b"+    , "5cade9fd3690b72bf90c29c529cb5b1bb50832554ba525b15c5d3f7c994814af522c5a68d61a950bc5f98d9ff4e3e20ffecef65ddaa2858251768ec999ed8b06"     ]  token16 :: TestTree token16 = testCase "Token 16" $ do   b <- readFromFile "test16_caveat_head_name.bc"-  rids <- getHex b+  let rids = getHex b   rids @?=-    [ "8f03890eeaa997cd03da71115168e41425b2be82731026225b0c5b87163e4d8e"-    , "94fff36a9fa4d4149ab1488bf4aa84ed0bab0075cc7d051270367fb9c9688795"+    [ "aa8f26e32b6a55fe99decfb0f2c229776cc30360e5b68a5b06e730f1e9a13697f87929592f37b7b58dd00dececd6fa40540a3879f74bd232505f1c419907000c"+    , "02766fa2dbb0bd5a2d4d3fc4e0dd9252ec4dc118fe5bc0eafb67fbce0ddf6a86f4db7ecc0b1da14c210b8dcae53fcfc44565edb32ba18bfc9ca9f97258c4db0d"     ]++parseTimeCheck :: TestTree+parseTimeCheck = testCase "Parse time revocation check" $ do+  let revokedIds :: [ByteString]+      revokedIds = mapMaybe fromHex [ "02766fa2dbb0bd5a2d4d3fc4e0dd9252ec4dc118fe5bc0eafb67fbce0ddf6a86f4db7ecc0b1da14c210b8dcae53fcfc44565edb32ba18bfc9ca9f97258c4db0d" ]+  res1 <- readFromFileCheckRevocation revokedIds "test16_caveat_head_name.bc"+  res1 @?= Left RevokedBiscuit+  res2 <- void <$> readFromFileCheckRevocation revokedIds "test1_basic.bc"+  res2 @?= Right ()

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds         #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-} {-# LANGUAGE RecordWildCards   #-}@@ -5,13 +6,15 @@   ( specs   ) where -import           Data.ByteString    (ByteString)-import           Data.List.NonEmpty (NonEmpty ((:|)))+import           Data.ByteString     (ByteString)+import           Data.List.NonEmpty  (NonEmpty ((:|))) import           Test.Tasty import           Test.Tasty.HUnit -import           Auth.Biscuit-import           Auth.Biscuit.Token (Biscuit (..))+import           Auth.Biscuit        hiding (Biscuit, ParseError, PublicKey,+                                      addBlock, mkBiscuit, publicKey)+import           Auth.Biscuit.Crypto+import           Auth.Biscuit.Token  specs :: TestTree specs = testGroup "Serde roundtrips"@@ -23,17 +26,15 @@       [ singleBlock    (serializeB64, parseB64)       , multipleBlocks (serializeB64, parseB64)       ]-  , testGroup "Hex serde"-      [ singleBlock    (serializeHex, parseHex)-      , multipleBlocks (serializeHex, parseHex)-      ]   , testGroup "Keys serde"-      [ private+      [ secret       , public       ]   ] -type Roundtrip = (Biscuit -> ByteString, ByteString -> Either ParseError Biscuit)+type Roundtrip = ( Biscuit Open Verified -> ByteString+                 , PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)+                 )  roundtrip :: Roundtrip           -> NonEmpty Block@@ -42,33 +43,35 @@   let addBlocks bs biscuit = case bs of         (b:rest) -> addBlocks rest =<< addBlock b biscuit         []       -> pure biscuit-  keypair <- newKeypair-  init' <- mkBiscuit keypair authority'+  sk <- generateSecretKey+  let pk = toPublic sk+  init' <- mkBiscuit sk authority'   final <- addBlocks blocks' init'   let serialized = s final-      parsed = p serialized-      getBlocks Biscuit{..} = snd (snd authority) :| (snd . snd <$> blocks)+      parsed = p pk serialized+      getBlock ((_, b), _, _) = b+      getBlocks b = getBlock <$> authority b :| blocks b   getBlocks <$> parsed @?= Right i  singleBlock :: Roundtrip -> TestTree singleBlock r = testCase "Single block" $ roundtrip r $ pure   [block|-    right(#authority, "file1", #read);-    right(#authority, "file2", #read);-    right(#authority, "file1", #write);+    right("file1", "read");+    right("file2", "read");+    right("file1", "write");   |]  multipleBlocks :: Roundtrip -> TestTree multipleBlocks r = testCase "Multiple block" $ roundtrip r $     [block|-      right(#authority, "file1", #read);-      right(#authority, "file2", #read);-      right(#authority, "file1", #write);+      right("file1", "read");+      right("file2", "read");+      right("file1", "write");     |] :|   [ [block|-      valid_date("file1") <- time(#ambient, $0), resource(#ambient, "file1"), $0 <= 2030-12-31T12:59:59+00:00;-      valid_date($1) <- time(#ambient, $0), resource(#ambient, $1), $0 <= 1999-12-31T12:59:59+00:00, !["file1"].contains($1);-      check if valid_date($0), resource(#ambient, $0);+      valid_date("file1") <- time($0), resource("file1"), $0 <= 2030-12-31T12:59:59+00:00;+      valid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59+00:00, !["file1"].contains($1);+      check if valid_date($0), resource($0);     |]   , [block|       check if true;@@ -93,43 +96,42 @@       check if 2020-12-04T09:46:41+00:00 >= 2019-12-04T09:46:41+00:00;       check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00;       check if 2020-12-04T09:46:41+00:00 == 2020-12-04T09:46:41+00:00;-      check if #abc == #abc;       check if hex:12ab == hex:12ab;       check if [1, 2].contains(2);       check if [2019-12-04T09:46:41+00:00, 2020-12-04T09:46:41+00:00].contains(2020-12-04T09:46:41+00:00);       check if [false, true].contains(true);       check if ["abc", "def"].contains("abc");       check if [hex:12ab, hex:34de].contains(hex:34de);-      check if [#hello, #world].contains(#hello);+      check if ["hello", "world"].contains("hello");     |]   , [block|       check if-        resource(#ambient, $0),-        operation(#ambient, #read),-        right(#authority, $0, #read);+        resource($0),+        operation("read"),+        right($0, "read");     |]   , [block|-      check if resource(#ambient, "file1");-      check if time(#ambient, $date), $date <= 2018-12-20T00:00:00+00:00;+      check if resource("file1");+      check if time($date), $date <= 2018-12-20T00:00:00+00:00;     |]   ] -private :: TestTree-private = testGroup "Private key serde"+secret :: TestTree+secret = testGroup "Secret key serde"   [ testCase "Raw bytes" $ do-      pk <- privateKey <$> newKeypair-      parsePrivateKey (serializePrivateKey pk) @?= Just pk+      sk <- newSecret+      parseSecretKey (serializeSecretKey sk) @?= Just sk   , testCase "Hex encoding" $ do-      pk <- privateKey <$> newKeypair-      parsePrivateKeyHex (serializePrivateKeyHex pk) @?= Just pk+      sk <- newSecret+      parseSecretKeyHex (serializeSecretKeyHex sk) @?= Just sk   ]  public :: TestTree public = testGroup "Public key serde"   [ testCase "Raw bytes" $ do-      pk <- publicKey <$> newKeypair+      pk <- toPublic <$> newSecret       parsePublicKey (serializePublicKey pk) @?= Just pk   , testCase "Hex encoding" $ do-      pk <- publicKey <$> newKeypair+      pk <- toPublic <$> newSecret       parsePublicKeyHex (serializePublicKeyHex pk) @?= Just pk   ]

@@ -0,0 +1,234 @@+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+module Spec.SampleReader where++import           Debug.Trace++import           Control.Arrow                 ((&&&))+import           Control.Monad                 (join, void, when)+import           Data.Aeson+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           Data.Foldable                 (traverse_)+import           Data.List.NonEmpty            (NonEmpty (..))+import           Data.Map.Strict               (Map)+import qualified Data.Map.Strict               as Map+import           Data.Text                     (Text, pack)+import           Data.Text.Encoding            (encodeUtf8)+import           GHC.Generics                  (Generic)++import           Test.Tasty                    hiding (Timeout)+import           Test.Tasty.HUnit++import           Auth.Biscuit+import           Auth.Biscuit.Datalog.Executor (ExecutionError (..),+                                                ResultError (..))+import           Auth.Biscuit.Datalog.Parser   (authorizerParser, blockParser)+import           Auth.Biscuit.Token++getB :: ParsedSignedBlock -> Block+getB ((_, b), _, _) = b++getAuthority :: Biscuit OpenOrSealed Verified -> Block+getAuthority = getB . authority++getBlocks :: Biscuit OpenOrSealed Verified -> [Block]+getBlocks = fmap getB . blocks++instance FromJSON SecretKey where+  parseJSON = withText "Ed25519 secret key" $ \t -> do+    let bs = encodeUtf8 t+        res = parseSecretKeyHex bs+        notSk = typeMismatch "Ed25519 secret key" (String t)+    maybe notSk pure res++instance FromJSON PublicKey where+  parseJSON = withText "Ed25519 public key" $ \t -> do+    let bs = encodeUtf8 t+        res = parsePublicKeyHex bs+        notPk = typeMismatch "Ed25519 public key" (String t)+    maybe notPk pure res++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++data SampleFile a+  = SampleFile+  { root_private_key :: SecretKey+  , root_public_key  :: PublicKey+  , testcases        :: [TestCase a]+  }+  deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable)+  deriving anyclass FromJSON++data RustResult e a+  = Err e+  | Ok a+  deriving stock (Generic, Eq, Show)++instance Bifunctor RustResult where+  bimap f g = \case+    Err e -> Err $ f e+    Ok  a -> Ok $ g a++instance (FromJSON e, FromJSON a) => FromJSON (RustResult e a) where+   parseJSON = genericParseJSON $+     defaultOptions { sumEncoding = ObjectWithSingleField }++data ValidationR+  = ValidationR+  { world           :: Maybe WorldDesc+  , result          :: RustResult [Text] Int+  , authorizer_code :: Authorizer+  } deriving stock (Eq, Show, Generic)+    deriving anyclass FromJSON+++checkResult :: Show a+            => RustResult [Text] Int+            -> Either a b+            -> Assertion+checkResult r e = case (r, e) of+  (Err es, Right _) -> assertFailure $ "Got success, but expected failure: " <> show es+  (Ok   _, Left  e) -> assertFailure $ "Expected success, but got failure: " <> show e+  _ -> pure ()+++data TestCase a+  = TestCase+  { title       :: String+  , filename    :: a+  , token       :: NonEmpty BlockDesc+  , validations :: Map String ValidationR+  }+  deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable)+  deriving anyclass FromJSON++data BlockDesc+  = BlockDesc+  { symbols :: [Text]+  , code    :: Text+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass FromJSON++data WorldDesc+  =  WorldDesc+  { facts    :: [Text]+  , rules    :: [Text]+  , checks   :: [Text]+  , policies :: [Text]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass FromJSON++readBiscuits :: SampleFile FilePath -> IO (SampleFile (FilePath, ByteString))+readBiscuits =+   traverse $ traverse (BS.readFile . ("test/samples/v2/" <>)) . join (&&&) id++readSamplesFile :: IO (SampleFile (FilePath, ByteString))+readSamplesFile = do+  Just f <- decodeFileStrict' "test/samples/v2/samples.json"+  readBiscuits f++checkTokenBlocks :: (String -> IO ())+                 -> Biscuit OpenOrSealed Verified+                 -> NonEmpty BlockDesc+                 -> Assertion+checkTokenBlocks step b blockDescs = do+  step "Checking blocks"+  let bs = getAuthority b :| getBlocks b+      expected = traverse (parseBlock . code) blockDescs+  expected @?= Right bs++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++parseErrorToRust :: ParseError -> RustResult [Text] a+parseErrorToRust = Err . pure . \case+  InvalidHexEncoding -> "todo"+  InvalidB64Encoding -> "todo"+  InvalidProtobufSer w e -> pack $ "todo " <> show w <> e+  InvalidProtobuf True "Invalid signature" -> "Format(InvalidSignatureSize(16))"+  InvalidProtobuf w e -> "todo"+  InvalidProof -> "todo"+  InvalidSignatures -> "Format(Signature(InvalidSignature(\"signature error\")))"++processFailedValidation :: (String -> IO ())+                        -> ParseError+                        -> (String, ValidationR)+                        -> Assertion+processFailedValidation step e (name, ValidationR{result}) = do+  step $ "Checking validation " <> name+  checkResult result (Left e)++execErrorToRust :: Either ExecutionError a -> RustResult [Text] Int+execErrorToRust (Right _) = Ok 0+execErrorToRust (Left e) = Err $ case e of+  Timeout                            -> ["todo"]+  TooManyFacts                       -> ["todo"]+  TooManyIterations                  -> ["todo"]+  FactsInBlocks                      -> ["todo"]+  ResultError (NoPoliciesMatched cs) -> ["todo"]+  ResultError (FailedChecks cs)      -> ["Block(FailedBlockCheck { block_id: 1, check_id: 0, rule: \"check if resource($0), operation(#read), right($0, #read)\" })"]+  ResultError (DenyRuleMatched cs q) -> ["todo"]++processValidation :: (String -> IO ())+                  -> Biscuit OpenOrSealed Verified+                  -> (String, ValidationR)+                  -> Assertion+processValidation step b (name, ValidationR{..}) = do+  when (name /= "") $ step ("Checking " <> name)+  w    <- maybe (assertFailure "missing authorizer contents") pure world+  pols <- either (assertFailure . show) pure $ parseAuthorizer $ foldMap (<> ";") (policies w)+  res <- authorizeBiscuit b (authorizer_code <> pols)+  checkResult result res++runTests :: (String -> IO ())+         -> Assertion+runTests step = do+  step "Parsing sample file"+  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)++getSpecs :: IO TestTree+getSpecs = do+  SampleFile{..} <- readSamplesFile+  pure $ testGroup "Biscuit samples - compliance checks"+       $ mkTestCase root_public_key <$> testcases

@@ -1,103 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-module Spec.Samples-  ( specs-  ) where--import qualified Data.ByteString             as ByteString-import           Test.Tasty-import           Test.Tasty.HUnit--import           Auth.Biscuit                (ParseError (..), parse)-import           Auth.Biscuit.Datalog.AST    (Block)-import           Auth.Biscuit.Datalog.Parser (block)-import           Auth.Biscuit.Token          (Biscuit (..))--readFromFile :: FilePath -> IO (Either ParseError Biscuit)-readFromFile path =-  parse <$> ByteString.readFile ("test/samples/" <> path)--getAuthority :: Biscuit -> Block-getAuthority = snd . snd . authority--getBlocks :: Biscuit -> [Block]-getBlocks = fmap (snd . snd) . blocks--specs :: TestTree-specs = testGroup "Biscuit samples"-  [ testCase "test1_basic" $ do-      result <- readFromFile "test1_basic.bc"-      getAuthority <$> result @?= Right-        [block|-          right(#authority, "file1", #read);-          right(#authority, "file2", #read);-          right(#authority, "file1", #write);-        |]-      getBlocks <$> result @?= Right-        [ [block|-            check if-              resource(#ambient, $0),-              operation(#ambient, #read),-              right(#authority, $0, #read);-          |]-        ]-  , testCase "test9_expired_token" $ do-      result <- readFromFile "test9_expired_token.bc"-      getAuthority <$> result @?= Right mempty-      getBlocks <$> result @?= Right-        [ [block|-            check if resource(#ambient, "file1");-            check if time(#ambient, $date), $date <= 2018-12-20T00:00:00+00:00;-          |]-        ]-  , testCase "test13_block_rules" $ do-      result <- readFromFile "test13_block_rules.bc"-      getAuthority <$> result @?= Right-        [block|-          right(#authority, "file1", #read);-          right(#authority, "file2", #read);-        |]-      getBlocks <$> result @?= Right-        [ [block|-            valid_date("file1") <- time(#ambient, $0), resource(#ambient, "file1"), $0 <= 2030-12-31T12:59:59+00:00;-            valid_date($1) <- time(#ambient, $0), resource(#ambient, $1), $0 <= 1999-12-31T12:59:59+00:00, !["file1"].contains($1);-            check if valid_date($0), resource(#ambient, $0);-          |]-        ]-  , testCase "test17_expressions" $ do-      result <- readFromFile "test17_expressions.bc"-      getAuthority <$> result @?= Right-        [block|-          check if true;-          check if !false;-          check if !false;-          check if false or true;-          check if 1 < 2;-          check if 2 > 1;-          check if 1 <= 2;-          check if 1 <= 1;-          check if 2 >= 1;-          check if 2 >= 2;-          check if 3 == 3;-          check if 1 + 2 * 3 - 4 / 2 == 5;-          check if "hello world".starts_with("hello") && "hello world".ends_with("world");-          check if "aaabde".matches("a*c?.e");-          check if "abcD12" == "abcD12";-          check if 2019-12-04T09:46:41+00:00 < 2020-12-04T09:46:41+00:00;-          check if 2020-12-04T09:46:41+00:00 > 2019-12-04T09:46:41+00:00;-          check if 2019-12-04T09:46:41+00:00 <= 2020-12-04T09:46:41+00:00;-          check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00;-          check if 2020-12-04T09:46:41+00:00 >= 2019-12-04T09:46:41+00:00;-          check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00;-          check if 2020-12-04T09:46:41+00:00 == 2020-12-04T09:46:41+00:00;-          check if #abc == #abc;-          check if hex:12ab == hex:12ab;-          check if [1, 2].contains(2);-          check if [2019-12-04T09:46:41+00:00, 2020-12-04T09:46:41+00:00].contains(2020-12-04T09:46:41+00:00);-          check if [false, true].contains(true);-          check if ["abc", "def"].contains("abc");-          check if [hex:12ab, hex:34de].contains(hex:34de);-          check if [#hello, #world].contains(#hello);-        |]-      getBlocks <$> result @?= Right []-  ]

@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{- HLINT ignore "Reduce duplication" -}+module Spec.ScopedExecutor (specs) where++import           Data.Attoparsec.Text                (parseOnly)+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.Datalog.AST+import           Auth.Biscuit.Datalog.Executor       (ExecutionError (..),+                                                      Limits (..),+                                                      ResultError (..),+                                                      defaultLimits)+import           Auth.Biscuit.Datalog.Parser         (authorizer, block, check,+                                                      query)+import           Auth.Biscuit.Datalog.ScopedExecutor++specs :: TestTree+specs = testGroup "Block-scoped Datalog Evaluation"+  [ authorizerOnlySeesAuthority+  , authorityOnlySeesItselfAndAuthorizer+  , block1OnlySeesAuthorityAndAuthorizer+  , block1SeesAuthorityAndAuthorizer+  , iterationCountWorks+  , maxFactsCountWorks+  , allChecksAreCollected+  , revocationIdsAreInjected+  , factsAreQueried+  ]++authorizerOnlySeesAuthority :: TestTree+authorizerOnlySeesAuthority = testCase "Authorizer only accesses facts from authority" $ do+  let authority =+       [block|+         user(1234);+       |]+      block1 =+       [block|+         is_allowed(1234, "file1", "write");+       |]+      verif =+       [authorizer|+         allow if is_allowed(1234, "file1", "write");+       |]+  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError (NoPoliciesMatched []))++authorityOnlySeesItselfAndAuthorizer :: TestTree+authorityOnlySeesItselfAndAuthorizer = testCase "Authority rules only see authority and authorizer facts" $ do+  let authority =+       [block|+         user(1234);+         is_allowed($user, $resource) <- right($user, $resource, "read");+       |]+      block1 =+       [block|+         right(1234, "file1", "read");+       |]+      verif =+       [authorizer|+         allow if is_allowed(1234, "file1");+       |]+  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError (NoPoliciesMatched []))++block1OnlySeesAuthorityAndAuthorizer :: TestTree+block1OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do+  let authority =+       [block|+         user(1234);+       |]+      block1 =+       [block|+         is_allowed($user, $resource) <- right($user, $resource, "read");+         check if is_allowed(1234, "file1");+       |]+      block2 =+       [block|+         right(1234, "file1", "read");+       |]+      verif =+       [authorizer|+         allow if true;+       |]+  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |]))++block1SeesAuthorityAndAuthorizer :: TestTree+block1SeesAuthorityAndAuthorizer = testCase "Arbitrary blocks see previous blocks" $ do+  let authority =+       [block|+         user(1234);+       |]+      block1 =+       [block|+         is_allowed($user, $resource) <- user($user), right($user, $resource, "read");+         right(1234, "file1", "read");+         check if is_allowed(1234, "file1");+       |]+      verif =+       [authorizer| allow if false;+       |]+  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError $ NoPoliciesMatched [])+++iterationCountWorks :: TestTree+iterationCountWorks = testCase "ScopedExecutions stops when hitting the iterations threshold" $ do+  let limits = defaultLimits { maxIterations = 8 }+      authority =+       [block|+         a("yolo");+         b($a) <- a($a);+         c($b) <- b($b);+         d($c) <- c($c);+         e($d) <- d($d);+         f($e) <- e($e);+         g($f) <- f($f);+       |]+      block1 =+       [block|+         h($g) <- g($g);+         i($h) <- h($h);+         j($i) <- i($i);+         k($j) <- j($j);+         l($k) <- k($k);+         m($l) <- l($l);+       |]+      verif =+       [authorizer|+         allow if true;+       |]+  runAuthorizerNoTimeout limits (authority, "") [(block1, "")] verif @?= Left TooManyIterations++maxFactsCountWorks :: TestTree+maxFactsCountWorks = testCase "ScopedExecutions stops when hitting the facts threshold" $ do+  let limits = defaultLimits { maxFacts = 8 }+      authority =+       [block|+         a("yolo");+         b($a) <- a($a);+         c($b) <- b($b);+         d($c) <- c($c);+         e($d) <- d($d);+         f($e) <- e($e);+         g($f) <- f($f);+       |]+      block1 =+       [block|+         h($g) <- g($g);+         i($h) <- h($h);+         j($i) <- i($i);+         k($j) <- j($j);+         l($k) <- k($k);+         m($l) <- l($l);+       |]+      verif =+       [authorizer|+         allow if true;+       |]+  runAuthorizerNoTimeout limits (authority, "") [(block1, "")] verif @?= Left TooManyFacts++allChecksAreCollected :: TestTree+allChecksAreCollected = testCase "ScopedExecutions collects all facts results even after a failure" $ do+  let authority =+       [block|+         user(1234);+       |]+      block1 =+       [block|+         check if false;+       |]+      block2 =+       [block|+         check if false;+       |]+      verif =+       [authorizer|+         allow if user(4567);+       |]+  runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError $ NoPoliciesMatched [[check|check if false|], [check|check if false|]])++revocationIdsAreInjected :: TestTree+revocationIdsAreInjected = testCase "ScopedExecutions injects revocation ids" $ do+  let authority =+       [block|+         user(1234);+       |]+      block1 =+       [block|yolo("block1");|]+      block2 =+       [block|yolo("block2");|]+      verif =+       [authorizer|+         check if revocation_id(0, hex:61),+                  revocation_id(1, hex:62),+                  revocation_id(2, hex:63);+       |]+  runAuthorizerNoTimeout defaultLimits (authority, "a") [(block1, "b"), (block2, "c")] 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

@@ -6,15 +6,17 @@   ) where  import           Data.List.NonEmpty            (NonEmpty ((:|)))+import qualified Data.Set                      as Set import           Test.Tasty import           Test.Tasty.HUnit  import           Auth.Biscuit-import           Auth.Biscuit.Datalog.AST      (Expression' (..), ID' (..),-                                                Query, QueryItem' (..))-import           Auth.Biscuit.Datalog.Executor (ResultError (..))+import           Auth.Biscuit.Datalog.AST      (Expression' (..), Query,+                                                QueryItem' (..), Term' (..))+import           Auth.Biscuit.Datalog.Executor (MatchedQuery (..),+                                                ResultError (..)) import qualified Auth.Biscuit.Datalog.Executor as Executor-import           Auth.Biscuit.Datalog.Parser   (check)+import           Auth.Biscuit.Datalog.Parser   (check, fact, query)  specs :: TestTree specs = testGroup "Datalog checks"@@ -25,64 +27,69 @@   , factsRestrictions   ] -ifTrue :: Query-ifTrue = [QueryItem [] [EValue $ LBool True]]+ifTrue :: MatchedQuery+ifTrue = MatchedQuery+  { matchedQuery = [query|true|]+  , bindings = Set.singleton mempty+  } -ifFalse :: Query-ifFalse = [QueryItem [] [EValue $ LBool False]]+ifFalse :: MatchedQuery+ifFalse = MatchedQuery+  { matchedQuery = [query|false|]+  , bindings = Set.singleton mempty+  } +ifFalse' :: Query+ifFalse' = matchedQuery ifFalse+ singleBlock :: TestTree singleBlock = testCase "Single block" $ do-  keypair <- newKeypair-  biscuit <- mkBiscuit keypair [block|right(#authority, "file1", #read);|]-  res <- verifyBiscuit biscuit [verifier|check if right(#authority, "file1", #read);allow if true;|] (publicKey keypair)-  res @?= Right ifTrue--resultError :: Executor.ResultError-            -> Either VerificationError a-resultError = Left . DatalogError . Executor.ResultError+  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  errorAccumulation :: TestTree errorAccumulation = testGroup "Error accumulation"   [ testCase "Only checks" $ do-      keypair <- newKeypair-      biscuit <- mkBiscuit keypair [block|check if false; check if false;|]-      res <- verifyBiscuit biscuit [verifier|allow if true;|] (publicKey keypair)-      res @?= resultError (FailedChecks $ ifFalse :| [ifFalse])+      secret <- newSecret+      biscuit <- mkBiscuit secret[block|check if false; check if false;|]+      res <- authorizeBiscuit biscuit [authorizer|allow if true;|]+      res @?= Left (ResultError $ FailedChecks $ ifFalse' :| [ifFalse'])   , testCase "Checks and deny policies" $ do-      keypair <- newKeypair-      biscuit <- mkBiscuit keypair [block|check if false; check if false;|]-      res <- verifyBiscuit biscuit [verifier|deny if true;|] (publicKey keypair)-      res @?= resultError (DenyRuleMatched [ifFalse, ifFalse] ifTrue)+      secret <- newSecret+      biscuit <- mkBiscuit secret [block|check if false; check if false;|]+      res <- authorizeBiscuit biscuit [authorizer|deny if true;|]+      res @?= Left(ResultError $ DenyRuleMatched [ifFalse', ifFalse'] ifTrue)   , testCase "Checks and no policies matched" $ do-      keypair <- newKeypair-      biscuit <- mkBiscuit keypair [block|check if false; check if false;|]-      res <- verifyBiscuit biscuit [verifier|allow if false;|] (publicKey keypair)-      res @?= resultError (NoPoliciesMatched [ifFalse, ifFalse])+      secret <- newSecret+      biscuit <- mkBiscuit secret [block|check if false; check if false;|]+      res <- authorizeBiscuit biscuit [authorizer|allow if false;|]+      res @?= Left (ResultError $ NoPoliciesMatched [ifFalse', ifFalse'])   ]  unboundVarRule :: TestTree unboundVarRule = testCase "Rule with unbound variable" $ do-  keypair <- newKeypair-  b1 <- mkBiscuit keypair [block|check if operation(#ambient, #read);|]-  b2 <- addBlock [block|operation($unbound, #read) <- operation($any1, $any2);|] b1-  res <- verifyBiscuit b2 [verifier|operation(#ambient,#write);allow if true;|] (publicKey keypair)-  res @?= Left (DatalogError $ Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation(#ambient, #read)|])+  secret <- newSecret+  b1 <- mkBiscuit secret [block|check if operation("read");|]+  b2 <- addBlock [block|operation($unbound, "read") <- operation($any1, $any2);|] b1+  res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|]+  res @?= Left (Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation("read")|])  symbolRestrictions :: TestTree symbolRestrictions = testGroup "Restricted symbols in blocks"   [ testCase "In facts" $ do-      keypair <- newKeypair-      b1 <- mkBiscuit keypair [block|check if operation(#ambient, #read);|]-      b2 <- addBlock [block|operation(#ambient, #read);|] b1-      res <- verifyBiscuit b2 [verifier|allow if true;|] (publicKey keypair)-      res @?= Left (DatalogError $ Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation(#ambient, #read)|])+      secret <- newSecret+      b1 <- mkBiscuit secret [block|check if operation("read");|]+      b2 <- addBlock [block|operation("read");|] b1+      res <- authorizeBiscuit b2 [authorizer|allow if true;|]+      res @?= Left (Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation("read")|])   , testCase "In rules" $ do-      keypair <- newKeypair-      b1 <- mkBiscuit keypair [block|check if operation(#ambient, #read);|]-      b2 <- addBlock [block|operation($ambient, #read) <- operation($ambient, $any);|] b1-      res <- verifyBiscuit b2 [verifier|operation(#ambient,#write);allow if true;|] (publicKey keypair)-      res @?= Left (DatalogError $ Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation(#ambient, #read)|])+      secret <- newSecret+      b1 <- mkBiscuit secret [block|check if operation("read");|]+      b2 <- addBlock [block|operation($ambient, "read") <- operation($ambient, $any);|] b1+      res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|]+      res @?= Left (Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation("read")|])   ]  factsRestrictions :: TestTree@@ -90,15 +97,15 @@   let limits = defaultLimits { allowBlockFacts = False }    in testGroup "No facts or rules in blocks"         [ testCase "No facts" $ do-            keypair <- newKeypair-            b1 <- mkBiscuit keypair [block|right(#read);|]-            b2 <- addBlock [block|right(#write);|] b1-            res <- verifyBiscuitWithLimits limits b2 [verifier|allow if right(#write);|] (publicKey keypair)-            res @?= Left (DatalogError $ Executor.ResultError $ Executor.NoPoliciesMatched [])+            secret <- newSecret+            b1 <- mkBiscuit secret [block|right("read");|]+            b2 <- addBlock [block|right("write");|] b1+            res <- authorizeBiscuitWithLimits limits b2 [authorizer|allow if right("write");|]+            res @?= Left (Executor.ResultError $ Executor.NoPoliciesMatched [])         , testCase "No rules" $ do-            keypair <- newKeypair-            b1 <- mkBiscuit keypair [block|right(#read);|]-            b2 <- addBlock [block|right(#write) <- right(#read);|] b1-            res <- verifyBiscuitWithLimits limits b2 [verifier|allow if right(#write);|] (publicKey keypair)-            res @?= Left (DatalogError $ Executor.ResultError $ Executor.NoPoliciesMatched [])+            secret <- newSecret+            b1 <- mkBiscuit secret [block|right("read");|]+            b2 <- addBlock [block|right("write") <- right("read");|] b1+            res <- authorizeBiscuitWithLimits limits b2 [authorizer|allow if right("write");|]+            res @?= Left (Executor.ResultError $ Executor.NoPoliciesMatched [])         ]