diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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.
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,1 +1,109 @@
-# biscuit-haskell
+# biscuit-haskell [![CI-badge][CI-badge]][CI-url] [![Hackage][hackage]][hackage-url]
+
+
+
+Main library for biscuit tokens support, providing minting and signature verification of biscuit tokens, as well as a datalog engine allowing to compute the validity of a token in a given context.
+
+## 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
diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/Bench.hs
@@ -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");|])
+ ]
+ ]
diff --git a/biscuit-haskell.cabal b/biscuit-haskell.cabal
--- a/biscuit-haskell.cabal
+++ b/biscuit-haskell.cabal
@@ -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
@@ -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
diff --git a/src/Auth/Biscuit.hs b/src/Auth/Biscuit.hs
--- a/src/Auth/Biscuit.hs
+++ b/src/Auth/Biscuit.hs
@@ -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
--
-- 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 . 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.
+
diff --git a/src/Auth/Biscuit/Crypto.hs b/src/Auth/Biscuit/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/src/Auth/Biscuit/Crypto.hs
@@ -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
diff --git a/src/Auth/Biscuit/Datalog/AST.hs b/src/Auth/Biscuit/Datalog/AST.hs
--- a/src/Auth/Biscuit/Datalog/AST.hs
+++ b/src/Auth/Biscuit/Datalog/AST.hs
@@ -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)
diff --git a/src/Auth/Biscuit/Datalog/Executor.hs b/src/Auth/Biscuit/Datalog/Executor.hs
--- a/src/Auth/Biscuit/Datalog/Executor.hs
+++ b/src/Auth/Biscuit/Datalog/Executor.hs
@@ -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')
diff --git a/src/Auth/Biscuit/Datalog/Parser.hs b/src/Auth/Biscuit/Datalog/Parser.hs
--- a/src/Auth/Biscuit/Datalog/Parser.hs
+++ b/src/Auth/Biscuit/Datalog/Parser.hs
@@ -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"
diff --git a/src/Auth/Biscuit/Datalog/ScopedExecutor.hs b/src/Auth/Biscuit/Datalog/ScopedExecutor.hs
new file mode 100644
--- /dev/null
+++ b/src/Auth/Biscuit/Datalog/ScopedExecutor.hs
@@ -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
diff --git a/src/Auth/Biscuit/Example.hs b/src/Auth/Biscuit/Example.hs
--- a/src/Auth/Biscuit/Example.hs
+++ b/src/Auth/Biscuit/Example.hs
@@ -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
diff --git a/src/Auth/Biscuit/Proto.hs b/src/Auth/Biscuit/Proto.hs
--- a/src/Auth/Biscuit/Proto.hs
+++ b/src/Auth/Biscuit/Proto.hs
@@ -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)
diff --git a/src/Auth/Biscuit/ProtoBufAdapter.hs b/src/Auth/Biscuit/ProtoBufAdapter.hs
--- a/src/Auth/Biscuit/ProtoBufAdapter.hs
+++ b/src/Auth/Biscuit/ProtoBufAdapter.hs
@@ -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
diff --git a/src/Auth/Biscuit/Sel.hs b/src/Auth/Biscuit/Sel.hs
deleted file mode 100644
--- a/src/Auth/Biscuit/Sel.hs
+++ /dev/null
@@ -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
diff --git a/src/Auth/Biscuit/Token.hs b/src/Auth/Biscuit/Token.hs
--- a/src/Auth/Biscuit/Token.hs
+++ b/src/Auth/Biscuit/Token.hs
@@ -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
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -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
+ ]
diff --git a/test/Spec/Crypto.hs b/test/Spec/Crypto.hs
deleted file mode 100644
--- a/test/Spec/Crypto.hs
+++ /dev/null
@@ -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
diff --git a/test/Spec/Executor.hs b/test/Spec/Executor.hs
--- a/test/Spec/Executor.hs
+++ b/test/Spec/Executor.hs
@@ -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
]
diff --git a/test/Spec/NewCrypto.hs b/test/Spec/NewCrypto.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec/NewCrypto.hs
@@ -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
diff --git a/test/Spec/Parser.hs b/test/Spec/Parser.hs
--- a/test/Spec/Parser.hs
+++ b/test/Spec/Parser.hs
@@ -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{..}, ..}
]
diff --git a/test/Spec/Quasiquoter.hs b/test/Spec/Quasiquoter.hs
--- a/test/Spec/Quasiquoter.hs
+++ b/test/Spec/Quasiquoter.hs
@@ -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"]
] []
diff --git a/test/Spec/RevocationIds.hs b/test/Spec/RevocationIds.hs
--- a/test/Spec/RevocationIds.hs
+++ b/test/Spec/RevocationIds.hs
@@ -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 ()
diff --git a/test/Spec/Roundtrip.hs b/test/Spec/Roundtrip.hs
--- a/test/Spec/Roundtrip.hs
+++ b/test/Spec/Roundtrip.hs
@@ -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
]
diff --git a/test/Spec/SampleReader.hs b/test/Spec/SampleReader.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec/SampleReader.hs
@@ -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
diff --git a/test/Spec/Samples.hs b/test/Spec/Samples.hs
deleted file mode 100644
--- a/test/Spec/Samples.hs
+++ /dev/null
@@ -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 []
- ]
diff --git a/test/Spec/ScopedExecutor.hs b/test/Spec/ScopedExecutor.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec/ScopedExecutor.hs
@@ -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
diff --git a/test/Spec/Verification.hs b/test/Spec/Verification.hs
--- a/test/Spec/Verification.hs
+++ b/test/Spec/Verification.hs
@@ -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 [])
]