diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,38 @@ # Changelog for biscuit-haskell +## 0.3.0.0 + +- GHC 9.2 support +- support for `v4` blocks: + - support for third-party blocks & scope annotations + - support for `check all` + - support for bitwise operations in datalog + - support for scoped queries after authorization +- new datalog parser with better error reporting +- forbid unbound variables during datalog parsing and + token deserialization +- update parameters syntax: `${name}` is now `{name}` +- support for runtime datalog parsing +- support for pre-authorization queries + +## 0.2.1.0 + +- support for string concatenation in datalog +- support for `.contains()` on strings in datalog +- update default symbol table + +## 0.2.0.1 + +- rename `verifier` to `authorizer` +- keep track of the public key used to verify a biscuit +- check revocation id during parsing +- support for sealing biscuits +- support for querying facts after authorization + +## 0.2.0.0 + +- support for v2 biscuits + ## 0.1.1.0 Bugfix for `serializeB64` and `serializeHex`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -47,7 +47,7 @@ -- verifiers are defined inline, directly in datalog, through the `verifier` -- quasiquoter. datalog parsing and validation happens at compile time, but -- can still reference haskell variables. - let authorizer' = [authorizer|time(${now}); + let authorizer' = [authorizer|time({now}); allow if true; |] -- `authorizeBiscuit` only works on valid biscuits, and runs the datalog verifications diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain 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.2.1.0 +version: 0.3.0.0 category: Security synopsis: Library support for the Biscuit security token description: Please see the README on GitHub at @@ -13,9 +13,12 @@ license: BSD3 license-file: LICENSE build-type: Simple +tested-with: GHC ==8.10.7 || == 9.0.2 || ==9.2.4 extra-source-files: README.md ChangeLog.md + test/samples/current/samples.json + test/samples/current/*.bc source-repository head type: git @@ -46,14 +49,13 @@ build-depends: base >= 4.7 && <5, async ^>= 2.2, - base16-bytestring ^>= 1.0, - bytestring ^>= 0.10, - text ^>= 1.2, + base16 ^>= 0.3, + bytestring >= 0.10 && <0.12, + text >= 1.2 && <3, containers ^>= 0.6, - cryptonite >= 0.27 && < 0.30, - memory >= 0.15 && < 0.17, - template-haskell >= 2.16 && < 2.18, - attoparsec >= 0.13 && < 0.15, + cryptonite >= 0.27 && < 0.31, + memory >= 0.15 && < 0.19, + template-haskell >= 2.16 && < 2.19, base64 ^>= 0.4, cereal ^>= 0.5, mtl ^>= 2.2, @@ -63,7 +65,8 @@ regex-tdfa ^>= 1.3, th-lift-instances ^>= 0.1, time ^>= 1.9, - validation-selective ^>= 0.1 + validation-selective ^>= 0.1, + megaparsec ^>= 9.2 default-language: Haskell2010 test-suite biscuit-haskell-test @@ -85,9 +88,8 @@ build-depends: async , aeson - , attoparsec , base >=4.7 && <5 - , base16-bytestring ^>=1.0 + , base16 ^>=0.3 , base64 , biscuit-haskell , bytestring @@ -96,6 +98,7 @@ , cryptonite , lens , lens-aeson + , megaparsec , mtl , parser-combinators , protobuf diff --git a/src/Auth/Biscuit.hs b/src/Auth/Biscuit.hs --- a/src/Auth/Biscuit.hs +++ b/src/Auth/Biscuit.hs @@ -58,6 +58,16 @@ -- ** Attenuating biscuits -- $attenuatingBiscuits , addBlock + -- ** Third-party blocks + -- $thirdPartyBlocks + , addSignedBlock + , mkThirdPartyBlockReq + , mkThirdPartyBlockReqB64 + , mkThirdPartyBlock + , mkThirdPartyBlockB64 + , applyThirdPartyBlock + , applyThirdPartyBlockB64 + -- ** Sealing biscuits -- $sealedBiscuits , seal , fromOpen @@ -75,39 +85,42 @@ , defaultLimits , ParseError (..) , ExecutionError (..) + , AuthorizedBiscuit (..) , AuthorizationSuccess (..) , MatchedQuery (..) - , query - , queryAuthorizerFacts , getBindings - , getVariableValues - , getSingleVariableValue , ToTerm (..) , FromValue (..) , Term , Term' (..) -- * Retrieving information from a biscuit + , queryAuthorizerFacts + , queryRawBiscuitFacts + , getVariableValues + , getSingleVariableValue + , query , getRevocationIds , getVerifiedBiscuitPublicKey ) where import Control.Monad ((<=<)) import Control.Monad.Identity (runIdentity) +import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Hex import qualified Data.ByteString.Base64.URL as B64 import Data.Foldable (toList) import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text, unpack) import Auth.Biscuit.Crypto (PublicKey, SecretKey, - convert, generateSecretKey, - maybeCryptoError, - publicKey, secretKey, - toPublic) + pkBytes, + readEd25519PublicKey, + readEd25519SecretKey, + skBytes, toPublic) import Auth.Biscuit.Datalog.AST (Authorizer, Block, FromValue (..), Term, Term' (..), ToTerm (..), @@ -120,17 +133,18 @@ import Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess (..), getBindings, getSingleVariableValue, - getVariableValues, - queryAuthorizerFacts) -import Auth.Biscuit.Token (Biscuit, + getVariableValues) +import Auth.Biscuit.Token (AuthorizedBiscuit (..), + Biscuit, BiscuitEncoding (..), BiscuitProof (..), Open, OpenOrSealed, ParseError (..), ParserConfig (..), Sealed, Unverified, Verified, - addBlock, asOpen, - asSealed, + addBlock, addSignedBlock, + applyThirdPartyBlock, + asOpen, asSealed, authorizeBiscuit, authorizeBiscuitWithLimits, checkBiscuitSignatures, @@ -138,14 +152,19 @@ getRevocationIds, getVerifiedBiscuitPublicKey, mkBiscuit, mkBiscuitWith, + mkThirdPartyBlock, + mkThirdPartyBlockReq, parseBiscuitUnverified, - parseBiscuitWith, seal, - serializeBiscuit) + parseBiscuitWith, + queryAuthorizerFacts, + queryRawBiscuitFacts, + seal, serializeBiscuit) +import qualified Data.Text as Text -- $biscuitOverview -- --- is a /bearer token/, +-- is a /bearer token/, -- allowing /offline attenuation/ (meaning that anyone having a token can craft a new, more -- restricted token), -- and /'PublicKey' verification/. Token rights and attenuation are expressed using a logic @@ -204,25 +223,23 @@ -- > Left e -> print e $> False -- > Right biscuit -> do -- > now <- getCurrentTime --- > let verif = [authorizer| +-- > let authorizer' = [authorizer| -- > // the datalog snippets can reference haskell variables --- > // with the ${variableName} syntax --- > time(${now}); +-- > // with the {variableName} syntax +-- > time({now}); -- > -- > // policies are tried in order. The first matching policy -- > // will decide if the token is valid or not. If no policies -- > // match, the token will fail validation -- > allow if resource("file1"); --- > // catch-all policy if the previous ones did not match --- > deny if true; -- > |] --- > result <- authorizeBiscuit biscuit [authorizer|current_time()|] +-- > result <- authorizeBiscuit biscuit authorizer' -- > case result of -- > Left e -> print e $> False -- > Right _ -> pure True --- | Build a block containing an explicit context value. --- The context of a block can't be parsed from datalog currently, +-- | Build a block containing an explicit freeform context value. +-- The context of a block can't be parsed from datalog, -- so you'll need an explicit call to `blockContext` to add it -- -- > [block|check if time($t), $t < 2021-01-01;|] @@ -232,7 +249,7 @@ -- | Decode a base16-encoded bytestring, reporting errors via `MonadFail` fromHex :: MonadFail m => ByteString -> m ByteString -fromHex = either fail pure . Hex.decode +fromHex = either (fail . Text.unpack) pure . Hex.decodeBase16 -- $keypairs -- @@ -248,23 +265,23 @@ -- | Serialize a 'SecretKey' to raw bytes, without any encoding serializeSecretKey :: SecretKey -> ByteString -serializeSecretKey = convert +serializeSecretKey = skBytes -- | Serialize a 'PublicKey' to raw bytes, without any encoding serializePublicKey :: PublicKey -> ByteString -serializePublicKey = convert +serializePublicKey = pkBytes -- | Serialize a 'SecretKey' to a hex-encoded bytestring serializeSecretKeyHex :: SecretKey -> ByteString -serializeSecretKeyHex = Hex.encode . convert +serializeSecretKeyHex = Hex.encodeBase16' . skBytes -- | Serialize a 'PublicKey' to a hex-encoded bytestring serializePublicKeyHex :: PublicKey -> ByteString -serializePublicKeyHex = Hex.encode . convert +serializePublicKeyHex = Hex.encodeBase16' . pkBytes -- | Read a 'SecretKey' from raw bytes parseSecretKey :: ByteString -> Maybe SecretKey -parseSecretKey = maybeCryptoError . secretKey +parseSecretKey = readEd25519SecretKey -- | Read a 'SecretKey' from an hex bytestring parseSecretKeyHex :: ByteString -> Maybe SecretKey @@ -272,7 +289,7 @@ -- | Read a 'PublicKey' from raw bytes parsePublicKey :: ByteString -> Maybe PublicKey -parsePublicKey = maybeCryptoError . publicKey +parsePublicKey = readEd25519PublicKey -- | Read a 'PublicKey' from an hex bytestring parsePublicKeyHex :: ByteString -> Maybe PublicKey @@ -336,6 +353,28 @@ serializeB64 :: BiscuitProof p => Biscuit p Verified -> ByteString serializeB64 = B64.encodeBase64' . serialize +-- | Generate a base64-encoded third-party block request. It can be used in +-- conjunction with 'mkThirdPartyBlockB64' to generate a base64-encoded +-- third-party block, which can be then appended to a token with +-- 'applyThirdPartyBlockB64'. +mkThirdPartyBlockReqB64 :: Biscuit Open c -> ByteString +mkThirdPartyBlockReqB64 = B64.encodeBase64' . mkThirdPartyBlockReq + +-- | Given a base64-encoded third-party block request, generate a base64-encoded +-- third-party block, which can be then appended to a token with +-- 'applyThirdPartyBlockB64'. +mkThirdPartyBlockB64 :: SecretKey -> ByteString -> Block -> Either String ByteString +mkThirdPartyBlockB64 sk reqB64 b = do + req <- first unpack $ B64.decodeBase64 reqB64 + contents <- mkThirdPartyBlock sk req b + pure $ B64.encodeBase64' contents + +-- | Given a base64-encoded third-party block, append it to a token. +applyThirdPartyBlockB64 :: Biscuit Open check -> ByteString -> Either String (IO (Biscuit Open check)) +applyThirdPartyBlockB64 b contentsB64 = do + contents <- first unpack $ B64.decodeBase64 contentsB64 + applyThirdPartyBlock b contents + -- $biscuitBlocks -- -- The core of a biscuit is its authority block. This block declares facts and rules and @@ -352,6 +391,34 @@ -- By default, biscuits can be /attenuated/. It means that any party that holds a biscuit can -- craft a new biscuit with fewer rights. A common example is taking a long-lived biscuit and -- adding a short TTL right before sending it over the wire. + +-- $thirdPartyBlocks +-- +-- Regular blocks can be added by anyone and as such can only /attenuate/ a token: the facts +-- they carry are not visible outside themselves, only their checks are evaluated. +-- +-- Third-party blocks lift this limitation by carrying an extra signature, crafted with a +-- dedicated keypair. This way, the token authorizer (as well as blocks themselves) can +-- opt-in to trust facts coming from third-party blocks signed with specific keypairs. +-- +-- For instance, adding `check if group("admin") trusting {publicKey};` to a token will +-- make it usable only if it carries a third party-block signed by the corresponding keypair, +-- and carrying a `group("admin")` fact. +-- +-- Since it is not desirable to share the token with the external entity providing the third-party +-- block, a request mechanism is available: +-- +-- - the token holder generates a /third-party block request/ from the token (it contains technical +-- information needed to generate a third-party block) with 'mkThirdPartyBlockReq'; +-- - the token holder forwards this request to the external entity; +-- - the external entity uses this request, a 'Block' value, and a 'SecretKey' to generate a third-party +-- block, with 'mkThirdPartyBlock'; +-- - the external entity sends this block back to the token holder; +-- - the token holder can now add the block to the token with 'applyThirdPartyBlock'. +-- +-- In some cases, the party holding the token is also the one who's adding the third-party block. It +-- is then possible to directly use 'addSignedBlock' to append a third-party block to the token without +-- having to go through generating a third-party block request. -- $sealedBiscuits -- diff --git a/src/Auth/Biscuit/Crypto.hs b/src/Auth/Biscuit/Crypto.hs --- a/src/Auth/Biscuit/Crypto.hs +++ b/src/Auth/Biscuit/Crypto.hs @@ -1,39 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Auth.Biscuit.Crypto ( SignedBlock , Blocks , signBlock + , signExternalBlock + , sign3rdPartyBlock , verifyBlocks , verifySecretProof , verifySignatureProof , getSignatureProof - - -- Ed25519 reexports + , verifyExternalSig , PublicKey + , pkBytes + , readEd25519PublicKey , SecretKey + , skBytes + , readEd25519SecretKey , Signature - , convert - , publicKey - , secretKey + , sigBytes , signature - , eitherCryptoError - , maybeCryptoError , generateSecretKey , toPublic + , sign ) where -import Control.Arrow ((&&&)) -import Crypto.Error (eitherCryptoError, maybeCryptoError) -import Crypto.PubKey.Ed25519 -import Data.ByteArray (convert) -import Data.ByteString (ByteString) -import Data.Int (Int32) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE +import Control.Arrow ((&&&)) +import Crypto.Error (maybeCryptoError) +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import Data.Function (on) +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (catMaybes, fromJust) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax -import qualified Auth.Biscuit.Proto as PB -import qualified Data.Serialize as PB +import qualified Auth.Biscuit.Proto as PB +import qualified Data.Serialize as PB -type SignedBlock = (ByteString, Signature, PublicKey) +newtype PublicKey = PublicKey Ed25519.PublicKey + deriving newtype (Eq, Show) + +instance Ord PublicKey where + compare = compare `on` serializePublicKey + +instance Lift PublicKey where + lift pk = [| fromJust $ readEd25519PublicKey $(lift $ pkBytes pk) |] +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = liftCode . unsafeTExpCoerce . lift +#else + liftTyped = unsafeTExpCoerce . lift +#endif + +newtype SecretKey = SecretKey Ed25519.SecretKey + deriving newtype (Eq, Show) +newtype Signature = Signature ByteString + deriving newtype (Eq, Show) + +signature :: ByteString -> Signature +signature = Signature + +sigBytes :: Signature -> ByteString +sigBytes (Signature b) = b + +readEd25519PublicKey :: ByteString -> Maybe PublicKey +readEd25519PublicKey bs = PublicKey <$> maybeCryptoError (Ed25519.publicKey bs) + +readEd25519SecretKey :: ByteString -> Maybe SecretKey +readEd25519SecretKey bs = SecretKey <$> maybeCryptoError (Ed25519.secretKey bs) + +readEd25519Signature :: Signature -> Maybe Ed25519.Signature +readEd25519Signature (Signature bs) = maybeCryptoError (Ed25519.signature bs) + +-- | Generate a public key from a secret key +toPublic :: SecretKey -> PublicKey +toPublic (SecretKey sk) = PublicKey $ Ed25519.toPublic sk + +generateSecretKey :: IO SecretKey +generateSecretKey = SecretKey <$> Ed25519.generateSecretKey + +sign :: SecretKey -> PublicKey -> ByteString -> Signature +sign (SecretKey sk) (PublicKey pk) payload = + Signature . convert $ Ed25519.sign sk pk payload + +verify :: PublicKey -> ByteString -> Signature -> Bool +verify (PublicKey pk) payload sig = + case readEd25519Signature sig of + Just sig' -> Ed25519.verify pk payload sig' + Nothing -> False + +pkBytes :: PublicKey -> ByteString +pkBytes (PublicKey pk) = convert pk + +skBytes :: SecretKey -> ByteString +skBytes (SecretKey sk) = convert sk + +type SignedBlock = (ByteString, Signature, PublicKey, Maybe (Signature, PublicKey)) type Blocks = NonEmpty SignedBlock -- | Biscuit 2.0 allows multiple signature algorithms. @@ -44,7 +114,7 @@ -- signatures, and the final signature for sealed tokens). serializePublicKey :: PublicKey -> ByteString serializePublicKey pk = - let keyBytes = convert pk + let keyBytes = pkBytes pk algId :: Int32 algId = fromIntegral $ fromEnum PB.Ed25519 -- The spec mandates that we serialize the algorithm id as a little-endian int32 @@ -53,31 +123,64 @@ signBlock :: SecretKey -> ByteString + -> Maybe (Signature, PublicKey) -> IO (SignedBlock, SecretKey) -signBlock sk payload = do +signBlock sk payload eSig = do let pk = toPublic sk (nextPk, nextSk) <- (toPublic &&& id) <$> generateSecretKey - let toSign = payload <> serializePublicKey nextPk + let toSign = getToSig (payload, (), nextPk, eSig) sig = sign sk pk toSign - pure ((payload, sig, nextPk), nextSk) + pure ((payload, sig, nextPk, eSig), nextSk) +signExternalBlock :: SecretKey + -> SecretKey + -> PublicKey + -> ByteString + -> IO (SignedBlock, SecretKey) +signExternalBlock sk eSk pk payload = + let eSig = sign3rdPartyBlock eSk pk payload + in signBlock sk payload (Just eSig) + +sign3rdPartyBlock :: SecretKey + -> PublicKey + -> ByteString + -> (Signature, PublicKey) +sign3rdPartyBlock eSk nextPk payload = + let toSign = payload <> serializePublicKey nextPk + ePk = toPublic eSk + eSig = sign eSk ePk toSign + in (eSig, ePk) + getSignatureProof :: SignedBlock -> SecretKey -> Signature -getSignatureProof (lastPayload, lastSig, lastPk) nextSecret = +getSignatureProof (lastPayload, Signature lastSig, lastPk, _todo) nextSecret = let sk = nextSecret pk = toPublic nextSecret - toSign = lastPayload <> serializePublicKey lastPk <> convert lastSig + toSign = lastPayload <> serializePublicKey lastPk <> lastSig in sign sk pk toSign -getToSig :: (ByteString, a, PublicKey) -> ByteString -getToSig (p, _, nextPk) = - p <> serializePublicKey nextPk +getToSig :: (ByteString, a, PublicKey, Maybe (Signature, PublicKey)) -> ByteString +getToSig (p, _, nextPk, ePk) = + p <> foldMap (sigBytes . fst) ePk <> serializePublicKey nextPk getSignature :: SignedBlock -> Signature -getSignature (_, sig, _) = sig +getSignature (_, sig, _, _) = sig getPublicKey :: SignedBlock -> PublicKey -getPublicKey (_, _, pk) = pk +getPublicKey (_, _, pk, _) = pk +-- | The data signed by the external key is the payload for the current block + the public key from +-- the previous block: this prevents signature reuse (the external signature cannot be used on another +-- token) +getExternalSigPayload :: PublicKey -> SignedBlock -> Maybe (PublicKey, ByteString, Signature) +getExternalSigPayload pkN (payload, _, _, Just (eSig, ePk)) = Just (ePk, payload <> serializePublicKey pkN, eSig) +getExternalSigPayload _ _ = Nothing + +-- | When adding a pre-signed third-party block to a token, we make sure the third-party block is correctly +-- signed (pk-signature match, and the third-party block is pinned to the last biscuit block) +verifyExternalSig :: PublicKey -> (ByteString, Signature, PublicKey) -> Bool +verifyExternalSig previousPk (payload, eSig, ePk) = + verify ePk (payload <> serializePublicKey previousPk) eSig + verifyBlocks :: Blocks -> PublicKey -> Bool @@ -90,17 +193,25 @@ -- key for block n is the key from block (n - 1) keys = pure rootPk <> (getPublicKey <$> blocks) keysPayloadsSigs = NE.zipWith attachKey keys (NE.zip toSigs sigs) - in all (uncurry3 verify) keysPayloadsSigs + -- external_signature(block_n) = sign(external_key_n, payload_n <> public_key_n-1) + -- so we need to pair each block with the public key carried by the previous block + -- (the authority block can't have an external signature) + previousKeys = getPublicKey <$> NE.init blocks + blocksAfterAuthority = NE.tail blocks + eKeysPayloadsESigs = catMaybes $ zipWith getExternalSigPayload previousKeys blocksAfterAuthority + in all (uncurry3 verify) keysPayloadsSigs + && all (uncurry3 verify) eKeysPayloadsESigs + verifySecretProof :: SecretKey -> SignedBlock -> Bool -verifySecretProof nextSecret (_, _, lastPk) = +verifySecretProof nextSecret (_, _, lastPk, _) = lastPk == toPublic nextSecret verifySignatureProof :: Signature -> SignedBlock -> Bool -verifySignatureProof extraSig (lastPayload, lastSig, lastPk) = - let toSign = lastPayload <> serializePublicKey lastPk <> convert lastSig +verifySignatureProof extraSig (lastPayload, Signature lastSig, lastPk, _) = + let toSign = lastPayload <> serializePublicKey lastPk <> lastSig in verify lastPk toSign extraSig diff --git a/src/Auth/Biscuit/Datalog/AST.hs b/src/Auth/Biscuit/Datalog/AST.hs --- a/src/Auth/Biscuit/Datalog/AST.hs +++ b/src/Auth/Biscuit/Datalog/AST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} @@ -6,9 +7,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -25,10 +28,13 @@ ( Binary (..) , Block + , EvalBlock , Block' (..) , BlockElement' (..) + , CheckKind (..) , Check - , Check' + , EvalCheck + , Check' (..) , Expression , Expression' (..) , Fact @@ -38,8 +44,10 @@ , Term' (..) , IsWithinSet (..) , Op (..) - , ParsedAs (..) + , DatalogContext (..) + , EvaluationContext (..) , Policy + , EvalPolicy , Policy' , PolicyType (..) , Predicate @@ -50,76 +58,143 @@ , Query' , QueryItem' (..) , Rule + , EvalRule , Rule' (..) - , RuleScope (..) + , RuleScope' (..) + , RuleScope + , EvalRuleScope , SetType , Slice (..) + , PkOrSlice (..) , SliceType + , BlockIdType , Unary (..) , Value , VariableType , Authorizer , Authorizer' (..) , AuthorizerElement' (..) + , ToEvaluation (..) + , makeRule + , makeQueryItem + , checkToEvaluation + , policyToEvaluation , elementToBlock , elementToAuthorizer + , extractVariables , fromStack , listSymbolsInBlock + , listPublicKeysInBlock + , queryHasNoScope + , queryHasNoV4Operators + , ruleHasNoScope + , ruleHasNoV4Operators + , isCheckOne , renderBlock + , renderAuthorizer , renderFact , renderRule - , toSetTerm + , valueToSetTerm , toStack + , substituteAuthorizer + , substituteBlock + , substituteCheck + , substituteExpression + , substituteFact + , substitutePolicy + , substitutePredicate + , substitutePTerm + , substituteQuery + , substituteRule + , substituteTerm ) where import Control.Applicative ((<|>)) import Control.Monad ((<=<)) import Data.ByteString (ByteString) import Data.ByteString.Base16 as Hex -import Data.Foldable (fold) +import Data.Foldable (fold, toList) +import Data.Function (on) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.String (IsString) import Data.Text (Text, intercalate, pack, unpack) -import Data.Text.Encoding (decodeUtf8) -import Data.Time (UTCTime) +import Data.Time (UTCTime, defaultTimeLocale, + formatTime) import Data.Void (Void, absurd) import Instances.TH.Lift () import Language.Haskell.TH import Language.Haskell.TH.Syntax import Numeric.Natural (Natural) +import Validation (Validation (..), failure) +import Auth.Biscuit.Crypto (PublicKey, pkBytes) + data IsWithinSet = NotWithinSet | WithinSet -data ParsedAs = RegularString | QuasiQuote +data DatalogContext + = WithSlices + -- ^ Intermediate Datalog representation, which may contain references + -- to external variables (currently, only sliced in through TemplateHaskell, + -- but it could also be done at runtime, a bit like parameter substitution in + -- SQL queries) + | Representation + -- ^ A datalog representation faithful to its text display. There are no external + -- variables, and the authorized blocks are identified through their public keys + +data EvaluationContext = Repr | Eval + data PredicateOrFact = InPredicate | InFact type family VariableType (inSet :: IsWithinSet) (pof :: PredicateOrFact) where VariableType 'NotWithinSet 'InPredicate = Text VariableType inSet pof = Void -newtype Slice = Slice String +newtype Slice = Slice Text deriving newtype (Eq, Show, Ord, IsString) instance Lift Slice where - lift (Slice name) = [| toTerm $(varE $ mkName name) |] + lift (Slice name) = [| toTerm $(varE $ mkName $ unpack name) |] #if MIN_VERSION_template_haskell(2,17,0) liftTyped = liftCode . unsafeTExpCoerce . lift #else liftTyped = unsafeTExpCoerce . lift #endif -type family SliceType (ctx :: ParsedAs) where - SliceType 'RegularString = Void - SliceType 'QuasiQuote = Slice +type family SliceType (ctx :: DatalogContext) where + SliceType 'Representation = Void + SliceType 'WithSlices = Slice -type family SetType (inSet :: IsWithinSet) (ctx :: ParsedAs) where +data PkOrSlice + = PkSlice Text + | Pk PublicKey + deriving (Eq, Show, Ord) + +instance Lift PkOrSlice where + lift (PkSlice name) = [| $(varE $ mkName $ unpack name) |] + lift (Pk pk) = [| pk |] +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = liftCode . unsafeTExpCoerce . lift +#else + liftTyped = unsafeTExpCoerce . lift +#endif + +type family SetType (inSet :: IsWithinSet) (ctx :: DatalogContext) where SetType 'NotWithinSet ctx = Set (Term' 'WithinSet 'InFact ctx) SetType 'WithinSet ctx = Void +type family BlockIdType (evalCtx :: EvaluationContext) (ctx :: DatalogContext) where + BlockIdType 'Repr 'WithSlices = PkOrSlice + BlockIdType 'Repr 'Representation = PublicKey + BlockIdType 'Eval 'Representation = (Set Natural, PublicKey) + -- | A single datalog item. -- | This can be a value, a set of items, or a slice (a value that will be injected later), -- | depending on the context -data Term' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: ParsedAs) = +data Term' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: DatalogContext) = Variable (VariableType inSet pof) -- ^ A variable (eg. @$0@) | LInteger Int @@ -133,7 +208,7 @@ | LBool Bool -- ^ A bool literal (eg. @true@) | Antiquote (SliceType ctx) - -- ^ A slice (eg. @${name}@) + -- ^ A slice (eg. @{name}@) | TermSet (SetType inSet ctx) -- ^ A set (eg. @[true, false]@) @@ -153,13 +228,13 @@ ) => Show (Term' inSet pof ctx) -- | In a regular AST, slices have already been eliminated -type Term = Term' 'NotWithinSet 'InPredicate 'RegularString --- | In an AST parsed from a QuasiQuoter, there might be references to haskell variables -type QQTerm = Term' 'NotWithinSet 'InPredicate 'QuasiQuote +type Term = Term' 'NotWithinSet 'InPredicate 'Representation +-- | In an AST parsed from a WithSlicesr, there might be references to haskell variables +type QQTerm = Term' 'NotWithinSet 'InPredicate 'WithSlices -- | A term that is not a variable -type Value = Term' 'NotWithinSet 'InFact 'RegularString +type Value = Term' 'NotWithinSet 'InFact 'Representation -- | An element of a set -type SetValue = Term' 'WithinSet 'InFact 'RegularString +type SetValue = Term' 'WithinSet 'InFact 'Representation instance ( Lift (VariableType inSet pof) , Lift (SetType inSet ctx) @@ -183,62 +258,65 @@ -- | This class describes how to turn a haskell value into a datalog value. -- | This is used when slicing a haskell variable in a datalog expression -class ToTerm t where +class ToTerm t inSet pof where -- | How to turn a value into a datalog item - toTerm :: t -> Term' inSet pof 'RegularString + toTerm :: t -> Term' inSet pof 'Representation -- | This class describes how to turn a datalog value into a regular haskell value. class FromValue t where fromValue :: Value -> Maybe t -instance ToTerm Int where +instance ToTerm Int inSet pof where toTerm = LInteger instance FromValue Int where fromValue (LInteger v) = Just v fromValue _ = Nothing -instance ToTerm Integer where +instance ToTerm Integer inSet pof where toTerm = LInteger . fromIntegral instance FromValue Integer where fromValue (LInteger v) = Just (fromIntegral v) fromValue _ = Nothing -instance ToTerm Text where +instance ToTerm Text inSet pof where toTerm = LString instance FromValue Text where fromValue (LString t) = Just t fromValue _ = Nothing -instance ToTerm Bool where +instance ToTerm Bool inSet pof where toTerm = LBool instance FromValue Bool where fromValue (LBool b) = Just b fromValue _ = Nothing -instance ToTerm ByteString where +instance ToTerm ByteString inSet pof where toTerm = LBytes instance FromValue ByteString where fromValue (LBytes bs) = Just bs fromValue _ = Nothing -instance ToTerm UTCTime where +instance ToTerm UTCTime inSet pof where toTerm = LDate instance FromValue UTCTime where fromValue (LDate t) = Just t fromValue _ = Nothing +instance (Foldable f, ToTerm a 'WithinSet 'InFact) => ToTerm (f a) 'NotWithinSet pof where + toTerm vs = TermSet . Set.fromList $ toTerm <$> toList vs + instance FromValue Value where fromValue = Just -toSetTerm :: Value - -> Maybe (Term' 'WithinSet 'InFact 'RegularString) -toSetTerm = \case +valueToSetTerm :: Value + -> Maybe (Term' 'WithinSet 'InFact 'Representation) +valueToSetTerm = \case LInteger i -> Just $ LInteger i LString i -> Just $ LString i LDate i -> Just $ LDate i @@ -248,6 +326,17 @@ Variable v -> absurd v Antiquote v -> absurd v +valueToTerm :: Value -> Term +valueToTerm = \case + LInteger i -> LInteger i + LString i -> LString i + LDate i -> LDate i + LBytes i -> LBytes i + LBool i -> LBool i + TermSet i -> TermSet i + Variable v -> absurd v + Antiquote v -> absurd v + renderId' :: (VariableType inSet pof -> Text) -> (SetType inSet ctx -> Text) -> (SliceType ctx -> Text) @@ -256,11 +345,11 @@ Variable name -> var name LInteger int -> pack $ show int LString str -> pack $ show str - LDate time -> pack $ show time - LBytes bs -> "hex:" <> decodeUtf8 (Hex.encode bs) + LDate time -> pack $ formatTime defaultTimeLocale "%FT%T%Q%Ez" time + LBytes bs -> "hex:" <> Hex.encodeBase16 bs LBool True -> "true" LBool False -> "false" - TermSet terms -> set terms -- "[" <> intercalate "," (renderInnerId <$> Set.toList terms) <> "]" + TermSet terms -> set terms Antiquote v -> slice v renderSet :: (SliceType ctx -> Text) @@ -272,7 +361,7 @@ renderId :: Term -> Text renderId = renderId' ("$" <>) (renderSet absurd) absurd -renderFactId :: Term' 'NotWithinSet 'InFact 'RegularString -> Text +renderFactId :: Term' 'NotWithinSet 'InFact 'Representation -> Text renderFactId = renderId' absurd (renderSet absurd) absurd listSymbolsInTerm :: Term -> Set.Set Text @@ -299,7 +388,7 @@ Antiquote v -> absurd v _ -> mempty -data Predicate' (pof :: PredicateOrFact) (ctx :: ParsedAs) = Predicate +data Predicate' (pof :: PredicateOrFact) (ctx :: DatalogContext) = Predicate { name :: Text , terms :: [Term' 'NotWithinSet pof ctx] } @@ -313,8 +402,8 @@ deriving instance Lift (Term' 'NotWithinSet pof ctx) => Lift (Predicate' pof ctx) -type Predicate = Predicate' 'InPredicate 'RegularString -type Fact = Predicate' 'InFact 'RegularString +type Predicate = Predicate' 'InPredicate 'Representation +type Fact = Predicate' 'InFact 'Representation renderPredicate :: Predicate -> Text renderPredicate Predicate{name,terms} = @@ -334,46 +423,105 @@ Set.singleton name <> foldMap listSymbolsInTerm terms -data QueryItem' ctx = QueryItem +data QueryItem' evalCtx ctx = QueryItem { qBody :: [Predicate' 'InPredicate ctx] , qExpressions :: [Expression' ctx] - , qScope :: Maybe RuleScope + , qScope :: Set (RuleScope' evalCtx ctx) } -type Query' ctx = [QueryItem' ctx] -type Query = Query' 'RegularString +type Query' evalCtx ctx = [QueryItem' evalCtx ctx] +type Query = Query' 'Repr 'Representation -type Check' ctx = Query' ctx -type Check = Query +queryHasNoScope :: Query -> Bool +queryHasNoScope = all (Set.null . qScope) + +queryHasNoV4Operators :: Query -> Bool +queryHasNoV4Operators = + all (all expressionHasNoV4Operators . qExpressions) + +makeQueryItem :: [Predicate' 'InPredicate ctx] + -> [Expression' ctx] + -> Set (RuleScope' 'Repr ctx) + -> Validation (NonEmpty Text) (QueryItem' 'Repr ctx) +makeQueryItem qBody qExpressions qScope = + let boundVariables = extractVariables qBody + exprVariables = foldMap extractExprVariables qExpressions + unboundVariables = exprVariables `Set.difference` boundVariables + in case nonEmpty (Set.toList unboundVariables) of + Nothing -> pure QueryItem{..} + Just vs -> Failure vs + + +data CheckKind = One | All + deriving (Eq, Show, Ord, Lift) + +data Check' evalCtx ctx = Check + { cQueries :: Query' evalCtx ctx + , cKind :: CheckKind + } +deriving instance ( Eq (QueryItem' evalCtx ctx) + ) => Eq (Check' evalCtx ctx) +deriving instance ( Ord (QueryItem' evalCtx ctx) + ) => Ord (Check' evalCtx ctx) +deriving instance ( Show (QueryItem' evalCtx ctx) + ) => Show (Check' evalCtx ctx) +deriving instance ( Lift (QueryItem' evalCtx ctx) + ) => Lift (Check' evalCtx ctx) + +type Check = Check' 'Repr 'Representation +type EvalCheck = Check' 'Eval 'Representation + +isCheckOne :: Check' evalCtx ctx -> Bool +isCheckOne Check{cKind} = cKind == One + data PolicyType = Allow | Deny deriving (Eq, Show, Ord, Lift) -type Policy' ctx = (PolicyType, Query' ctx) -type Policy = (PolicyType, Query) +type Policy' evalCtx ctx = (PolicyType, Query' evalCtx ctx) +type Policy = Policy' 'Repr 'Representation +type EvalPolicy = Policy' 'Eval 'Representation deriving instance ( Eq (Predicate' 'InPredicate ctx) , Eq (Expression' ctx) - ) => Eq (QueryItem' ctx) + , Eq (RuleScope' evalCtx ctx) + ) => Eq (QueryItem' evalCtx ctx) deriving instance ( Ord (Predicate' 'InPredicate ctx) , Ord (Expression' ctx) - ) => Ord (QueryItem' ctx) + , Ord (RuleScope' evalCtx ctx) + ) => Ord (QueryItem' evalCtx ctx) deriving instance ( Show (Predicate' 'InPredicate ctx) , Show (Expression' ctx) - ) => Show (QueryItem' ctx) + , Show (RuleScope' evalCtx ctx) + ) => Show (QueryItem' evalCtx ctx) +deriving instance ( Lift (Predicate' 'InPredicate ctx) + , Lift (Expression' ctx) + , Lift (RuleScope' evalCtx ctx) + ) => Lift (QueryItem' evalCtx ctx) -deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (QueryItem' ctx) +renderPolicy :: Policy -> Text +renderPolicy (pType, query) = + let prefix = case pType of + Allow -> "allow if " + Deny -> "deny if " + in prefix <> intercalate " or \n" (renderQueryItem <$> query) <> ";" -renderQueryItem :: QueryItem' 'RegularString -> Text +renderQueryItem :: QueryItem' 'Repr 'Representation -> Text renderQueryItem QueryItem{..} = - intercalate ",\n" $ fold + intercalate ",\n" (fold [ renderPredicate <$> qBody , renderExpression <$> qExpressions - ] + ]) + <> if null qScope then "" + else " trusting " <> renderRuleScope qScope renderCheck :: Check -> Text -renderCheck is = "check if " <> - intercalate "\n or " (renderQueryItem <$> is) +renderCheck Check{..} = + let kindToken = case cKind of + One -> "if" + All -> "all" + in "check " <> kindToken <> " " <> + intercalate "\n or " (renderQueryItem <$> cQueries) -listSymbolsInQueryItem :: QueryItem' 'RegularString -> Set.Set Text +listSymbolsInQueryItem :: QueryItem' evalCtx 'Representation -> Set.Set Text listSymbolsInQueryItem QueryItem{..} = Set.singleton "query" -- query items are serialized as `Rule`s -- so an empty rule head is added: `query()` @@ -384,46 +532,124 @@ listSymbolsInCheck :: Check -> Set.Set Text listSymbolsInCheck = - foldMap listSymbolsInQueryItem + foldMap listSymbolsInQueryItem . cQueries -data RuleScope = +listPublicKeysInQueryItem :: QueryItem' 'Repr 'Representation -> Set.Set PublicKey +listPublicKeysInQueryItem QueryItem{qScope} = + listPublicKeysInScope qScope + +listPublicKeysInCheck :: Check -> Set.Set PublicKey +listPublicKeysInCheck = foldMap listPublicKeysInQueryItem . cQueries + +type RuleScope = RuleScope' 'Repr 'Representation +type EvalRuleScope = RuleScope' 'Eval 'Representation + +data RuleScope' (evalCtx :: EvaluationContext) (ctx :: DatalogContext) = OnlyAuthority | Previous - | UnsafeAny - | OnlyBlocks (Set Natural) - deriving (Eq, Ord, Show, Lift) + | BlockId (BlockIdType evalCtx ctx) -data Rule' ctx = Rule +deriving instance Eq (BlockIdType evalCtx ctx) => Eq (RuleScope' evalCtx ctx) +deriving instance Ord (BlockIdType evalCtx ctx) => Ord (RuleScope' evalCtx ctx) +deriving instance Show (BlockIdType evalCtx ctx) => Show (RuleScope' evalCtx ctx) +deriving instance Lift (BlockIdType evalCtx ctx) => Lift (RuleScope' evalCtx ctx) + +listPublicKeysInScope :: Set.Set RuleScope -> Set.Set PublicKey +listPublicKeysInScope = foldMap $ + \case BlockId pk -> Set.singleton pk + _ -> Set.empty + + +data Rule' evalCtx ctx = Rule { rhead :: Predicate' 'InPredicate ctx , body :: [Predicate' 'InPredicate ctx] , expressions :: [Expression' ctx] - , scope :: Maybe RuleScope + , scope :: Set (RuleScope' evalCtx ctx) } deriving instance ( Eq (Predicate' 'InPredicate ctx) , Eq (Expression' ctx) - ) => Eq (Rule' ctx) + , Eq (RuleScope' evalCtx ctx) + ) => Eq (Rule' evalCtx ctx) deriving instance ( Ord (Predicate' 'InPredicate ctx) , Ord (Expression' ctx) - ) => Ord (Rule' ctx) + , Ord (RuleScope' evalCtx ctx) + ) => Ord (Rule' evalCtx ctx) deriving instance ( Show (Predicate' 'InPredicate ctx) , Show (Expression' ctx) - ) => Show (Rule' ctx) + , Show (RuleScope' evalCtx ctx) + ) => Show (Rule' evalCtx ctx) +deriving instance ( Lift (Predicate' 'InPredicate ctx) + , Lift (Expression' ctx) + , Lift (RuleScope' evalCtx ctx) + ) => Lift (Rule' evalCtx ctx) -type Rule = Rule' 'RegularString +type Rule = Rule' 'Repr 'Representation +type EvalRule = Rule' 'Eval 'Representation -deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (Rule' ctx) +ruleHasNoScope :: Rule -> Bool +ruleHasNoScope Rule{scope} = Set.null scope -renderRule :: Rule' 'RegularString -> Text -renderRule Rule{rhead,body,expressions} = - renderPredicate rhead <> " <- " <> intercalate ", " (fmap renderPredicate body <> fmap renderExpression expressions) +expressionHasNoV4Operators :: Expression -> Bool +expressionHasNoV4Operators = \case + EBinary BitwiseAnd _ _ -> False + EBinary BitwiseOr _ _ -> False + EBinary BitwiseXor _ _ -> False + EBinary _ l r -> expressionHasNoV4Operators l && expressionHasNoV4Operators r + _ -> True +ruleHasNoV4Operators :: Rule -> Bool +ruleHasNoV4Operators Rule{expressions} = + all expressionHasNoV4Operators expressions + +renderRule :: Rule -> Text +renderRule Rule{rhead,body,expressions,scope} = + renderPredicate rhead <> " <- " + <> intercalate ", " (fmap renderPredicate body <> fmap renderExpression expressions) + <> if null scope then "" + else " trusting " <> renderRuleScope scope + listSymbolsInRule :: Rule -> Set.Set Text listSymbolsInRule Rule{..} = listSymbolsInPredicate rhead <> foldMap listSymbolsInPredicate body <> foldMap listSymbolsInExpression expressions +listPublicKeysInRule :: Rule -> Set.Set PublicKey +listPublicKeysInRule Rule{scope} = listPublicKeysInScope scope + +extractVariables :: [Predicate' 'InPredicate ctx] -> Set Text +extractVariables predicates = + let keepVariable = \case + Variable name -> Just name + _ -> Nothing + extractVariables' Predicate{terms} = mapMaybe keepVariable terms + in Set.fromList $ extractVariables' =<< predicates + +extractExprVariables :: Expression' ctx -> Set Text +extractExprVariables = + let keepVariable = \case + Variable name -> Set.singleton name + _ -> Set.empty + in \case + EValue t -> keepVariable t + EUnary _ e -> extractExprVariables e + EBinary _ e e' -> ((<>) `on` extractExprVariables) e e' + +makeRule :: Predicate' 'InPredicate ctx + -> [Predicate' 'InPredicate ctx] + -> [Expression' ctx] + -> Set (RuleScope' 'Repr ctx) + -> Validation (NonEmpty Text) (Rule' 'Repr ctx) +makeRule rhead body expressions scope = + let boundVariables = extractVariables body + exprVariables = foldMap extractExprVariables expressions + headVariables = extractVariables [rhead] + unboundVariables = (headVariables `Set.union` exprVariables) `Set.difference` boundVariables + in case nonEmpty (Set.toList unboundVariables) of + Nothing -> pure Rule{..} + Just vs -> Failure vs + data Unary = Negate | Parens @@ -448,9 +674,12 @@ | Or | Intersection | Union + | BitwiseAnd + | BitwiseOr + | BitwiseXor deriving (Eq, Ord, Show, Lift) -data Expression' (ctx :: ParsedAs) = +data Expression' (ctx :: DatalogContext) = EValue (Term' 'NotWithinSet 'InPredicate ctx) | EUnary Unary (Expression' ctx) | EBinary Binary (Expression' ctx) (Expression' ctx) @@ -460,7 +689,7 @@ deriving instance Lift (Term' 'NotWithinSet 'InPredicate ctx) => Lift (Expression' ctx) deriving instance Show (Term' 'NotWithinSet 'InPredicate ctx) => Show (Expression' ctx) -type Expression = Expression' 'RegularString +type Expression = Expression' 'Representation listSymbolsInExpression :: Expression -> Set.Set Text listSymbolsInExpression = \case @@ -526,6 +755,9 @@ EBinary Div e e' -> rOp "/" e e' EBinary And e e' -> rOp "&&" e e' EBinary Or e e' -> rOp "||" e e' + EBinary BitwiseAnd e e' -> rOp "&" e e' + EBinary BitwiseOr e e' -> rOp "|" e e' + EBinary BitwiseXor e e' -> rOp "^" e e' -- | A biscuit block, containing facts, rules and checks. -- @@ -533,132 +765,366 @@ -- to build composite blocks (eg if you need to generate a list of facts): -- -- > -- build a block from multiple variables v1, v2, v3 --- > [block| value(${v1}); |] <> --- > [block| value(${v2}); |] <> --- > [block| value(${v3}); |] -type Block = Block' 'RegularString +-- > [block| value({v1}); |] <> +-- > [block| value({v2}); |] <> +-- > [block| value({v3}); |] +type Block = Block' 'Repr 'Representation +type EvalBlock = Block' 'Eval 'Representation -- | A biscuit block, that may or may not contain slices referencing -- haskell variables -data Block' (ctx :: ParsedAs) = Block - { bRules :: [Rule' ctx] +data Block' (evalCtx :: EvaluationContext) (ctx :: DatalogContext) = Block + { bRules :: [Rule' evalCtx ctx] , bFacts :: [Predicate' 'InFact ctx] - , bChecks :: [Check' ctx] + , bChecks :: [Check' evalCtx ctx] , bContext :: Maybe Text - , bScope :: Maybe RuleScope + , bScope :: Set (RuleScope' evalCtx ctx) } -renderBlock :: Block -> Text -renderBlock Block{..} = - intercalate ";\n" $ fold - [ renderRule <$> bRules - , renderFact <$> bFacts - , renderCheck <$> bChecks - ] - deriving instance ( Eq (Predicate' 'InFact ctx) - , Eq (Rule' ctx) - , Eq (QueryItem' ctx) - ) => Eq (Block' ctx) + , Eq (Rule' evalCtx ctx) + , Eq (QueryItem' evalCtx ctx) + , Eq (RuleScope' evalCtx ctx) + ) => Eq (Block' evalCtx ctx) +deriving instance ( Lift (Predicate' 'InFact ctx) + , Lift (Rule' evalCtx ctx) + , Lift (QueryItem' evalCtx ctx) + , Lift (RuleScope' evalCtx ctx) + ) => Lift (Block' evalCtx ctx) --- deriving instance ( Show (Predicate' 'InFact ctx) --- , Show (Rule' ctx) --- , Show (QueryItem' ctx) --- ) => Show (Block' ctx) instance Show Block where show = unpack . renderBlock -deriving instance ( Lift (Predicate' 'InFact ctx) - , Lift (Rule' ctx) - , Lift (QueryItem' ctx) - ) => Lift (Block' ctx) - -instance Semigroup (Block' ctx) where +instance Semigroup (Block' evalCtx ctx) where b1 <> b2 = Block { bRules = bRules b1 <> bRules b2 , bFacts = bFacts b1 <> bFacts b2 , bChecks = bChecks b1 <> bChecks b2 , bContext = bContext b2 <|> bContext b1 - , bScope = bScope b1 <|> bScope b2 + -- `trusting` declarations in blocks override + -- each other, they don't accumulate + , bScope = if null (bScope b1) + then bScope b2 + else bScope b1 } -instance Monoid (Block' ctx) where +instance Monoid (Block' evalCtx ctx) where mempty = Block { bRules = [] , bFacts = [] , bChecks = [] , bContext = Nothing - , bScope = Nothing + , bScope = Set.empty } -listSymbolsInBlock :: Block' 'RegularString -> Set.Set Text +renderRuleScope :: Set RuleScope -> Text +renderRuleScope = + let renderScopeElem = \case + OnlyAuthority -> "authority" + Previous -> "previous" + BlockId bs -> "ed25519/" <> Hex.encodeBase16 (pkBytes bs) + in intercalate ", " . Set.toList . Set.map renderScopeElem + +renderBlock :: Block -> Text +renderBlock Block{..} = + let renderScopeLine = ("trusting " <>) . renderRuleScope + in foldMap (<> ";\n") $ fold + [ [renderScopeLine bScope | not (null bScope)] + , renderRule <$> bRules + , renderFact <$> bFacts + , renderCheck <$> bChecks + ] + +listSymbolsInBlock :: Block -> Set.Set Text listSymbolsInBlock Block {..} = fold [ foldMap listSymbolsInRule bRules , foldMap listSymbolsInFact bFacts , foldMap listSymbolsInCheck bChecks ] +listPublicKeysInBlock :: Block -> Set.Set PublicKey +listPublicKeysInBlock Block{..} = fold + [ foldMap listPublicKeysInRule bRules + , foldMap listPublicKeysInCheck bChecks + , listPublicKeysInScope bScope + ] + -- | A biscuit authorizer, containing, facts, rules, checks and policies -type Authorizer = Authorizer' 'RegularString +type Authorizer = Authorizer' 'Repr 'Representation -- | The context in which a biscuit policies and checks are verified. -- A authorizer may add policies (`deny if` / `allow if` conditions), as well as rules, facts, and checks. -- A authorizer may or may not contain slices referencing haskell variables. -data Authorizer' (ctx :: ParsedAs) = Authorizer - { vPolicies :: [Policy' ctx] +data Authorizer' (evalCtx :: EvaluationContext) (ctx :: DatalogContext) = Authorizer + { vPolicies :: [Policy' evalCtx ctx] -- ^ the allow / deny policies. - , vBlock :: Block' ctx + , vBlock :: Block' evalCtx ctx -- ^ the facts, rules and checks } -instance Semigroup (Authorizer' ctx) where +instance Semigroup (Authorizer' evalCtx ctx) where v1 <> v2 = Authorizer { vPolicies = vPolicies v1 <> vPolicies v2 , vBlock = vBlock v1 <> vBlock v2 } -instance Monoid (Authorizer' ctx) where +instance Monoid (Authorizer' evalCtx ctx) where mempty = Authorizer { vPolicies = [] , vBlock = mempty } -deriving instance ( Eq (Block' ctx) - , Eq (QueryItem' ctx) - ) => Eq (Authorizer' ctx) +deriving instance ( Eq (Block' evalCtx ctx) + , Eq (QueryItem' evalCtx ctx) + ) => Eq (Authorizer' evalCtx ctx) -deriving instance ( Show (Block' ctx) - , Show (QueryItem' ctx) - ) => Show (Authorizer' ctx) +deriving instance ( Show (Block' evalCtx ctx) + , Show (QueryItem' evalCtx ctx) + ) => Show (Authorizer' evalCtx ctx) -deriving instance ( Lift (Block' ctx) - , Lift (QueryItem' ctx) - ) => Lift (Authorizer' ctx) +deriving instance ( Lift (Block' evalCtx ctx) + , Lift (QueryItem' evalCtx ctx) + ) => Lift (Authorizer' evalCtx ctx) -data BlockElement' ctx +renderAuthorizer :: Authorizer -> Text +renderAuthorizer Authorizer{..} = + renderBlock vBlock <> "\n" <> + intercalate "\n" (renderPolicy <$> vPolicies) + +data BlockElement' evalCtx ctx = BlockFact (Predicate' 'InFact ctx) - | BlockRule (Rule' ctx) - | BlockCheck (Check' ctx) + | BlockRule (Rule' evalCtx ctx) + | BlockCheck (Check' evalCtx ctx) | BlockComment deriving instance ( Show (Predicate' 'InFact ctx) - , Show (Rule' ctx) - , Show (QueryItem' ctx) - ) => Show (BlockElement' ctx) + , Show (Rule' evalCtx ctx) + , Show (QueryItem' evalCtx ctx) + ) => Show (BlockElement' evalCtx ctx) -elementToBlock :: BlockElement' ctx -> Block' ctx +elementToBlock :: BlockElement' evalCtx ctx -> Block' evalCtx ctx elementToBlock = \case - BlockRule r -> Block [r] [] [] Nothing Nothing - BlockFact f -> Block [] [f] [] Nothing Nothing - BlockCheck c -> Block [] [] [c] Nothing Nothing + BlockRule r -> Block [r] [] [] Nothing Set.empty + BlockFact f -> Block [] [f] [] Nothing Set.empty + BlockCheck c -> Block [] [] [c] Nothing Set.empty BlockComment -> mempty -data AuthorizerElement' ctx - = AuthorizerPolicy (Policy' ctx) - | BlockElement (BlockElement' ctx) +data AuthorizerElement' evalCtx ctx + = AuthorizerPolicy (Policy' evalCtx ctx) + | BlockElement (BlockElement' evalCtx ctx) deriving instance ( Show (Predicate' 'InFact ctx) - , Show (Rule' ctx) - , Show (QueryItem' ctx) - ) => Show (AuthorizerElement' ctx) + , Show (Rule' evalCtx ctx) + , Show (QueryItem' evalCtx ctx) + ) => Show (AuthorizerElement' evalCtx ctx) -elementToAuthorizer :: AuthorizerElement' ctx -> Authorizer' ctx +elementToAuthorizer :: AuthorizerElement' evalCtx ctx -> Authorizer' evalCtx ctx elementToAuthorizer = \case AuthorizerPolicy p -> Authorizer [p] mempty BlockElement be -> Authorizer [] (elementToBlock be) + +class ToEvaluation elem where + toEvaluation :: [Maybe PublicKey] -> elem 'Repr 'Representation -> elem 'Eval 'Representation + toRepresentation :: elem 'Eval 'Representation -> elem 'Repr 'Representation + +translateScope :: [Maybe PublicKey] -> Set RuleScope -> Set EvalRuleScope +translateScope ePks = + let indexedPks :: Map PublicKey (Set Natural) + indexedPks = + let makeEntry (Just bPk, bId) = [(bPk, Set.singleton bId)] + makeEntry _ = [] + in Map.fromListWith (<>) $ foldMap makeEntry $ zip ePks [0..] + translateElem = \case + Previous -> Previous + OnlyAuthority -> OnlyAuthority + BlockId bPk -> BlockId (fold $ Map.lookup bPk indexedPks, bPk) + in Set.map translateElem + +renderBlockIds :: Set EvalRuleScope -> Set RuleScope +renderBlockIds = + let renderElem = \case + Previous -> Previous + OnlyAuthority -> OnlyAuthority + BlockId (_, ePk) -> BlockId ePk + in Set.map renderElem + +instance ToEvaluation Rule' where + toEvaluation ePks r = r { scope = translateScope ePks $ scope r } + toRepresentation r = r { scope = renderBlockIds $ scope r } + +instance ToEvaluation QueryItem' where + toEvaluation ePks qi = qi{ qScope = translateScope ePks $ qScope qi} + toRepresentation qi = qi { qScope = renderBlockIds $ qScope qi} + +instance ToEvaluation Check' where + toEvaluation ePks c = c { cQueries = fmap (toEvaluation ePks) (cQueries c) } + toRepresentation c = c { cQueries = fmap toRepresentation (cQueries c) } + +instance ToEvaluation Block' where + toEvaluation ePks b = b + { bScope = translateScope ePks $ bScope b + , bRules = toEvaluation ePks <$> bRules b + , bChecks = checkToEvaluation ePks <$> bChecks b + } + toRepresentation b = b + { bScope = renderBlockIds $ bScope b + , bRules = toRepresentation <$> bRules b + , bChecks = toRepresentation <$> bChecks b + } + +instance ToEvaluation Authorizer' where + toEvaluation ePks a = a + { vBlock = toEvaluation ePks (vBlock a) + , vPolicies = policyToEvaluation ePks <$> vPolicies a + } + toRepresentation a = a + { vBlock = toRepresentation (vBlock a) + , vPolicies = fmap (fmap toRepresentation) <$> vPolicies a + } + +checkToEvaluation :: [Maybe PublicKey] -> Check -> EvalCheck +checkToEvaluation = toEvaluation + +policyToEvaluation :: [Maybe PublicKey] -> Policy -> EvalPolicy +policyToEvaluation ePks = fmap (fmap (toEvaluation ePks)) + +substituteAuthorizer :: Map Text Value + -> Map Text PublicKey + -> Authorizer' 'Repr 'WithSlices + -> Validation (NonEmpty Text) Authorizer +substituteAuthorizer termMapping keyMapping Authorizer{..} = do + newPolicies <- traverse (substitutePolicy termMapping keyMapping) vPolicies + newBlock <- substituteBlock termMapping keyMapping vBlock + pure Authorizer{ + vPolicies = newPolicies, + vBlock = newBlock + } + +substituteBlock :: Map Text Value + -> Map Text PublicKey + -> Block' 'Repr 'WithSlices + -> Validation (NonEmpty Text) Block +substituteBlock termMapping keyMapping Block{..} = do + newRules <- traverse (substituteRule termMapping keyMapping) bRules + newFacts <- traverse (substituteFact termMapping) bFacts + newChecks <- traverse (substituteCheck termMapping keyMapping) bChecks + newScope <- Set.fromList <$> traverse (substituteScope keyMapping) (Set.toList bScope) + pure Block{ + bRules = newRules, + bFacts = newFacts, + bChecks = newChecks, + bScope = newScope, + ..} + +substituteRule :: Map Text Value -> Map Text PublicKey + -> Rule' 'Repr 'WithSlices + -> Validation (NonEmpty Text) Rule +substituteRule termMapping keyMapping Rule{..} = do + newHead <- substitutePredicate termMapping rhead + newBody <- traverse (substitutePredicate termMapping) body + newExpressions <- traverse (substituteExpression termMapping) expressions + newScope <- Set.fromList <$> traverse (substituteScope keyMapping) (Set.toList scope) + pure Rule{ + rhead = newHead, + body = newBody, + expressions = newExpressions, + scope = newScope + } + +substituteCheck :: Map Text Value -> Map Text PublicKey + -> Check' 'Repr 'WithSlices + -> Validation (NonEmpty Text) Check +substituteCheck termMapping keyMapping Check{..} = do + newQueries <- traverse (substituteQuery termMapping keyMapping) cQueries + pure Check{cQueries = newQueries, ..} + +substitutePolicy :: Map Text Value -> Map Text PublicKey + -> Policy' 'Repr 'WithSlices + -> Validation (NonEmpty Text) Policy +substitutePolicy termMapping keyMapping = + traverse (traverse (substituteQuery termMapping keyMapping)) + +substituteQuery :: Map Text Value-> Map Text PublicKey + -> QueryItem' 'Repr 'WithSlices + -> Validation (NonEmpty Text) (QueryItem' 'Repr 'Representation) +substituteQuery termMapping keyMapping QueryItem{..} = do + newBody <- traverse (substitutePredicate termMapping) qBody + newExpressions <- traverse (substituteExpression termMapping) qExpressions + newScope <- Set.fromList <$> traverse (substituteScope keyMapping) (Set.toList qScope) + pure QueryItem{ + qBody = newBody, + qExpressions = newExpressions, + qScope = newScope + } + +substitutePredicate :: Map Text Value + -> Predicate' 'InPredicate 'WithSlices + -> Validation (NonEmpty Text) (Predicate' 'InPredicate 'Representation) +substitutePredicate termMapping Predicate{..} = do + newTerms <- traverse (substitutePTerm termMapping) terms + pure Predicate{ terms = newTerms, .. } + +substituteFact :: Map Text Value + -> Predicate' 'InFact 'WithSlices + -> Validation (NonEmpty Text) Fact +substituteFact termMapping Predicate{..} = do + newTerms <- traverse (substituteTerm termMapping) terms + pure Predicate{ terms = newTerms, .. } + + +substitutePTerm :: Map Text Value + -> Term' 'NotWithinSet 'InPredicate 'WithSlices + -> Validation (NonEmpty Text) (Term' 'NotWithinSet 'InPredicate 'Representation) +substitutePTerm termMapping = \case + LInteger i -> pure $ LInteger i + LString i -> pure $ LString i + LDate i -> pure $ LDate i + LBytes i -> pure $ LBytes i + LBool i -> pure $ LBool i + TermSet i -> + TermSet . Set.fromList <$> traverse (substituteSetTerm termMapping) (Set.toList i) + Variable i -> pure $ Variable i + Antiquote (Slice v) -> maybe (failure v) (pure . valueToTerm) $ termMapping Map.!? v + +substituteTerm :: Map Text Value + -> Term' 'NotWithinSet 'InFact 'WithSlices + -> Validation (NonEmpty Text) Value +substituteTerm termMapping = \case + LInteger i -> pure $ LInteger i + LString i -> pure $ LString i + LDate i -> pure $ LDate i + LBytes i -> pure $ LBytes i + LBool i -> pure $ LBool i + TermSet i -> + TermSet . Set.fromList <$> traverse (substituteSetTerm termMapping) (Set.toList i) + Variable v -> absurd v + Antiquote (Slice v) -> maybe (failure v) pure $ termMapping Map.!? v + +substituteSetTerm :: Map Text Value + -> Term' 'WithinSet 'InFact 'WithSlices + -> Validation (NonEmpty Text) (Term' 'WithinSet 'InFact 'Representation) +substituteSetTerm termMapping = \case + LInteger i -> pure $ LInteger i + LString i -> pure $ LString i + LDate i -> pure $ LDate i + LBytes i -> pure $ LBytes i + LBool i -> pure $ LBool i + TermSet v -> absurd v + Variable v -> absurd v + Antiquote (Slice v) -> + let setTerm = valueToSetTerm =<< termMapping Map.!? v + in maybe (failure v) pure setTerm + +substituteExpression :: Map Text Value + -> Expression' 'WithSlices + -> Validation (NonEmpty Text) Expression +substituteExpression termMapping = \case + EValue v -> EValue <$> substitutePTerm termMapping v + EUnary op e -> EUnary op <$> substituteExpression termMapping e + EBinary op e e' -> EBinary op <$> substituteExpression termMapping e + <*> substituteExpression termMapping e' + +substituteScope :: Map Text PublicKey + -> RuleScope' 'Repr 'WithSlices + -> Validation (NonEmpty Text) RuleScope +substituteScope keyMapping = \case + OnlyAuthority -> pure OnlyAuthority + Previous -> pure Previous + BlockId (Pk pk) -> pure $ BlockId pk + BlockId (PkSlice n) -> maybe (failure n) (pure . BlockId) $ keyMapping Map.!? n 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 @@ -28,8 +28,6 @@ , keepAuthorized' , defaultLimits , evaluateExpression - , extractVariables - -- , getFactsForRule , checkCheck @@ -40,6 +38,7 @@ import Control.Monad (join, mfilter, zipWithM) import Data.Bitraversable (bitraverse) +import Data.Bits (xor, (.&.), (.|.)) import qualified Data.ByteString as ByteString import Data.Foldable (fold) import Data.Functor.Compose (Compose (..)) @@ -47,7 +46,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map, (!?)) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Maybe (isJust, mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text, isInfixOf, unpack) @@ -159,18 +158,24 @@ let isAuthorized k _ = k `Set.isSubsetOf` authorizedOrigins in FactGroup $ Map.filterWithKey isAuthorized facts -keepAuthorized' :: FactGroup -> Maybe RuleScope -> Natural -> FactGroup -keepAuthorized' factGroup mScope currentBlockId = - let scope = fromMaybe OnlyAuthority mScope - in case scope of - OnlyAuthority -> keepAuthorized factGroup (Set.fromList [0, currentBlockId]) - Previous -> keepAuthorized factGroup (Set.fromList [0..currentBlockId]) - UnsafeAny -> factGroup - OnlyBlocks ids -> keepAuthorized factGroup (Set.insert currentBlockId ids) +keepAuthorized' :: Bool -> Natural -> FactGroup -> Set EvalRuleScope -> Natural -> FactGroup +keepAuthorized' allowPreviousInAuthorizer blockCount factGroup trustedBlocks currentBlockId = + let scope = if null trustedBlocks then Set.singleton OnlyAuthority + else trustedBlocks + toBlockIds = \case + OnlyAuthority -> Set.singleton 0 + Previous -> if allowPreviousInAuthorizer || currentBlockId < blockCount + then Set.fromList [0..currentBlockId] + else mempty -- `Previous` is forbidden in the authorizer + -- except when querying the authorizer contents + -- after authorization + BlockId (idx, _) -> idx + allBlockIds = foldMap toBlockIds scope + in keepAuthorized factGroup $ Set.insert currentBlockId $ Set.insert blockCount allBlockIds toScopedFacts :: FactGroup -> Set (Scoped Fact) toScopedFacts (FactGroup factGroups) = - let distributeScope scope facts = Set.map (scope,) facts + let distributeScope scope = Set.map (scope,) in foldMap (uncurry distributeScope) $ Map.toList factGroups fromScopedFacts :: Set (Scoped Fact) -> FactGroup @@ -179,34 +184,58 @@ countFacts :: FactGroup -> Int countFacts (FactGroup facts) = sum $ Set.size <$> Map.elems facts -checkCheck :: Limits -> Natural -> FactGroup -> Check -> Validation (NonEmpty Check) () -checkCheck l checkBlockId facts items = - if any (isJust . isQueryItemSatisfied l checkBlockId facts) items - then Success () - else failure items +-- todo handle Check All +checkCheck :: Limits -> Natural -> Natural -> FactGroup -> EvalCheck -> Validation (NonEmpty Check) () +checkCheck l blockCount checkBlockId facts c@Check{cQueries,cKind} = + let isQueryItemOk = case cKind of + One -> isQueryItemSatisfied l blockCount checkBlockId facts + All -> isQueryItemSatisfiedForAllMatches l blockCount checkBlockId facts + in if any (isJust . isQueryItemOk) cQueries + then Success () + else failure (toRepresentation c) -checkPolicy :: Limits -> FactGroup -> Policy -> Maybe (Either MatchedQuery MatchedQuery) -checkPolicy l facts (pType, query) = - let bindings = fold $ mapMaybe (isQueryItemSatisfied l 0 facts) query +checkPolicy :: Limits -> Natural -> FactGroup -> EvalPolicy -> Maybe (Either MatchedQuery MatchedQuery) +checkPolicy l blockCount facts (pType, query) = + let bindings = fold $ mapMaybe (isQueryItemSatisfied l blockCount blockCount facts) query in if not (null bindings) then Just $ case pType of - Allow -> Right $ MatchedQuery{matchedQuery = query, bindings} - Deny -> Left $ MatchedQuery{matchedQuery = query, bindings} + Allow -> Right $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings} + Deny -> Left $ MatchedQuery{matchedQuery = toRepresentation <$> query, bindings} else Nothing -isQueryItemSatisfied :: Limits -> Natural -> FactGroup -> QueryItem' 'RegularString -> Maybe (Set Bindings) -isQueryItemSatisfied l blockId allFacts QueryItem{qBody, qExpressions, qScope} = +isQueryItemSatisfied :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Maybe (Set Bindings) +isQueryItemSatisfied l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} = let removeScope = Set.map snd - facts = toScopedFacts $ keepAuthorized' allFacts qScope blockId + facts = toScopedFacts $ keepAuthorized' False blockCount allFacts qScope blockId bindings = removeScope $ getBindingsForRuleBody l facts qBody qExpressions in if Set.size bindings > 0 then Just bindings else Nothing +-- | Given a set of scoped facts and a rule body, we generate a set of variable +-- bindings that satisfy the rule clauses (predicates match, and expression constraints +-- are fulfilled), and ensure that all bindings where predicates match also fulfill +-- expression constraints. This is the behaviour of `check all`. +isQueryItemSatisfiedForAllMatches :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Maybe (Set Bindings) +isQueryItemSatisfiedForAllMatches l blockCount blockId allFacts QueryItem{qBody, qExpressions, qScope} = + let removeScope = Set.map snd + facts = toScopedFacts $ keepAuthorized' False blockCount allFacts qScope blockId + allVariables = extractVariables qBody + -- bindings that match facts + candidateBindings = getCandidateBindings facts qBody + -- bindings that unify correctly (each variable has a single possible match) + legalBindingsForFacts = reduceCandidateBindings allVariables candidateBindings + -- bindings that fulfill the constraints + constraintFulfillingBindings = Set.filter (\b -> all (satisfies l b) qExpressions) legalBindingsForFacts + in if Set.size constraintFulfillingBindings > 0 -- there is at least one match that fulfills the constraints + && constraintFulfillingBindings == legalBindingsForFacts -- all matches fulfill the constraints + then Just $ removeScope constraintFulfillingBindings + else Nothing + -- | Given a rule and a set of available (scoped) facts, we find all fact -- combinations that match the rule body, and generate new facts by applying -- the bindings to the rule head (while keeping track of the facts origins) -getFactsForRule :: Limits -> Set (Scoped Fact) -> Rule -> Set (Scoped Fact) +getFactsForRule :: Limits -> Set (Scoped Fact) -> EvalRule -> Set (Scoped Fact) getFactsForRule l facts Rule{rhead, body, expressions} = let legalBindings :: Set (Scoped Bindings) legalBindings = getBindingsForRuleBody l facts body expressions @@ -232,15 +261,6 @@ -> Bool satisfies l b e = evaluateExpression l (snd b) e == Right (LBool True) -extractVariables :: [Predicate] -> Set Name -extractVariables predicates = - let keepVariable = \case - Variable name -> Just name - _ -> Nothing - extractVariables' Predicate{terms} = mapMaybe keepVariable terms - in Set.fromList $ extractVariables' =<< predicates - - applyBindings :: Predicate -> Scoped Bindings -> Maybe (Scoped Fact) applyBindings p@Predicate{terms} (origins, bindings) = let newTerms = traverse replaceTerm terms @@ -395,6 +415,13 @@ evalBinary _ Div (LInteger _) (LInteger 0) = Left "Divide by 0" evalBinary _ Div (LInteger i) (LInteger i') = pure $ LInteger (i `div` i') evalBinary _ Div _ _ = Left "Only integers support division" +-- bitwise operations +evalBinary _ BitwiseAnd (LInteger i) (LInteger i') = pure $ LInteger (i .&. i') +evalBinary _ BitwiseAnd _ _ = Left "Only integers support bitwise and" +evalBinary _ BitwiseOr (LInteger i) (LInteger i') = pure $ LInteger (i .|. i') +evalBinary _ BitwiseOr _ _ = Left "Only integers support bitwise or" +evalBinary _ BitwiseXor (LInteger i) (LInteger i') = pure $ LInteger (i `xor` i') +evalBinary _ BitwiseXor _ _ = Left "Only integers support bitwise xor" -- boolean operations evalBinary _ And (LBool b) (LBool b') = pure $ LBool (b && b') evalBinary _ And _ _ = Left "Only booleans support &&" @@ -402,7 +429,7 @@ evalBinary _ Or _ _ = Left "Only booleans support ||" -- set operations evalBinary _ Contains (TermSet t) (TermSet t') = pure $ LBool (Set.isSubsetOf t' t) -evalBinary _ Contains (TermSet t) t' = case toSetTerm t' of +evalBinary _ Contains (TermSet t) t' = case valueToSetTerm t' of Just t'' -> pure $ LBool (Set.member t'' t) Nothing -> Left "Sets cannot contain nested sets nor variables" evalBinary _ Contains (LString t) (LString t') = pure $ LBool (t' `isInfixOf` t) 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 @@ -1,397 +1,452 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{- HLINT ignore "Reduce duplication" -} module Auth.Biscuit.Datalog.Parser - ( block - , check - , fact - , predicate - , rule - , authorizer - , query - -- these are only exported for testing purposes - , checkParser - , expressionParser - , policyParser - , predicateParser - , ruleParser - , termParser - , blockParser - , authorizerParser - , HasParsers - , HasTermParsers - ) where + where -import Control.Applicative (liftA2, optional, (<|>)) +import Auth.Biscuit.Crypto (PublicKey, + readEd25519PublicKey) +import Auth.Biscuit.Datalog.AST +import Control.Monad (join) import qualified Control.Monad.Combinators.Expr as Expr -import Data.Attoparsec.Text -import qualified Data.Attoparsec.Text as A +import Data.Bifunctor import Data.ByteString (ByteString) import Data.ByteString.Base16 as Hex -import Data.Char (isAlphaNum, isLetter, isSpace) +import qualified Data.ByteString.Char8 as C8 +import Data.Char import Data.Either (partitionEithers) -import Data.Foldable (fold) -import Data.Functor (void, ($>)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import Data.Maybe (isJust) +import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text, pack, singleton, unpack) -import Data.Text.Encoding (encodeUtf8) +import Data.Text (Text) +import qualified Data.Text as T import Data.Time (UTCTime, defaultTimeLocale, parseTimeM) -import Data.Void (Void) import Instances.TH.Lift () import Language.Haskell.TH -import Language.Haskell.TH.Quote +import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax (Lift) +import Text.Megaparsec +import qualified Text.Megaparsec.Char as C +import qualified Text.Megaparsec.Char.Lexer as L +import Validation (Validation (..), + validationToEither) -import Auth.Biscuit.Datalog.AST +type Parser = Parsec SemanticError Text -class ConditionalParse a v where - ifPresent :: String -> Parser a -> Parser v +type Span = (Int, Int) -instance ConditionalParse a Void where - ifPresent name _ = fail $ name <> " is not available in this context" +data SemanticError = + VarInFact Span + | VarInSet Span + | NestedSet Span + | InvalidBs Text Span + | InvalidPublicKey Text Span + | UnboundVariables (NonEmpty Text) Span + | PreviousInAuthorizer Span + deriving stock (Eq, Ord) -instance ConditionalParse m m where - ifPresent _ p = p +instance ShowErrorComponent SemanticError where + showErrorComponent = \case + VarInFact _ -> "Variables can't appear in a fact" + VarInSet _ -> "Variables can't appear in a set" + NestedSet _ -> "Sets cannot be nested" + InvalidBs e _ -> "Invalid bytestring literal: " <> T.unpack e + InvalidPublicKey e _ -> "Invalid public key: " <> T.unpack e + UnboundVariables e _ -> "Unbound variables: " <> T.unpack (T.intercalate ", " $ NE.toList e) + PreviousInAuthorizer _ -> "'previous' can't appear in an authorizer scope" -class SetParser (inSet :: IsWithinSet) (ctx :: ParsedAs) where - parseSet :: Parser (SetType inSet ctx) +run :: Parser a -> Text -> Either String a +run p = first errorBundlePretty . runParser (l (pure ()) *> l p <* eof) "" -instance SetParser 'WithinSet ctx where - parseSet = fail "nested sets are forbidden" +l :: Parser a -> Parser a +l = L.lexeme $ L.space C.space1 (L.skipLineComment "//") empty -instance SetParser 'NotWithinSet 'QuasiQuote where - parseSet = Set.fromList <$> (char '[' *> commaList0 termParser <* char ']') +getSpan :: Parser a -> Parser (Span, a) +getSpan p = do + begin <- getOffset + a <- p + end <- getOffset + pure ((begin, end), a) -instance SetParser 'NotWithinSet 'RegularString where - parseSet = Set.fromList <$> (char '[' *> commaList0 termParser <* char ']') +registerError :: (Span -> SemanticError) -> Span -> Parser a +registerError mkError sp = do + let err = FancyError (fst sp) (Set.singleton (ErrorCustom $ mkError sp)) + registerParseError err + pure $ error "delayed parsing error" -type HasTermParsers inSet pof ctx = - ( ConditionalParse (SliceType 'QuasiQuote) (SliceType ctx) - , ConditionalParse (VariableType 'NotWithinSet 'InPredicate) (VariableType inSet pof) - , SetParser inSet ctx - ) -type HasParsers pof ctx = HasTermParsers 'NotWithinSet pof ctx +forbid :: (Span -> SemanticError) -> Parser a -> Parser b +forbid mkError p = do + (sp, _) <- getSpan p + registerError mkError sp --- | Parser for a datalog predicate name -predicateNameParser :: Parser Text -predicateNameParser = do - first <- satisfy isLetter - rest <- A.takeWhile $ \c -> c == '_' || c == ':' || isAlphaNum c - pure $ singleton first <> rest +variableParser :: Parser Text +variableParser = + C.char '$' *> takeWhile1P (Just "_, :, or any alphanumeric char") (\c -> c == '_' || c == ':' || isAlphaNum c) -variableNameParser :: Parser Text -variableNameParser = char '$' *> takeWhile1 (\c -> c == '_' || c == ':' || isAlphaNum c) +haskellVariableParser :: Parser Text +haskellVariableParser = l $ do + _ <- chunk "{" + leadingUS <- optional $ C.char '_' + x <- if isJust leadingUS then C.letterChar else C.lowerChar + xs <- takeWhileP (Just "_, ', or any alphanumeric char") (\c -> c == '_' || c == '\'' || isAlphaNum c) + _ <- C.char '}' + pure . maybe id T.cons leadingUS $ T.cons x xs -delimited :: Parser x - -> Parser y - -> Parser a - -> Parser a -delimited before after p = before *> p <* after +setParser :: Parser (Set (Term' 'WithinSet 'InFact 'WithSlices)) +setParser = do + _ <- l $ C.char '[' + ts <- sepBy (termParser (forbid VarInSet variableParser) (forbid NestedSet setParser)) (l $ C.char ',') + _ <- l $ C.char ']' + pure $ Set.fromList ts -parens :: Parser a -> Parser a -parens = delimited (char '(') (skipSpace *> char ')') +factTermParser :: Parser (Term' 'NotWithinSet 'InFact 'WithSlices) +factTermParser = termParser (forbid VarInFact variableParser) + setParser -commaList :: Parser a -> Parser [a] -commaList p = - sepBy1 p (skipSpace *> char ',') +predicateTermParser :: Parser (Term' 'NotWithinSet 'InPredicate 'WithSlices) +predicateTermParser = termParser variableParser + setParser -commaList0 :: Parser a -> Parser [a] -commaList0 p = - sepBy p (skipSpace *> char ',') +termParser :: Parser (VariableType inSet pof) + -> Parser (SetType inSet 'WithSlices) + -> Parser (Term' inSet pof 'WithSlices) +termParser parseVar parseSet = l $ choice + [ Antiquote . Slice <$> haskellVariableParser "parameter (eg. {paramName})" + , Variable <$> parseVar "datalog variable (eg. $variable)" + , TermSet <$> parseSet "set (eg. [1,2,3])" + , LBytes <$> (chunk "hex:" *> hexParser) "hex-encoded bytestring (eg. hex:00ff99)" + , LDate <$> rfc3339DateParser "RFC3339-formatted timestamp (eg. 2022-11-29T00:00:00Z)" + , LInteger <$> L.signed C.space L.decimal "(signed) integer" + , LString . T.pack <$> (C.char '"' *> manyTill L.charLiteral (C.char '"')) "string literal" + , LBool <$> choice [ True <$ chunk "true" + , False <$ chunk "false" + ] + "boolean value (eg. true or false)" + ] -predicateParser :: HasParsers pof ctx => Parser (Predicate' pof ctx) -predicateParser = do - skipSpace - name <- predicateNameParser - skipSpace - terms <- parens (commaList termParser) - pure Predicate{name,terms} +hexParser :: Parser ByteString +hexParser = do + (sp, hexStr) <- getSpan $ C8.pack <$> some C.hexDigitChar + case Hex.decodeBase16 hexStr of + Left e -> registerError (InvalidBs e) sp + Right bs -> pure bs -unary :: HasParsers 'InPredicate ctx => Parser (Expression' ctx) -unary = choice - [ unaryParens - , unaryNegate - , unaryLength - ] +publicKeyParser :: Parser PublicKey +publicKeyParser = do + (sp, hexStr) <- getSpan $ C8.pack <$> (chunk "ed25519/" *> some C.hexDigitChar) + case Hex.decodeBase16 hexStr of + Left e -> registerError (InvalidPublicKey e) sp + Right bs -> case readEd25519PublicKey bs of + Nothing -> registerError (InvalidPublicKey "Invalid ed25519 public key") sp + Just pk -> pure pk -unaryParens :: HasParsers 'InPredicate ctx => Parser (Expression' ctx) -unaryParens = do - skipSpace - _ <- char '(' - skipSpace - e <- expressionParser - skipSpace - _ <- char ')' - pure $ EUnary Parens e +rfc3339DateParser :: Parser UTCTime +rfc3339DateParser = do + let parseDate = parseTimeM False defaultTimeLocale "%FT%T%Q%EZ" + input <- sequenceA [ + try (sequenceA [ + C.digitChar, + C.digitChar, + C.digitChar, + C.digitChar, + C.char '-', + C.digitChar, + C.digitChar, + C.char '-', + C.digitChar, + C.digitChar, + C.char 'T' + ]), + pure <$> C.digitChar, + pure <$> C.digitChar, + pure <$> C.char ':', + pure <$> C.digitChar, + pure <$> C.digitChar, + pure <$> C.char ':', + pure <$> C.digitChar, + pure <$> C.digitChar, + foldMap join <$> optional (sequenceA [ + pure <$> C.char '.', + some C.digitChar + ]), + choice [ + pure <$> C.char 'Z', + sequenceA [ + choice [C.char '+', C.char '-'], + C.digitChar, + C.digitChar, + C.char ':', + C.digitChar, + C.digitChar + ] + ] + ] + parseDate $ join input -unaryNegate :: HasParsers 'InPredicate ctx => Parser (Expression' ctx) -unaryNegate = do - skipSpace - _ <- char '!' - skipSpace - EUnary Negate <$> expressionParser +predicateParser' :: Parser (Term' 'NotWithinSet pof 'WithSlices) + -> Parser (Predicate' pof 'WithSlices) +predicateParser' parseTerm = l $ do + name <- try . ( "predicate name") $ do + x <- C.letterChar + xs <- takeWhileP (Just "_, :, or any alphanumeric char") (\c -> c == '_' || c == ':' || isAlphaNum c) + _ <- l $ C.char '(' + pure $ T.cons x xs + terms <- sepBy1 parseTerm (l $ C.char ',') + _ <- l $ C.char ')' + pure Predicate { + name, + terms + } -unaryLength :: HasParsers 'InPredicate ctx => Parser (Expression' ctx) -unaryLength = do - skipSpace - e <- choice - [ EValue <$> termParser - , unaryParens - ] - skipSpace - _ <- string ".length()" - pure $ EUnary Length e +factParser :: Parser (Predicate' 'InFact 'WithSlices) +factParser = predicateParser' factTermParser -exprTerm :: HasParsers 'InPredicate ctx => Parser (Expression' ctx) -exprTerm = choice - [ unary - , EValue <$> termParser - ] +predicateParser :: Parser (Predicate' 'InPredicate 'WithSlices) +predicateParser = predicateParser' predicateTermParser -methodParser :: HasParsers 'InPredicate ctx => Parser (Expression' ctx) -methodParser = do +expressionParser :: Parser (Expression' 'WithSlices) +expressionParser = + let base = choice [ try binaryMethodParser + , try unaryMethodParser + , exprTerm + ] + in Expr.makeExprParser base table + +table :: [[Expr.Operator Parser (Expression' 'WithSlices)]] +table = + let infixL name op = Expr.InfixL (EBinary op <$ l (chunk name) "infix operator") + infixN name op = Expr.InfixN (EBinary op <$ l (chunk name) "infix operator") + prefix name op = Expr.Prefix (EUnary op <$ l (chunk name) "prefix operator") + in [ [ prefix "!" Negate] + , [ infixL "*" Mul + , infixL "/" Div + ] + , [ infixL "+" Add + , infixL "-" Sub + ] + -- TODO find a better way to avoid eager parsing + -- of && and || by the bitwise operators + , [ infixL "& " BitwiseAnd ] + , [ infixL "| " BitwiseOr ] + , [ infixL "^" BitwiseXor ] + , [ infixN "<=" LessOrEqual + , infixN ">=" GreaterOrEqual + , infixN "<" LessThan + , infixN ">" GreaterThan + , infixN "==" Equal + ] + , [ infixL "&&" And ] + , [ infixL "||" Or ] + ] + +binaryMethodParser :: Parser (Expression' 'WithSlices) +binaryMethodParser = do e1 <- exprTerm - _ <- char '.' + _ <- C.char '.' method <- choice - [ Contains <$ string "contains" - , Intersection <$ string "intersection" - , Union <$ string "union" - , Prefix <$ string "starts_with" - , Suffix <$ string "ends_with" - , Regex <$ string "matches" + [ Contains <$ chunk "contains" + , Intersection <$ chunk "intersection" + , Union <$ chunk "union" + , Prefix <$ chunk "starts_with" + , Suffix <$ chunk "ends_with" + , Regex <$ chunk "matches" ] - _ <- char '(' - skipSpace - e2 <- expressionParser - skipSpace - _ <- char ')' + _ <- l $ C.char '(' + e2 <- l expressionParser + _ <- l $ C.char ')' pure $ EBinary method e1 e2 -expressionParser :: HasParsers 'InPredicate ctx => Parser (Expression' ctx) -expressionParser = Expr.makeExprParser (methodParser <|> exprTerm) table - -table :: HasParsers 'InPredicate ctx - => [[Expr.Operator Parser (Expression' ctx)]] -table = [ [ binary "*" Mul - , binary "/" Div - ] - , [ binary "+" Add - , binary "-" Sub - ] - , [ binary "<=" LessOrEqual - , binary ">=" GreaterOrEqual - , binary "<" LessThan - , binary ">" GreaterThan - , binary "==" Equal - ] - , [ binary "&&" And - , binary "||" Or - ] - ] - -binary :: HasParsers 'InPredicate ctx - => Text - -> Binary - -> Expr.Operator Parser (Expression' ctx) -binary name op = Expr.InfixL (EBinary op <$ (skipSpace *> string name)) - -hexBsParser :: Parser ByteString -hexBsParser = do - void $ string "hex:" - either fail pure . Hex.decode . encodeUtf8 =<< takeWhile1 (inClass "0-9a-fA-F") +unaryMethodParser :: Parser (Expression' 'WithSlices) +unaryMethodParser = do + e1 <- exprTerm + _ <- C.char '.' + method <- Length <$ chunk "length" + _ <- l $ chunk "()" + pure $ EUnary method e1 -litStringParser :: Parser Text -litStringParser = - let regularChars = takeTill (inClass "\"\\") - escaped = choice - [ string "\\n" $> "\n" - , string "\\\"" $> "\"" - , string "\\\\" $> "\\" - ] - str = do - f <- regularChars - r <- optional (liftA2 (<>) escaped str) - pure $ f <> fold r - in char '"' *> str <* char '"' +methodParser :: Parser (Expression' 'WithSlices) +methodParser = binaryMethodParser <|> unaryMethodParser -rfc3339DateParser :: Parser UTCTime -rfc3339DateParser = - -- get all the chars until the end of the term - -- a term can be terminated by - -- - a space (before another delimiter) - -- - a comma (before another term) - -- - a closing paren (the end of a term list) - -- - a closing bracket (the end of a set) - let getDateInput = takeWhile1 (notInClass ", )];") - parseDate = parseTimeM False defaultTimeLocale "%FT%T%Q%EZ" - in parseDate . unpack =<< getDateInput +unaryParens :: Parser (Expression' 'WithSlices) +unaryParens = do + _ <- l $ C.char '(' + e <- l expressionParser + _ <- l $ C.char ')' + pure $ EUnary Parens e -termParser :: forall inSet pof ctx - . ( HasTermParsers inSet pof ctx - ) - => Parser (Term' inSet pof ctx) -termParser = skipSpace *> choice - [ Antiquote <$> ifPresent "slice" (Slice <$> (string "${" *> many1 letter <* char '}')) - , Variable <$> ifPresent "var" variableNameParser - , TermSet <$> parseSet @inSet @ctx - , LBytes <$> hexBsParser - , LDate <$> rfc3339DateParser - , LInteger <$> signed decimal - , LString <$> litStringParser - , LBool <$> choice [ string "true" $> True - , string "false" $> False - ] +exprTerm :: Parser (Expression' 'WithSlices) +exprTerm = choice + [ unaryParens "parens" + , EValue <$> predicateTermParser ] --- | same as a predicate, but allows empty --- | terms list -ruleHeadParser :: HasParsers 'InPredicate ctx => Parser (Predicate' 'InPredicate ctx) -ruleHeadParser = do - skipSpace - name <- predicateNameParser - skipSpace - terms <- parens (commaList0 termParser) - pure Predicate{name,terms} +ruleParser :: Bool -> Parser (Rule' 'Repr 'WithSlices) +ruleParser inAuthorizer = do + begin <- getOffset + rhead <- try $ l predicateParser <* l (chunk "<-") + (body, expressions, scope) <- ruleBodyParser inAuthorizer + end <- getOffset + case makeRule rhead body expressions scope of + Failure vs -> registerError (UnboundVariables vs) (begin, end) + Success r -> pure r -ruleBodyParser :: HasParsers 'InPredicate ctx - => Parser ([Predicate' 'InPredicate ctx], [Expression' ctx]) -ruleBodyParser = do +ruleBodyParser :: Bool -> Parser ([Predicate' 'InPredicate 'WithSlices], [Expression' 'WithSlices], Set.Set (RuleScope' 'Repr 'WithSlices)) +ruleBodyParser inAuthorizer = do let predicateOrExprParser = - Right <$> expressionParser - <|> Left <$> predicateParser - elems <- sepBy1 (skipSpace *> predicateOrExprParser) - (skipSpace *> char ',') - pure $ partitionEithers elems + Left <$> (predicateParser "predicate") + <|> Right <$> (expressionParser "expression") + elems <- l $ sepBy1 (l predicateOrExprParser) + (l $ C.char ',') + scope <- option Set.empty $ scopeParser inAuthorizer + let (predicates, expressions) = partitionEithers elems + pure (predicates, expressions, scope) -ruleParser :: HasParsers 'InPredicate ctx => Parser (Rule' ctx) -ruleParser = do - rhead <- ruleHeadParser - skipSpace - void $ string "<-" - (body, expressions) <- ruleBodyParser - pure Rule{rhead, body, expressions, scope = Nothing} -- todo parse scope +scopeParser :: Bool -> Parser (Set.Set (RuleScope' 'Repr 'WithSlices)) +scopeParser inAuthorizer = ( "scope annotation") $ do + _ <- l $ chunk "trusting " + let elemParser = do + (sp, s) <- getSpan $ choice [ OnlyAuthority <$ chunk "authority" + , Previous <$ chunk "previous" + , BlockId <$> + choice [ PkSlice <$> haskellVariableParser "parameter (eg. {paramName})" + , Pk <$> publicKeyParser "public key (eg. ed25519/00ff99)" + ] + ] + if inAuthorizer && s == Previous + then registerError PreviousInAuthorizer sp + else pure s + Set.fromList <$> sepBy1 (l elemParser) + (l $ C.char ',') -queryParser :: HasParsers 'InPredicate ctx => Parser (Query' ctx) -queryParser = - let mkQueryItem (qBody, qExpressions) = QueryItem { qBody, qExpressions, qScope = Nothing } -- todo parse scope - in fmap mkQueryItem <$> sepBy1 ruleBodyParser (skipSpace *> asciiCI "or" <* satisfy isSpace) +queryItemParser :: Bool -> Parser (QueryItem' 'Repr 'WithSlices) +queryItemParser inAuthorizer = do + (sp, (predicates, expressions, scope)) <- getSpan $ ruleBodyParser inAuthorizer + case makeQueryItem predicates expressions scope of + Failure e -> registerError (UnboundVariables e) sp + Success qi -> pure qi -checkParser :: HasParsers 'InPredicate ctx => Parser (Check' ctx) -checkParser = string "check if" *> queryParser +queryParser :: Bool -> Parser [QueryItem' 'Repr 'WithSlices] +queryParser inAuthorizer = + sepBy1 (queryItemParser inAuthorizer) (l $ C.string' "or" <* C.space) + "datalog query" -commentParser :: Parser () -commentParser = do - skipSpace - _ <- string "//" - _ <- skipWhile ((&&) <$> (/= '\r') <*> (/= '\n')) - void $ choice [ void (char '\n') - , void (string "\r\n") - , endOfInput - ] +checkParser :: Bool -> Parser (Check' 'Repr 'WithSlices) +checkParser inAuthorizer = do + cKind <- l $ choice [ One <$ chunk "check if" + , All <$ chunk "check all" + ] + cQueries <- queryParser inAuthorizer + pure Check{..} -blockElementParser :: HasParsers 'InPredicate ctx => Parser (BlockElement' ctx) -blockElementParser = choice - [ BlockRule <$> ruleParser <* skipSpace <* char ';' - , BlockFact <$> predicateParser <* skipSpace <* char ';' - , BlockCheck <$> checkParser <* skipSpace <* char ';' - , BlockComment <$ commentParser +policyParser :: Parser (Policy' 'Repr 'WithSlices) +policyParser = do + policy <- l $ choice [ Allow <$ chunk "allow if" + , Deny <$ chunk "deny if" + ] + (policy, ) <$> queryParser True + +blockElementParser :: Bool -> Parser (BlockElement' 'Repr 'WithSlices) +blockElementParser inAuthorizer = choice + [ BlockCheck <$> checkParser inAuthorizer <* C.char ';' "check" + , BlockRule <$> ruleParser inAuthorizer <* C.char ';' "rule" + , BlockFact <$> factParser <* C.char ';' "fact" ] -authorizerElementParser :: HasParsers 'InPredicate ctx => Parser (AuthorizerElement' ctx) +authorizerElementParser :: Parser (AuthorizerElement' 'Repr 'WithSlices) authorizerElementParser = choice - [ AuthorizerPolicy <$> policyParser <* skipSpace <* char ';' - , BlockElement <$> blockElementParser + [ AuthorizerPolicy <$> policyParser <* C.char ';' "policy" + , BlockElement <$> blockElementParser True ] -authorizerParser :: ( HasParsers 'InPredicate ctx - , HasParsers 'InFact ctx - , Show (AuthorizerElement' ctx) - ) - => Parser (Authorizer' ctx) +blockParser :: Parser (Block' 'Repr 'WithSlices) +blockParser = do + bScope <- option Set.empty $ l (scopeParser False <* C.char ';' "scope annotation") + elems <- many $ l $ blockElementParser False + pure $ (foldMap elementToBlock elems) { bScope = bScope } + +authorizerParser :: Parser (Authorizer' 'Repr 'WithSlices) authorizerParser = do - elems <- many' (skipSpace *> authorizerElementParser) - pure $ foldMap elementToAuthorizer elems + bScope <- option Set.empty $ l (scopeParser True <* C.char ';' "scope annotation") + elems <- many $ l authorizerElementParser + let addScope a = a { vBlock = (vBlock a) { bScope = bScope } } + pure $ addScope $ foldMap elementToAuthorizer elems -blockParser :: ( HasParsers 'InPredicate ctx - , HasParsers 'InFact ctx - , Show (BlockElement' ctx) - ) - => Parser (Block' ctx) -blockParser = do - elems <- many' (skipSpace *> blockElementParser) - pure $ foldMap elementToBlock elems +parseWithParams :: Parser (a 'WithSlices) + -> (Map Text Value -> Map Text PublicKey -> a 'WithSlices -> Validation (NonEmpty Text) (a 'Representation)) + -> Text + -> Map Text Value -> Map Text PublicKey + -> Either (NonEmpty Text) (a 'Representation) +parseWithParams parser substitute input termMapping keyMapping = do + withSlices <- first (pure . T.pack) $ run parser input + validationToEither $ substitute termMapping keyMapping withSlices -policyParser :: HasParsers 'InPredicate ctx => Parser (Policy' ctx) -policyParser = do - policy <- choice - [ Allow <$ string "allow if" - , Deny <$ string "deny if" - ] - (policy, ) <$> queryParser +parseBlock :: Text -> Map Text Value -> Map Text PublicKey + -> Either (NonEmpty Text) Block +parseBlock = parseWithParams blockParser substituteBlock -compileParser :: Lift a => Parser a -> String -> Q Exp -compileParser p str = case parseOnly (p <* skipSpace <* endOfInput) (pack str) of - Right result -> [| result |] - Left e -> fail e +parseAuthorizer :: Text -> Map Text Value -> Map Text PublicKey + -> Either (NonEmpty Text) Authorizer +parseAuthorizer = parseWithParams authorizerParser substituteAuthorizer +compileParser :: Lift a => Parser a -> (a -> Q Exp) -> String -> Q Exp +compileParser p build = + either fail build . run p . T.pack + -- | Quasiquoter for a rule expression. You can reference haskell variables --- like this: @${variableName}@. +-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. rule :: QuasiQuoter rule = QuasiQuoter - { quoteExp = compileParser (ruleParser @'QuasiQuote) + { quoteExp = compileParser (ruleParser False) $ \result -> [| result :: Rule |] , quotePat = error "not supported" , quoteType = error "not supported" , quoteDec = error "not supported" } -- | Quasiquoter for a predicate expression. You can reference haskell variables --- like this: @${variableName}@. +-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. predicate :: QuasiQuoter predicate = QuasiQuoter - { quoteExp = compileParser (predicateParser @'InPredicate @'QuasiQuote) + { quoteExp = compileParser predicateParser $ \result -> [| result :: Predicate |] , quotePat = error "not supported" , quoteType = error "not supported" , quoteDec = error "not supported" } -- | Quasiquoter for a fact expression. You can reference haskell variables --- like this: @${variableName}@. +-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. fact :: QuasiQuoter fact = QuasiQuoter - { quoteExp = compileParser (predicateParser @'InFact @'QuasiQuote) + { quoteExp = compileParser factParser $ \result -> [| result :: Fact |] , quotePat = error "not supported" , quoteType = error "not supported" , quoteDec = error "not supported" } -- | Quasiquoter for a check expression. You can reference haskell variables --- like this: @${variableName}@. +-- like this: @{variableName}@. -- -- You most likely want to directly use 'block' or 'authorizer' instead. check :: QuasiQuoter check = QuasiQuoter - { quoteExp = compileParser (checkParser @'QuasiQuote) + { quoteExp = compileParser (checkParser False) $ \result -> [| result :: Check |] , quotePat = error "not supported" , quoteType = error "not supported" , quoteDec = error "not supported" @@ -404,14 +459,14 @@ -- -- > let fileName = "data.pdf" -- > in [block| --- > // datalog can reference haskell variables with ${variableName} --- > resource(${fileName}); +-- > // datalog can reference haskell variables with {variableName} +-- > resource({fileName}); -- > rule($variable) <- fact($value), other_fact($value); -- > check if operation("read"); -- > |] block :: QuasiQuoter block = QuasiQuoter - { quoteExp = compileParser (blockParser @'QuasiQuote) + { quoteExp = compileParser blockParser $ \result -> [| result :: Block |] , quotePat = error "not supported" , quoteType = error "not supported" , quoteDec = error "not supported" @@ -425,8 +480,8 @@ -- > do -- > now <- getCurrentTime -- > pure [authorizer| --- > // datalog can reference haskell variables with ${variableName} --- > current_time(${now}); +-- > // datalog can reference haskell variables with {variableName} +-- > current_time({now}); -- > // authorizers can contain facts, rules and checks like blocks, but -- > // also declare policies. While every check has to pass for a biscuit to -- > // be valid, policies are tried in order. The first one to match decides @@ -436,7 +491,7 @@ -- > |] authorizer :: QuasiQuoter authorizer = QuasiQuoter - { quoteExp = compileParser (authorizerParser @'QuasiQuote) + { quoteExp = compileParser authorizerParser $ \result -> [| result :: Authorizer |] , quotePat = error "not supported" , quoteType = error "not supported" , quoteDec = error "not supported" @@ -450,7 +505,7 @@ -- > [query|user($user_id) or group($group_id)|] query :: QuasiQuoter query = QuasiQuoter - { quoteExp = compileParser (queryParser @'QuasiQuote) + { quoteExp = compileParser (queryParser False) $ \result -> [| result :: Query |] , quotePat = error "not supported" , quoteType = error "not supported" , quoteDec = error "not supported" diff --git a/src/Auth/Biscuit/Datalog/ScopedExecutor.hs b/src/Auth/Biscuit/Datalog/ScopedExecutor.hs --- a/src/Auth/Biscuit/Datalog/ScopedExecutor.hs +++ b/src/Auth/Biscuit/Datalog/ScopedExecutor.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -16,19 +17,21 @@ , PureExecError (..) , AuthorizationSuccess (..) , getBindings - , queryAuthorizerFacts + , queryGeneratedFacts + , queryAvailableFacts , getVariableValues , getSingleVariableValue , FactGroup (..) + , collectWorld ) where -import Control.Applicative ((<|>)) import Control.Monad (unless, when) import Control.Monad.State (StateT (..), evalStateT, get, gets, lift, put) import Data.Bifunctor (first) import Data.ByteString (ByteString) import Data.Foldable (fold, traverse_) +import Data.List (genericLength) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map (Map) @@ -41,6 +44,7 @@ import Numeric.Natural (Natural) import Validation (Validation (..)) +import Auth.Biscuit.Crypto (PublicKey) import Auth.Biscuit.Datalog.AST import Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..), FactGroup (..), Limits (..), @@ -48,7 +52,6 @@ ResultError (..), Scoped, checkCheck, checkPolicy, countFacts, defaultLimits, - extractVariables, fromScopedFacts, getBindingsForRuleBody, getFactsForRule, @@ -56,7 +59,7 @@ import Auth.Biscuit.Datalog.Parser (fact) import Auth.Biscuit.Timer (timer) -type BlockWithRevocationId = (Block, ByteString) +type BlockWithRevocationId = (Block, ByteString, Maybe PublicKey) -- | A subset of 'ExecutionError' that can only happen during fact generation data PureExecError = Facts | Iterations | BadRule @@ -83,7 +86,6 @@ getBindings :: AuthorizationSuccess -> Set Bindings getBindings AuthorizationSuccess{matchedAllowQuery=MatchedQuery{bindings}} = bindings - -- | Given a series of blocks and an authorizer, ensure that all -- the checks and policies match runAuthorizer :: BlockWithRevocationId @@ -118,14 +120,16 @@ -> Set Fact mkRevocationIdFacts authority blocks = let allIds :: [(Int, ByteString)] - allIds = zip [0..] $ snd <$> authority : blocks - mkFact (index, rid) = [fact|revocation_id(${index}, ${rid})|] + allIds = zip [0..] $ snd' <$> authority : blocks + snd' (_,b,_) = b + mkFact (index, rid) = [fact|revocation_id({index}, {rid})|] in Set.fromList $ mkFact <$> allIds data ComputeState = ComputeState { sLimits :: Limits -- readonly - , sRules :: Map Natural (Set Rule) -- readonly + , sRules :: Map Natural (Set EvalRule) -- readonly + , sBlockCount :: Natural -- state , sIterations :: Int -- elapsed iterations , sFacts :: FactGroup -- facts generated so far @@ -134,16 +138,21 @@ mkInitState :: Limits -> BlockWithRevocationId -> [BlockWithRevocationId] -> Authorizer -> ComputeState mkInitState limits authority blocks authorizer = - let revocationWorld = (mempty, FactGroup $ Map.singleton (Set.singleton 0) $ mkRevocationIdFacts authority blocks) - firstBlock = fst authority <> vBlock authorizer - otherBlocks = fst <$> blocks - allBlocks = firstBlock : otherBlocks - (sRules, sFacts) = revocationWorld <> fold (zipWith collectWorld [0..] allBlocks) + let fst' (a,_,_) = a + trd' (_,_,c) = c + sBlockCount = 1 + genericLength blocks + externalKeys = Nothing : (trd' <$> blocks) + revocationWorld = (mempty, FactGroup $ Map.singleton (Set.singleton sBlockCount) $ mkRevocationIdFacts authority blocks) + firstBlock = fst' authority + otherBlocks = fst' <$> blocks + allBlocks = zip [0..] (firstBlock : otherBlocks) <> [(sBlockCount, vBlock authorizer)] + (sRules, sFacts) = revocationWorld <> fold (uncurry collectWorld . fmap (toEvaluation externalKeys) <$> allBlocks) in ComputeState { sLimits = limits , sRules - , sFacts + , sBlockCount , sIterations = 0 + , sFacts } runAuthorizerNoTimeout :: Limits @@ -152,16 +161,24 @@ -> Authorizer -> Either ExecutionError AuthorizationSuccess runAuthorizerNoTimeout limits authority blocks authorizer = do - let initState = mkInitState limits authority blocks authorizer + let fst' (a,_,_) = a + trd' (_,_,c) = c + blockCount = 1 + genericLength blocks + externalKeys = Nothing : (trd' <$> blocks) + (<$$>) = fmap . fmap + (<$$$>) = fmap . fmap . fmap + initState = mkInitState limits authority blocks authorizer toExecutionError = \case Facts -> TooManyFacts Iterations -> TooManyIterations BadRule -> InvalidRule allFacts <- first toExecutionError $ computeAllFacts initState - let checks = zip [0..] $ bChecks <$> ((fst authority <> vBlock authorizer) : (fst <$> blocks)) + let checks = bChecks <$$> ( zip [0..] (fst' <$> authority : blocks) + <> [(blockCount,vBlock authorizer)] + ) policies = vPolicies authorizer - checkResults = checkChecks limits allFacts checks - policyResults = checkPolicies limits allFacts policies + checkResults = checkChecks limits blockCount allFacts (checkToEvaluation externalKeys <$$$> checks) + policyResults = checkPolicies limits blockCount allFacts (policyToEvaluation externalKeys <$> policies) case (checkResults, policyResults) of (Success (), Left Nothing) -> Left $ ResultError $ NoPoliciesMatched [] (Success (), Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p @@ -175,10 +192,10 @@ runStep :: StateT ComputeState (Either PureExecError) Int runStep = do - state@ComputeState{sLimits,sFacts,sRules,sIterations} <- get + state@ComputeState{sLimits,sFacts,sRules,sBlockCount,sIterations} <- get let Limits{maxFacts, maxIterations} = sLimits previousCount = countFacts sFacts - newFacts = sFacts <> extend sLimits sRules sFacts + newFacts = sFacts <> extend sLimits sBlockCount sRules sFacts newCount = countFacts newFacts -- counting the facts returned by `extend` is not equivalent to -- comparing complete counts, as `extend` may return facts that @@ -192,7 +209,7 @@ return addedFactsCount -- | Check if every variable from the head is present in the body -checkRuleHead :: Rule -> Bool +checkRuleHead :: EvalRule -> Bool checkRuleHead Rule{rhead, body} = let headVars = extractVariables [rhead] bodyVars = extractVariables body @@ -212,36 +229,36 @@ -- | Small helper used in tests to directly provide rules and facts without creating -- a biscuit token -runFactGeneration :: Limits -> Map Natural (Set Rule) -> FactGroup -> Either PureExecError FactGroup -runFactGeneration sLimits sRules sFacts = +runFactGeneration :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> Either PureExecError FactGroup +runFactGeneration sLimits sBlockCount sRules sFacts = let initState = ComputeState{sIterations = 0, ..} in computeAllFacts initState -checkChecks :: Limits -> FactGroup -> [(Natural, [Check])] -> Validation (NonEmpty Check) () -checkChecks limits allFacts = - traverse_ (uncurry $ checkChecksForGroup limits allFacts) +checkChecks :: Limits -> Natural -> FactGroup -> [(Natural, [EvalCheck])] -> Validation (NonEmpty Check) () +checkChecks limits blockCount allFacts = + traverse_ (uncurry $ checkChecksForGroup limits blockCount allFacts) -checkChecksForGroup :: Limits -> FactGroup -> Natural -> [Check] -> Validation (NonEmpty Check) () -checkChecksForGroup limits allFacts checksBlockId = - traverse_ (checkCheck limits checksBlockId allFacts) +checkChecksForGroup :: Limits -> Natural -> FactGroup -> Natural -> [EvalCheck] -> Validation (NonEmpty Check) () +checkChecksForGroup limits blockCount allFacts checksBlockId = + traverse_ (checkCheck limits blockCount checksBlockId allFacts) -checkPolicies :: Limits -> FactGroup -> [Policy] -> Either (Maybe MatchedQuery) MatchedQuery -checkPolicies limits allFacts policies = - let results = mapMaybe (checkPolicy limits allFacts) policies +checkPolicies :: Limits -> Natural -> FactGroup -> [EvalPolicy] -> Either (Maybe MatchedQuery) MatchedQuery +checkPolicies limits blockCount allFacts policies = + let results = mapMaybe (checkPolicy limits blockCount allFacts) policies in case results of p : _ -> first Just p [] -> Left Nothing -- | Generate new facts by applying rules on existing facts -extend :: Limits -> Map Natural (Set Rule) -> FactGroup -> FactGroup -extend l rules facts = - let buildFacts :: Natural -> Set Rule -> FactGroup -> Set (Scoped Fact) +extend :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> FactGroup +extend l blockCount rules facts = + let buildFacts :: Natural -> Set EvalRule -> FactGroup -> Set (Scoped Fact) buildFacts ruleBlockId ruleGroup factGroup = - let extendRule :: Rule -> Set (Scoped Fact) - extendRule r@Rule{scope} = getFactsForRule l (toScopedFacts $ keepAuthorized' factGroup scope ruleBlockId) r + let extendRule :: EvalRule -> Set (Scoped Fact) + extendRule r@Rule{scope} = getFactsForRule l (toScopedFacts $ keepAuthorized' False blockCount factGroup scope ruleBlockId) r in foldMap extendRule ruleGroup - extendRuleGroup :: Natural -> Set Rule -> FactGroup + extendRuleGroup :: Natural -> Set EvalRule -> FactGroup extendRuleGroup ruleBlockId ruleGroup = -- todo pre-filter facts based on the weakest rule scope to avoid passing too many facts -- to buildFacts @@ -252,32 +269,27 @@ in foldMap (uncurry extendRuleGroup) $ Map.toList rules -collectWorld :: Natural -> Block -> (Map Natural (Set Rule), FactGroup) +collectWorld :: Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup) collectWorld blockId Block{..} = let -- a block can define a default scope for its rule -- which is used unless the rule itself has defined a scope - applyScope r@Rule{scope} = r { scope = scope <|> bScope } + applyScope r@Rule{scope} = r { scope = if null scope then bScope else scope } in ( Map.singleton blockId $ Set.map applyScope $ Set.fromList bRules , FactGroup $ Map.singleton (Set.singleton blockId) $ Set.fromList bFacts ) --- | Query the facts generated by the authority and authorizer blocks --- during authorization. This can be used in conjuction with 'getVariableValues' --- and 'getSingleVariableValue' to retrieve actual values. --- --- ⚠ Only the facts generated by the authority and authorizer blocks are queried. --- Block facts are not queried (since they can't be trusted). --- --- 💁 If the facts you want to query are part of an allow query in the authorizer, --- you can directly get values from 'AuthorizationSuccess'. -queryAuthorizerFacts :: AuthorizationSuccess -> Query -> Set Bindings -queryAuthorizerFacts AuthorizationSuccess{allFacts, limits} q = - let authorityFacts = fold (Map.lookup (Set.singleton 0) $ getFactGroup allFacts) - -- we've already ensured that we've kept only authority facts, we don't - -- need to track their origin further - getBindingsForQueryItem QueryItem{qBody,qExpressions} = Set.map snd $ - getBindingsForRuleBody limits (Set.map (mempty,) authorityFacts) qBody qExpressions - in foldMap getBindingsForQueryItem q +queryGeneratedFacts :: [Maybe PublicKey] -> AuthorizationSuccess -> Query -> Set Bindings +queryGeneratedFacts ePks AuthorizationSuccess{allFacts, limits} = + queryAvailableFacts ePks allFacts limits + +queryAvailableFacts :: [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Set Bindings +queryAvailableFacts ePks allFacts limits q = + let blockCount = genericLength ePks + getBindingsForQueryItem QueryItem{qBody,qExpressions,qScope} = + let facts = toScopedFacts $ keepAuthorized' True blockCount allFacts qScope blockCount + in Set.map snd $ + getBindingsForRuleBody limits facts qBody qExpressions + in foldMap (getBindingsForQueryItem . toEvaluation ePks) q -- | Extract a set of values from a matched variable for a specific type. -- Returning @Set Value@ allows to get all values, whatever their type. 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 @@ -5,24 +5,28 @@ import Data.ByteString (ByteString) import Data.Functor (($>)) import Data.Maybe (fromMaybe) +import Data.Text (Text) import Data.Time (getCurrentTime) import Auth.Biscuit privateKey' :: SecretKey -privateKey' = fromMaybe (error "Error parsing private key") $ parseSecretKeyHex "todo" +privateKey' = fromMaybe (error "Error parsing private key") $ parseSecretKeyHex "a2c4ead323536b925f3488ee83e0888b79c2761405ca7c0c9a018c7c1905eecc" publicKey' :: PublicKey -publicKey' = fromMaybe (error "Error parsing public key") $ parsePublicKeyHex "todo" +publicKey' = fromMaybe (error "Error parsing public key") $ parsePublicKeyHex "24afd8171d2c0107ec6d5656aa36f8409184c2567649e0a7f66e629cc3dbfd70" creation :: IO ByteString creation = do + let allowedOperations = ["read", "write"] :: [Text] + networkLocal = "192.168.0.1" :: Text let authority = [block| - // toto - resource("file1"); + // this is a comment + right("file1", {allowedOperations}); + check if source_ip($source_ip), ["127.0.0.1", {networkLocal}].contains($source_ip); |] biscuit <- mkBiscuit privateKey' authority - let block1 = [block|check if current_time($time), $time < 2021-05-08T00:00:00Z;|] + let block1 = [block|check if time($time), $time < 2025-05-08T00:00:00Z;|] newBiscuit <- addBlock block1 biscuit pure $ serializeB64 newBiscuit @@ -30,7 +34,11 @@ verification serialized = do now <- getCurrentTime biscuit <- either (fail . show) pure $ parseB64 publicKey' serialized - let authorizer' = [authorizer|current_time(${now});|] + let authorizer' = [authorizer| + time({now}); + source_ip("127.0.0.1"); + allow if right("file1", $ops), $ops.contains("read"); + |] result <- authorizeBiscuit biscuit authorizer' case result of Left e -> print e $> False 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 @@ -16,10 +16,14 @@ , SignedBlock (..) , PublicKey (..) , Algorithm (..) + , ExternalSig (..) , Proof (..) , Block (..) + , Scope (..) + , ScopeType (..) , FactV2 (..) , RuleV2 (..) + , CheckKind (..) , CheckV2 (..) , PredicateV2 (..) , TermV2 (..) @@ -32,12 +36,18 @@ , BinaryKind (..) , OpTernary (..) , TernaryKind (..) + , ThirdPartyBlockContents (..) + , ThirdPartyBlockRequest (..) , getField , putField , decodeBlockList , decodeBlock , encodeBlockList , encodeBlock + , decodeThirdPartyBlockRequest + , decodeThirdPartyBlockContents + , encodeThirdPartyBlockRequest + , encodeThirdPartyBlockContents ) where import Data.ByteString (ByteString) @@ -61,10 +71,18 @@ deriving (Generic, Show) deriving anyclass (Decode, Encode) +data ExternalSig = ExternalSig + { signature :: Required 1 (Value ByteString) + , publicKey :: Required 2 (Message PublicKey) + } + deriving (Generic, Show) + deriving anyclass (Decode, Encode) + data SignedBlock = SignedBlock - { block :: Required 1 (Value ByteString) - , nextKey :: Required 2 (Message PublicKey) - , signature :: Required 3 (Value ByteString) + { block :: Required 1 (Value ByteString) + , nextKey :: Required 2 (Message PublicKey) + , signature :: Required 3 (Value ByteString) + , externalSig :: Optional 4 (Message ExternalSig) } deriving (Generic, Show) deriving anyclass (Decode, Encode) @@ -86,9 +104,22 @@ , facts_v2 :: Repeated 4 (Message FactV2) , rules_v2 :: Repeated 5 (Message RuleV2) , checks_v2 :: Repeated 6 (Message CheckV2) - } deriving (Generic, Show) + , scope :: Repeated 7 (Message Scope) + , pksTable :: Repeated 8 (Message PublicKey) + } deriving stock (Generic, Show) deriving anyclass (Decode, Encode) +data ScopeType = + ScopeAuthority + | ScopePrevious + deriving stock (Show, Enum, Bounded) + +data Scope = + ScType (Required 1 (Enumeration ScopeType)) + | ScBlock (Required 2 (Value Int64)) + deriving stock (Generic, Show) + deriving anyclass (Decode, Encode) + newtype FactV2 = FactV2 { predicate :: Required 1 (Message PredicateV2) } deriving stock (Generic, Show) @@ -98,11 +129,18 @@ { head :: Required 1 (Message PredicateV2) , body :: Repeated 2 (Message PredicateV2) , expressions :: Repeated 3 (Message ExpressionV2) + , scope :: Repeated 4 (Message Scope) } deriving stock (Generic, Show) deriving anyclass (Decode, Encode) -newtype CheckV2 = CheckV2 +data CheckKind = + One + | All + deriving stock (Show, Enum, Bounded) + +data CheckV2 = CheckV2 { queries :: Repeated 1 (Message RuleV2) + , kind :: Optional 2 (Enumeration CheckKind) } deriving stock (Generic, Show) deriving anyclass (Decode, Encode) @@ -129,77 +167,6 @@ } deriving stock (Generic, Show) deriving anyclass (Decode, Encode) -type CV2Id = Required 1 (Value Int32) -data ConstraintV2 = - CV2Int CV2Id (Required 2 (Message IntConstraintV2)) - | CV2String CV2Id (Required 3 (Message StringConstraintV2)) - | CV2Date CV2Id (Required 4 (Message DateConstraintV2)) - | CV2Symbol CV2Id (Required 5 (Message SymbolConstraintV2)) - | CV2Bytes CV2Id (Required 6 (Message BytesConstraintV2)) - deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -data IntConstraintV2 = - ICV2LessThan (Required 1 (Value Int64)) - | ICV2GreaterThan (Required 2 (Value Int64)) - | ICV2LessOrEqual (Required 3 (Value Int64)) - | ICV2GreaterOrEqual (Required 4 (Value Int64)) - | ICV2Equal (Required 5 (Value Int64)) - | ICV2InSet (Required 6 (Message IntSet)) - | ICV2NotInSet (Required 7 (Message IntSet)) - deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -newtype IntSet = IntSet - { set :: Packed 7 (Value Int64) - } deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -data StringConstraintV2 = - SCV2Prefix (Required 1 (Value Text)) - | SCV2Suffix (Required 2 (Value Text)) - | SCV2Equal (Required 3 (Value Text)) - | SCV2InSet (Required 4 (Message StringSet)) - | SCV2NotInSet (Required 5 (Message StringSet)) - | SCV2Regex (Required 6 (Value Text)) - deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -newtype StringSet = StringSet - { set :: Repeated 1 (Value Text) - } deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -data DateConstraintV2 = - DCV2Before (Required 1 (Value Int64)) - | DCV2After (Required 2 (Value Int64)) - deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -data SymbolConstraintV2 = - SyCV2InSet (Required 1 (Message SymbolSet)) - | SyCV2NotInSet (Required 2 (Message SymbolSet)) - deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -newtype SymbolSet = SymbolSet - { set :: Packed 1 (Value Int64) - } deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - - -data BytesConstraintV2 = - BCV2Equal (Required 1 (Value ByteString)) - | BCV2InSet (Required 2 (Message BytesSet)) - | BCV2NotInSet (Required 3 (Message BytesSet)) - deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - -newtype BytesSet = BytesSet - { set :: Repeated 1 (Value ByteString) - } deriving stock (Generic, Show) - deriving anyclass (Decode, Encode) - newtype ExpressionV2 = ExpressionV2 { ops :: Repeated 1 (Message Op) } deriving stock (Generic, Show) @@ -238,6 +205,9 @@ | Or | Intersection | Union + | BitwiseAnd + | BitwiseOr + | BitwiseXor deriving stock (Show, Enum, Bounded) newtype OpBinary = OpBinary @@ -267,3 +237,29 @@ encodeBlock :: Block -> ByteString encodeBlock = runPut . encodeMessage + +encodeThirdPartyBlockRequest :: ThirdPartyBlockRequest -> ByteString +encodeThirdPartyBlockRequest = runPut . encodeMessage + +encodeThirdPartyBlockContents :: ThirdPartyBlockContents -> ByteString +encodeThirdPartyBlockContents = runPut . encodeMessage + +decodeThirdPartyBlockRequest :: ByteString -> Either String ThirdPartyBlockRequest +decodeThirdPartyBlockRequest = runGet decodeMessage + +decodeThirdPartyBlockContents :: ByteString -> Either String ThirdPartyBlockContents +decodeThirdPartyBlockContents = runGet decodeMessage + +data ThirdPartyBlockRequest + = ThirdPartyBlockRequest + { previousPk :: Required 1 (Message PublicKey) + , pkTable :: Repeated 2 (Message PublicKey) + } deriving stock (Generic, Show) + deriving anyclass (Decode, Encode) + +data ThirdPartyBlockContents + = ThirdPartyBlockContents + { payload :: Required 1 (Value ByteString) + , externalSig :: Required 2 (Message ExternalSig) + } deriving stock (Generic, Show) + deriving anyclass (Decode, Encode) 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 @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-| Module : Auth.Biscuit.Utils Copyright : © Clément Delafargue, 2021 @@ -13,103 +14,158 @@ module Auth.Biscuit.ProtoBufAdapter ( Symbols , buildSymbolTable - , extractSymbols , pbToBlock , blockToPb , pbToSignedBlock , signedBlockToPb , pbToProof + , pbToThirdPartyBlockRequest + , thirdPartyBlockRequestToPb + , pbToThirdPartyBlockContents + , thirdPartyBlockContentsToPb ) where import Control.Monad (when) -import Crypto.PubKey.Ed25519 (PublicKey) -import Data.Bifunctor (first) +import Control.Monad.State (StateT, get, lift, modify) +import Data.Bitraversable (bisequence) +import Data.ByteString (ByteString) import Data.Int (Int64) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isNothing) import qualified Data.Set as Set +import qualified Data.Text as T import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Void (absurd) +import GHC.Records (getField) +import Validation (Validation (..)) import qualified Auth.Biscuit.Crypto as Crypto import Auth.Biscuit.Datalog.AST import qualified Auth.Biscuit.Proto as PB import Auth.Biscuit.Symbols - - --- | Given existing symbols and a series of protobuf blocks, --- compute the complete symbol mapping -extractSymbols :: [PB.Block] -> Symbols -extractSymbols blocks = - addFromBlocks (PB.getField . PB.symbols <$> blocks) +import Auth.Biscuit.Utils (maybeToRight) --- | Given existing symbols and a biscuit block, compute the --- symbol table for the given block. Already existing symbols --- won't be included buildSymbolTable :: Symbols -> Block -> BlockSymbols buildSymbolTable existingSymbols block = let allSymbols = listSymbolsInBlock block - in addSymbols existingSymbols allSymbols + allKeys = listPublicKeysInBlock block + in addSymbols existingSymbols allSymbols allKeys -pbToPublicKey :: PB.PublicKey -> Either String PublicKey +pbToPublicKey :: PB.PublicKey -> Either String Crypto.PublicKey pbToPublicKey PB.PublicKey{..} = let keyBytes = PB.getField key - parseKey = Crypto.eitherCryptoError . Crypto.publicKey + parseKey = Crypto.readEd25519PublicKey in case PB.getField algorithm of - PB.Ed25519 -> first (const "Invalid ed25519 public key") $ parseKey keyBytes + PB.Ed25519 -> maybeToRight "Invalid ed25519 public key" $ parseKey keyBytes +pbToOptionalSignature :: PB.ExternalSig -> Either String (Crypto.Signature, Crypto.PublicKey) +pbToOptionalSignature PB.ExternalSig{..} = do + let sig = Crypto.signature $ PB.getField signature + pk <- pbToPublicKey $ PB.getField publicKey + pure (sig, pk) + -- | Parse a protobuf signed block into a signed biscuit block pbToSignedBlock :: PB.SignedBlock -> Either String Crypto.SignedBlock pbToSignedBlock PB.SignedBlock{..} = do - sig <- first (const "Invalid signature") $ Crypto.eitherCryptoError $ Crypto.signature $ PB.getField signature + let sig = Crypto.signature $ PB.getField signature + mSig <- traverse pbToOptionalSignature $ PB.getField externalSig pk <- pbToPublicKey $ PB.getField nextKey pure ( PB.getField block , sig , pk + , mSig ) -publicKeyToPb :: PublicKey -> PB.PublicKey +publicKeyToPb :: Crypto.PublicKey -> PB.PublicKey publicKeyToPb pk = PB.PublicKey { algorithm = PB.putField PB.Ed25519 - , key = PB.putField $ Crypto.convert pk + , key = PB.putField $ Crypto.pkBytes pk } +externalSigToPb :: (Crypto.Signature, Crypto.PublicKey) -> PB.ExternalSig +externalSigToPb (sig, pk) = PB.ExternalSig + { signature = PB.putField $ Crypto.sigBytes sig + , publicKey = PB.putField $ publicKeyToPb pk + } + signedBlockToPb :: Crypto.SignedBlock -> PB.SignedBlock -signedBlockToPb (block, sig, pk) = PB.SignedBlock +signedBlockToPb (block, sig, pk, eSig) = PB.SignedBlock { block = PB.putField block - , signature = PB.putField $ Crypto.convert sig + , signature = PB.putField $ Crypto.sigBytes sig , nextKey = PB.putField $ publicKeyToPb pk + , externalSig = PB.putField $ externalSigToPb <$> eSig } pbToProof :: PB.Proof -> Either String (Either Crypto.Signature Crypto.SecretKey) -pbToProof (PB.ProofSignature rawSig) = Left <$> first (const "Invalid signature proof") (Crypto.eitherCryptoError $ Crypto.signature $ PB.getField rawSig) -pbToProof (PB.ProofSecret rawPk) = Right <$> first (const "Invalid public key proof") (Crypto.eitherCryptoError $ Crypto.secretKey $ PB.getField rawPk) +pbToProof (PB.ProofSignature rawSig) = Left <$> Right (Crypto.signature $ PB.getField rawSig) +pbToProof (PB.ProofSecret rawPk) = Right <$> maybeToRight "Invalid public key proof" (Crypto.readEd25519SecretKey $ PB.getField rawPk) --- | Parse a protobuf block into a proper biscuit block -pbToBlock :: Symbols -> PB.Block -> Either String Block -pbToBlock s PB.Block{..} = do +pbToBlock :: Maybe Crypto.PublicKey -> PB.Block -> StateT Symbols (Either String) Block +pbToBlock ePk PB.Block{..} = do + blockPks <- lift $ traverse pbToPublicKey $ PB.getField pksTable + let blockSymbols = PB.getField symbols + -- third party blocks use an isolated symbol table, + -- but use the global public keys table: + -- symbols defined in 3rd party blocks are not visible + -- to following blocks, but public keys are + when (isNothing ePk) $ modify (registerNewSymbols blockSymbols) + modify (registerNewPublicKeys $ foldMap pure ePk <> blockPks) + currentSymbols <- get + + let symbolsForCurrentBlock = + -- third party blocks use an isolated symbol table, + -- but use the global public keys table. + -- 3rd party blocks don't see previously defined + -- symbols, but see previously defined public keys + if isNothing ePk then currentSymbols + else registerNewSymbols blockSymbols $ forgetSymbols currentSymbols let bContext = PB.getField context bVersion = PB.getField version - bFacts <- traverse (pbToFact s) $ PB.getField facts_v2 - bRules <- traverse (pbToRule s) $ PB.getField rules_v2 - bChecks <- traverse (pbToCheck s) $ PB.getField checks_v2 - let bScope = Nothing -- todo parse from protobuf - when (bVersion /= Just 3) $ Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only version 3 is supported" - pure Block{ .. } + lift $ do + let s = symbolsForCurrentBlock + bFacts <- traverse (pbToFact s) $ PB.getField facts_v2 + bRules <- traverse (pbToRule s) $ PB.getField rules_v2 + bChecks <- traverse (pbToCheck s) $ PB.getField checks_v2 + bScope <- Set.fromList <$> traverse (pbToScope s) (PB.getField scope) + let isV3 = isNothing ePk + && Set.null bScope + && all ruleHasNoScope bRules + && all queryHasNoScope (cQueries <$> bChecks) + && all isCheckOne bChecks + && all ruleHasNoV4Operators bRules + && all queryHasNoV4Operators (cQueries <$> bChecks) + case (bVersion, isV3) of + (Just 4, _) -> pure Block {..} + (Just 3, True) -> pure Block {..} + (Just 3, False) -> + Left "Biscuit v4 fields are present, but the block version is 3." + _ -> + Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only versions 3 and 4 are supported" -- | Turn a biscuit block into a protobuf block, for serialization, -- along with the newly defined symbols -blockToPb :: Symbols -> Block -> (BlockSymbols, PB.Block) -blockToPb existingSymbols b@Block{..} = - let +blockToPb :: Bool -> Symbols -> Block -> (BlockSymbols, PB.Block) +blockToPb hasExternalPk existingSymbols b@Block{..} = + let isV3 = not hasExternalPk + && Set.null bScope + && all ruleHasNoScope bRules + && all queryHasNoScope (cQueries <$> bChecks) + && all isCheckOne bChecks + && all ruleHasNoV4Operators bRules + && all queryHasNoV4Operators (cQueries <$> bChecks) bSymbols = buildSymbolTable existingSymbols b s = reverseSymbols $ addFromBlock existingSymbols bSymbols symbols = PB.putField $ getSymbolList bSymbols context = PB.putField bContext - version = PB.putField $ Just 3 facts_v2 = PB.putField $ factToPb s <$> bFacts rules_v2 = PB.putField $ ruleToPb s <$> bRules checks_v2 = PB.putField $ checkToPb s <$> bChecks + scope = PB.putField $ scopeToPb s <$> Set.toList bScope + pksTable = PB.putField $ publicKeyToPb <$> getPkList bSymbols + version = PB.putField $ if isV3 then Just 3 + else Just 4 in (bSymbols, PB.Block {..}) pbToFact :: Symbols -> PB.FactV2 -> Either String Fact @@ -134,11 +190,14 @@ let pbHead = PB.getField $ PB.head pbRule pbBody = PB.getField $ PB.body pbRule pbExpressions = PB.getField $ PB.expressions pbRule + pbScope = PB.getField $ getField @"scope" pbRule rhead <- pbToPredicate s pbHead body <- traverse (pbToPredicate s) pbBody expressions <- traverse (pbToExpression s) pbExpressions - let scope = Nothing -- todo read it from PB - pure Rule {..} + scope <- Set.fromList <$> traverse (pbToScope s) pbScope + case makeRule rhead body expressions scope of + Failure vs -> Left $ "Unbound variables in rule: " <> T.unpack (T.intercalate ", " $ NE.toList vs) + Success r -> pure r ruleToPb :: ReverseSymbols -> Rule -> PB.RuleV2 ruleToPb s Rule{..} = @@ -146,16 +205,22 @@ { head = PB.putField $ predicateToPb s rhead , body = PB.putField $ predicateToPb s <$> body , expressions = PB.putField $ expressionToPb s <$> expressions + , scope = PB.putField $ scopeToPb s <$> Set.toList scope } pbToCheck :: Symbols -> PB.CheckV2 -> Either String Check -pbToCheck s PB.CheckV2{queries} = do +pbToCheck s PB.CheckV2{queries,kind} = do let toCheck Rule{body,expressions,scope} = QueryItem{qBody = body, qExpressions = expressions, qScope = scope} rules <- traverse (pbToRule s) $ PB.getField queries - pure $ toCheck <$> rules + let cQueries = toCheck <$> rules + let cKind = case PB.getField kind of + Just PB.All -> All + Just PB.One -> One + Nothing -> One + pure Check{..} checkToPb :: ReverseSymbols -> Check -> PB.CheckV2 -checkToPb s items = +checkToPb s Check{..} = let dummyHead = Predicate "query" [] toQuery QueryItem{..} = ruleToPb s $ Rule { rhead = dummyHead @@ -163,9 +228,28 @@ , expressions = qExpressions , scope = qScope } - in PB.CheckV2 { queries = PB.putField $ toQuery <$> items } + pbKind = case cKind of + One -> Nothing + All -> Just PB.All + in PB.CheckV2 { queries = PB.putField $ toQuery <$> cQueries + , kind = PB.putField pbKind + } -pbToPredicate :: Symbols -> PB.PredicateV2 -> Either String (Predicate' 'InPredicate 'RegularString) +pbToScope :: Symbols -> PB.Scope -> Either String RuleScope +pbToScope s = \case + PB.ScType e -> case PB.getField e of + PB.ScopeAuthority -> Right OnlyAuthority + PB.ScopePrevious -> Right Previous + PB.ScBlock pkRef -> + BlockId <$> getPublicKey' s (PublicKeyRef $ PB.getField pkRef) + +scopeToPb :: ReverseSymbols -> RuleScope -> PB.Scope +scopeToPb s = \case + OnlyAuthority -> PB.ScType $ PB.putField PB.ScopeAuthority + Previous -> PB.ScType $ PB.putField PB.ScopePrevious + BlockId pk -> PB.ScBlock $ PB.putField $ getPublicKeyCode s pk + +pbToPredicate :: Symbols -> PB.PredicateV2 -> Either String (Predicate' 'InPredicate 'Representation) pbToPredicate s pbPredicate = do let pbName = PB.getField $ PB.name pbPredicate pbTerms = PB.getField $ PB.terms pbPredicate @@ -227,7 +311,7 @@ Variable v -> absurd v Antiquote v -> absurd v -pbToSetValue :: Symbols -> PB.TermV2 -> Either String (Term' 'WithinSet 'InFact 'RegularString) +pbToSetValue :: Symbols -> PB.TermV2 -> Either String (Term' 'WithinSet 'InFact 'Representation) pbToSetValue s = \case PB.TermInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f PB.TermString f -> LString <$> getSymbol s (SymbolRef $ PB.getField f) @@ -237,7 +321,7 @@ PB.TermVariable _ -> Left "Variables can't appear in facts or sets" PB.TermTermSet _ -> Left "Sets can't be nested" -setValueToPb :: ReverseSymbols -> Term' 'WithinSet 'InFact 'RegularString -> PB.TermV2 +setValueToPb :: ReverseSymbols -> Term' 'WithinSet 'InFact 'Representation -> PB.TermV2 setValueToPb s = \case LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v LString v -> PB.TermString $ PB.putField $ getSymbolRef $ getSymbolCode s v @@ -302,6 +386,9 @@ PB.Or -> Or PB.Intersection -> Intersection PB.Union -> Union + PB.BitwiseAnd -> BitwiseAnd + PB.BitwiseOr -> BitwiseOr + PB.BitwiseXor -> BitwiseXor binaryToPb :: Binary -> PB.OpBinary binaryToPb = PB.OpBinary . PB.putField . \case @@ -322,3 +409,35 @@ Or -> PB.Or Intersection -> PB.Intersection Union -> PB.Union + BitwiseAnd -> PB.BitwiseAnd + BitwiseOr -> PB.BitwiseOr + BitwiseXor -> PB.BitwiseXor + + +pbToThirdPartyBlockRequest :: PB.ThirdPartyBlockRequest -> Either String (Crypto.PublicKey, [Crypto.PublicKey]) +pbToThirdPartyBlockRequest PB.ThirdPartyBlockRequest{previousPk, pkTable} = do + bisequence + ( pbToPublicKey $ PB.getField previousPk + , traverse pbToPublicKey $ PB.getField pkTable + ) + +thirdPartyBlockRequestToPb :: (Crypto.PublicKey, [Crypto.PublicKey]) -> PB.ThirdPartyBlockRequest +thirdPartyBlockRequestToPb (previousPk, pkTable) = PB.ThirdPartyBlockRequest + { previousPk = PB.putField $ publicKeyToPb previousPk + , pkTable = PB.putField $ publicKeyToPb <$> pkTable + } + +pbToThirdPartyBlockContents :: PB.ThirdPartyBlockContents -> Either String (ByteString, Crypto.Signature, Crypto.PublicKey) +pbToThirdPartyBlockContents PB.ThirdPartyBlockContents{payload,externalSig} = do + (sig, pk) <- pbToOptionalSignature $ PB.getField externalSig + pure ( PB.getField payload + , sig + , pk + ) + +thirdPartyBlockContentsToPb :: (ByteString, Crypto.Signature, Crypto.PublicKey) -> PB.ThirdPartyBlockContents +thirdPartyBlockContentsToPb (payload, sig, pk) = PB.ThirdPartyBlockContents + { PB.payload = PB.putField payload + , PB.externalSig = PB.putField $ externalSigToPb (sig, pk) + } + diff --git a/src/Auth/Biscuit/Symbols.hs b/src/Auth/Biscuit/Symbols.hs --- a/src/Auth/Biscuit/Symbols.hs +++ b/src/Auth/Biscuit/Symbols.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Auth.Biscuit.Symbols @@ -7,89 +8,164 @@ , BlockSymbols , ReverseSymbols , SymbolRef (..) + , PublicKeyRef (..) , getSymbol + , getPublicKey' , addSymbols , addFromBlock - , addFromBlocks + , registerNewSymbols + , registerNewPublicKeys + , forgetSymbols , reverseSymbols , getSymbolList + , getPkList + , getPkTable , getSymbolCode + , getPublicKeyCode , newSymbolTable ) where -import Control.Monad (join) -import Data.Int (Int64) -import Data.Map (Map, elems, (!?)) -import qualified Data.Map as Map -import Data.Set (Set, difference, union) -import qualified Data.Set as Set -import Data.Text (Text) +import Auth.Biscuit.Crypto (PublicKey) +import Data.Int (Int64) +import Data.List ((\\)) +import Data.Map (Map, elems, (!?)) +import qualified Data.Map as Map +import Data.Set (Set, difference, union) +import qualified Data.Set as Set +import Data.Text (Text) -import Auth.Biscuit.Utils (maybeToRight) +import Auth.Biscuit.Utils (maybeToRight) newtype SymbolRef = SymbolRef { getSymbolRef :: Int64 } - deriving stock (Eq) + deriving stock (Eq, Ord) + deriving newtype (Enum) instance Show SymbolRef where show = ("#" <>) . show . getSymbolRef -newtype Symbols = Symbols { getSymbols :: Map Int64 Text } - deriving stock (Eq, Show) +newtype PublicKeyRef = PublicKeyRef { getPublicKeyRef :: Int64 } + deriving stock (Eq, Ord) + deriving newtype (Enum) -newtype BlockSymbols = BlockSymbols { getBlockSymbols :: Map Int64 Text } - deriving stock (Eq, Show) - deriving newtype (Semigroup) +instance Show PublicKeyRef where + show = ("#" <>) . show . getPublicKeyRef -newtype ReverseSymbols = ReverseSymbols { getReverseSymbols :: Map Text Int64 } +data Symbols = Symbols + { symbols :: Map SymbolRef Text + , publicKeys :: Map PublicKeyRef PublicKey + } deriving stock (Eq, Show) + +data BlockSymbols = BlockSymbols + { blockSymbols :: Map SymbolRef Text + , blockPublicKeys :: Map PublicKeyRef PublicKey + } deriving stock (Eq, Show) + +instance Semigroup BlockSymbols where + b <> b' = BlockSymbols + { blockSymbols = blockSymbols b <> blockSymbols b' + , blockPublicKeys = blockPublicKeys b <> blockPublicKeys b' + } + +data ReverseSymbols = ReverseSymbols + { reverseSymbolMap :: Map Text SymbolRef + , reversePublicKeyMap :: Map PublicKey PublicKeyRef + } deriving stock (Eq, Show) - deriving newtype (Semigroup) +instance Semigroup ReverseSymbols where + b <> b' = ReverseSymbols + { reverseSymbolMap = reverseSymbolMap b <> reverseSymbolMap b' + , reversePublicKeyMap = reversePublicKeyMap b <> reversePublicKeyMap b' + } + +getNextOffset :: Symbols -> SymbolRef +getNextOffset (Symbols m _) = + SymbolRef $ fromIntegral $ 1024 + (Map.size m - Map.size commonSymbols) + +getNextPublicKeyOffset :: Symbols -> PublicKeyRef +getNextPublicKeyOffset (Symbols _ m) = + PublicKeyRef $ fromIntegral $ Map.size m + getSymbol :: Symbols -> SymbolRef -> Either String Text -getSymbol (Symbols m) (SymbolRef i) = - maybeToRight ("Missing symbol at id #" <> show i) $ m !? i +getSymbol (Symbols m _) i = + maybeToRight ("Missing symbol at id " <> show i) $ m !? i +getPublicKey' :: Symbols -> PublicKeyRef -> Either String PublicKey +getPublicKey' (Symbols _ m) i = + maybeToRight ("Missing symbol at id " <> show i) $ m !? i + -- | Given already existing symbols and a set of symbols used in a block, -- compute the symbol table carried by this specific block -addSymbols :: Symbols -> Set Text -> BlockSymbols -addSymbols (Symbols m) symbols = - let existingSymbols = Set.fromList (elems commonSymbols) `union` Set.fromList (elems m) - newSymbols = Set.toList $ symbols `difference` existingSymbols - starting = fromIntegral $ 1024 + (Map.size m - Map.size commonSymbols) - in BlockSymbols $ Map.fromList (zip [starting..] newSymbols) +addSymbols :: Symbols -> Set Text -> Set PublicKey -> BlockSymbols +addSymbols s@(Symbols sm pkm) bSymbols pks = + let existingSymbols = Set.fromList (elems commonSymbols) `union` Set.fromList (elems sm) + newSymbols = Set.toList $ bSymbols `difference` existingSymbols + starting = getNextOffset s + existingPks = Set.fromList (elems pkm) + newPks = Set.toList $ pks `difference` existingPks + startingPk = getNextPublicKeyOffset s + in BlockSymbols + { blockSymbols = Map.fromList (zip [starting..] newSymbols) + , blockPublicKeys = Map.fromList (zip [startingPk..] newPks) + } getSymbolList :: BlockSymbols -> [Text] -getSymbolList (BlockSymbols m) = Map.elems m +getSymbolList (BlockSymbols m _) = Map.elems m +getPkList :: BlockSymbols -> [PublicKey] +getPkList (BlockSymbols _ m) = Map.elems m + +getPkTable :: Symbols -> [PublicKey] +getPkTable (Symbols _ m) = Map.elems m + newSymbolTable :: Symbols -newSymbolTable = Symbols commonSymbols +newSymbolTable = Symbols commonSymbols Map.empty -- | Given the symbol table of a protobuf block, update the provided symbol table addFromBlock :: Symbols -> BlockSymbols -> Symbols -addFromBlock (Symbols m) (BlockSymbols bm) = - Symbols $ m <> bm +addFromBlock (Symbols sm pkm) (BlockSymbols bsm bpkm) = + Symbols + { symbols = sm <> bsm + , publicKeys = pkm <> bpkm + } --- | Compute a global symbol table from a series of block symbol tables -addFromBlocks :: [[Text]] -> Symbols -addFromBlocks blocksTables = - let allSymbols = join blocksTables - in Symbols $ commonSymbols <> Map.fromList (zip [1024..] allSymbols) +registerNewSymbols :: [Text] -> Symbols -> Symbols +registerNewSymbols newSymbols s@Symbols{symbols} = + let newSymbolsMap = Map.fromList $ zip [getNextOffset s..] newSymbols + in s { symbols = symbols <> newSymbolsMap } +registerNewPublicKeys :: [PublicKey] -> Symbols -> Symbols +registerNewPublicKeys newPks s@Symbols{publicKeys} = + let newPkMap = Map.fromList $ zip [getNextPublicKeyOffset s..] (newPks \\ elems publicKeys) + in s { publicKeys = publicKeys <> newPkMap } + +forgetSymbols :: Symbols -> Symbols +forgetSymbols s = s { symbols = commonSymbols } + -- | Reverse a symbol table reverseSymbols :: Symbols -> ReverseSymbols -reverseSymbols = +reverseSymbols (Symbols sm pkm) = let swap (a,b) = (b,a) - in ReverseSymbols . Map.fromList . fmap swap . Map.toList . getSymbols + reverseMap :: (Ord a, Ord b) => Map a b -> Map b a + reverseMap = Map.fromList . fmap swap . Map.toList + in ReverseSymbols + { reverseSymbolMap = reverseMap sm + , reversePublicKeyMap = reverseMap pkm + } -- | Given a reverse symbol table (symbol refs indexed by their textual -- representation), turn textual representations into symbol refs. -- This function is partial, the reverse table is guaranteed to -- contain the expected textual symbols. getSymbolCode :: ReverseSymbols -> Text -> SymbolRef -getSymbolCode (ReverseSymbols rm) t = SymbolRef $ rm Map.! t +getSymbolCode (ReverseSymbols rm _) t = rm Map.! t +getPublicKeyCode :: ReverseSymbols -> PublicKey -> Int64 +getPublicKeyCode (ReverseSymbols _ rm) t = getPublicKeyRef $ rm Map.! t + -- | The common symbols defined in the biscuit spec -commonSymbols :: Map Int64 Text -commonSymbols = Map.fromList $ zip [0..] +commonSymbols :: Map SymbolRef Text +commonSymbols = Map.fromList $ zip [SymbolRef 0..] [ "read" , "write" , "resource" 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 @@ -20,9 +20,12 @@ , blocks , proof , proofCheck + , queryRawBiscuitFacts , ParseError (..) , ExistingBlock , ParsedSignedBlock + , AuthorizedBiscuit (..) + , queryAuthorizerFacts -- $openOrSealed , OpenOrSealed , Open @@ -33,6 +36,7 @@ , mkBiscuit , mkBiscuitWith , addBlock + , addSignedBlock , BiscuitEncoding (..) , ParserConfig (..) , parseBiscuitWith @@ -50,12 +54,19 @@ , getRevocationIds , getVerifiedBiscuitPublicKey + -- third party + , mkThirdPartyBlockReq + , mkThirdPartyBlock + , applyThirdPartyBlock ) where -import Control.Monad (join, when) +import Control.Monad (join, unless, when) +import Control.Monad.State (lift, mapStateT, + runStateT) import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as B64 +import Data.Foldable (fold) import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Set (Set) @@ -63,29 +74,41 @@ import Auth.Biscuit.Crypto (PublicKey, SecretKey, Signature, SignedBlock, - convert, getSignatureProof, - signBlock, toPublic, + sigBytes, + sign3rdPartyBlock, + signBlock, + signExternalBlock, + skBytes, toPublic, verifyBlocks, + verifyExternalSig, verifySecretProof, verifySignatureProof) -import Auth.Biscuit.Datalog.AST (Authorizer, Block) -import Auth.Biscuit.Datalog.Executor (ExecutionError, Limits, - defaultLimits) +import Auth.Biscuit.Datalog.AST (Authorizer, Block, Query, + toEvaluation) +import Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError, + Limits, defaultLimits) import Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess, + collectWorld, + queryAvailableFacts, + queryGeneratedFacts, runAuthorizerWithLimits) import qualified Auth.Biscuit.Proto as PB -import Auth.Biscuit.ProtoBufAdapter (blockToPb, extractSymbols, - pbToBlock, pbToProof, +import Auth.Biscuit.ProtoBufAdapter (blockToPb, pbToBlock, + pbToProof, pbToSignedBlock, - signedBlockToPb) + pbToThirdPartyBlockContents, + pbToThirdPartyBlockRequest, + signedBlockToPb, + thirdPartyBlockContentsToPb, + thirdPartyBlockRequestToPb) import Auth.Biscuit.Symbols -- | Protobuf serialization does not have a guaranteed deterministic behaviour, -- so we need to keep the initial serialized payload around in order to compute -- a new signature when adding a block. type ExistingBlock = (ByteString, Block) -type ParsedSignedBlock = (ExistingBlock, Signature, PublicKey) +type ParsedSignedBlock = (ExistingBlock, Signature, PublicKey, Maybe (Signature, PublicKey)) -- $openOrSealed -- @@ -109,12 +132,14 @@ -- /open/ (capable of being attenuated further). In that case the proof is a secret -- key that can be used to sign a new block. newtype Open = Open SecretKey + deriving stock (Eq, Show) -- | This datatype represents the final proof of a biscuit statically known to be -- /sealed/ (not capable of being attenuated further). In that case the proof is a -- signature proving that the party who sealed the token did know the last secret -- key. newtype Sealed = Sealed Signature + deriving stock (Eq, Show) -- | This class allows functions working on both open and sealed biscuits to accept -- indifferently 'OpenOrSealed', 'Open' or 'Sealed' biscuits. It has no laws, it only @@ -178,6 +203,42 @@ } deriving (Eq, Show) +-- | Query the facts contained in a biscuit, /before running authorization/. This function +-- should only be used to extract information needed to generate an authorizer. In other +-- cases, you likely want 'queryAuthorizerFacts' instead, which queries facts /after running +-- authorization/. +-- +-- ⚠ Only facts directly contained in the biscuit are queried. Rules are not processed +-- at this point, so derived facts are not generated yet. +-- +-- ⚠ By default, only facts from the authority block are queried, +-- like what happens in rules and checks. Facts from other blocks can be queried +-- with a @trusting@ annotation. Be careful with @trusting previous@, as it queries +-- facts from all blocks, even untrusted ones. +queryRawBiscuitFactsWithLimits :: Biscuit openOrSealed check -> Limits -> Query + -> Set Bindings +queryRawBiscuitFactsWithLimits b@Biscuit{authority,blocks} = + let ePks = externalKeys b + getBlock ((_, block), _, _, _) = block + allBlocks = zip [0..] $ getBlock <$> authority : blocks + (_, sFacts) = fold (uncurry collectWorld . fmap (toEvaluation ePks) <$> allBlocks) + in queryAvailableFacts ePks sFacts + +-- | Query the facts generated by the authority and authorizer blocks +-- during authorization. This can be used in conjuction with 'getVariableValues' +-- and 'getSingleVariableValue' to retrieve actual values. +-- +-- ⚠ By default, only facts from the authority block and the authorizer are queried, +-- like what happens in rules and checks. Facts from other blocks can be queried +-- with a @trusting@ annotation. Be careful with @trusting previous@, as it queries +-- facts from all blocks, even untrusted ones. +-- +-- 💁 If the facts you want to query are part of an allow query in the authorizer, +-- you can directly get values by calling 'getBindings' on 'AuthorizationSuccess'. +queryRawBiscuitFacts :: Biscuit openOrSealed check -> Query + -> Set Bindings +queryRawBiscuitFacts b = queryRawBiscuitFactsWithLimits b defaultLimits + -- | Turn a 'Biscuit' statically known to be 'Open' into a more generic 'OpenOrSealed' 'Biscuit' -- (essentially /forgetting/ about the fact it's 'Open') fromOpen :: Biscuit Open check -> Biscuit OpenOrSealed check @@ -203,7 +264,7 @@ _ -> Nothing toParsedSignedBlock :: Block -> SignedBlock -> ParsedSignedBlock -toParsedSignedBlock block (serializedBlock, sig, pk) = ((serializedBlock, block), sig, pk) +toParsedSignedBlock block (serializedBlock, sig, pk, eSig) = ((serializedBlock, block), sig, pk, eSig) -- | Create a new biscuit with the provided authority block. Such a biscuit is 'Open' to -- further attenuation. @@ -214,8 +275,8 @@ -- further attenuation. mkBiscuitWith :: Maybe Int -> SecretKey -> Block -> IO (Biscuit Open Verified) mkBiscuitWith rootKeyId sk authority = do - let (authoritySymbols, authoritySerialized) = PB.encodeBlock <$> blockToPb newSymbolTable authority - (signedBlock, nextSk) <- signBlock sk authoritySerialized + let (authoritySymbols, authoritySerialized) = PB.encodeBlock <$> blockToPb False newSymbolTable authority + (signedBlock, nextSk) <- signBlock sk authoritySerialized Nothing pure Biscuit { rootKeyId , authority = toParsedSignedBlock authority signedBlock , blocks = [] @@ -230,29 +291,103 @@ -> Biscuit Open check -> IO (Biscuit Open check) addBlock block b@Biscuit{..} = do - let (blockSymbols, blockSerialized) = PB.encodeBlock <$> blockToPb symbols block + let (blockSymbols, blockSerialized) = PB.encodeBlock <$> blockToPb False symbols block Open p = proof - (signedBlock, nextSk) <- signBlock p blockSerialized + (signedBlock, nextSk) <- signBlock p blockSerialized Nothing pure $ b { blocks = blocks <> [toParsedSignedBlock block signedBlock] , symbols = addFromBlock symbols blockSymbols , proof = Open nextSk } +-- | Directly append a third-party block to a token. Please use +-- 'mkThirdPartyBlockReq', 'mkThirdPartyBlock' and 'applyThirdPartyBlock' +-- instead if the party signing the block cannot have access to the token. +addSignedBlock :: SecretKey + -> Block + -> Biscuit Open check + -> IO (Biscuit Open check) +addSignedBlock eSk block b@Biscuit{..} = do + let symbolsForCurrentBlock = forgetSymbols $ registerNewPublicKeys [toPublic eSk] symbols + (newSymbols, blockSerialized) = PB.encodeBlock <$> blockToPb True symbolsForCurrentBlock block + lastBlock = NE.last (authority :| blocks) + (_, _, lastPublicKey, _) = lastBlock + Open p = proof + (signedBlock, nextSk) <- signExternalBlock p eSk lastPublicKey blockSerialized + pure $ b { blocks = blocks <> [toParsedSignedBlock block signedBlock] + , symbols = registerNewPublicKeys (getPkList newSymbols) symbols + , proof = Open nextSk + } + +mkThirdPartyBlock' :: SecretKey + -> [PublicKey] + -> PublicKey + -> Block + -> (ByteString, Signature, PublicKey) +mkThirdPartyBlock' eSk pkTable lastPublicKey block = + let symbolsForCurrentBlock = registerNewPublicKeys [toPublic eSk] $ + registerNewPublicKeys pkTable newSymbolTable + (_, payload) = PB.encodeBlock <$> blockToPb True symbolsForCurrentBlock block + (eSig, ePk) = sign3rdPartyBlock eSk lastPublicKey payload + in (payload, eSig, ePk) + +-- | Given a third-party block request, generate a third-party block, +-- which can be then appended to a token with 'applyThirdPartyBlock'. +mkThirdPartyBlock :: SecretKey + -> ByteString + -> Block + -> Either String ByteString +mkThirdPartyBlock eSk req block = do + (previousPk, pkTable) <- pbToThirdPartyBlockRequest =<< PB.decodeThirdPartyBlockRequest req + pure $ PB.encodeThirdPartyBlockContents . thirdPartyBlockContentsToPb $ mkThirdPartyBlock' eSk pkTable previousPk block + +-- | Generate a third-party block request. It can be used in +-- conjunction with 'mkThirdPartyBlock' to generate a +-- third-party block, which can be then appended to a token with +-- 'applyThirdPartyBlock'. +mkThirdPartyBlockReq :: Biscuit proof check -> ByteString +mkThirdPartyBlockReq Biscuit{authority,blocks,symbols} = + let (_, _ , lastPk, _) = NE.last $ authority :| blocks + in PB.encodeThirdPartyBlockRequest $ thirdPartyBlockRequestToPb (lastPk, getPkTable symbols) + +-- | Given a base64-encoded third-party block, append it to a token. +applyThirdPartyBlock :: Biscuit Open check -> ByteString -> Either String (IO (Biscuit Open check)) +applyThirdPartyBlock b@Biscuit{..} contents = do + (payload, eSig, ePk) <- pbToThirdPartyBlockContents =<< PB.decodeThirdPartyBlockContents contents + let Open p = proof + addESig (a,b',c,_) = (a,b',c, Just (eSig, ePk)) + (_, _, lastPk, _) = NE.last $ authority :| blocks + pbBlock <- PB.decodeBlock payload + (block, newSymbols) <- (`runStateT` symbols) $ pbToBlock (Just ePk) pbBlock + unless (verifyExternalSig lastPk (payload, eSig, ePk)) $ + Left "Invalid 3rd party signature" + pure $ do + (signedBlock, nextSk) <- signBlock p payload (Just (eSig, ePk)) + pure $ b { blocks = blocks <> [toParsedSignedBlock block (addESig signedBlock)] + , proof = Open nextSk + , symbols = newSymbols + } + +externalKeys :: Biscuit openOrSealed check -> [Maybe PublicKey] +externalKeys Biscuit{blocks} = + let getEpk (_, _, _, Just (_, ePk)) = Just ePk + getEpk _ = Nothing + in Nothing : (getEpk <$> blocks) + -- | Turn an 'Open' biscuit into a 'Sealed' one, preventing it from being attenuated -- further. A 'Sealed' biscuit cannot be turned into an 'Open' one. seal :: Biscuit Open check -> Biscuit Sealed check seal b@Biscuit{..} = let Open sk = proof - ((lastPayload, _), lastSig, lastPk) = NE.last $ authority :| blocks - newProof = Sealed $ getSignatureProof (lastPayload, lastSig, lastPk) sk + ((lastPayload, _), lastSig, lastPk, eSig) = NE.last $ authority :| blocks + newProof = Sealed $ getSignatureProof (lastPayload, lastSig, lastPk, eSig) sk in b { proof = newProof } -- | Serialize a biscuit to a raw bytestring serializeBiscuit :: BiscuitProof p => Biscuit p Verified -> ByteString serializeBiscuit Biscuit{..} = let proofField = case toPossibleProofs proof of - SealedProof sig -> PB.ProofSignature $ PB.putField (convert sig) - OpenProof sk -> PB.ProofSecret $ PB.putField (convert sk) + SealedProof sig -> PB.ProofSignature $ PB.putField (sigBytes sig) + OpenProof sk -> PB.ProofSecret $ PB.putField (skBytes sk) in PB.encodeBlockList PB.Biscuit { rootKeyId = PB.putField $ fromIntegral <$> rootKeyId , authority = PB.putField $ toPBSignedBlock authority @@ -261,7 +396,7 @@ } toPBSignedBlock :: ParsedSignedBlock -> PB.SignedBlock -toPBSignedBlock ((block, _), sig, pk) = signedBlockToPb (block, sig, pk) +toPBSignedBlock ((block, _), sig, pk, eSig) = signedBlockToPb (block, sig, pk, eSig) -- | Errors that can happen when parsing a biscuit. Since complete parsing of a biscuit -- requires a signature check, an invalid signature check is a parsing error @@ -272,8 +407,10 @@ -- ^ The provided ByteString is not base64-encoded | InvalidProtobufSer Bool String -- ^ The provided ByteString does not contain properly serialized protobuf values + -- The boolean parameter is True if the error happened on the wrapper, False if it happened on a block | InvalidProtobuf Bool String -- ^ The bytestring was correctly deserialized from protobuf, but the values can't be turned into a proper biscuit + -- The boolean parameter is True if the error happened on the wrapper, False if it happened on a block | InvalidSignatures -- ^ The signatures were invalid | InvalidProof @@ -313,7 +450,7 @@ -> BiscuitWrapper -> m (Either ParseError BiscuitWrapper) checkRevocation isRevoked bw@BiscuitWrapper{wAuthority,wBlocks} = - let getRevocationId (_, sig, _) = convert sig + let getRevocationId (_, sig, _, _) = sigBytes sig revocationIds = getRevocationId <$> wAuthority :| wBlocks keepIfNotRevoked True = Left RevokedBiscuit keepIfNotRevoked False = Right bw @@ -321,18 +458,15 @@ parseBlocks :: BiscuitWrapper -> Either ParseError (Symbols, NonEmpty ParsedSignedBlock) parseBlocks BiscuitWrapper{..} = do - let toRawSignedBlock (payload, sig, pk') = do - pbBlock <- first (InvalidProtobufSer False) $ PB.decodeBlock payload - pure ((payload, pbBlock), sig, pk') - - rawAuthority <- toRawSignedBlock wAuthority - rawBlocks <- traverse toRawSignedBlock wBlocks + let parseBlock (payload, sig, pk, eSig) = do + pbBlock <- lift $ first (InvalidProtobufSer False) $ PB.decodeBlock payload + block <- mapStateT (first (InvalidProtobuf False)) $ pbToBlock (snd <$> eSig) pbBlock + pure ((payload, block), sig, pk, eSig) - let symbols = extractSymbols $ (\((_, p), _, _) -> p) <$> rawAuthority : rawBlocks + (allBlocks, symbols) <- (`runStateT` newSymbolTable) $ do + traverse parseBlock (wAuthority :| wBlocks) - authority <- rawSignedBlockToParsedSignedBlock symbols rawAuthority - blocks <- traverse (rawSignedBlockToParsedSignedBlock symbols) rawBlocks - pure (symbols, authority :| blocks) + pure (symbols, allBlocks) -- | Parse a biscuit without performing any signatures check. This function is intended to -- provide tooling (eg adding a block, or inspecting a biscuit) without having to verify @@ -374,7 +508,7 @@ -> Either ParseError (Biscuit proof Verified) checkBiscuitSignatures getPublicKey b@Biscuit{..} = do let pk = getPublicKey rootKeyId - toSignedBlock ((payload, _), sig, nextPk) = (payload, sig, nextPk) + toSignedBlock ((payload, _), sig, nextPk, eSig) = (payload, sig, nextPk, eSig) allBlocks = toSignedBlock <$> (authority :| blocks) blocksResult = verifyBlocks allBlocks pk proofResult = case toPossibleProofs proof of @@ -415,30 +549,34 @@ in (parseBiscuit' pk =<<) <$> checkRevocation isRevoked w in join <$> traverse wrapperToBiscuit parsedWrapper -rawSignedBlockToParsedSignedBlock :: Symbols - -> ((ByteString, PB.Block), Signature, PublicKey) - -> Either ParseError ParsedSignedBlock -rawSignedBlockToParsedSignedBlock s ((payload, pbBlock), sig, pk) = do - block <- first (InvalidProtobuf False) $ pbToBlock s pbBlock - pure ((payload, block), sig, pk) - -- | Extract the list of revocation ids from a biscuit. -- To reject revoked biscuits, please use 'parseWith' instead. This function --- should only be used for debugging purposes. +-- should only be used for inspecting biscuits, not for deciding whether to +-- reject them or not. getRevocationIds :: Biscuit proof check -> NonEmpty ByteString getRevocationIds Biscuit{authority, blocks} = let allBlocks = authority :| blocks - getRevocationId (_, sig, _) = convert sig + getRevocationId (_, sig, _, _) = sigBytes sig in getRevocationId <$> allBlocks -- | Generic version of 'authorizeBiscuitWithLimits' which takes custom 'Limits'. -authorizeBiscuitWithLimits :: Limits -> Biscuit a Verified -> Authorizer -> IO (Either ExecutionError AuthorizationSuccess) -authorizeBiscuitWithLimits l Biscuit{..} authorizer = - let toBlockWithRevocationId ((_, block), sig, _) = (block, convert sig) - in runAuthorizerWithLimits l - (toBlockWithRevocationId authority) - (toBlockWithRevocationId <$> blocks) - authorizer +authorizeBiscuitWithLimits :: Limits -> Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof)) +authorizeBiscuitWithLimits l biscuit@Biscuit{..} authorizer = + let toBlockWithRevocationId ((_, block), sig, _, eSig) = (block, sigBytes sig, snd <$> eSig) + -- the authority block can't be externally signed. If it carries a signature, it won't be + -- verified. So we need to make sure there is none, to avoid having facts trusted without + -- a proper signature check + dropExternalPk (b, rid, _) = (b, rid, Nothing) + withBiscuit authorizationSuccess = + AuthorizedBiscuit + { authorizedBiscuit = biscuit + , authorizationSuccess + } + in fmap withBiscuit <$> + runAuthorizerWithLimits l + (dropExternalPk $ toBlockWithRevocationId authority) + (toBlockWithRevocationId <$> blocks) + authorizer -- | Given a biscuit with a verified signature and an authorizer (a set of facts, rules, checks -- and policies), verify a biscuit: @@ -453,7 +591,7 @@ -- -- Specific runtime limits can be specified by using 'authorizeBiscuitWithLimits'. 'authorizeBiscuit' -- uses a set of defaults defined in 'defaultLimits'. -authorizeBiscuit :: Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError AuthorizationSuccess) +authorizeBiscuit :: Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof)) authorizeBiscuit = authorizeBiscuitWithLimits defaultLimits -- | Retrieve the `PublicKey` which was used to verify the `Biscuit` signatures @@ -461,3 +599,30 @@ getVerifiedBiscuitPublicKey Biscuit{proofCheck} = let Verified pk = proofCheck in pk + +-- | The results of authorization, along with the biscuit that was authorized. +data AuthorizedBiscuit p + = AuthorizedBiscuit + { authorizedBiscuit :: Biscuit p Verified + , authorizationSuccess :: AuthorizationSuccess + } + deriving (Eq, Show) + +-- | Query the facts generated during authorization. This can be used in conjuction +-- with 'getVariableValues' and 'getSingleVariableValue' to retrieve actual values. +-- +-- ⚠ By default, only facts from the authority block and the authorizer are queried, +-- like what happens in rules and checks. Facts from other blocks can be queried +-- with a @trusting@ annotation. Be careful with @trusting previous@, as it queries +-- facts from all blocks, even untrusted ones. +-- +-- 💁 If the facts you want to query are part of an allow query in the authorizer, +-- you can directly get values by calling 'getBindings' on 'AuthorizationSuccess'. +-- +-- 💁 If you are trying to extract facts from a biscuit in order to generate an +-- authorizer, have a look at 'queryRawBiscuitFacts' instead. +queryAuthorizerFacts :: AuthorizedBiscuit p -> Query + -> Set Bindings +queryAuthorizerFacts AuthorizedBiscuit{authorizedBiscuit, authorizationSuccess} = + let ePks = externalKeys authorizedBiscuit + in queryGeneratedFacts ePks authorizationSuccess diff --git a/src/Auth/Biscuit/Utils.hs b/src/Auth/Biscuit/Utils.hs --- a/src/Auth/Biscuit/Utils.hs +++ b/src/Auth/Biscuit/Utils.hs @@ -6,9 +6,15 @@ -} module Auth.Biscuit.Utils ( maybeToRight + , rightToMaybe ) where -- | Exactly like `maybeToRight` from the `either` package, -- but without the dependency footprint maybeToRight :: b -> Maybe a -> Either b a maybeToRight b = maybe (Left b) Right + +-- | Exactly like `rightToMaybe` from the `either` package, +-- but without the dependency footprint +rightToMaybe :: Either b a -> Maybe a +rightToMaybe = either (const Nothing) Just diff --git a/test/Spec/Executor.hs b/test/Spec/Executor.hs --- a/test/Spec/Executor.hs +++ b/test/Spec/Executor.hs @@ -3,7 +3,6 @@ {-# LANGUAGE QuasiQuotes #-} module Spec.Executor (specs) where -import Data.Attoparsec.Text (parseOnly) import Data.Map.Strict as Map import Data.Set as Set import Data.Text (Text, unpack) @@ -19,6 +18,7 @@ import Auth.Biscuit.Datalog.Parser (expressionParser, fact, rule) import Auth.Biscuit.Datalog.ScopedExecutor hiding (limits) +import Spec.Parser (parseExpression) specs :: TestTree specs = testGroup "Datalog evaluation" @@ -35,9 +35,12 @@ authGroup :: Set Fact -> FactGroup authGroup = FactGroup . Map.singleton (Set.singleton 0) -authRulesGroup :: Set Rule -> Map Natural (Set Rule) -authRulesGroup = Map.singleton 0 +authRulesGroup :: Set Rule -> Map Natural (Set EvalRule) +authRulesGroup = Map.singleton 0 . adaptRules +adaptRules :: Set Rule -> Set EvalRule +adaptRules = Set.map (toEvaluation []) + grandparent :: TestTree grandparent = testCase "Basic grandparent rule" $ let rules = authRulesGroup $ Set.fromList @@ -48,7 +51,7 @@ , [fact|parent("bob", "jean-pierre")|] , [fact|parent("alice", "toto")|] ] - in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList + in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList [ [fact|parent("alice", "bob")|] , [fact|parent("bob", "jean-pierre")|] , [fact|parent("alice", "toto")|] @@ -66,7 +69,7 @@ , [fact|parent("bob", "jean-pierre")|] , [fact|parent("alice", "toto")|] ] - in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList + in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList [ [fact|parent("alice", "bob")|] , [fact|parent("bob", "jean-pierre")|] , [fact|parent("alice", "toto")|] @@ -77,7 +80,7 @@ ]) expr :: Text -> Expression -expr = either error id . parseOnly expressionParser +expr = either error id . parseExpression exprEval :: TestTree exprEval = do @@ -188,7 +191,7 @@ , [fact|resource("file1")|] , [fact|resource("file2")|] ] - in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList + in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList [ [fact|time(2019-12-04T01:00:00Z)|] , [fact|resource("file1")|] , [fact|resource("file2")|] @@ -203,7 +206,7 @@ facts = authGroup $ Set.fromList [ [fact|test("whatever", "notNothing")|] ] - in runFactGeneration defaultLimits rules facts @?= Right (authGroup $ Set.fromList + in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList [ [fact|test("whatever", "notNothing")|] ]) @@ -223,36 +226,71 @@ iterLimits = defaultLimits { maxIterations = 2 } in testGroup "Facts generation limits" [ testCase "max facts" $ - runFactGeneration factLimits rules facts @?= Left Facts + runFactGeneration factLimits 1 rules facts @?= Left Facts , testCase "max iterations" $ - runFactGeneration iterLimits rules facts @?= Left Iterations + runFactGeneration iterLimits 1 rules facts @?= Left Iterations ] scopedRules :: TestTree -scopedRules = testCase "Rules and facts in different scopes, with default scoping for rules" $ - let rules :: Map Natural (Set Rule) - rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b)|] ]) - , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] ]) - ] - facts :: FactGroup - facts = FactGroup - [ ([0], [ [fact|parent("alice", "bob")|] - , [fact|parent("bob", "trudy")|] - ]) - , ([1], [ [fact|parent("bob", "jean-pierre")|] - ]) - , ([2], [ [fact|parent("toto", "toto")|] - ]) - ] - in runFactGeneration defaultLimits rules facts @?= Right (FactGroup - [ ([0], [ [fact|parent("alice", "bob")|] - , [fact|ancestor("alice", "bob")|] - , [fact|parent("bob", "trudy")|] - , [fact|ancestor("bob", "trudy")|] - ]) - , ([1], [ [fact|parent("bob", "jean-pierre")|] - ]) - , ([0,1], [ [fact|ancestor("alice", "trudy")|] - ]) - , ([2], [ [fact|parent("toto", "toto")|] ]) - ]) +scopedRules = testGroup "Rules and facts in different scopes" + [ testCase "with default scoping for rules" $ + let rules :: Map Natural (Set Rule) + rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b)|] ]) + , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] ]) + ] + facts :: FactGroup + facts = FactGroup + [ ([0], [ [fact|parent("alice", "bob")|] + , [fact|parent("bob", "trudy")|] + ]) + , ([1], [ [fact|parent("bob", "jean-pierre")|] + ]) + , ([2], [ [fact|parent("toto", "toto")|] + ]) + ] + in runFactGeneration defaultLimits 3 (adaptRules <$> rules) facts @?= Right (FactGroup + [ ([0], [ [fact|parent("alice", "bob")|] + , [fact|ancestor("alice", "bob")|] + , [fact|parent("bob", "trudy")|] + , [fact|ancestor("bob", "trudy")|] + ]) + , ([1], [ [fact|parent("bob", "jean-pierre")|] + ]) + , ([0,1], [ [fact|ancestor("alice", "trudy")|] + ]) + , ([2], [ [fact|parent("toto", "toto")|] ]) + ]) + , testCase "with explicit scoping for rules (authority)" $ + let rules :: Map Natural (Set Rule) + rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b) trusting authority |] ]) + , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b) trusting authority |] ]) + , (2, [ [rule|family($a,$b) <- parent($a,$b) trusting authority |] ]) + ] + facts :: FactGroup + facts = FactGroup + [ ([0], [ [fact|parent("alice", "bob")|] + , [fact|parent("bob", "trudy")|] + ]) + , ([1], [ [fact|parent("bob", "jean-pierre")|] + ]) + , ([2], [ [fact|parent("toto", "toto")|] + ]) + ] + in runFactGeneration defaultLimits 3 (adaptRules <$> rules) facts @?= Right (FactGroup + [ ([0], [ [fact|parent("alice", "bob")|] + , [fact|ancestor("alice", "bob")|] + , [fact|parent("bob", "trudy")|] + , [fact|ancestor("bob", "trudy")|] + ]) + , ([1], [ [fact|parent("bob", "jean-pierre")|] + ]) + , ([0,1], [ [fact|ancestor("alice", "trudy")|] + ]) + , ([2], [ [fact|parent("toto", "toto")|] + , [fact|family("toto", "toto")|] + ]) + , ([0,2], [ [fact|family("alice", "bob")|] + , [fact|family("bob", "trudy")|] + ]) + ]) + ] diff --git a/test/Spec/NewCrypto.hs b/test/Spec/NewCrypto.hs --- a/test/Spec/NewCrypto.hs +++ b/test/Spec/NewCrypto.hs @@ -5,15 +5,14 @@ {- HLINT ignore "Reduce duplication" -} module Spec.NewCrypto (specs) where -import Data.ByteString (ByteString) -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust) +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isJust) import Test.Tasty import Test.Tasty.HUnit import Auth.Biscuit.Crypto -import Crypto.PubKey.Ed25519 -- This test module is only there to test the crypto layer of biscuits, -- so we define a custom token type that only cares about the envelope, @@ -30,7 +29,7 @@ signToken :: ByteString -> SecretKey -> IO Token signToken p sk = do - (signedBlock, privKey) <- signBlock sk p + (signedBlock, privKey) <- signBlock sk p Nothing pure Token { payload = pure signedBlock , privKey @@ -41,12 +40,21 @@ append :: Token -> ByteString -> IO Token append t@Token{payload} p = do - (signedBlock, privKey) <- signBlock (privKey t) p + (signedBlock, privKey) <- signBlock (privKey t) p Nothing pure Token { payload = snocNE payload signedBlock , privKey } +appendSigned :: Token -> SecretKey -> ByteString -> IO Token +appendSigned t@Token{payload} eSk p = do + let (_, _, lastPk, _) = NE.last payload + (signedBlock, privKey) <- signExternalBlock (privKey t) eSk lastPk p + pure Token + { payload = snocNE payload signedBlock + , privKey + } + seal :: Token -> SealedToken seal Token{payload,privKey} = let lastBlock = NE.last payload @@ -89,6 +97,10 @@ , tamperedBlockSealed , removedBlockSealed ] + , testGroup "external signatures" + [ multiBlockRoundtripWithExternal + , invalidExternalSig + ] ] singleBlockRoundtrip :: TestTree @@ -110,6 +122,36 @@ let res = verifyToken attenuated pk res @?= True +multiBlockRoundtripWithExternal :: TestTree +multiBlockRoundtripWithExternal = testCase "Multi block with external signatures roundtrip" $ do + sk <- generateSecretKey + eSk <- generateSecretKey + let pk = toPublic sk + content = "content" + token <- signToken content sk + attenuated <- appendSigned token eSk "block1" + let res = verifyToken attenuated pk + res @?= True + +invalidExternalSig :: TestTree +invalidExternalSig = testCase "Invalid external signature" $ do + sk <- generateSecretKey + eSk <- generateSecretKey + let pk = toPublic sk + ePk = toPublic eSk + content = "content" + token <- signToken content sk + attenuated <- appendSigned token eSk "block1" + let bogusSignature = sign eSk ePk ("yolo yolo" :: ByteString) + replaceExternalSig :: SignedBlock -> SignedBlock + replaceExternalSig (p, s, pk, Just (_, ePk)) = (p, s, pk, Just (bogusSignature, ePk)) + replaceExternalSig sb = sb + tamper :: Blocks -> Blocks + tamper = fmap replaceExternalSig + tampered = alterPayload tamper attenuated + let res = verifyToken tampered pk + res @?= False + alterPayload :: (Blocks -> Blocks) -> Token -> Token @@ -122,7 +164,7 @@ content = "content" token <- signToken content sk attenuated <- append token "block1" - let tamper ((_, s, pk) :| o) = ("tampered", s, pk) :| o + let tamper ((_, s, pk, eS) :| o) = ("tampered", s, pk, eS) :| o tampered = alterPayload tamper attenuated let res = verifyToken tampered pk res @?= False @@ -134,7 +176,7 @@ content = "content" token <- signToken content sk attenuated <- append token "block1" - let tamper (h :| ((_, s, pk): t)) = h :| (("tampered", s, pk) : t) + let tamper (h :| ((_, s, pk, eS): t)) = h :| (("tampered", s, pk, eS) : t) tampered = alterPayload tamper attenuated let res = verifyToken tampered pk res @?= False @@ -182,7 +224,7 @@ content = "content" token <- signToken content sk attenuated <- seal <$> append token "block1" - let tamper ((_, s, pk) :| o) = ("tampered", s, pk) :| o + let tamper ((_, s, pk, eS) :| o) = ("tampered", s, pk, eS) :| o tampered = alterPayloadSealed tamper attenuated let res = verifySealedToken tampered pk res @?= False @@ -194,7 +236,7 @@ content = "content" token <- signToken content sk attenuated <- seal <$> append token "block1" - let tamper (h :| ((_, s, pk): t)) = h :| (("tampered", s, pk) : t) + let tamper (h :| ((_, s, pk, eS): t)) = h :| (("tampered", s, pk, eS) : t) tampered = alterPayloadSealed tamper attenuated let res = verifySealedToken tampered pk res @?= False diff --git a/test/Spec/Parser.hs b/test/Spec/Parser.hs --- a/test/Spec/Parser.hs +++ b/test/Spec/Parser.hs @@ -1,44 +1,69 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Spec.Parser (specs) where +module Spec.Parser (specs, parseExpression, parseBlock, parseAuthorizer) where -import Data.Attoparsec.Text (parseOnly) +import Control.Monad ((<=<)) +import Data.Bifunctor (first) +import Data.Either (isLeft) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Text (Text) import Test.Tasty import Test.Tasty.HUnit +import Validation (Validation, validationToEither) +import Auth.Biscuit (PublicKey, parsePublicKeyHex) import Auth.Biscuit.Datalog.AST -import Auth.Biscuit.Datalog.Parser (authorizerParser, checkParser, +import Auth.Biscuit.Datalog.Parser (Parser, authorizerParser, + blockParser, checkParser, expressionParser, policyParser, - predicateParser, ruleParser, - termParser) + predicateParser, + predicateTermParser, ruleParser, + run) +pk1, pk2, pk3, pk4, pk5 :: PublicKey +pk1 = fromJust $ parsePublicKeyHex "a1b712761c609039f878edad694d762652f1548a68acccc96735b3196a240e8b" +pk2 = fromJust $ parsePublicKeyHex "b82c748be51784a58496675752e04cc48009a7e78bcfae8cad51fba959102af1" +pk3 = fromJust $ parsePublicKeyHex "083aae4ba29a9a3781cdee7a800f4f8ab90591f65ca983fc429687628311aedd" +pk4 = fromJust $ parsePublicKeyHex "c6864578bc03596d52878bd70025ec966c95c60727cb6573198453e82132510d" +pk5 = fromJust $ parsePublicKeyHex "a0d3dc7ab62a0a2732ba267e0d57894170458ec1659ca1226240b99764554a2e" + +runWithNoParams :: Parser a + -> (a -> Validation (NonEmpty Text) b) + -> Text + -> Either String b +runWithNoParams p s = validationToEither . first show . s <=< run p + parseTerm :: Text -> Either String Term -parseTerm = parseOnly termParser +parseTerm = runWithNoParams predicateTermParser $ substitutePTerm mempty parseTermQQ :: Text -> Either String QQTerm -parseTermQQ = parseOnly termParser +parseTermQQ = run predicateTermParser parsePredicate :: Text -> Either String Predicate -parsePredicate = parseOnly predicateParser +parsePredicate = runWithNoParams predicateParser $ substitutePredicate mempty parseRule :: Text -> Either String Rule -parseRule = parseOnly ruleParser +parseRule = runWithNoParams (ruleParser False) $ substituteRule mempty mempty parseExpression :: Text -> Either String Expression -parseExpression = parseOnly expressionParser +parseExpression = runWithNoParams expressionParser $ substituteExpression mempty parseCheck :: Text -> Either String Check -parseCheck = parseOnly checkParser +parseCheck = runWithNoParams (checkParser False) $ substituteCheck mempty mempty parseAuthorizer :: Text -> Either String Authorizer -parseAuthorizer = parseOnly authorizerParser +parseAuthorizer = runWithNoParams authorizerParser $ substituteAuthorizer mempty mempty parsePolicy :: Text -> Either String Policy -parsePolicy = parseOnly policyParser +parsePolicy = runWithNoParams policyParser $ substitutePolicy mempty mempty +parseBlock :: Text -> Either String Block +parseBlock = runWithNoParams blockParser $ substituteBlock mempty mempty + specs :: TestTree specs = testGroup "datalog parser" [ factWithDate @@ -51,9 +76,12 @@ , constraints , constrainedRule , constrainedRuleOrdering + , ruleVariables + , ruleWithScopeParsing , checkParsing , policyParsing , authorizerParsing + , blockParsing ] termsGroup :: TestTree @@ -64,7 +92,7 @@ , testCase "Date" $ parseTerm "2019-12-02T13:49:53Z" @?= Right (LDate $ read "2019-12-02 13:49:53 UTC") , testCase "Variable" $ parseTerm "$1" @?= Right (Variable "1") - , testCase "Antiquote" $ parseTerm "${toto}" @?= Left "Failed reading: empty" + , testCase "Antiquote" $ isLeft (parseTerm "{toto}") @? "Unsubstituted parameters triggers an error" ] termsGroupQQ :: TestTree @@ -75,7 +103,14 @@ , testCase "Date" $ parseTermQQ "2019-12-02T13:49:53Z" @?= Right (LDate $ read "2019-12-02 13:49:53 UTC") , testCase "Variable" $ parseTermQQ "$1" @?= Right (Variable "1") - , testCase "Antiquote" $ parseTermQQ "${toto}" @?= Right (Antiquote "toto") + , testGroup "Antiquote" + [ testCase "Variable name" $ parseTermQQ "{toto2_'}" @?= Right (Antiquote "toto2_'") + , testCase "Leading underscore" $ parseTermQQ "{_toto}" @?= Right (Antiquote "_toto") + , testCase "`_` is reserved" $ parseTermQQ "{_}" @?= Left "1:3:\n |\n1 | {_}\n | ^\nunexpected '}'\nexpecting letter\n" + , testCase "Variables are lower-cased" $ parseTermQQ "{Toto}" @?= Left "1:2:\n |\n1 | {Toto}\n | ^\nunexpected 'T'\nexpecting '_' or lowercase letter\n" + , testCase "_ is lower-case" $ parseTermQQ "{_Toto}" @?= Right (Antiquote "_Toto") + , testCase "unicode is allowed" $ parseTermQQ "{éllo}" @?= Right (Antiquote "éllo") + ] ] simpleFact :: TestTree @@ -89,9 +124,13 @@ Right (Predicate "a" [LInteger 12]) factWithDate :: TestTree -factWithDate = testCase "Parse fact containing a date" $ +factWithDate = testCase "Parse fact containing a date" $ do parsePredicate "date(2019-12-02T13:49:53Z)" @?= Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53 UTC"]) + parsePredicate "date(2019-12-02T13:49:53.001Z)" @?= + Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53.001 UTC"]) + parsePredicate "date(2019-12-02T13:49:53+00:00)" @?= + Right (Predicate "date" [LDate $ read "2019-12-02 13:49:53 UTC"]) simpleRule :: TestTree simpleRule = testCase "Parse simple rule" $ @@ -99,7 +138,7 @@ Right (Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read"] - ] [] Nothing) + ] [] []) multilineRule :: TestTree multilineRule = testCase "Parse multiline rule" $ @@ -107,7 +146,7 @@ Right (Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read"] - ] [] Nothing) + ] [] []) constrainedRule :: TestTree constrainedRule = testCase "Parse constained rule" $ @@ -119,7 +158,7 @@ [ EBinary LessOrEqual (EValue $ Variable "0") (EValue $ LDate $ read "2019-12-04 09:46:41 UTC") - ] Nothing) + ] []) constrainedRuleOrdering :: TestTree constrainedRuleOrdering = testCase "Parse constained rule (interleaved)" $ @@ -131,7 +170,7 @@ [ EBinary LessOrEqual (EValue $ Variable "0") (EValue $ LDate $ read "2019-12-04 09:46:41 UTC") - ] Nothing) + ] []) constraints :: TestTree constraints = testGroup "Parse expressions" @@ -227,6 +266,18 @@ (EValue (TermSet $ Set.fromList [LString "abc", LString "def"])) (EValue (Variable "0")) )) + , testCase "arithmetic operation that looks like the beginning of a RFC3339 date" $ + parseExpression "2022-12-10==2000" @?= + Right (EBinary Equal + (EBinary Sub + (EBinary Sub + (EValue $ LInteger 2022) + (EValue $ LInteger 12) + ) + (EValue $ LInteger 10) + ) + (EValue $ LInteger 2000) + ) , operatorPrecedences ] @@ -276,35 +327,138 @@ ) (EValue $ LInteger 3) ) + , testCase "+ & | *" $ + parseExpression "1 + 2 | 4 * 3 & 4" @?= + Right (EBinary BitwiseOr + (EBinary Add + (EValue $ LInteger 1) + (EValue $ LInteger 2) + ) + (EBinary BitwiseAnd + (EBinary Mul + (EValue $ LInteger 4) + (EValue $ LInteger 3) + ) + (EValue $ LInteger 4) + ) + ) ] +ruleVariables :: TestTree +ruleVariables = testGroup "Make sure rule & query variables are correctly introduced" + [ testCase "Head variables are correctly introduced" $ + parseRule "head($unbound) <- body(true)" @?= + Left "1:1:\n |\n1 | head($unbound) <- body(true)\n | ^\nUnbound variables: unbound\n" + , testCase "Expression variables are correctly introduced (rule)" $ + parseRule "head(true) <- body(true), $unbound" @?= + Left "1:1:\n |\n1 | head(true) <- body(true), $unbound\n | ^\nUnbound variables: unbound\n" + , testCase "Expression variables are correctly introduced (check)" $ + parseCheck "check if body(true), $unbound" @?= + Left "1:10:\n |\n1 | check if body(true), $unbound\n | ^\nUnbound variables: unbound\n" + , testCase "Expression variables are correctly introduced (allow policy)" $ + parsePolicy "allow if body(true), $unbound" @?= + Left "1:10:\n |\n1 | allow if body(true), $unbound\n | ^\nUnbound variables: unbound\n" + , testCase "Expression variables are correctly introduced (deny policy)" $ + parsePolicy "deny if body(true), $unbound" @?= + Left "1:9:\n |\n1 | deny if body(true), $unbound\n | ^\nUnbound variables: unbound\n" + ] + +ruleWithScopeParsing :: TestTree +ruleWithScopeParsing = testCase "Parse constained rule with scope annotation" $ + parseRule "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2019-12-04T09:46:41+00:00 trusting previous" @?= + Right (Rule (Predicate "valid_date" [LString "file1"]) + [ Predicate "time" [Variable "0"] + , Predicate "resource" [LString "file1"] + ] + [ EBinary LessOrEqual + (EValue $ Variable "0") + (EValue $ LDate $ read "2019-12-04 09:46:41 UTC") + ] [Previous]) + checkParsing :: TestTree checkParsing = testGroup "check blocks" [ testCase "Simple check" $ parseCheck "check if true" @?= - Right [QueryItem [] [EValue $ LBool True] Nothing] + Right Check + { cQueries = [QueryItem [] [EValue $ LBool True] []] + , cKind = One + } + , testCase "Simple check all" $ + parseCheck "check all true" @?= + Right Check + { cQueries = [QueryItem [] [EValue $ LBool True] []] + , cKind = All + } , testCase "Multiple groups" $ parseCheck "check if fact($var), $var == true or \ \other($var), $var == 2" @?= - Right - [ QueryItem [Predicate "fact" [Variable "var"]] - [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] - Nothing - , QueryItem [Predicate "other" [Variable "var"]] - [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] - Nothing - ] + Right Check + { cQueries = + [ QueryItem [Predicate "fact" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [] + , QueryItem [Predicate "other" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] + [] + ] + , cKind = One + } + , testCase "Multiple check all groups" $ + parseCheck + "check all fact($var), $var == true or \ + \other($var), $var == 2" @?= + Right Check + { cQueries = + [ QueryItem [Predicate "fact" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [] + , QueryItem [Predicate "other" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] + [] + ] + , cKind = All + } + , testCase "Multiple groups, scoped" $ + parseCheck + "check if fact($var), $var == true trusting previous or \ + \other($var), $var == 2 trusting authority" @?= + Right Check + { cQueries = + [ QueryItem [Predicate "fact" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [Previous] + , QueryItem [Predicate "other" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] + [OnlyAuthority] + ] + , cKind = One + } + , testCase "Multiple check all groups, scoped" $ + parseCheck + "check all fact($var), $var == true trusting previous or \ + \other($var), $var == 2 trusting authority" @?= + Right Check + { cQueries = + [ QueryItem [Predicate "fact" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [Previous] + , QueryItem [Predicate "other" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] + [OnlyAuthority] + ] + , cKind = All + } ] policyParsing :: TestTree policyParsing = testGroup "policy blocks" [ testCase "Simple allow policy" $ parsePolicy "allow if true" @?= - Right (Allow, [QueryItem [] [EValue $ LBool True] Nothing]) + Right (Allow, [QueryItem [] [EValue $ LBool True] []]) , testCase "Simple deny policy" $ parsePolicy "deny if true" @?= - Right (Deny, [QueryItem [] [EValue $ LBool True] Nothing]) + Right (Deny, [QueryItem [] [EValue $ LBool True] []]) , testCase "Allow with multiple groups" $ parsePolicy "allow if fact($var), $var == true or \ @@ -313,10 +467,10 @@ ( Allow , [ QueryItem [Predicate "fact" [Variable "var"]] [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] - Nothing + [] , QueryItem [Predicate "other" [Variable "var"]] [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] - Nothing + [] ] ) , testCase "Deny with multiple groups" $ @@ -327,47 +481,74 @@ ( Deny , [ QueryItem [Predicate "fact" [Variable "var"]] [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] - Nothing + [] , QueryItem [Predicate "other" [Variable "var"]] [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] - Nothing + [] ] ) , testCase "Deny with multiple groups, multiline" $ parsePolicy "deny if\n\ - \fact($var), $var == true or\n\ + \fact($var), $var == true or //comment\n\ \other($var), $var == 2" @?= Right ( Deny , [ QueryItem [Predicate "fact" [Variable "var"]] [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] - Nothing + [] , QueryItem [Predicate "other" [Variable "var"]] [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] - Nothing + [] ] ) + , testCase "Allow with multiple groups, scoped" $ + parsePolicy + "allow if fact($var), $var == true trusting authority or \ + \other($var), $var == 2 trusting ed25519/a1b712761c609039f878edad694d762652f1548a68acccc96735b3196a240e8b,ed25519/083aae4ba29a9a3781cdee7a800f4f8ab90591f65ca983fc429687628311aedd,ed25519/c6864578bc03596d52878bd70025ec966c95c60727cb6573198453e82132510d " @?= + Right + ( Allow + , [ QueryItem [Predicate "fact" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))] + [OnlyAuthority] + , QueryItem [Predicate "other" [Variable "var"]] + [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))] + [BlockId pk1, BlockId pk3, BlockId pk4] + ] + ) ] authorizerParsing :: TestTree authorizerParsing = testGroup "Simple authorizers" [ testCase "Just a deny" $ parseAuthorizer "deny if true;" @?= - Right (Authorizer [(Deny, [QueryItem [] [EValue (LBool True)] Nothing])] mempty + Right (Authorizer [(Deny, [QueryItem [] [EValue (LBool True)] []])] mempty ) , testCase "Allow and deny" $ parseAuthorizer "allow if operation(\"read\");\n deny if true;" @?= Right (Authorizer - [ (Allow, [QueryItem [Predicate "operation" [LString "read"]] [] Nothing]) - , (Deny, [QueryItem [] [EValue (LBool True)] Nothing]) + [ (Allow, [QueryItem [Predicate "operation" [LString "read"]] [] []]) + , (Deny, [QueryItem [] [EValue (LBool True)] []]) ] mempty ) + , testCase "Previous is denied at the top level" $ + parseAuthorizer "trusting previous; allow if true;" @?= + Left "1:10:\n |\n1 | trusting previous; allow if true;\n | ^\n'previous' can't appear in an authorizer scope\n" + , testCase "Previous is denied in rules" $ + parseAuthorizer "head(true) <- tail(true) trusting previous;" @?= + Left "1:35:\n |\n1 | head(true) <- tail(true) trusting previous;\n | ^\n'previous' can't appear in an authorizer scope\n" + , testCase "Previous is denied in checks" $ + parseAuthorizer "check if true trusting previous;" @?= + Left "1:24:\n |\n1 | check if true trusting previous;\n | ^\n'previous' can't appear in an authorizer scope\n" + , testCase "Previous is denied in policies" $ + parseAuthorizer "allow if true trusting previous;" @?= + Left "1:24:\n |\n1 | allow if true trusting previous;\n | ^\n'previous' can't appear in an authorizer scope\n" , testCase "Complete authorizer" $ do let spec :: Text spec = - "// the owner has all rights\n\ + " trusting authority;\n\ + \// the owner has all rights\n\ \right($blog_id, $article_id, $operation) <-\n\ \ article($blog_id, $article_id),\n\ \ operation($operation),\n\ @@ -416,13 +597,13 @@ , p "operation" [vOp] , p "user" [vUserId] , p "owner" [vUserId, vBlogId] - ] [] Nothing + ] [] [] , Rule (p "right" [vBlogId, vArticleId, sRead]) [ p "article" [vBlogId, vArticleId] , p "premium_readable" [vBlogId, vArticleId] , p "user" [vUserId] , p "premium_user" [vUserId, vBlogId] - ] [] Nothing + ] [] [] , Rule (p "right" [vBlogId, vArticleId, vOp]) [ p "article" [vBlogId, vArticleId] , p "operation" [vOp] @@ -430,23 +611,86 @@ , p "member" [vUserId, vTeamId] , p "team_role" [vTeamId, vBlogId, sContributor] ] [EBinary Contains (EValue (TermSet $ Set.fromList [sRead, sWrite])) - (EValue vOp)] Nothing + (EValue vOp)] [] ] bFacts = [] bChecks = [] bContext = Nothing - bScope = Nothing + bScope = [OnlyAuthority] vPolicies = [ (Allow, [QueryItem [ p "operation" [sRead] , p "article" [vBlogId, vArticleId] , p "readable" [vBlogId, vArticleId] - ] [] Nothing]) + ] [] []]) , (Allow, [QueryItem [ p "blog" [vBlogId] , p "article" [vBlogId, vArticleId] , p "operation" [vOp] , p "right" [vBlogId, vArticleId, vOp] - ] [] Nothing]) - , (Deny, [QueryItem [] [EValue (LBool True)] Nothing]) + ] [] []]) + , (Deny, [QueryItem [] [EValue (LBool True)] []]) ] parseAuthorizer spec @?= Right Authorizer{vBlock = Block{..}, ..} ] + +blockParsing :: TestTree +blockParsing = testCase "Full block" $ do + let spec :: Text + spec = + " trusting ed25519/b82c748be51784a58496675752e04cc48009a7e78bcfae8cad51fba959102af1,ed25519/083aae4ba29a9a3781cdee7a800f4f8ab90591f65ca983fc429687628311aedd,ed25519/a0d3dc7ab62a0a2732ba267e0d57894170458ec1659ca1226240b99764554a2e;\n\ + \// the owner has all rights\n\ + \right($blog_id, $article_id, $operation) <-\n\ + \ article($blog_id, $article_id),\n\ + \ operation($operation),\n\ + \ user($user_id),\n\ + \ owner($user_id, $blog_id);\n\ + \// premium users can access some restricted articles\n\ + \right($blog_id, $article_id, \"read\") <-\n\ + \ article($blog_id, $article_id),\n\ + \ premium_readable($blog_id, $article_id),\n\ + \ user($user_id),\n\ + \ premium_user($user_id, $blog_id);\n\ + \// define teams and roles\n\ + \right($blog_id, $article_id, $operation) <-\n\ + \ article($blog_id, $article_id),\n\ + \ operation($operation),\n\ + \ user($user_id),\n\ + \ member($user_id, $team_id),\n\ + \ team_role($team_id, $blog_id, \"contributor\"),\n\ + \ [\"read\", \"write\"].contains($operation);\n\ + \ " + p = Predicate + sRead = LString "read" + sWrite = LString "write" + sContributor = LString "contributor" + vBlogId = Variable "blog_id" + vArticleId = Variable "article_id" + vUserId = Variable "user_id" + vTeamId = Variable "team_id" + vOp = Variable "operation" + bRules = + [ Rule (p "right" [vBlogId, vArticleId, vOp]) + [ p "article" [vBlogId, vArticleId] + , p "operation" [vOp] + , p "user" [vUserId] + , p "owner" [vUserId, vBlogId] + ] [] [] + , Rule (p "right" [vBlogId, vArticleId, sRead]) + [ p "article" [vBlogId, vArticleId] + , p "premium_readable" [vBlogId, vArticleId] + , p "user" [vUserId] + , p "premium_user" [vUserId, vBlogId] + ] [] [] + , Rule (p "right" [vBlogId, vArticleId, vOp]) + [ p "article" [vBlogId, vArticleId] + , p "operation" [vOp] + , p "user" [vUserId] + , p "member" [vUserId, vTeamId] + , p "team_role" [vTeamId, vBlogId, sContributor] + ] [EBinary Contains (EValue (TermSet $ Set.fromList [sRead, sWrite])) + (EValue vOp)] [] + ] + bFacts = [] + bChecks = [] + bContext = Nothing + bScope = Set.fromList $ BlockId <$> [pk2,pk3,pk5] + parseBlock spec @?= Right Block{..} diff --git a/test/Spec/Quasiquoter.hs b/test/Spec/Quasiquoter.hs --- a/test/Spec/Quasiquoter.hs +++ b/test/Spec/Quasiquoter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Spec.Quasiquoter (specs) where @@ -34,14 +35,14 @@ Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read"] - ] [] Nothing + ] [] [] antiquotedFact :: TestTree antiquotedFact = testCase "Sliced fact" $ - let toto :: Text - toto = "test" + let toto2' :: Text + toto2' = "test" actual :: Fact - actual = [fact|right(${toto}, "read")|] + actual = [fact|right({toto2'}, "read")|] in actual @?= Predicate "right" [ LString "test" , LString "read" @@ -52,9 +53,9 @@ let toto :: Text toto = "test" actual :: Rule - actual = [rule|right($0, "read") <- resource( $0), operation("read", ${toto})|] + actual = [rule|right($0, "read") <- resource( $0), operation("read", {toto})|] in actual @?= Rule (Predicate "right" [Variable "0", LString "read"]) [ Predicate "resource" [Variable "0"] , Predicate "operation" [LString "read", LString "test"] - ] [] Nothing + ] [] [] diff --git a/test/Spec/Roundtrip.hs b/test/Spec/Roundtrip.hs --- a/test/Spec/Roundtrip.hs +++ b/test/Spec/Roundtrip.hs @@ -2,10 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Spec.Roundtrip ( specs ) where +import Control.Arrow ((&&&)) import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty ((:|))) import Test.Tasty @@ -21,6 +23,7 @@ [ testGroup "Raw serde" [ singleBlock (serialize, parse) , multipleBlocks (serialize, parse) + , thirdPartyBlocks (serialize, parse) ] , testGroup "B64 serde" [ singleBlock (serializeB64, parseB64) @@ -39,21 +42,56 @@ roundtrip :: Roundtrip -> NonEmpty Block -> Assertion -roundtrip (s,p) i@(authority' :| blocks') = do +roundtrip r bs = roundtrip' r $ (Nothing,) <$> bs + +roundtrip' :: Roundtrip + -> NonEmpty (Maybe SecretKey, Block) + -> Assertion +roundtrip' (s,p) i@(authority' :| blocks') = do let addBlocks bs biscuit = case bs of - (b:rest) -> addBlocks rest =<< addBlock b biscuit - [] -> pure biscuit + ((Just sk, b):rest) -> addBlocks rest =<< addSignedBlock sk b biscuit + ((Nothing, b):rest) -> addBlocks rest =<< addBlock b biscuit + [] -> pure biscuit sk <- generateSecretKey let pk = toPublic sk - init' <- mkBiscuitWith (Just 1) sk authority' + init' <- mkBiscuitWith (Just 1) sk (snd authority') final <- addBlocks blocks' init' let serialized = s final parsed = p pk serialized - getBlock ((_, b), _, _) = b + getBlock ((_, b), _, _, _) = b getBlocks b = getBlock <$> authority b :| blocks b - getBlocks <$> parsed @?= Right i + getBlocks <$> parsed @?= Right (snd <$> i) rootKeyId <$> parsed @?= Right (Just 1) +roundtrip'' :: Bool + -> Roundtrip + -> NonEmpty (Maybe SecretKey, Block) + -> Assertion +roundtrip'' direct (s,p) i@(authority' :| blocks') = do + let addSignedBlock' :: SecretKey -> Block -> Biscuit Open check -> IO (Biscuit Open check) + addSignedBlock' sk block biscuit = do + if direct + then + addSignedBlock sk block biscuit + else do + let req = mkThirdPartyBlockReq biscuit + thirdPartyBlock <- either (fail . ("req " <>)) pure $ mkThirdPartyBlock sk req block + either (fail . ("apply " <>)) id $ applyThirdPartyBlock biscuit thirdPartyBlock + addBlocks bs biscuit = case bs of + ((Just sk, b):rest) -> addBlocks rest =<< addSignedBlock' sk b biscuit + ((Nothing, b):rest) -> addBlocks rest =<< addBlock b biscuit + [] -> pure biscuit + sk <- generateSecretKey + let pk = toPublic sk + init' <- mkBiscuitWith (Just 1) sk (snd authority') + final <- addBlocks blocks' init' + let serialized = s final + parsed = p pk serialized + getBlock ((_, b), _, _, _) = b + getBlocks b = getBlock <$> authority b :| blocks b + getBlocks <$> parsed @?= Right (snd <$> i) + rootKeyId <$> parsed @?= Right (Just 1) + singleBlock :: Roundtrip -> TestTree singleBlock r = testCase "Single block" $ roundtrip r $ pure [block| @@ -116,6 +154,40 @@ check if time($date), $date <= 2018-12-20T00:00:00+00:00; |] ] + +thirdPartyBlocks :: Roundtrip -> TestTree +thirdPartyBlocks r = + let mkBlocks = do + (sk1, pkOne) <- (id &&& toPublic) <$> generateSecretKey + (sk2, pkTwo) <- (id &&& toPublic) <$> generateSecretKey + (sk3, pkThree) <- (id &&& toPublic) <$> generateSecretKey + pure $ (Nothing, [block| + query("authority"); + right("file1", "read"); + right("file2", "read"); + right("file1", "write"); + check if true trusting previous, {pkOne}; + |]) :| + [ (Just sk1, [block| + query("block1"); + check if right("file2", "read") trusting {pkTwo}; + check if right("file3", "read") trusting {pkOne}; + |]) + , (Just sk2, [block| + query("block2"); + check if right("file2", "read") trusting {pkTwo}; + check if right("file3", "read") trusting {pkOne}; + |]) + , (Nothing, [block| + query("block3"); + check if right("file2", "read") trusting {pkTwo}; + check if right("file3", "read") trusting {pkThree}; + |]) + ] + in testGroup "Third party blocks" + [ testCase "Direct append" $ roundtrip'' True r =<< mkBlocks + , testCase "Indirect append" $ roundtrip'' False r =<< mkBlocks + ] secret :: TestTree secret = testGroup "Secret key serde" diff --git a/test/Spec/SampleReader.hs b/test/Spec/SampleReader.hs --- a/test/Spec/SampleReader.hs +++ b/test/Spec/SampleReader.hs @@ -10,45 +10,46 @@ {-# LANGUAGE RecordWildCards #-} module Spec.SampleReader where -import Debug.Trace - import Control.Arrow ((&&&)) import Control.Lens ((^?)) import Control.Monad (join, void, when) import Data.Aeson import Data.Aeson.Lens (key) import Data.Aeson.Types (typeMismatch, unexpected) -import Data.Attoparsec.Text (parseOnly) import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Hex import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (traverse_) +import Data.Foldable (fold, traverse_) import Data.List.NonEmpty (NonEmpty (..), toList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, isNothing) +import Data.Maybe (fromJust, isJust, isNothing) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Traversable (for) import GHC.Generics (Generic) import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Auth.Biscuit +import Auth.Biscuit.Datalog.AST (renderAuthorizer, renderBlock) import Auth.Biscuit.Datalog.Executor (ExecutionError (..), ResultError (..)) import Auth.Biscuit.Datalog.Parser (authorizerParser, blockParser) import Auth.Biscuit.Token +import Spec.Parser (parseAuthorizer, parseBlock) + getB :: ParsedSignedBlock -> Block -getB ((_, b), _, _) = b +getB ((_, b), _, _, _) = b -getAuthority :: Biscuit OpenOrSealed Verified -> Block +getAuthority :: Biscuit p Verified -> Block getAuthority = getB . authority -getBlocks :: Biscuit OpenOrSealed Verified -> [Block] +getBlocks :: Biscuit p Verified -> [Block] getBlocks = fmap getB . blocks instance FromJSON SecretKey where @@ -58,6 +59,9 @@ notSk = typeMismatch "Ed25519 secret key" (String t) maybe notSk pure res +instance ToJSON SecretKey where + toJSON = toJSON . decodeUtf8 . serializeSecretKeyHex + instance FromJSON PublicKey where parseJSON = withText "Ed25519 public key" $ \t -> do let bs = encodeUtf8 t @@ -65,17 +69,17 @@ notPk = typeMismatch "Ed25519 public key" (String t) maybe notPk pure res +instance ToJSON PublicKey where + toJSON = toJSON . decodeUtf8 . serializePublicKeyHex + instance FromJSON Authorizer where parseJSON = withText "authorizer" $ \t -> do let res = parseAuthorizer t notAuthorizer e = typeMismatch e (String t) either notAuthorizer pure res -parseAuthorizer :: Text -> Either String Authorizer -parseAuthorizer = parseOnly authorizerParser - -parseBlock :: Text -> Either String Block -parseBlock = parseOnly blockParser +instance ToJSON Authorizer where + toJSON = toJSON . renderAuthorizer data SampleFile a = SampleFile @@ -84,7 +88,7 @@ , testcases :: [TestCase a] } deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) - deriving anyclass FromJSON + deriving anyclass (FromJSON, ToJSON) data RustResult e a = Err e @@ -100,6 +104,10 @@ parseJSON = genericParseJSON $ defaultOptions { sumEncoding = ObjectWithSingleField } +instance (ToJSON e, ToJSON a) => ToJSON (RustResult e a) where + toJSON = genericToJSON $ + defaultOptions { sumEncoding = ObjectWithSingleField } + type RustError = Value data ValidationR @@ -109,8 +117,7 @@ , authorizer_code :: Authorizer , revocation_ids :: [Text] } deriving stock (Eq, Show, Generic) - deriving anyclass FromJSON - + deriving anyclass (FromJSON, ToJSON) checkResult :: Show a => (a -> RustError -> Assertion) @@ -132,7 +139,7 @@ , validations :: Map String ValidationR } deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) - deriving anyclass FromJSON + deriving anyclass (FromJSON, ToJSON) data BlockDesc = BlockDesc @@ -140,7 +147,7 @@ , code :: Text } deriving stock (Eq, Show, Generic) - deriving anyclass FromJSON + deriving anyclass (FromJSON, ToJSON) data WorldDesc = WorldDesc @@ -150,15 +157,26 @@ , policies :: [Text] } deriving stock (Eq, Show, Generic) - deriving anyclass FromJSON + deriving anyclass (FromJSON, ToJSON) +instance Semigroup WorldDesc where + a <> b = WorldDesc + { facts = facts a <> facts b + , rules = rules a <> rules b + , checks = checks a <> checks b + , policies = policies a <> policies b + } + +instance Monoid WorldDesc where + mempty = WorldDesc [] [] [] [] + readBiscuits :: SampleFile FilePath -> IO (SampleFile (FilePath, ByteString)) readBiscuits = - traverse $ traverse (BS.readFile . ("test/samples/v2/" <>)) . join (&&&) id + traverse $ traverse (BS.readFile . ("test/samples/current/" <>)) . join (&&&) id readSamplesFile :: IO (SampleFile (FilePath, ByteString)) readSamplesFile = do - Just f <- decodeFileStrict' "test/samples/v2/samples.json" + f <- either fail pure =<< eitherDecodeFileStrict' "test/samples/current/samples.json" readBiscuits f checkTokenBlocks :: (String -> IO ()) @@ -174,35 +192,45 @@ processTestCase :: (String -> IO ()) -> PublicKey -> TestCase (FilePath, ByteString) -> Assertion -processTestCase step rootPk TestCase{..} = do - step "Parsing " - let vList = Map.toList validations - case parse rootPk (snd filename) of - Left parseError -> traverse_ (processFailedValidation step parseError) vList - Right biscuit -> do - checkTokenBlocks step biscuit token - traverse_ (processValidation step biscuit) vList +processTestCase step rootPk TestCase{..} = + if fst filename == "test018_unbound_variables_in_rule.bc" + then + step "Skipping for now (unbound variables are now caught before evaluation)" + else do + step "Parsing " + let vList = Map.toList validations + case parse rootPk (snd filename) of + Left parseError -> traverse_ (processFailedValidation step parseError) vList + Right biscuit -> do + checkTokenBlocks step biscuit token + traverse_ (processValidation step biscuit) vList compareParseErrors :: ParseError -> RustError -> Assertion compareParseErrors pe re = - let mustMatch p = assertBool (show re) $ isJust $ re ^? p + let mustMatch p = assertBool (show (re,pe)) $ isJust $ re ^? p + mustMatchEither ps = assertBool (show (re, pe)) $ any isJust $ (re ^?) <$> ps in case pe of InvalidHexEncoding -> assertFailure $ "InvalidHexEncoding can't appear here " <> show re InvalidB64Encoding -> mustMatch $ key "Base64" InvalidProtobufSer True s -> - mustMatch $ key "Format" . key "SerializationError" - InvalidProtobufSer False s -> - mustMatch $ key "Format" . key "BlockSerializationError" - InvalidProtobuf True "Invalid signature" -> - mustMatch $ key "Format" . key "InvalidSignatureSize" + mustMatch $ key "Format" . key "DeserializationError" InvalidProtobuf True s -> mustMatch $ key "Format" . key "DeserializationError" + InvalidProtobufSer False s -> + mustMatch $ key "Format" . key "BlockDeserializationError" InvalidProtobuf False s -> mustMatch $ key "Format" . key "BlockDeserializationError" + -- the signature size is now verified just before verifying the + -- signature itself, not at deserialization time, since we want + -- to interpret signatures only relative to the verifying public + -- key. InvalidSignatures -> - mustMatch $ key "Format" . key "Signature" . key "InvalidSignature" + mustMatchEither + [ key "Format" . key "Signature" . key "InvalidSignature" + , key "Format" . key "InvalidSignatureSize" + ] InvalidProof -> assertFailure $ "InvalidProof can't appear here " <> show re RevokedBiscuit -> @@ -236,11 +264,11 @@ -> Assertion processValidation step b (name, ValidationR{..}) = do when (name /= "") $ step ("Checking " <> name) - w <- maybe (assertFailure "missing authorizer contents") pure world + let w = fold world pols <- either (assertFailure . show) pure $ parseAuthorizer $ foldMap (<> ";") (policies w) res <- authorizeBiscuit b (authorizer_code <> pols) checkResult compareExecErrors result res - let revocationIds = decodeUtf8 . Hex.encode <$> toList (getRevocationIds b) + let revocationIds = Hex.encodeBase16 <$> toList (getRevocationIds b) step "Comparing revocation ids" revocation_ids @?= revocationIds @@ -252,9 +280,6 @@ SampleFile{..} <- readSamplesFile traverse_ (processTestCase step root_public_key) testcases -specs :: TestTree -specs = testCaseSteps "Biscuit samples - compliance checks" runTests - mkTestCase :: PublicKey -> TestCase (FilePath, ByteString) -> TestTree mkTestCase root_public_key tc@TestCase{filename} = testCaseSteps (fst filename) (\step -> processTestCase step root_public_key tc) @@ -264,3 +289,34 @@ SampleFile{..} <- readSamplesFile pure $ testGroup "Biscuit samples - compliance checks" $ mkTestCase root_public_key <$> testcases +mkTestCaseFromBiscuit + :: String + -> FilePath + -> Biscuit Open Verified + -> [(String, Authorizer)] + -> IO (TestCase FilePath) +mkTestCaseFromBiscuit title filename biscuit authorizers = do + let mkBlockDesc :: Block -> BlockDesc + mkBlockDesc b = BlockDesc + { code = renderBlock b + , symbols = [] + } + mkValidation :: Authorizer -> IO ValidationR + mkValidation authorizer = do + Right success <- authorizeBiscuit biscuit authorizer + pure ValidationR + { world = Just $ WorldDesc + { facts = [] + , rules = [] + , checks = [] + , policies = [] + } + , result = Ok 0 + , authorizer_code = authorizer + , revocation_ids = Hex.encodeBase16 <$> toList (getRevocationIds biscuit) + } + BS.writeFile ("test/samples/current/" <> filename) (serialize biscuit) + let token = mkBlockDesc <$> getAuthority biscuit :| getBlocks biscuit + validations <- Map.fromList <$> traverse (traverse mkValidation) authorizers + + pure TestCase{..} diff --git a/test/Spec/ScopedExecutor.hs b/test/Spec/ScopedExecutor.hs --- a/test/Spec/ScopedExecutor.hs +++ b/test/Spec/ScopedExecutor.hs @@ -3,20 +3,27 @@ {- HLINT ignore "Reduce duplication" -} module Spec.ScopedExecutor (specs) where -import Data.Attoparsec.Text (parseOnly) +import Control.Arrow ((&&&)) +import Data.Either (isRight) import Data.Map.Strict as Map import Data.Set as Set import Data.Text (Text, unpack) import Test.Tasty import Test.Tasty.HUnit +import Auth.Biscuit (addBlock, addSignedBlock, + authorizeBiscuit, + mkBiscuit, newSecret, + queryAuthorizerFacts, + queryRawBiscuitFacts) +import Auth.Biscuit.Crypto import Auth.Biscuit.Datalog.AST import Auth.Biscuit.Datalog.Executor (ExecutionError (..), Limits (..), ResultError (..), defaultLimits) import Auth.Biscuit.Datalog.Parser (authorizer, block, check, - query) + query, run) import Auth.Biscuit.Datalog.ScopedExecutor specs :: TestTree @@ -26,11 +33,13 @@ , block1OnlySeesAuthorityAndAuthorizer , block2OnlySeesAuthorityAndAuthorizer , block1SeesAuthorityAndAuthorizer + , thirdPartyBlocks , iterationCountWorks , maxFactsCountWorks , allChecksAreCollected , revocationIdsAreInjected - , factsAreQueried + , authorizerFactsAreQueried + , biscuitFactsAreQueried ] authorizerOnlySeesAuthority :: TestTree @@ -47,7 +56,7 @@ [authorizer| allow if is_allowed(1234, "file1", "write"); |] - runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError (NoPoliciesMatched [])) + runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError (NoPoliciesMatched [])) authorityOnlySeesItselfAndAuthorizer :: TestTree authorityOnlySeesItselfAndAuthorizer = testCase "Authority rules only see authority and authorizer facts" $ do @@ -64,7 +73,7 @@ [authorizer| allow if is_allowed(1234, "file1"); |] - runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError (NoPoliciesMatched [])) + runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError (NoPoliciesMatched [])) block1OnlySeesAuthorityAndAuthorizer :: TestTree block1OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do @@ -85,7 +94,7 @@ [authorizer| allow if true; |] - runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) + runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) block1SeesAuthorityAndAuthorizer :: TestTree block1SeesAuthorityAndAuthorizer = testCase "Arbitrary blocks see previous blocks" $ do @@ -102,7 +111,7 @@ verif = [authorizer| allow if false; |] - runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, "")] verif @?= Left (ResultError $ NoPoliciesMatched []) + runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched []) block2OnlySeesAuthorityAndAuthorizer :: TestTree block2OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do @@ -123,8 +132,38 @@ [authorizer| allow if true; |] - runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) + runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) +thirdPartyBlocks :: TestTree +thirdPartyBlocks = testCase "Third party blocks are correctly scoped" $ do + (sk1, pkOne) <- (id &&& toPublic) <$> generateSecretKey + let authority = + [block| + user(1234); + check if from3rd(1, true) trusting {pkOne}; + check if from3rd(2, true) trusting {pkOne}; + |] + block1 = + [block| + from3rd(1, true); + |] + block2 = + [block| + from3rd(2, true); + |] + verif = + [authorizer| + deny if from3rd(1, true); + allow if from3rd(1, true), from3rd(2, true) trusting {pkOne}; + |] + let result = runAuthorizerNoTimeout defaultLimits + (authority, "", Nothing) + [ (block1, "", Just pkOne) + , (block2, "", Just pkOne) + ] + verif + isRight result @?= True + iterationCountWorks :: TestTree iterationCountWorks = testCase "ScopedExecutions stops when hitting the iterations threshold" $ do let limits = defaultLimits { maxIterations = 8 } @@ -151,7 +190,7 @@ [authorizer| allow if true; |] - runAuthorizerNoTimeout limits (authority, "") [(block1, "")] verif @?= Left TooManyIterations + runAuthorizerNoTimeout limits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left TooManyIterations maxFactsCountWorks :: TestTree maxFactsCountWorks = testCase "ScopedExecutions stops when hitting the facts threshold" $ do @@ -179,7 +218,7 @@ [authorizer| allow if true; |] - runAuthorizerNoTimeout limits (authority, "") [(block1, "")] verif @?= Left TooManyFacts + runAuthorizerNoTimeout limits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left TooManyFacts allChecksAreCollected :: TestTree allChecksAreCollected = testCase "ScopedExecutions collects all facts results even after a failure" $ do @@ -199,7 +238,7 @@ [authorizer| allow if user(4567); |] - runAuthorizerNoTimeout defaultLimits (authority, "") [(block1, ""), (block2, "")] verif @?= Left (ResultError $ NoPoliciesMatched [[check|check if false|], [check|check if false|]]) + runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched [[check|check if false|], [check|check if false|]]) revocationIdsAreInjected :: TestTree revocationIdsAreInjected = testCase "ScopedExecutions injects revocation ids" $ do @@ -217,16 +256,77 @@ revocation_id(1, hex:62), revocation_id(2, hex:63); |] - runAuthorizerNoTimeout defaultLimits (authority, "a") [(block1, "b"), (block2, "c")] verif @?= Left (ResultError $ NoPoliciesMatched []) + runAuthorizerNoTimeout defaultLimits (authority, "a", Nothing) [(block1, "b", Nothing), (block2, "c", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched []) -factsAreQueried :: TestTree -factsAreQueried = testCase "AuthorizationSuccess can be queried" $ do - let authority = [block|user(1234);|] - block1 = [block|user("tampered value");|] - verif = [authorizer|allow if true;|] - result = runAuthorizerNoTimeout defaultLimits (authority, "a") [(block1, "b")] verif - getUser s = queryAuthorizerFacts s [query|user($user)|] - expected = Set.singleton $ Map.fromList - [ ("user", LInteger 1234) - ] - getUser <$> result @?= Right expected +authorizerFactsAreQueried :: TestTree +authorizerFactsAreQueried = testGroup "AuthorizedBiscuit can be queried" + [ testCase "Attenuation blocks are ignored" $ do + (p,s) <- (toPublic &&& id) <$> newSecret + b <- mkBiscuit s [block|user(1234);|] + b1 <- addBlock [block|user("tampered value");|] b + result <- authorizeBiscuit b1 [authorizer|allow if true;|] + let getUser s = queryAuthorizerFacts s [query|user($user)|] + expected = Set.singleton $ Map.fromList + [ ("user", LInteger 1234) + ] + getUser <$> result @?= Right expected + , testCase "Attenuation blocks can be accessed if asked nicely" $ do + (p,s) <- (toPublic &&& id) <$> newSecret + b <- mkBiscuit s [block|user(1234);|] + b1 <- addBlock [block|user("tampered value");|] b + result <- authorizeBiscuit b1 [authorizer|allow if true;|] + let getUser s = queryAuthorizerFacts s [query|user($user) trusting previous|] + expected = Set.fromList + [ Map.fromList [("user", LInteger 1234)] + , Map.fromList [("user", LString "tampered value")] + ] + getUser <$> result @?= Right expected + , testCase "Signed blocks can be accessed if asked nicely" $ do + (p,s) <- (toPublic &&& id) <$> newSecret + (p1,s1) <- (toPublic &&& id) <$> newSecret + b <- mkBiscuit s [block|user(1234);|] + b1 <- addBlock [block|user("tampered value");|] b + b2 <- addSignedBlock s1 [block|user("from signed");|] b1 + result <- authorizeBiscuit b2 [authorizer|allow if true;|] + let getUser s = queryAuthorizerFacts s [query|user($user) trusting authority, {p1}|] + expected = Set.fromList + [ Map.fromList [("user", LInteger 1234)] + , Map.fromList [("user", LString "from signed")] + ] + getUser <$> result @?= Right expected + ] + +biscuitFactsAreQueried :: TestTree +biscuitFactsAreQueried = testGroup "Biscuit can be queried" + [ testCase "Attenuation blocks are ignored" $ do + (p,s) <- (toPublic &&& id) <$> newSecret + b <- mkBiscuit s [block|user(1234);|] + b1 <- addBlock [block|user("tampered value");|] b + let user = queryRawBiscuitFacts b1 [query|user($user)|] + expected = Set.singleton $ Map.fromList + [ ("user", LInteger 1234) + ] + user @?= expected + , testCase "Attenuation blocks can be accessed if asked nicely" $ do + (p,s) <- (toPublic &&& id) <$> newSecret + b <- mkBiscuit s [block|user(1234);|] + b1 <- addBlock [block|user("tampered value");|] b + let user = queryRawBiscuitFacts b1 [query|user($user) trusting previous|] + expected = Set.fromList + [ Map.fromList [("user", LInteger 1234)] + , Map.fromList [("user", LString "tampered value")] + ] + user @?= expected + , testCase "Signed blocks can be accessed if asked nicely" $ do + (p,s) <- (toPublic &&& id) <$> newSecret + (p1,s1) <- (toPublic &&& id) <$> newSecret + b <- mkBiscuit s [block|user(1234);|] + b1 <- addBlock [block|user("tampered value");|] b + b2 <- addSignedBlock s1 [block|user("from signed");|] b1 + let user = queryRawBiscuitFacts b2 [query|user($user) trusting authority, {p1}|] + expected = Set.fromList + [ Map.fromList [("user", LInteger 1234)] + , Map.fromList [("user", LString "from signed")] + ] + user @?= expected + ] diff --git a/test/Spec/Verification.hs b/test/Spec/Verification.hs --- a/test/Spec/Verification.hs +++ b/test/Spec/Verification.hs @@ -11,8 +11,12 @@ import Test.Tasty.HUnit import Auth.Biscuit -import Auth.Biscuit.Datalog.AST (Expression' (..), Query, - QueryItem' (..), Term' (..)) +import Auth.Biscuit.Datalog.AST (Block' (..), Check, Check' (..), + CheckKind (..), + Expression' (..), + Predicate' (..), Query, + QueryItem' (..), Rule' (..), + Term' (..)) import Auth.Biscuit.Datalog.Executor (MatchedQuery (..), ResultError (..)) import qualified Auth.Biscuit.Datalog.Executor as Executor @@ -21,6 +25,7 @@ specs :: TestTree specs = testGroup "Datalog checks" [ singleBlock + , checkAll , errorAccumulation , unboundVarRule , symbolRestrictions @@ -38,16 +43,29 @@ , bindings = Set.singleton mempty } -ifFalse' :: Query -ifFalse' = matchedQuery ifFalse +ifFalse' :: Check +ifFalse' = Check + { cQueries = matchedQuery ifFalse + , cKind = One + } +checkAll' :: Check +checkAll' = [check|check all fact($value), $value|] + singleBlock :: TestTree singleBlock = testCase "Single block" $ do secret <- newSecret biscuit <- mkBiscuit secret [block|right("file1", "read");|] res <- authorizeBiscuit biscuit [authorizer|check if right("file1", "read");allow if true;|] - matchedAllowQuery <$> res @?= Right ifTrue + matchedAllowQuery . authorizationSuccess <$> res @?= Right ifTrue +checkAll :: TestTree +checkAll = testCase "Check all" $ do + secret <- newSecret + biscuit <- mkBiscuit secret [block|fact(true); fact(false);|] + res <- authorizeBiscuit biscuit [authorizer|check all fact($value), $value;allow if true;|] + res @?= Left (ResultError $ FailedChecks $ pure checkAll') + errorAccumulation :: TestTree errorAccumulation = testGroup "Error accumulation" [ testCase "Only checks" $ do @@ -71,7 +89,27 @@ unboundVarRule = testCase "Rule with unbound variable" $ do secret <- newSecret b1 <- mkBiscuit secret [block|check if operation("read");|] - b2 <- addBlock [block|operation($unbound, "read") <- operation($any1, $any2);|] b1 + -- rules with unbound variables don't parse, so we have + -- to manually construct a broken rule + let brokenRuleBlock = Block { + bRules = [Rule{ + rhead = Predicate{ + name = "operation", + terms = [Variable"unbound", LString "read"] + }, + body = [Predicate{ + name = "operation", + terms = Variable <$> ["any1", "any2"] + }], + expressions = mempty, + scope = mempty + }], + bFacts = mempty, + bChecks = mempty, + bScope = mempty, + bContext = mempty + } + b2 <- addBlock brokenRuleBlock b1 res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|] res @?= Left InvalidRule diff --git a/test/samples/current/samples.json b/test/samples/current/samples.json new file mode 100644 --- /dev/null +++ b/test/samples/current/samples.json @@ -0,0 +1,1587 @@ +{ + "root_private_key": "12aca40167fbdd1a11037e9fd440e3d510d9d9dea70a6646aa4aaf84d718d75a", + "root_public_key": "acdd6d5b53bfee478bf689f8e012fe7988bf755e3d7c5152947abc149bc20189", + "testcases": [ + { + "title": "basic token", + "filename": "test001_basic.bc", + "token": [ + { + "symbols": [ + "file1", + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "resource(\"file1\")", + "right(\"file1\", \"read\")", + "right(\"file1\", \"write\")", + "right(\"file2\", \"read\")" + ], + "rules": [], + "checks": [ + "check if resource($0), operation(\"read\"), right($0, \"read\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 1, + "check_id": 0, + "rule": "check if resource($0), operation(\"read\"), right($0, \"read\")" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file1\");\n\nallow if true;\n", + "revocation_ids": [ + "3ee1c0f42ba69ec63b1f39a6b3c57d25a4ccec452233ca6d40530ecfe83af4918fa78d9346f8b7c498545b54663960342b9ed298b2c8bbe2085b80c237b56f09", + "e16ccf0820b02092adb531e36c2e82884c6c6c647b1c85184007f2ace601648afb71faa261b11f9ab352093c96187870f868588b664579c8018864b306bd5007" + ] + } + } + }, + { + "title": "different root key", + "filename": "test002_different_root_key.bc", + "token": [ + { + "symbols": [ + "file1" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + } + ], + "validations": { + "": { + "world": null, + "result": { + "Err": { + "Format": { + "Signature": { + "InvalidSignature": "signature error: Verification equation was not satisfied" + } + } + } + }, + "authorizer_code": "", + "revocation_ids": [] + } + } + }, + { + "title": "invalid signature format", + "filename": "test003_invalid_signature_format.bc", + "token": [ + { + "symbols": [ + "file1", + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + } + ], + "validations": { + "": { + "world": null, + "result": { + "Err": { + "Format": { + "InvalidSignatureSize": 16 + } + } + }, + "authorizer_code": "", + "revocation_ids": [] + } + } + }, + { + "title": "random block", + "filename": "test004_random_block.bc", + "token": [ + { + "symbols": [ + "file1", + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + } + ], + "validations": { + "": { + "world": null, + "result": { + "Err": { + "Format": { + "Signature": { + "InvalidSignature": "signature error: Verification equation was not satisfied" + } + } + } + }, + "authorizer_code": "", + "revocation_ids": [] + } + } + }, + { + "title": "invalid signature", + "filename": "test005_invalid_signature.bc", + "token": [ + { + "symbols": [ + "file1", + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + } + ], + "validations": { + "": { + "world": null, + "result": { + "Err": { + "Format": { + "Signature": { + "InvalidSignature": "signature error: Verification equation was not satisfied" + } + } + } + }, + "authorizer_code": "", + "revocation_ids": [] + } + } + }, + { + "title": "reordered blocks", + "filename": "test006_reordered_blocks.bc", + "token": [ + { + "symbols": [ + "file1", + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + }, + { + "symbols": [], + "public_keys": [], + "external_key": null, + "code": "check if resource(\"file1\");\n" + } + ], + "validations": { + "": { + "world": null, + "result": { + "Err": { + "Format": { + "Signature": { + "InvalidSignature": "signature error: Verification equation was not satisfied" + } + } + } + }, + "authorizer_code": "", + "revocation_ids": [] + } + } + }, + { + "title": "scoped rules", + "filename": "test007_scoped_rules.bc", + "token": [ + { + "symbols": [ + "user_id", + "alice", + "file1" + ], + "public_keys": [], + "external_key": null, + "code": "user_id(\"alice\");\nowner(\"alice\", \"file1\");\n" + }, + { + "symbols": [ + "0", + "1" + ], + "public_keys": [], + "external_key": null, + "code": "right($0, \"read\") <- resource($0), user_id($1), owner($1, $0);\ncheck if resource($0), operation(\"read\"), right($0, \"read\");\n" + }, + { + "symbols": [ + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "owner(\"alice\", \"file2\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "operation(\"read\")", + "owner(\"alice\", \"file1\")", + "owner(\"alice\", \"file2\")", + "resource(\"file2\")", + "user_id(\"alice\")" + ], + "rules": [ + "right($0, \"read\") <- resource($0), user_id($1), owner($1, $0)" + ], + "checks": [ + "check if resource($0), operation(\"read\"), right($0, \"read\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 1, + "check_id": 0, + "rule": "check if resource($0), operation(\"read\"), right($0, \"read\")" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\nallow if true;\n", + "revocation_ids": [ + "02d287b0e5b22780192f8351538583c17f7d0200e064b32a1fcf07899e64ffb10e4de324f5c5ebc72c89a63e424317226cf555eb42dae81b2fd4639cf7591108", + "22e75ea200cf7b2b62b389298fe0dec973b7f9c7e54e76c3c41811d72ea82c68227bc9079b7d05986de17ef9301cccdc08f5023455386987d1e6ee4391b19f06", + "140a3631fecae550b51e50b9b822b947fb485c80070b34482fa116cdea560140164a1d0a959b40fed8a727e2f62c0b57635760c488c8bf0eda80ee591558c409" + ] + } + } + }, + { + "title": "scoped checks", + "filename": "test008_scoped_checks.bc", + "token": [ + { + "symbols": [ + "file1" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + }, + { + "symbols": [ + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file2\", \"read\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "operation(\"read\")", + "resource(\"file2\")", + "right(\"file1\", \"read\")", + "right(\"file2\", \"read\")" + ], + "rules": [], + "checks": [ + "check if resource($0), operation(\"read\"), right($0, \"read\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 1, + "check_id": 0, + "rule": "check if resource($0), operation(\"read\"), right($0, \"read\")" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\nallow if true;\n", + "revocation_ids": [ + "567682495bf002eb84c46491e40fad8c55943d918c65e2c110b1b88511bf393072c0305a243e3d632ca5f1e9b0ace3e3582de84838c3a258480657087c267f02", + "71f0010b1034dbc62c53f67a23947b92ccba46495088567ac7ad5c4d7d65476964bee42053a6a35088110c5918f9c9606057689271fef89d84253cf98e6d4407", + "6d00d5f2a5d25dbfaa19152a81b44328b368e8fb8300b25e36754cfe8b2ce1eb2d1452ce9b1502e6f377a23aa87098fb05b5b073541624a8815ba0610f793005" + ] + } + } + }, + { + "title": "expired token", + "filename": "test009_expired_token.bc", + "token": [ + { + "symbols": [], + "public_keys": [], + "external_key": null, + "code": "" + }, + { + "symbols": [ + "file1", + "expiration" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource(\"file1\");\ncheck if time($time), $time <= 2018-12-20T00:00:00Z;\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "operation(\"read\")", + "resource(\"file1\")", + "time(2020-12-21T09:23:12Z)" + ], + "rules": [], + "checks": [ + "check if resource(\"file1\")", + "check if time($time), $time <= 2018-12-20T00:00:00Z" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 1, + "check_id": 1, + "rule": "check if time($time), $time <= 2018-12-20T00:00:00Z" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file1\");\noperation(\"read\");\ntime(2020-12-21T09:23:12Z);\n\nallow if true;\n", + "revocation_ids": [ + "b2474f3e0a5788cdeff811f2599497a04d1ad71ca48dbafb90f20a950d565dda0b86bd6c9072a727c19b6b20a1ae10d8cb88155186550b77016ffd1dca9a6203", + "0d12152670cbefe2fa504af9a92b513f1a48ae460ae5e66aaac4ed9f7dc3cc1c4c510693312b351465062169a2169fc520ce4e17e548d21982c81a74c66a3c0c" + ] + } + } + }, + { + "title": "authorizer scope", + "filename": "test010_authorizer_scope.bc", + "token": [ + { + "symbols": [ + "file1" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\n" + }, + { + "symbols": [ + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file2\", \"read\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "operation(\"read\")", + "resource(\"file2\")", + "right(\"file1\", \"read\")", + "right(\"file2\", \"read\")" + ], + "rules": [], + "checks": [ + "check if right($0, $1), resource($0), operation($1)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Authorizer": { + "check_id": 0, + "rule": "check if right($0, $1), resource($0), operation($1)" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\ncheck if right($0, $1), resource($0), operation($1);\n\nallow if true;\n", + "revocation_ids": [ + "b9ecf192ecb1bbb10e45320c1c86661f0c6b6bd28e89fdd8fa838fe0ab3f754229f7fbbf92ad978d36f744c345c69bc156a2a91a2979a3c235a9d936d401b404", + "839728735701e589c2612e655afa2b53f573480e6a0477ae68ed71587987d1af398a31296bdec0b6eccee9348f4b4c23ca1031e809991626c579fef80b1d380d" + ] + } + } + }, + { + "title": "authorizer authority checks", + "filename": "test011_authorizer_authority_caveats.bc", + "token": [ + { + "symbols": [ + "file1" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "operation(\"read\")", + "resource(\"file2\")", + "right(\"file1\", \"read\")" + ], + "rules": [], + "checks": [ + "check if right($0, $1), resource($0), operation($1)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Authorizer": { + "check_id": 0, + "rule": "check if right($0, $1), resource($0), operation($1)" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\ncheck if right($0, $1), resource($0), operation($1);\n\nallow if true;\n", + "revocation_ids": [ + "593d273d141bf23a3e89b55fffe1b3f96f683a022bb763e78f4e49f31a7cf47668c3fd5e0f580727ac9113ede302d34264597f6f1e6c6dd4167836d57aedf504" + ] + } + } + }, + { + "title": "authority checks", + "filename": "test012_authority_caveats.bc", + "token": [ + { + "symbols": [ + "file1" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource(\"file1\");\n" + } + ], + "validations": { + "file1": { + "world": { + "facts": [ + "operation(\"read\")", + "resource(\"file1\")" + ], + "rules": [], + "checks": [ + "check if resource(\"file1\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "resource(\"file1\");\noperation(\"read\");\n\nallow if true;\n", + "revocation_ids": [ + "0a1d14a145debbb0a2f4ce0631d3a0a48a2e0eddabefda7fabb0414879ec6be24b9ae7295c434609ada3f8cc47b8845bbd5a0d4fba3d96748ff1b824496e0405" + ] + }, + "file2": { + "world": { + "facts": [ + "operation(\"read\")", + "resource(\"file2\")" + ], + "rules": [], + "checks": [ + "check if resource(\"file1\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 0, + "check_id": 0, + "rule": "check if resource(\"file1\")" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file2\");\noperation(\"read\");\n\nallow if true;\n", + "revocation_ids": [ + "0a1d14a145debbb0a2f4ce0631d3a0a48a2e0eddabefda7fabb0414879ec6be24b9ae7295c434609ada3f8cc47b8845bbd5a0d4fba3d96748ff1b824496e0405" + ] + } + } + }, + { + "title": "block rules", + "filename": "test013_block_rules.bc", + "token": [ + { + "symbols": [ + "file1", + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\n" + }, + { + "symbols": [ + "valid_date", + "0", + "1" + ], + "public_keys": [], + "external_key": null, + "code": "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2030-12-31T12:59:59Z;\nvalid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59Z, ![\"file1\"].contains($1);\ncheck if valid_date($0), resource($0);\n" + } + ], + "validations": { + "file1": { + "world": { + "facts": [ + "resource(\"file1\")", + "right(\"file1\", \"read\")", + "right(\"file2\", \"read\")", + "time(2020-12-21T09:23:12Z)", + "valid_date(\"file1\")" + ], + "rules": [ + "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2030-12-31T12:59:59Z", + "valid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59Z, ![\"file1\"].contains($1)" + ], + "checks": [ + "check if valid_date($0), resource($0)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "resource(\"file1\");\ntime(2020-12-21T09:23:12Z);\n\nallow if true;\n", + "revocation_ids": [ + "d251352efd4e4c72e8a1609fce002f558f1a0bb5e36cd3d8b3a6c6599e3960880f21bea6fe1857f4ecbc2c399dd77829b154e75f1323e9dec413aad70f97650d", + "9de4f51e6019540598a957515dad52f5403e5c6cd8d2adbca1bff42a4fbc0eb8c6adab499da2fe894a8a9c9c581276bfb0fdc3d35ab2ff9f920a2c4690739903" + ] + }, + "file2": { + "world": { + "facts": [ + "resource(\"file2\")", + "right(\"file1\", \"read\")", + "right(\"file2\", \"read\")", + "time(2020-12-21T09:23:12Z)" + ], + "rules": [ + "valid_date(\"file1\") <- time($0), resource(\"file1\"), $0 <= 2030-12-31T12:59:59Z", + "valid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59Z, ![\"file1\"].contains($1)" + ], + "checks": [ + "check if valid_date($0), resource($0)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 1, + "check_id": 0, + "rule": "check if valid_date($0), resource($0)" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file2\");\ntime(2020-12-21T09:23:12Z);\n\nallow if true;\n", + "revocation_ids": [ + "d251352efd4e4c72e8a1609fce002f558f1a0bb5e36cd3d8b3a6c6599e3960880f21bea6fe1857f4ecbc2c399dd77829b154e75f1323e9dec413aad70f97650d", + "9de4f51e6019540598a957515dad52f5403e5c6cd8d2adbca1bff42a4fbc0eb8c6adab499da2fe894a8a9c9c581276bfb0fdc3d35ab2ff9f920a2c4690739903" + ] + } + } + }, + { + "title": "regex_constraint", + "filename": "test014_regex_constraint.bc", + "token": [ + { + "symbols": [ + "0", + "file[0-9]+.txt" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), $0.matches(\"file[0-9]+.txt\");\n" + } + ], + "validations": { + "file1": { + "world": { + "facts": [ + "resource(\"file1\")" + ], + "rules": [], + "checks": [ + "check if resource($0), $0.matches(\"file[0-9]+.txt\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 0, + "check_id": 0, + "rule": "check if resource($0), $0.matches(\"file[0-9]+.txt\")" + } + } + ] + } + } + } + }, + "authorizer_code": "resource(\"file1\");\n\nallow if true;\n", + "revocation_ids": [ + "1c158e1e12c8670d3f4411597276fe1caab17b7728adb7f7e9c44eeec3e3d85676e6ebe2d28c287e285a45912386cfa53e1752997630bd7a4ca6c2cd9f143500" + ] + }, + "file123": { + "world": { + "facts": [ + "resource(\"file123.txt\")" + ], + "rules": [], + "checks": [ + "check if resource($0), $0.matches(\"file[0-9]+.txt\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "resource(\"file123.txt\");\n\nallow if true;\n", + "revocation_ids": [ + "1c158e1e12c8670d3f4411597276fe1caab17b7728adb7f7e9c44eeec3e3d85676e6ebe2d28c287e285a45912386cfa53e1752997630bd7a4ca6c2cd9f143500" + ] + } + } + }, + { + "title": "multi queries checks", + "filename": "test015_multi_queries_caveats.bc", + "token": [ + { + "symbols": [ + "must_be_present", + "hello" + ], + "public_keys": [], + "external_key": null, + "code": "must_be_present(\"hello\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "must_be_present(\"hello\")" + ], + "rules": [], + "checks": [ + "check if must_be_present($0) or must_be_present($0)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "check if must_be_present($0) or must_be_present($0);\n\nallow if true;\n", + "revocation_ids": [ + "d3eee8a74eacec9c51d4d1eb29b479727dfaafa9df7d4c651d07c493c56f3a5f037a51139ebd036f50d1159d12bccec3e377bbd32db90a39dd52c4776757ad0b" + ] + } + } + }, + { + "title": "check head name should be independent from fact names", + "filename": "test016_caveat_head_name.bc", + "token": [ + { + "symbols": [ + "hello" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource(\"hello\");\n" + }, + { + "symbols": [ + "test" + ], + "public_keys": [], + "external_key": null, + "code": "query(\"test\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "query(\"test\")" + ], + "rules": [], + "checks": [ + "check if resource(\"hello\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 0, + "check_id": 0, + "rule": "check if resource(\"hello\")" + } + } + ] + } + } + } + }, + "authorizer_code": "allow if true;\n", + "revocation_ids": [ + "e79679e019f1d7d3a9f9a309673aceadc7b2b2d67c0df3e7a1dccec25218e9b5935b9c8f8249243446406e3cdd86c1b35601a21cf1b119df48ca5e897cc6cd0d", + "2042ea2dca41ba3eb31196f49b211e615dcba46067be126e6035b8549bb57cdfeb24d07f2b44241bc0f70cc8ddc31e30772116d785b82bc91be8440dfdab500f" + ] + } + } + }, + { + "title": "test expression syntax and all available operations", + "filename": "test017_expressions.bc", + "token": [ + { + "symbols": [ + "hello world", + "hello", + "world", + "aaabde", + "a*c?.e", + "abd", + "aaa", + "b", + "de", + "abcD12", + "abc", + "def" + ], + "public_keys": [], + "external_key": null, + "code": "check if true;\ncheck if !false;\ncheck if !false && true;\ncheck if false or true;\ncheck if (true || false) && true;\ncheck if 1 < 2;\ncheck if 2 > 1;\ncheck if 1 <= 2;\ncheck if 1 <= 1;\ncheck if 2 >= 1;\ncheck if 2 >= 2;\ncheck if 3 == 3;\ncheck if 1 + 2 * 3 - 4 / 2 == 5;\ncheck if 1 | 2 ^ 3 == 0;\ncheck if \"hello world\".starts_with(\"hello\") && \"hello world\".ends_with(\"world\");\ncheck if \"aaabde\".matches(\"a*c?.e\");\ncheck if \"aaabde\".contains(\"abd\");\ncheck if \"aaabde\" == \"aaa\" + \"b\" + \"de\";\ncheck if \"abcD12\" == \"abcD12\";\ncheck if 2019-12-04T09:46:41Z < 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z > 2019-12-04T09:46:41Z;\ncheck if 2019-12-04T09:46:41Z <= 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z >= 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z >= 2019-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z >= 2020-12-04T09:46:41Z;\ncheck if 2020-12-04T09:46:41Z == 2020-12-04T09:46:41Z;\ncheck if hex:12ab == hex:12ab;\ncheck if [1, 2].contains(2);\ncheck if [2019-12-04T09:46:41Z, 2020-12-04T09:46:41Z].contains(2020-12-04T09:46:41Z);\ncheck if [false, true].contains(true);\ncheck if [\"abc\", \"def\"].contains(\"abc\");\ncheck if [hex:12ab, hex:34de].contains(hex:34de);\n" + } + ], + "validations": { + "": { + "world": { + "facts": [], + "rules": [], + "checks": [ + "check if !false", + "check if !false && true", + "check if \"aaabde\" == \"aaa\" + \"b\" + \"de\"", + "check if \"aaabde\".contains(\"abd\")", + "check if \"aaabde\".matches(\"a*c?.e\")", + "check if \"abcD12\" == \"abcD12\"", + "check if \"hello world\".starts_with(\"hello\") && \"hello world\".ends_with(\"world\")", + "check if (true || false) && true", + "check if 1 + 2 * 3 - 4 / 2 == 5", + "check if 1 < 2", + "check if 1 <= 1", + "check if 1 <= 2", + "check if 1 | 2 ^ 3 == 0", + "check if 2 > 1", + "check if 2 >= 1", + "check if 2 >= 2", + "check if 2019-12-04T09:46:41Z < 2020-12-04T09:46:41Z", + "check if 2019-12-04T09:46:41Z <= 2020-12-04T09:46:41Z", + "check if 2020-12-04T09:46:41Z == 2020-12-04T09:46:41Z", + "check if 2020-12-04T09:46:41Z > 2019-12-04T09:46:41Z", + "check if 2020-12-04T09:46:41Z >= 2019-12-04T09:46:41Z", + "check if 2020-12-04T09:46:41Z >= 2020-12-04T09:46:41Z", + "check if 3 == 3", + "check if [\"abc\", \"def\"].contains(\"abc\")", + "check if [1, 2].contains(2)", + "check if [2019-12-04T09:46:41Z, 2020-12-04T09:46:41Z].contains(2020-12-04T09:46:41Z)", + "check if [false, true].contains(true)", + "check if [hex:12ab, hex:34de].contains(hex:34de)", + "check if false or true", + "check if hex:12ab == hex:12ab", + "check if true" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "allow if true;\n", + "revocation_ids": [ + "1472c34b2854a24f5023f5c9a2ecead444b1ddb9c94ffc42f3ed1f062745d3983e8392cd0a94ec3b00e355f00fa5980e187bb86a625e289e2e723f373e3bcd05" + ] + } + } + }, + { + "title": "invalid block rule with unbound_variables", + "filename": "test018_unbound_variables_in_rule.bc", + "token": [ + { + "symbols": [], + "public_keys": [], + "external_key": null, + "code": "check if operation(\"read\");\n" + }, + { + "symbols": [ + "unbound", + "any1", + "any2" + ], + "public_keys": [], + "external_key": null, + "code": "operation($unbound, \"read\") <- operation($any1, $any2);\n" + } + ], + "validations": { + "": { + "world": null, + "result": { + "Err": { + "FailedLogic": { + "InvalidBlockRule": [ + 0, + "operation($unbound, \"read\") <- operation($any1, $any2)" + ] + } + } + }, + "authorizer_code": "", + "revocation_ids": [ + "c536d07f08f6f73da69a2f49310045168e059b8c07e3ddf25afd524df358a0397744b31a139eced043cb5f7a29dacbe3a510ce449fc792e53623186767cefc0c", + "8588c74c3701e8d4be770769b4e1054dbb5ea5f231a89d205000802b8718859ea1d596af207a41b1b0f7d05959180c227ea8954e903f13ade3ce3384d1e6a70a" + ] + } + } + }, + { + "title": "invalid block rule generating an #authority or #ambient symbol with a variable", + "filename": "test019_generating_ambient_from_variables.bc", + "token": [ + { + "symbols": [], + "public_keys": [], + "external_key": null, + "code": "check if operation(\"read\");\n" + }, + { + "symbols": [ + "any" + ], + "public_keys": [], + "external_key": null, + "code": "operation(\"read\") <- operation($any);\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "operation(\"read\")", + "operation(\"write\")" + ], + "rules": [ + "operation(\"read\") <- operation($any)" + ], + "checks": [ + "check if operation(\"read\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 0, + "check_id": 0, + "rule": "check if operation(\"read\")" + } + } + ] + } + } + } + }, + "authorizer_code": "operation(\"write\");\n\nallow if true;\n", + "revocation_ids": [ + "4819e7360fdb840e54e94afcbc110e9b0652894dba2b8bf3b8b8f2254aaf00272bba7eb603c153c7e50cca0e5bb8e20449d70a1b24e7192e902c64f94848a703", + "4a4c59354354d2f91b3a2d1e7afa2c5eeaf8be9f7b163c6b9091817551cc8661f0f3e0523b525ef9a5e597c0dd1f32e09e97ace531c150dba335bb3e1d329d00" + ] + } + } + }, + { + "title": "sealed token", + "filename": "test020_sealed.bc", + "token": [ + { + "symbols": [ + "file1", + "file2" + ], + "public_keys": [], + "external_key": null, + "code": "right(\"file1\", \"read\");\nright(\"file2\", \"read\");\nright(\"file1\", \"write\");\n" + }, + { + "symbols": [ + "0" + ], + "public_keys": [], + "external_key": null, + "code": "check if resource($0), operation(\"read\"), right($0, \"read\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "operation(\"read\")", + "resource(\"file1\")", + "right(\"file1\", \"read\")", + "right(\"file1\", \"write\")", + "right(\"file2\", \"read\")" + ], + "rules": [], + "checks": [ + "check if resource($0), operation(\"read\"), right($0, \"read\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "resource(\"file1\");\noperation(\"read\");\n\nallow if true;\n", + "revocation_ids": [ + "b279f8c6fee5ea3c3fcb5109d8c6b35ba3fecea64d83a4dc387102b9401633a1558ac6ac50ddd7fd9e9877f936f9f4064abd467faeca2bef3114b9695eb0580e", + "e1f0aca12704c1a3b9bb6292504ca6070462d9e043756dd209e625084e7d4053078bd4e55b6eebebbeb771d26d7794aa95f6b39ff949431548b32585a7379f0c" + ] + } + } + }, + { + "title": "parsing", + "filename": "test021_parsing.bc", + "token": [ + { + "symbols": [ + "ns::fact_123", + "hello é\t😁" + ], + "public_keys": [], + "external_key": null, + "code": "ns::fact_123(\"hello é\t😁\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "ns::fact_123(\"hello é\t😁\")" + ], + "rules": [], + "checks": [ + "check if ns::fact_123(\"hello é\t😁\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "check if ns::fact_123(\"hello é\t😁\");\n\nallow if true;\n", + "revocation_ids": [ + "4797a528328c8b5fb7939cc8956d8cda2513f552466eee501e26ea13a6cf6b4a381fd74ae547a9b50b627825142287d899b9d7bd1b5cfb18664a1be78320ea06" + ] + } + } + }, + { + "title": "default_symbols", + "filename": "test022_default_symbols.bc", + "token": [ + { + "symbols": [], + "public_keys": [], + "external_key": null, + "code": "read(0);\nwrite(1);\nresource(2);\noperation(3);\nright(4);\ntime(5);\nrole(6);\nowner(7);\ntenant(8);\nnamespace(9);\nuser(10);\nteam(11);\nservice(12);\nadmin(13);\nemail(14);\ngroup(15);\nmember(16);\nip_address(17);\nclient(18);\nclient_ip(19);\ndomain(20);\npath(21);\nversion(22);\ncluster(23);\nnode(24);\nhostname(25);\nnonce(26);\nquery(27);\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "admin(13)", + "client(18)", + "client_ip(19)", + "cluster(23)", + "domain(20)", + "email(14)", + "group(15)", + "hostname(25)", + "ip_address(17)", + "member(16)", + "namespace(9)", + "node(24)", + "nonce(26)", + "operation(3)", + "owner(7)", + "path(21)", + "query(27)", + "read(0)", + "resource(2)", + "right(4)", + "role(6)", + "service(12)", + "team(11)", + "tenant(8)", + "time(5)", + "user(10)", + "version(22)", + "write(1)" + ], + "rules": [], + "checks": [ + "check if read(0), write(1), resource(2), operation(3), right(4), time(5), role(6), owner(7), tenant(8), namespace(9), user(10), team(11), service(12), admin(13), email(14), group(15), member(16), ip_address(17), client(18), client_ip(19), domain(20), path(21), version(22), cluster(23), node(24), hostname(25), nonce(26), query(27)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "check if read(0), write(1), resource(2), operation(3), right(4), time(5), role(6), owner(7), tenant(8), namespace(9), user(10), team(11), service(12), admin(13), email(14), group(15), member(16), ip_address(17), client(18), client_ip(19), domain(20), path(21), version(22), cluster(23), node(24), hostname(25), nonce(26), query(27);\n\nallow if true;\n", + "revocation_ids": [ + "38094260b324eff92db2ef79e715d88c18503c0dafa400bff900399f2ab0840cedc5ac25bdd3e97860b3f9e78ca5e0df67a113eb87be50265d49278efb13210f" + ] + } + } + }, + { + "title": "execution scope", + "filename": "test023_execution_scope.bc", + "token": [ + { + "symbols": [ + "authority_fact" + ], + "public_keys": [], + "external_key": null, + "code": "authority_fact(1);\n" + }, + { + "symbols": [ + "block1_fact" + ], + "public_keys": [], + "external_key": null, + "code": "block1_fact(1);\n" + }, + { + "symbols": [ + "var" + ], + "public_keys": [], + "external_key": null, + "code": "check if authority_fact($var);\ncheck if block1_fact($var);\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "authority_fact(1)", + "block1_fact(1)" + ], + "rules": [], + "checks": [ + "check if authority_fact($var)", + "check if block1_fact($var)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 2, + "check_id": 1, + "rule": "check if block1_fact($var)" + } + } + ] + } + } + } + }, + "authorizer_code": "allow if true;\n", + "revocation_ids": [ + "6a3606836bc63b858f96ce5000c9bead8eda139ab54679a2a8d7a9984c2e5d864b93280acc1b728bed0be42b5b1c3be10f48a13a4dbd05fd5763de5be3855108", + "5f1468fc60999f22c4f87fa088a83961188b4e654686c5b04bdc977b9ff4666d51a3d8be5594f4cef08054d100f31d1637b50bb394de7cccafc643c9b650390b", + "3eda05ddb65ee90d715cefc046837c01de944d8c4a7ff67e3d9a9d8470b5e214a20a8b9866bfe5e0d385e530b75ec8fcfde46b7dd6d4d6647d1e955c9d2fb90d" + ] + } + } + }, + { + "title": "third party", + "filename": "test024_third_party.bc", + "token": [ + { + "symbols": [], + "public_keys": [ + "ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25" + ], + "external_key": null, + "code": "right(\"read\");\ncheck if group(\"admin\") trusting ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25;\n" + }, + { + "symbols": [], + "public_keys": [], + "external_key": "ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25", + "code": "group(\"admin\");\ncheck if right(\"read\");\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "group(\"admin\")", + "right(\"read\")" + ], + "rules": [], + "checks": [ + "check if group(\"admin\") trusting ed25519/a424157b8c00c25214ea39894bf395650d88426147679a9dd43a64d65ae5bc25", + "check if right(\"read\")" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "allow if true;\n", + "revocation_ids": [ + "4f61f2f2f9cefdcad03a82803638e459bef70d6fd72dbdf2bdcab78fbd23f33146e4ff9700e23acb547b820b871fa9b9fd3bb6d7a1a755afce47e9907c65600c", + "683b23943b73f53f57f473571ba266f79f1fca0633be249bc135054371a11ffb101c57150ab2f1b9a6a160b45d09567a314b7dbc84224edf6188afd5b86d9305" + ] + } + } + }, + { + "title": "block rules", + "filename": "test025_check_all.bc", + "token": [ + { + "symbols": [ + "allowed_operations", + "A", + "B", + "op", + "allowed" + ], + "public_keys": [], + "external_key": null, + "code": "allowed_operations([\"A\", \"B\"]);\ncheck all operation($op), allowed_operations($allowed), $allowed.contains($op);\n" + } + ], + "validations": { + "A, B": { + "world": { + "facts": [ + "allowed_operations([ \"A\", \"B\"])", + "operation(\"A\")", + "operation(\"B\")" + ], + "rules": [], + "checks": [ + "check all operation($op), allowed_operations($allowed), $allowed.contains($op)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Ok": 0 + }, + "authorizer_code": "operation(\"A\");\noperation(\"B\");\n\nallow if true;\n", + "revocation_ids": [ + "b4ee591001e4068a7ee8efb7a0586c3ca3a785558f34d1fa8dbfa21b41ace70de0b670ac49222c7413066d0d83e6d9edee94fb0fda4b27ea11e837304dfb4b0b" + ] + }, + "A, invalid": { + "world": { + "facts": [ + "allowed_operations([ \"A\", \"B\"])", + "operation(\"A\")", + "operation(\"invalid\")" + ], + "rules": [], + "checks": [ + "check all operation($op), allowed_operations($allowed), $allowed.contains($op)" + ], + "policies": [ + "allow if true" + ] + }, + "result": { + "Err": { + "FailedLogic": { + "Unauthorized": { + "policy": { + "Allow": 0 + }, + "checks": [ + { + "Block": { + "block_id": 0, + "check_id": 0, + "rule": "check all operation($op), allowed_operations($allowed), $allowed.contains($op)" + } + } + ] + } + } + } + }, + "authorizer_code": "operation(\"A\");\noperation(\"invalid\");\n\nallow if true;\n", + "revocation_ids": [ + "b4ee591001e4068a7ee8efb7a0586c3ca3a785558f34d1fa8dbfa21b41ace70de0b670ac49222c7413066d0d83e6d9edee94fb0fda4b27ea11e837304dfb4b0b" + ] + } + } + }, + { + "title": "public keys interning", + "filename": "test026_public_keys_interning.bc", + "token": [ + { + "symbols": [], + "public_keys": [ + "ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59" + ], + "external_key": null, + "code": "query(0);\ncheck if true trusting previous, ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n" + }, + { + "symbols": [], + "public_keys": [ + "ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee" + ], + "external_key": "ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59", + "code": "query(1);\nquery(1, 2) <- query(1), query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n" + }, + { + "symbols": [], + "public_keys": [], + "external_key": "ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee", + "code": "query(2);\ncheck if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n" + }, + { + "symbols": [], + "public_keys": [], + "external_key": "ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee", + "code": "query(3);\ncheck if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\n" + }, + { + "symbols": [], + "public_keys": [ + "ed25519/2e0118e63beb7731dab5119280ddb117234d0cdc41b7dd5dc4241bcbbb585d14" + ], + "external_key": null, + "code": "query(4);\ncheck if query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\ncheck if query(4) trusting ed25519/2e0118e63beb7731dab5119280ddb117234d0cdc41b7dd5dc4241bcbbb585d14;\n" + } + ], + "validations": { + "": { + "world": { + "facts": [ + "query(0)", + "query(1)", + "query(1, 2)", + "query(2)", + "query(3)", + "query(4)" + ], + "rules": [ + "query(1, 2) <- query(1), query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee" + ], + "checks": [ + "check if query(1) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59", + "check if query(1, 2) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59, ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee", + "check if query(2) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee", + "check if query(2), query(3) trusting ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee", + "check if query(4) trusting ed25519/2e0118e63beb7731dab5119280ddb117234d0cdc41b7dd5dc4241bcbbb585d14", + "check if true trusting previous, ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59" + ], + "policies": [ + "allow if true", + "deny if query(0) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59", + "deny if query(1, 2)", + "deny if query(3)" + ] + }, + "result": { + "Ok": 3 + }, + "authorizer_code": "check if query(1, 2) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59, ed25519/ecfb8ed11fd9e6be133ca4dd8d229d39c7dcb2d659704c39e82fd7acf0d12dee;\n\ndeny if query(3);\ndeny if query(1, 2);\ndeny if query(0) trusting ed25519/3c8aeced6363b8a862552fb2b0b4b8b0f8244e8cef3c11c3e55fd553f3a90f59;\nallow if true;\n", + "revocation_ids": [ + "bc144fef824b7ba4b266eac53e9b4f3f2d3cd443c6963833f2f8d4073bef9553f92034c2350fdd50966a9f0c09db35b142d61e0476b0133429885c787052060b", + "aba1631f8d0bea1c81447e73269f560973d03287c2b44325d1b42d10a496156dc8e78648b946bc7db7a3111d787a10c1a9da8d53fc066b1f207de7415a2e9b0b", + "539cff0f5c311dcac843a9e6c8bb445aff0d6510bfa9b17d5350747be92dc365217e89e1d733f3ead1ecc05f287f312c41831338708e788503b55517af3ad000", + "5b10f7a7b4487f4421cf7f7f6d00b24a7a71939037b65b2e44241909564082a3e1e70cf7d866eb96f0a5119b9ea395adb772faaa33252fa62a579eb15a108a0b", + "3905351588cdfc4433b510cc1ed9c11ca5c1a7bd7d9cef338bcd3f6d374c711f34edd83dd0d53c25b63bf05b49fc78addceb47905d5495580c2fd36c11bc1e0a" + ] + } + } + } + ] +} diff --git a/test/samples/current/test001_basic.bc b/test/samples/current/test001_basic.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test001_basic.bc differ diff --git a/test/samples/current/test002_different_root_key.bc b/test/samples/current/test002_different_root_key.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test002_different_root_key.bc differ diff --git a/test/samples/current/test003_invalid_signature_format.bc b/test/samples/current/test003_invalid_signature_format.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test003_invalid_signature_format.bc differ diff --git a/test/samples/current/test004_random_block.bc b/test/samples/current/test004_random_block.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test004_random_block.bc differ diff --git a/test/samples/current/test005_invalid_signature.bc b/test/samples/current/test005_invalid_signature.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test005_invalid_signature.bc differ diff --git a/test/samples/current/test006_reordered_blocks.bc b/test/samples/current/test006_reordered_blocks.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test006_reordered_blocks.bc differ diff --git a/test/samples/current/test007_scoped_rules.bc b/test/samples/current/test007_scoped_rules.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test007_scoped_rules.bc differ diff --git a/test/samples/current/test008_scoped_checks.bc b/test/samples/current/test008_scoped_checks.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test008_scoped_checks.bc differ diff --git a/test/samples/current/test009_expired_token.bc b/test/samples/current/test009_expired_token.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test009_expired_token.bc differ diff --git a/test/samples/current/test010_authorizer_scope.bc b/test/samples/current/test010_authorizer_scope.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test010_authorizer_scope.bc differ diff --git a/test/samples/current/test011_authorizer_authority_caveats.bc b/test/samples/current/test011_authorizer_authority_caveats.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test011_authorizer_authority_caveats.bc differ diff --git a/test/samples/current/test012_authority_caveats.bc b/test/samples/current/test012_authority_caveats.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test012_authority_caveats.bc differ diff --git a/test/samples/current/test013_block_rules.bc b/test/samples/current/test013_block_rules.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test013_block_rules.bc differ diff --git a/test/samples/current/test014_regex_constraint.bc b/test/samples/current/test014_regex_constraint.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test014_regex_constraint.bc differ diff --git a/test/samples/current/test015_multi_queries_caveats.bc b/test/samples/current/test015_multi_queries_caveats.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test015_multi_queries_caveats.bc differ diff --git a/test/samples/current/test016_caveat_head_name.bc b/test/samples/current/test016_caveat_head_name.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test016_caveat_head_name.bc differ diff --git a/test/samples/current/test017_expressions.bc b/test/samples/current/test017_expressions.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test017_expressions.bc differ diff --git a/test/samples/current/test018_unbound_variables_in_rule.bc b/test/samples/current/test018_unbound_variables_in_rule.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test018_unbound_variables_in_rule.bc differ diff --git a/test/samples/current/test019_generating_ambient_from_variables.bc b/test/samples/current/test019_generating_ambient_from_variables.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test019_generating_ambient_from_variables.bc differ diff --git a/test/samples/current/test020_sealed.bc b/test/samples/current/test020_sealed.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test020_sealed.bc differ diff --git a/test/samples/current/test021_parsing.bc b/test/samples/current/test021_parsing.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test021_parsing.bc differ diff --git a/test/samples/current/test022_default_symbols.bc b/test/samples/current/test022_default_symbols.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test022_default_symbols.bc differ diff --git a/test/samples/current/test023_execution_scope.bc b/test/samples/current/test023_execution_scope.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test023_execution_scope.bc differ diff --git a/test/samples/current/test024_third_party.bc b/test/samples/current/test024_third_party.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test024_third_party.bc differ diff --git a/test/samples/current/test025_check_all.bc b/test/samples/current/test025_check_all.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test025_check_all.bc differ diff --git a/test/samples/current/test026_public_keys_interning.bc b/test/samples/current/test026_public_keys_interning.bc new file mode 100644 Binary files /dev/null and b/test/samples/current/test026_public_keys_interning.bc differ