biscuit-haskell (empty) → 0.1.0.0
raw patch · 26 files changed
+4355/−0 lines, 26 filesdep +asyncdep +attoparsecdep +basesetup-changed
Dependencies added: async, attoparsec, base, base16-bytestring, base64, biscuit-haskell, bytestring, cereal, containers, libsodium, mtl, parser-combinators, primitive, protobuf, random, regex-tdfa, tasty, tasty-hunit, template-haskell, text, th-lift-instances, time, validation-selective
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- app/Main.hs +4/−0
- biscuit-haskell.cabal +136/−0
- src/Auth/Biscuit.hs +190/−0
- src/Auth/Biscuit/Datalog/AST.hs +611/−0
- src/Auth/Biscuit/Datalog/Executor.hs +493/−0
- src/Auth/Biscuit/Datalog/Parser.hs +426/−0
- src/Auth/Biscuit/Example.hs +37/−0
- src/Auth/Biscuit/Proto.hs +276/−0
- src/Auth/Biscuit/ProtoBufAdapter.hs +320/−0
- src/Auth/Biscuit/Sel.hs +334/−0
- src/Auth/Biscuit/Timer.hs +27/−0
- src/Auth/Biscuit/Token.hs +218/−0
- src/Auth/Biscuit/Utils.hs +14/−0
- test/Spec.hs +24/−0
- test/Spec/Crypto.hs +129/−0
- test/Spec/Executor.hs +204/−0
- test/Spec/Parser.hs +454/−0
- test/Spec/Quasiquoter.hs +62/−0
- test/Spec/RevocationIds.hs +54/−0
- test/Spec/Roundtrip.hs +99/−0
- test/Spec/Samples.hs +103/−0
- test/Spec/Verification.hs +104/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for biscuit-haskell++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Clément Delafargue (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# biscuit-haskell
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "todo"
+ biscuit-haskell.cabal view
@@ -0,0 +1,136 @@+cabal-version: 2.0++name: biscuit-haskell+version: 0.1.0.0+category: Security+synopsis: Library support for the Biscuit security token+description: Please see the README on GitHub at <https://github.com/divarvel/biscuit-haskell#readme>+homepage: https://github.com/divarvel/biscuit-haskell#readme+bug-reports: https://github.com/divarvel/biscuit-haskell/issues+author: Clément Delafargue+maintainer: clement@delafargue.name+copyright: 2021 Clément Delafargue+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/divarvel/biscuit-haskell++library+ exposed-modules:+ Auth.Biscuit+ Auth.Biscuit.Utils+ Auth.Biscuit.Datalog.AST+ Auth.Biscuit.Datalog.Executor+ Auth.Biscuit.Datalog.Parser+ Auth.Biscuit.Example+ Auth.Biscuit.Proto+ Auth.Biscuit.ProtoBufAdapter+ Auth.Biscuit.Sel+ Auth.Biscuit.Timer+ Auth.Biscuit.Token+ other-modules:+ Paths_biscuit_haskell+ autogen-modules:+ Paths_biscuit_haskell+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >= 4.7 && <5,+ async ^>= 2.2,+ base16-bytestring ^>= 0.1.0,+ bytestring ^>= 0.10,+ text ^>= 1.2,+ containers ^>= 0.6,+ template-haskell ^>= 2.16,+ attoparsec ^>= 0.13,+ primitive ^>= 0.7,+ base64 ^>= 0.4,+ cereal ^>= 0.5,+ libsodium ^>= 1.0,+ mtl ^>= 2.2,+ parser-combinators ^>= 1.2,+ protobuf ^>= 0.2,+ random ^>= 1.1,+ regex-tdfa ^>= 1.3,+ th-lift-instances ^>= 0.1,+ time ^>= 1.9,+ validation-selective ^>= 0.1+ default-language: Haskell2010++executable biscuit-haskell-exe+ main-is: Main.hs+ other-modules:+ Paths_biscuit_haskell+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ async+ , attoparsec+ , base >=4.7 && <5+ , base16-bytestring ^>=0.1.0+ , base64+ , biscuit-haskell+ , bytestring+ , cereal+ , containers+ , libsodium+ , mtl+ , parser-combinators+ , primitive+ , protobuf+ , random+ , template-haskell+ , text+ , th-lift-instances+ , time+ , validation-selective+ default-language: Haskell2010++test-suite biscuit-haskell-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Spec.Crypto+ Spec.Executor+ Spec.Parser+ Spec.Quasiquoter+ Spec.RevocationIds+ Spec.Roundtrip+ Spec.Samples+ Spec.Verification+ Paths_biscuit_haskell+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ async+ , attoparsec+ , base >=4.7 && <5+ , base16-bytestring ^>=0.1+ , base64+ , biscuit-haskell+ , bytestring+ , cereal+ , containers+ , libsodium+ , mtl+ , parser-combinators+ , primitive+ , protobuf+ , random+ , tasty+ , tasty-hunit+ , template-haskell+ , text+ , th-lift-instances+ , time+ , validation-selective+ default-language: Haskell2010
+ src/Auth/Biscuit.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-|+ Module : Auth.Biscuit+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ Haskell implementation for the Biscuit token.+-}+module Auth.Biscuit+ (+ -- * The biscuit auth token+ -- $biscuitOverview++ -- * Creating keypairs+ newKeypair+ , fromPrivateKey+ , PrivateKey+ , PublicKey+ , Keypair (..)++ -- ** Parsing and serializing keypairs+ , serializePrivateKeyHex+ , serializePublicKeyHex+ , parsePrivateKeyHex+ , parsePublicKeyHex+ , serializePrivateKey+ , serializePublicKey+ , parsePrivateKey+ , parsePublicKey++ -- * Creating a biscuit+ , block+ , blockContext+ , mkBiscuit+ , addBlock+ , Biscuit+ , Block+ -- ** Parsing and serializing biscuits+ , serializeB64+ , parseB64+ , parse+ , serialize+ , parseHex+ , serializeHex++ -- * Verifying a biscuit+ , verifier+ , verifyBiscuit+ , verifyBiscuitWithLimits+ , checkBiscuitSignature+ , defaultLimits+ , Verifier+ , ParseError (..)+ , VerificationError (..)+ , ExecutionError (..)+ , Limits (..)+ ) where++import Control.Monad ((<=<))+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16 as Hex+import qualified Data.ByteString.Base64.URL as B64+import Data.Text (Text)++import Auth.Biscuit.Datalog.AST (Block, Verifier, bContext)+import Auth.Biscuit.Datalog.Executor (ExecutionError (..),+ Limits (..), defaultLimits)+import Auth.Biscuit.Datalog.Parser (block, verifier)+import Auth.Biscuit.Sel (Keypair (..), PrivateKey,+ PublicKey, fromPrivateKey,+ newKeypair, parsePrivateKey,+ parsePublicKey,+ serializePrivateKey,+ serializePublicKey)+import Auth.Biscuit.Token (Biscuit, ParseError (..),+ VerificationError (..),+ addBlock, checkBiscuitSignature,+ mkBiscuit, parseBiscuit,+ serializeBiscuit, verifyBiscuit,+ verifyBiscuitWithLimits)+import Auth.Biscuit.Utils (maybeToRight)++-- $biscuitOverview+--+-- <https://github.com/CleverCloud/biscuit/blob/master/SUMMARY.md Biscuit> is a /bearer token/,+-- allowing /offline attenuation/ (meaning that anyone having a token can restrict its use),+-- and /public key verification/. Token rights and attenuation are expressed using a logic language.+--+-- Here's how to create a biscuit token:+--+-- > buildToken :: Keypair -> IO Biscuit+-- > buildToken keypair =+-- > mkBiscuit keypair [block|+-- > // the token holder is identified as `user_1234`+-- > user(#authority, "user_1234");+-- > // the token holder is granted access to resource `file1`+-- > resource(#authority, "file1");+-- > // the token can only be used before a specified date+-- > check if time(#ambient, $time), $time < 2021-05-08T00:00:00Z;+-- > |]+--+-- Here's how to attenuate a biscuit token:+--+-- > restrictToken :: Biscuit -> IO Biscuit+-- > restrictToken =+-- > addBlock [block|+-- > // restrict the token to local use only+-- > check if user_ip_address(#ambient, "127.0.0.1");+-- > |]+--+-- Here's how to verify a biscuit token:+--+-- > verifyToken :: PublicKey -> Biscuit -> IO Bool+-- > verifyToken publicKey biscuit = do+-- > now <- getCurrentTime+-- > let verif = [verifier|+-- > // the datalog snippets can reference haskell variables+-- > current_time(#ambient, ${now});+-- >+-- > // policies are tried in order+-- > allow if resource(#authority, "file1");+-- > // catch-all policy if the previous ones did not match+-- > deny if true;+-- > |]+-- > result <- verifyBiscuit biscuit [verifier|current_time()|]+-- > case result of+-- > Left e -> print e $> False+-- > Right _ -> pure True++-- | Build a block containing an explicit context value.+-- The context of a block can't be parsed from datalog currently,+-- so you'll need an explicit call to `blockContext` to add it+--+-- > [block|check if time(#ambient, $t), $t < 2021-01-01;|]+-- > <> blockContext "ttl-check"+blockContext :: Text -> Block+blockContext c = mempty { bContext = Just c }++-- | Decode a base16-encoded bytestring, reporting errors via `MonadFail`+fromHex :: MonadFail m => ByteString -> m ByteString+fromHex input = do+ (decoded, "") <- pure $ Hex.decode input+ pure decoded++-- | Get an hex bytestring from a private key+serializePrivateKeyHex :: PrivateKey -> ByteString+serializePrivateKeyHex = Hex.encode . serializePrivateKey++-- | Get an hex bytestring from a public key+serializePublicKeyHex :: PublicKey -> ByteString+serializePublicKeyHex = Hex.encode . serializePublicKey++-- | Read a private key from an hex bytestring+parsePrivateKeyHex :: ByteString -> Maybe PrivateKey+parsePrivateKeyHex = parsePrivateKey <=< fromHex++-- | Read a public key from an hex bytestring+parsePublicKeyHex :: ByteString -> Maybe PublicKey+parsePublicKeyHex = parsePublicKey <=< fromHex++-- | Parse a biscuit from a raw bytestring. If you want to parse+-- from a URL-compatible base 64 bytestring, consider using `parseB64`+-- instead+parse :: ByteString -> Either ParseError Biscuit+parse = parseBiscuit++-- | Parse a biscuit from a URL-compatible base 64 encoded bytestring+parseB64 :: ByteString -> Either ParseError Biscuit+parseB64 = parse <=< first (const InvalidB64Encoding) . B64.decodeBase64++-- | Parse a biscuit from an hex-encoded bytestring+parseHex :: ByteString -> Either ParseError Biscuit+parseHex = parse <=< maybeToRight InvalidHexEncoding . fromHex++-- | Serialize a biscuit to a binary format. If you intend to send+-- the biscuit over a text channel, consider using `serializeB64` or+-- `serializeHex` instead+serialize :: Biscuit -> ByteString+serialize = serializeBiscuit++-- | Serialize a biscuit to URL-compatible base 64, as recommended by the spec+serializeB64 :: Biscuit -> ByteString+serializeB64 = Hex.encode . serialize++-- | Serialize a biscuit to a hex (base 16) string. Be advised that the specs+-- recommends base 64 instead.+serializeHex :: Biscuit -> ByteString+serializeHex = B64.encodeBase64' . serialize
+ src/Auth/Biscuit/Datalog/AST.hs view
@@ -0,0 +1,611 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-|+ Module : Auth.Biscuit.Datalog.AST+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ The Datalog elements+-}+module Auth.Biscuit.Datalog.AST+ (+ Binary (..)+ , Block+ , Block' (..)+ , BlockElement' (..)+ , Check+ , Check'+ , Expression+ , Expression' (..)+ , Fact+ , ID+ , ID' (..)+ , IsWithinSet (..)+ , Op (..)+ , ParsedAs (..)+ , Policy+ , Policy'+ , PolicyType (..)+ , Predicate+ , Predicate' (..)+ , PredicateOrFact (..)+ , QQID+ , Query+ , Query'+ , QueryItem' (..)+ , Rule+ , Rule' (..)+ , SetType+ , Slice (..)+ , SliceType+ , Unary (..)+ , Value+ , VariableType+ , Verifier+ , Verifier' (..)+ , VerifierElement' (..)+ , elementToBlock+ , elementToVerifier+ , fromStack+ , listSymbolsInBlock+ , renderBlock+ , renderFact+ , renderRule+ , toSetTerm+ , toStack+ ) where++import Control.Applicative ((<|>))+import Control.Monad ((<=<))+import Data.ByteString (ByteString)+import Data.ByteString.Base16 as Hex+import Data.Foldable (fold)+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.Void (Void, absurd)+import Instances.TH.Lift ()+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++data IsWithinSet = NotWithinSet | WithinSet+data ParsedAs = RegularString | QuasiQuote+data PredicateOrFact = InPredicate | InFact++type family VariableType (inSet :: IsWithinSet) (pof :: PredicateOrFact) where+ VariableType 'NotWithinSet 'InPredicate = Text+ VariableType inSet pof = Void++newtype Slice = Slice String+ deriving newtype (Eq, Show, Ord, IsString)++instance Lift Slice where+ lift (Slice name) = [| toLiteralId $(varE $ mkName name) |]+ liftTyped = unsafeTExpCoerce . lift++type family SliceType (ctx :: ParsedAs) where+ SliceType 'RegularString = Void+ SliceType 'QuasiQuote = Slice++type family SetType (inSet :: IsWithinSet) (ctx :: ParsedAs) where+ SetType 'NotWithinSet ctx = Set (ID' 'WithinSet 'InFact ctx)+ SetType 'WithinSet ctx = Void++-- | A single datalog item.+-- | This can be a value, a set of items, or a slice (a value that will be injected later),+-- | depending on the context+data ID' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: ParsedAs) =+ Symbol Text+ -- ^ A symbol (eg. @#authority@)+ | Variable (VariableType inSet pof)+ -- ^ A variable (eg. @$0@)+ | LInteger Int+ -- ^ An integer literal (eg. @42@)+ | LString Text+ -- ^ A string literal (eg. @"file1"@)+ | LDate UTCTime+ -- ^ A date literal (eg. @2021-05-26T18:00:00Z@)+ | LBytes ByteString+ -- ^ A hex literal (eg. @hex:ff9900@)+ | LBool Bool+ -- ^ A bool literal (eg. @true@)+ | Antiquote (SliceType ctx)+ -- ^ A slice (eg. @${name}@)+ | TermSet (SetType inSet ctx)+ -- ^ A set (eg. @[true, false]@)++deriving instance ( Eq (VariableType inSet pof)+ , Eq (SliceType ctx)+ , Eq (SetType inSet ctx)+ ) => Eq (ID' inSet pof ctx)++deriving instance ( Ord (VariableType inSet pof)+ , Ord (SliceType ctx)+ , Ord (SetType inSet ctx)+ ) => Ord (ID' inSet pof ctx)++deriving instance ( Show (VariableType inSet pof)+ , Show (SliceType ctx)+ , Show (SetType inSet ctx)+ ) => Show (ID' inSet pof ctx)++-- | In a regular AST, slices have already been eliminated+type ID = ID' 'NotWithinSet 'InPredicate 'RegularString+-- | In an AST parsed from a QuasiQuoter, there might be references to haskell variables+type QQID = ID' 'NotWithinSet 'InPredicate 'QuasiQuote+-- | A term that is not a variable+type Value = ID' 'NotWithinSet 'InFact 'RegularString+-- | An element of a set+type SetValue = ID' 'WithinSet 'InFact 'RegularString++instance ( Lift (VariableType inSet pof)+ , Lift (SetType inSet ctx)+ , Lift (SliceType ctx)+ )+ => Lift (ID' inSet pof ctx) where+ lift (Symbol n) = [| Symbol n |]+ lift (Variable n) = [| Variable n |]+ lift (LInteger i) = [| LInteger i |]+ lift (LString s) = [| LString s |]+ lift (LBytes bs) = [| LBytes bs |]+ lift (LBool b) = [| LBool b |]+ lift (TermSet terms) = [| TermSet terms |]+ lift (LDate t) = [| LDate (read $(lift $ show t)) |]+ lift (Antiquote s) = [| s |]++ liftTyped = unsafeTExpCoerce . lift++-- | This class describes how to turn a haskell value into a datalog value.+-- | This is used when slicing a haskell variable in a datalog expression+class ToLiteralId t where+ -- | How to turn a value into a datalog item+ toLiteralId :: t -> ID' inSet pof 'RegularString++instance ToLiteralId Int where+ toLiteralId = LInteger++instance ToLiteralId Integer where+ toLiteralId = LInteger . fromIntegral++instance ToLiteralId Text where+ toLiteralId = LString++instance ToLiteralId Bool where+ toLiteralId = LBool++instance ToLiteralId ByteString where+ toLiteralId = LBytes++instance ToLiteralId UTCTime where+ toLiteralId = LDate++toSetTerm :: Value+ -> Maybe (ID' 'WithinSet 'InFact 'RegularString)+toSetTerm = \case+ Symbol i -> Just $ Symbol i+ LInteger i -> Just $ LInteger i+ LString i -> Just $ LString i+ LDate i -> Just $ LDate i+ LBytes i -> Just $ LBytes i+ LBool i -> Just $ LBool i+ TermSet _ -> Nothing+ Variable v -> absurd v+ Antiquote v -> absurd v++renderId' :: (VariableType inSet pof -> Text)+ -> (SetType inSet ctx -> Text)+ -> (SliceType ctx -> Text)+ -> ID' inSet pof ctx -> Text+renderId' var set slice = \case+ Symbol name -> "#" <> name+ Variable name -> var name+ LInteger int -> pack $ show int+ LString str -> pack $ show str+ LDate time -> pack $ show time+ LBytes bs -> "hex:" <> decodeUtf8 (Hex.encode bs)+ LBool True -> "true"+ LBool False -> "false"+ TermSet terms -> set terms -- "[" <> intercalate "," (renderInnerId <$> Set.toList terms) <> "]"+ Antiquote v -> slice v++renderSet :: (SliceType ctx -> Text)+ -> Set (ID' 'WithinSet 'InFact ctx)+ -> Text+renderSet slice terms =+ "[" <> intercalate "," (renderId' absurd absurd slice <$> Set.toList terms) <> "]"++renderId :: ID -> Text+renderId = renderId' ("$" <>) (renderSet absurd) absurd++renderFactId :: ID' 'NotWithinSet 'InFact 'RegularString -> Text+renderFactId = renderId' absurd (renderSet absurd) absurd++listSymbolsInTerm :: ID -> Set.Set Text+listSymbolsInTerm = \case+ Symbol name -> Set.singleton name+ Variable name -> Set.singleton name+ TermSet terms -> foldMap listSymbolsInSetValue terms+ Antiquote v -> absurd v+ _ -> mempty++listSymbolsInValue :: Value -> Set.Set Text+listSymbolsInValue = \case+ Symbol name -> Set.singleton name+ TermSet terms -> foldMap listSymbolsInSetValue terms+ Variable v -> absurd v+ Antiquote v -> absurd v+ _ -> mempty++listSymbolsInSetValue :: SetValue -> Set.Set Text+listSymbolsInSetValue = \case+ Symbol name -> Set.singleton name+ TermSet v -> absurd v+ Variable v -> absurd v+ Antiquote v -> absurd v+ _ -> mempty++data Predicate' (pof :: PredicateOrFact) (ctx :: ParsedAs) = Predicate+ { name :: Text+ , terms :: [ID' 'NotWithinSet pof ctx]+ }++deriving instance ( Eq (ID' 'NotWithinSet pof ctx)+ ) => Eq (Predicate' pof ctx)+deriving instance ( Ord (ID' 'NotWithinSet pof ctx)+ ) => Ord (Predicate' pof ctx)+deriving instance ( Show (ID' 'NotWithinSet pof ctx)+ ) => Show (Predicate' pof ctx)++deriving instance Lift (ID' 'NotWithinSet pof ctx) => Lift (Predicate' pof ctx)++type Predicate = Predicate' 'InPredicate 'RegularString+type Fact = Predicate' 'InFact 'RegularString++renderPredicate :: Predicate -> Text+renderPredicate Predicate{name,terms} =+ name <> "(" <> intercalate ", " (fmap renderId terms) <> ")"++renderFact :: Fact -> Text+renderFact Predicate{name,terms} =+ name <> "(" <> intercalate ", " (fmap renderFactId terms) <> ")"++listSymbolsInFact :: Fact -> Set.Set Text+listSymbolsInFact Predicate{..} =+ Set.singleton name+ <> foldMap listSymbolsInValue terms++listSymbolsInPredicate :: Predicate -> Set.Set Text+listSymbolsInPredicate Predicate{..} =+ Set.singleton name+ <> foldMap listSymbolsInTerm terms++data QueryItem' ctx = QueryItem+ { qBody :: [Predicate' 'InPredicate ctx]+ , qExpressions :: [Expression' ctx]+ }++type Query' ctx = [QueryItem' ctx]+type Query = Query' 'RegularString++type Check' ctx = Query' ctx+type Check = Query+data PolicyType = Allow | Deny+ deriving (Eq, Show, Ord, Lift)+type Policy' ctx = (PolicyType, Query' ctx)+type Policy = (PolicyType, Query)++deriving instance ( Eq (Predicate' 'InPredicate ctx)+ , Eq (Expression' ctx)+ ) => Eq (QueryItem' ctx)+deriving instance ( Ord (Predicate' 'InPredicate ctx)+ , Ord (Expression' ctx)+ ) => Ord (QueryItem' ctx)+deriving instance ( Show (Predicate' 'InPredicate ctx)+ , Show (Expression' ctx)+ ) => Show (QueryItem' ctx)++deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (QueryItem' ctx)++renderQueryItem :: QueryItem' 'RegularString -> Text+renderQueryItem QueryItem{..} =+ intercalate ",\n" $ fold+ [ renderPredicate <$> qBody+ , renderExpression <$> qExpressions+ ]++renderCheck :: Check -> Text+renderCheck is = "check if " <>+ intercalate "\n or " (renderQueryItem <$> is)++listSymbolsInQueryItem :: QueryItem' 'RegularString -> Set.Set Text+listSymbolsInQueryItem QueryItem{..} =+ Set.singleton "query" -- query items are serialized as `Rule`s+ -- so an empty rule head is added: `query()`+ -- It means that query items implicitly depend on+ -- the `query` symbol being defined.+ <> foldMap listSymbolsInPredicate qBody+ <> foldMap listSymbolsInExpression qExpressions++listSymbolsInCheck :: Check -> Set.Set Text+listSymbolsInCheck =+ foldMap listSymbolsInQueryItem++data Rule' ctx = Rule+ { rhead :: Predicate' 'InPredicate ctx+ , body :: [Predicate' 'InPredicate ctx]+ , expressions :: [Expression' ctx]+ }++deriving instance ( Eq (Predicate' 'InPredicate ctx)+ , Eq (Expression' ctx)+ ) => Eq (Rule' ctx)+deriving instance ( Ord (Predicate' 'InPredicate ctx)+ , Ord (Expression' ctx)+ ) => Ord (Rule' ctx)+deriving instance ( Show (Predicate' 'InPredicate ctx)+ , Show (Expression' ctx)+ ) => Show (Rule' ctx)++type Rule = Rule' 'RegularString++deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (Rule' ctx)++renderRule :: Rule' 'RegularString -> Text+renderRule Rule{rhead,body,expressions} =+ renderPredicate rhead <> " <- " <> intercalate ", " (fmap renderPredicate body <> fmap renderExpression expressions)++listSymbolsInRule :: Rule -> Set.Set Text+listSymbolsInRule Rule{..} =+ listSymbolsInPredicate rhead+ <> foldMap listSymbolsInPredicate body+ <> foldMap listSymbolsInExpression expressions++data Unary =+ Negate+ | Parens+ | Length+ deriving (Eq, Ord, Show, Lift)++data Binary =+ LessThan+ | GreaterThan+ | LessOrEqual+ | GreaterOrEqual+ | Equal+ | Contains+ | Prefix+ | Suffix+ | Regex+ | Add+ | Sub+ | Mul+ | Div+ | And+ | Or+ | Intersection+ | Union+ deriving (Eq, Ord, Show, Lift)++data Expression' (ctx :: ParsedAs) =+ EValue (ID' 'NotWithinSet 'InPredicate ctx)+ | EUnary Unary (Expression' ctx)+ | EBinary Binary (Expression' ctx) (Expression' ctx)++deriving instance Eq (ID' 'NotWithinSet 'InPredicate ctx) => Eq (Expression' ctx)+deriving instance Ord (ID' 'NotWithinSet 'InPredicate ctx) => Ord (Expression' ctx)+deriving instance Lift (ID' 'NotWithinSet 'InPredicate ctx) => Lift (Expression' ctx)+deriving instance Show (ID' 'NotWithinSet 'InPredicate ctx) => Show (Expression' ctx)++type Expression = Expression' 'RegularString++listSymbolsInExpression :: Expression -> Set.Set Text+listSymbolsInExpression = \case+ EValue t -> listSymbolsInTerm t+ EUnary _ e -> listSymbolsInExpression e+ EBinary _ e e' -> foldMap listSymbolsInExpression [e, e']++data Op =+ VOp ID+ | UOp Unary+ | BOp Binary++fromStack :: [Op] -> Either String Expression+fromStack =+ let go stack [] = Right stack+ go stack (VOp t : rest) = go (EValue t : stack) rest+ go (e:stack) (UOp o : rest) = go (EUnary o e : stack) rest+ go [] (UOp _ : _) = Left "Empty stack on unary op"+ go (e:e':stack) (BOp o : rest) = go (EBinary o e' e : stack) rest+ go [_] (BOp _ : _) = Left "Unary stack on binary op"+ go [] (BOp _ : _) = Left "Empty stack on binary op"+ final [] = Left "Empty stack"+ final [x] = Right x+ final _ = Left "Stack containing more than one element"+ in final <=< go []++toStack :: Expression -> [Op]+toStack expr =+ let go e s = case e of+ EValue t -> VOp t : s+ EUnary o i -> go i $ UOp o : s+ EBinary o l r -> go l $ go r $ BOp o : s+ in go expr []++renderExpression :: Expression -> Text+renderExpression =+ let rOp t e e' = renderExpression e+ <> " " <> t <> " "+ <> renderExpression e'+ rm m e e' = renderExpression e+ <> "." <> m <> "("+ <> renderExpression e'+ <> ")"+ in \case+ EValue t -> renderId t+ EUnary Negate e -> "!" <> renderExpression e+ EUnary Parens e -> "(" <> renderExpression e <> ")"+ EUnary Length e -> renderExpression e <> ".length()"+ EBinary LessThan e e' -> rOp "<" e e'+ EBinary GreaterThan e e' -> rOp ">" e e'+ EBinary LessOrEqual e e' -> rOp "<=" e e'+ EBinary GreaterOrEqual e e' -> rOp ">=" e e'+ EBinary Equal e e' -> rOp "==" e e'+ EBinary Contains e e' -> rm "contains" e e'+ EBinary Prefix e e' -> rm "starts_with" e e'+ EBinary Suffix e e' -> rm "ends_with" e e'+ EBinary Regex e e' -> rm "matches" e e'+ EBinary Intersection e e' -> rm "intersection" e e'+ EBinary Union e e' -> rm "union" e e'+ EBinary Add e e' -> rOp "+" e e'+ EBinary Sub e e' -> rOp "-" e e'+ EBinary Mul e e' -> rOp "*" e e'+ EBinary Div e e' -> rOp "/" e e'+ EBinary And e e' -> rOp "&&" e e'+ EBinary Or e e' -> rOp "||" e e'++-- | A biscuit block, containing facts, rules and checks.+--+-- 'Block' has a 'Monoid' instance, this is the expected way+-- to build composite blocks (eg if you need to generate a list of facts):+--+-- > -- build a block containing a list of facts `value("a"); value("b"); value("c");`.+-- > foldMap (\v -> [block| value(${v}) |]) ["a", "b", "c"]+type Block = Block' 'RegularString++-- | A biscuit block, that may or may not contain slices referencing+-- haskell variables+data Block' (ctx :: ParsedAs) = Block+ { bRules :: [Rule' ctx]+ , bFacts :: [Predicate' 'InFact ctx]+ , bChecks :: [Check' ctx]+ , bContext :: Maybe Text+ }++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)++-- 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+ b1 <> b2 = Block { bRules = bRules b1 <> bRules b2+ , bFacts = bFacts b1 <> bFacts b2+ , bChecks = bChecks b1 <> bChecks b2+ , bContext = bContext b2 <|> bContext b1+ }++instance Monoid (Block' ctx) where+ mempty = Block { bRules = []+ , bFacts = []+ , bChecks = []+ , bContext = Nothing+ }++listSymbolsInBlock :: Block' 'RegularString -> Set.Set Text+listSymbolsInBlock Block {..} = fold+ [ foldMap listSymbolsInRule bRules+ , foldMap listSymbolsInFact bFacts+ , foldMap listSymbolsInCheck bChecks+ ]++-- | A biscuit verifier, containing, facts, rules, checks and policies+type Verifier = Verifier' 'RegularString++-- | The context in which a biscuit policies and checks are verified.+-- A verifier may add policies (`deny if` / `allow if` conditions), as well as rules, facts, and checks.+-- A verifier may or may not contain slices referencing haskell variables.+data Verifier' (ctx :: ParsedAs) = Verifier+ { vPolicies :: [Policy' ctx]+ -- ^ the allow / deny policies.+ , vBlock :: Block' ctx+ -- ^ the facts, rules and checks+ }++instance Semigroup (Verifier' ctx) where+ v1 <> v2 = Verifier { vPolicies = vPolicies v1 <> vPolicies v2+ , vBlock = vBlock v1 <> vBlock v2+ }++instance Monoid (Verifier' ctx) where+ mempty = Verifier { vPolicies = []+ , vBlock = mempty+ }++deriving instance ( Eq (Block' ctx)+ , Eq (QueryItem' ctx)+ ) => Eq (Verifier' ctx)++deriving instance ( Show (Block' ctx)+ , Show (QueryItem' ctx)+ ) => Show (Verifier' ctx)++deriving instance ( Lift (Block' ctx)+ , Lift (QueryItem' ctx)+ ) => Lift (Verifier' ctx)++data BlockElement' ctx+ = BlockFact (Predicate' 'InFact ctx)+ | BlockRule (Rule' ctx)+ | BlockCheck (Check' ctx)+ | BlockComment++deriving instance ( Show (Predicate' 'InFact ctx)+ , Show (Rule' ctx)+ , Show (QueryItem' ctx)+ ) => Show (BlockElement' ctx)++elementToBlock :: BlockElement' ctx -> Block' ctx+elementToBlock = \case+ BlockRule r -> Block [r] [] [] Nothing+ BlockFact f -> Block [] [f] [] Nothing+ BlockCheck c -> Block [] [] [c] Nothing+ BlockComment -> mempty++data VerifierElement' ctx+ = VerifierPolicy (Policy' ctx)+ | BlockElement (BlockElement' ctx)++deriving instance ( Show (Predicate' 'InFact ctx)+ , Show (Rule' ctx)+ , Show (QueryItem' ctx)+ ) => Show (VerifierElement' ctx)++elementToVerifier :: VerifierElement' ctx -> Verifier' ctx+elementToVerifier = \case+ VerifierPolicy p -> Verifier [p] mempty+ BlockElement be -> Verifier [] (elementToBlock be)
+ src/Auth/Biscuit/Datalog/Executor.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-|+ Module : Auth.Biscuit.Datalog.Executor+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ The Datalog engine, tasked with deriving new facts from existing facts and rules, as well as matching available facts against checks and policies+-}+module Auth.Biscuit.Datalog.Executor+ ( BlockWithRevocationIds (..)+ , ExecutionError (..)+ , Limits (..)+ , ResultError (..)+ , World (..)+ , Bindings+ , Name+ , computeAllFacts+ , defaultLimits+ , evaluateExpression+ , runVerifier+ , runVerifierWithLimits+ ) where++import Control.Monad (join, mfilter, when)+import Data.Bifunctor (first)+import Data.Bitraversable (bitraverse)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Map.Strict (Map, (!?))+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust, mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text, intercalate, unpack)+import qualified Data.Text as Text+import Data.Void (absurd)+import qualified Text.Regex.TDFA as Regex+import qualified Text.Regex.TDFA.Text as Regex+import Validation (Validation (..), failure)++import Auth.Biscuit.Datalog.AST+import Auth.Biscuit.Datalog.Parser (fact)+import Auth.Biscuit.Timer (timer)+import Auth.Biscuit.Utils (maybeToRight)++-- | A variable name+type Name = Text++-- | A list of bound variables, with the associated value+type Bindings = Map Name Value++-- | The result of matching the checks and policies against all the available+-- facts.+data ResultError+ = NoPoliciesMatched [Check]+ -- ^ No policy matched. additionally some checks may have failed+ | FailedChecks (NonEmpty Check)+ -- ^ An allow rule matched, but at least one check failed+ | DenyRuleMatched [Check] Query+ -- ^ A deny rule matched. additionally some checks may have failed+ deriving (Eq, Show)++-- | The result of running verification+data ExecutionError+ = Timeout+ -- ^ Verification took too much time+ | TooManyFacts+ -- ^ Too many facts were generated during evaluation+ | TooManyIterations+ -- ^ Evaluation did not converge in the alloted number of iterations+ | FactsInBlocks+ -- ^ Some blocks contained either rules or facts while it was forbidden+ | ResultError ResultError+ -- ^ The checks and policies were not fulfilled after evaluation+ deriving (Eq, Show)++-- | Settings for the executor restrictions+-- See `defaultLimits` for default values.+data Limits+ = Limits+ { maxFacts :: Int+ -- ^ maximum number of facts that can be produced (else `TooManyFacts` is thrown)+ , maxIterations :: Int+ -- ^ maximum number of iterations before throwing `TooManyIterations`+ , maxTime :: Int+ -- ^ maximum duration the verification can take (in μs)+ , allowRegexes :: Bool+ -- ^ whether or not allowing `.matches()` during verification+ , allowBlockFacts :: Bool+ -- ^ wheter or not accept facts and rules in blocks. Even when they are enabled, they+ -- can’t give rise to facts containing `#authority` or `#ambient` symbols+ , checkRevocationId :: ByteString -> IO (Either () ())+ -- ^ how to check for token revocation `Left ()` means that the given id is revoked,+ -- `Right ()` means it’s not revoked.+ }++-- | Default settings for the executor restrictions.+-- (1000 facts, 100 iterations, 1000μs max, regexes are allowed, facts and rules are allowed in blocks)+defaultLimits :: Limits+defaultLimits = Limits+ { maxFacts = 1000+ , maxIterations = 100+ , maxTime = 1000+ , allowRegexes = True+ , allowBlockFacts = True+ , checkRevocationId = const . pure $ Right ()+ }++-- | A parsed block, along with the associated revocation ids.+data BlockWithRevocationIds+ = BlockWithRevocationIds+ { bBlock :: Block+ -- ^ The parsed block+ , genericRevocationId :: ByteString+ -- ^ Generic revocation id (depends on the block contents and its primary key)+ , uniqueRevocationId :: ByteString+ -- ^ Unique revocation id (specific to the token)+ }++-- | A collection of facts and rules used to derive new facts.+-- Rules coming from blocks are stored separately since they are subject to specific+-- restrictions regarding the facts they can generate.+data World+ = World+ { rules :: Set Rule+ , blockRules :: Set Rule+ , facts :: Set Fact+ }++instance Semigroup World where+ w1 <> w2 = World+ { rules = rules w1 <> rules w2+ , blockRules = blockRules w1 <> blockRules w2+ , facts = facts w1 <> facts w2+ }++instance Monoid World where+ mempty = World mempty mempty mempty++instance Show World where+ show World{..} = unpack . intercalate "\n" $ join+ [ [ "Authority & Verifier Rules" ]+ , renderRule <$> Set.toList rules+ , [ "Block Rules" ]+ , renderRule <$> Set.toList blockRules+ , [ "Facts" ]+ , renderFact <$> Set.toList facts+ ]++-- | Is the fact "restricted" (meaning it is not allowed to come from a block, or generated by a block rule).+-- In practice, only authority blocks can contain the symbols `#ambient` and `#authority`+isRestricted :: Fact -> Bool+isRestricted Predicate{terms} =+ let restrictedSymbol (Symbol s ) = s == "ambient" || s == "authority"+ restrictedSymbol _ = False+ in any restrictedSymbol terms++-- | Expose the block revocation ids through facts+revocationIdFacts :: Integer+ -- ^ The block index (0 for authority, 1-n for blocks)+ -> BlockWithRevocationIds+ -> [Fact]+revocationIdFacts index BlockWithRevocationIds{genericRevocationId, uniqueRevocationId} =+ [ [fact|revocation_id(${index}, ${genericRevocationId})|]+ , [fact|unique_revocation_id(${index}, ${uniqueRevocationId})|]+ ]++collectWorld :: Limits -> Verifier -> BlockWithRevocationIds -> [BlockWithRevocationIds] -> World+collectWorld Limits{allowBlockFacts} Verifier{vBlock} authority blocks =+ let getRules = bRules . bBlock+ getFacts = bFacts . bBlock+ revocationIds = join $ zipWith revocationIdFacts [0..] (authority : blocks)+ in World+ { rules = Set.fromList $ bRules vBlock <> getRules authority+ , blockRules = if allowBlockFacts+ then Set.fromList $ foldMap getRules blocks+ else mempty+ , facts = Set.fromList $+ bFacts vBlock+ <> getFacts authority+ <> filter ((allowBlockFacts &&) . not . isRestricted) (getFacts =<< blocks)+ <> revocationIds+ }++-- | Given a series of blocks and a verifier, ensure that all+-- the checks and policies match+runVerifier :: BlockWithRevocationIds+ -- ^ The authority block+ -> [BlockWithRevocationIds]+ -- ^ The extra blocks+ -> Verifier+ -- ^ A verifier+ -> IO (Either ExecutionError Query)+runVerifier = runVerifierWithLimits defaultLimits++-- | Given a series of blocks and a verifier, ensure that all+-- the checks and policies match, with provided execution+-- constraints+runVerifierWithLimits :: Limits+ -- ^ custom limits+ -> BlockWithRevocationIds+ -- ^ The authority block+ -> [BlockWithRevocationIds]+ -- ^ The extra blocks+ -> Verifier+ -- ^ A verifier+ -> IO (Either ExecutionError Query)+runVerifierWithLimits l@Limits{..} authority blocks v = do+ resultOrTimeout <- timer maxTime $ runVerifier' l authority blocks v+ pure $ case resultOrTimeout of+ Nothing -> Left Timeout+ Just r -> r++runVerifier' :: Limits+ -> BlockWithRevocationIds+ -> [BlockWithRevocationIds]+ -> Verifier+ -> IO (Either ExecutionError Query)+runVerifier' l authority blocks v@Verifier{..} = do+ let initialWorld = collectWorld l v authority blocks+ allFacts' = computeAllFacts l initialWorld+ case allFacts' of+ Left e -> pure $ Left e+ Right allFacts -> do+ let allChecks = foldMap bChecks $ vBlock : (bBlock <$> authority : blocks)+ checkResults = traverse_ (checkCheck l allFacts) allChecks+ policiesResults = mapMaybe (checkPolicy l allFacts) vPolicies+ policyResult = case policiesResults of+ p : _ -> first Just p+ [] -> Left Nothing+ pure $ case (checkResults, policyResult) of+ (Success (), Right p) -> Right p+ (Success (), Left Nothing) -> Left $ ResultError $ NoPoliciesMatched []+ (Success (), Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p+ (Failure cs, Left Nothing) -> Left $ ResultError $ NoPoliciesMatched (NE.toList cs)+ (Failure cs, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched (NE.toList cs) p+ (Failure cs, Right _) -> Left $ ResultError $ FailedChecks cs++checkCheck :: Limits -> Set Fact -> Check -> Validation (NonEmpty Check) ()+checkCheck l facts items =+ if any (isQueryItemSatisfied l facts) items+ then Success ()+ else failure items++checkPolicy :: Limits -> Set Fact -> Policy -> Maybe (Either Query Query)+checkPolicy l facts (pType, items) =+ if any (isQueryItemSatisfied l facts) items+ then Just $ case pType of+ Allow -> Right items+ Deny -> Left items+ else Nothing++isQueryItemSatisfied :: Limits -> Set Fact -> QueryItem' 'RegularString -> Bool+isQueryItemSatisfied l facts QueryItem{qBody, qExpressions} =+ let bindings = getBindingsForRuleBody l facts qBody qExpressions+ in Set.size bindings > 0++-- | Compute all possible facts, recursively calling itself+-- until it can't generate new facts or a limit is reached+computeAllFacts :: Limits+ -- ^ The maximum amount of iterations that can be reached+ -> World+ -- ^ The initial rules and facts+ -> Either ExecutionError (Set Fact)+computeAllFacts l@Limits{..} = computeAllFacts' l maxIterations+++-- | Compute all possible facts, recursively calling itself+-- until it can't generate new facts or a limit is reached+computeAllFacts' :: Limits+ -> Int+ -> World+ -> Either ExecutionError (Set Fact)+computeAllFacts' l@Limits{..} remainingIterations w@World{facts} = do+ let newFacts = extend l w+ allFacts = facts <> newFacts+ when (Set.size allFacts >= maxFacts) $ Left TooManyFacts+ when (remainingIterations - 1 <= 0) $ Left TooManyIterations+ if null newFacts+ then pure allFacts+ else computeAllFacts' l (remainingIterations - 1) (w { facts = allFacts })++extend :: Limits -> World -> Set Fact+extend l World{..} =+ let buildFacts = foldMap (getFactsForRule l facts)+ allNewFacts = buildFacts rules+ allNewBlockFacts = Set.filter (not . isRestricted) $ buildFacts blockRules+ in Set.difference (allNewFacts <> allNewBlockFacts) facts++getFactsForRule :: Limits -> Set Fact -> Rule -> Set Fact+getFactsForRule l facts Rule{rhead, body, expressions} =+ let legalBindings = getBindingsForRuleBody l facts body expressions+ newFacts = mapMaybe (applyBindings rhead) $ Set.toList legalBindings+ in Set.fromList newFacts++getBindingsForRuleBody :: Limits -> Set Fact -> [Predicate] -> [Expression] -> Set Bindings+getBindingsForRuleBody l facts body expressions =+ let candidateBindings = getCandidateBindings facts body+ allVariables = extractVariables body+ legalBindingsForFacts = reduceCandidateBindings allVariables candidateBindings+ in Set.filter (\b -> all (satisfies l b) expressions) legalBindingsForFacts++satisfies :: Limits+ -> Bindings+ -> Expression+ -> Bool+satisfies l b e = evaluateExpression l 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 -> Bindings -> Maybe Fact+applyBindings p@Predicate{terms} bindings =+ let newTerms = traverse replaceTerm terms+ replaceTerm :: ID -> Maybe Value+ replaceTerm (Variable n) = Map.lookup n bindings+ replaceTerm (Symbol t) = Just $ Symbol t+ replaceTerm (LInteger t) = Just $ LInteger t+ replaceTerm (LString t) = Just $ LString t+ replaceTerm (LDate t) = Just $ LDate t+ replaceTerm (LBytes t) = Just $ LBytes t+ replaceTerm (LBool t) = Just $ LBool t+ replaceTerm (TermSet t) = Just $ TermSet t+ replaceTerm (Antiquote t) = absurd t+ in (\nt -> p { terms = nt}) <$> newTerms++getCombinations :: [[a]] -> [[a]]+getCombinations (x:xs) = do+ y <- x+ (y:) <$> getCombinations xs+getCombinations [] = [[]]++mergeBindings :: [Bindings] -> Bindings+mergeBindings =+ -- group all the values unified with each variable+ let combinations = Map.unionsWith (<>) . fmap (fmap pure)+ sameValues = fmap NE.head . mfilter ((== 1) . length) . Just . NE.nub+ -- only keep+ keepConsistent = Map.mapMaybe sameValues+ in keepConsistent . combinations++reduceCandidateBindings :: Set Name+ -> [Set Bindings]+ -> Set Bindings+reduceCandidateBindings allVariables matches =+ let allCombinations :: [[Bindings]]+ allCombinations = getCombinations $ Set.toList <$> matches+ isComplete :: Bindings -> Bool+ isComplete = (== allVariables) . Set.fromList . Map.keys+ in Set.fromList $ filter isComplete $ mergeBindings <$> allCombinations++getCandidateBindings :: Set Fact+ -> [Predicate]+ -> [Set Bindings]+getCandidateBindings facts predicates =+ let mapMaybeS f = foldMap (foldMap Set.singleton . f)+ keepFacts p = mapMaybeS (factMatchesPredicate p) facts+ in keepFacts <$> predicates++isSame :: ID -> Value -> Bool+isSame (Symbol t) (Symbol t') = t == t'+isSame (LInteger t) (LInteger t') = t == t'+isSame (LString t) (LString t') = t == t'+isSame (LDate t) (LDate t') = t == t'+isSame (LBytes t) (LBytes t') = t == t'+isSame (LBool t) (LBool t') = t == t'+isSame (TermSet t) (TermSet t') = t == t'+isSame _ _ = False++factMatchesPredicate :: Predicate -> Fact -> Maybe Bindings+factMatchesPredicate Predicate{name = predicateName, terms = predicateTerms }+ Predicate{name = factName, terms = factTerms } =+ let namesMatch = predicateName == factName+ lengthsMatch = length predicateTerms == length factTerms+ allMatches = sequenceA $ zipWith yolo predicateTerms factTerms+ yolo :: ID -> Value -> Maybe Bindings+ yolo (Variable vname) value = Just (Map.singleton vname value)+ yolo t t' | isSame t t' = Just mempty+ | otherwise = Nothing+ in if namesMatch && lengthsMatch+ then mergeBindings <$> allMatches+ else Nothing++applyVariable :: Bindings+ -> ID+ -> Either String Value+applyVariable bindings = \case+ Variable n -> maybeToRight "Unbound variable" $ bindings !? n+ Symbol t -> Right $ Symbol t+ LInteger t -> Right $ LInteger t+ LString t -> Right $ LString t+ LDate t -> Right $ LDate t+ LBytes t -> Right $ LBytes t+ LBool t -> Right $ LBool t+ TermSet t -> Right $ TermSet t+ Antiquote v -> absurd v++evalUnary :: Unary -> Value -> Either String Value+evalUnary Parens t = pure t+evalUnary Negate (LBool b) = pure (LBool $ not b)+evalUnary Negate _ = Left "Only booleans support negation"+evalUnary Length (LString t) = pure . LInteger $ Text.length t+evalUnary Length (LBytes bs) = pure . LInteger $ ByteString.length bs+evalUnary Length (TermSet s) = pure . LInteger $ Set.size s+evalUnary Length _ = Left "Only strings, bytes and sets support `.length()`"++evalBinary :: Limits -> Binary -> Value -> Value -> Either String Value+-- eq / ord operations+evalBinary _ Equal (Symbol s) (Symbol s') = pure $ LBool (s == s')+evalBinary _ Equal (LInteger i) (LInteger i') = pure $ LBool (i == i')+evalBinary _ Equal (LString t) (LString t') = pure $ LBool (t == t')+evalBinary _ Equal (LDate t) (LDate t') = pure $ LBool (t == t')+evalBinary _ Equal (LBytes t) (LBytes t') = pure $ LBool (t == t')+evalBinary _ Equal (LBool t) (LBool t') = pure $ LBool (t == t')+evalBinary _ Equal (TermSet t) (TermSet t') = pure $ LBool (t == t')+evalBinary _ Equal _ _ = Left "Equality mismatch"+evalBinary _ LessThan (LInteger i) (LInteger i') = pure $ LBool (i < i')+evalBinary _ LessThan (LDate t) (LDate t') = pure $ LBool (t < t')+evalBinary _ LessThan _ _ = Left "< mismatch"+evalBinary _ GreaterThan (LInteger i) (LInteger i') = pure $ LBool (i > i')+evalBinary _ GreaterThan (LDate t) (LDate t') = pure $ LBool (t > t')+evalBinary _ GreaterThan _ _ = Left "> mismatch"+evalBinary _ LessOrEqual (LInteger i) (LInteger i') = pure $ LBool (i <= i')+evalBinary _ LessOrEqual (LDate t) (LDate t') = pure $ LBool (t <= t')+evalBinary _ LessOrEqual _ _ = Left "<= mismatch"+evalBinary _ GreaterOrEqual (LInteger i) (LInteger i') = pure $ LBool (i >= i')+evalBinary _ GreaterOrEqual (LDate t) (LDate t') = pure $ LBool (t >= t')+evalBinary _ GreaterOrEqual _ _ = Left ">= mismatch"+-- string-related operations+evalBinary _ Prefix (LString t) (LString t') = pure $ LBool (t' `Text.isPrefixOf` t)+evalBinary _ Prefix _ _ = Left "Only strings support `.starts_with()`"+evalBinary _ Suffix (LString t) (LString t') = pure $ LBool (t' `Text.isSuffixOf` t)+evalBinary _ Suffix _ _ = Left "Only strings support `.ends_with()`"+evalBinary Limits{allowRegexes} Regex (LString t) (LString r) | allowRegexes = regexMatch t r+ | otherwise = Left "Regex evaluation is disabled"+evalBinary _ Regex _ _ = Left "Only strings support `.matches()`"+-- num operations+evalBinary _ Add (LInteger i) (LInteger i') = pure $ LInteger (i + i')+evalBinary _ Add _ _ = Left "Only integers support addition"+evalBinary _ Sub (LInteger i) (LInteger i') = pure $ LInteger (i - i')+evalBinary _ Sub _ _ = Left "Only integers support subtraction"+evalBinary _ Mul (LInteger i) (LInteger i') = pure $ LInteger (i * i')+evalBinary _ Mul _ _ = Left "Only integers support multiplication"+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"+-- boolean operations+evalBinary _ And (LBool b) (LBool b') = pure $ LBool (b && b')+evalBinary _ And _ _ = Left "Only booleans support &&"+evalBinary _ Or (LBool b) (LBool b') = pure $ LBool (b || b')+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+ Just t'' -> pure $ LBool (Set.member t'' t)+ Nothing -> Left "Sets cannot contain nested sets nor variables"+evalBinary _ Contains _ _ = Left "Only sets support `.contains()`"+evalBinary _ Intersection (TermSet t) (TermSet t') = pure $ TermSet (Set.intersection t t')+evalBinary _ Intersection _ _ = Left "Only sets support `.intersection()`"+evalBinary _ Union (TermSet t) (TermSet t') = pure $ TermSet (Set.union t t')+evalBinary _ Union _ _ = Left "Only sets support `.union()`"++regexMatch :: Text -> Text -> Either String Value+regexMatch text regexT = do+ regex <- Regex.compile Regex.defaultCompOpt Regex.defaultExecOpt regexT+ result <- Regex.execute regex text+ pure . LBool $ isJust result++-- | Given bindings for variables, reduce an expression to a single+-- datalog value+evaluateExpression :: Limits+ -> Bindings+ -> Expression+ -> Either String Value+evaluateExpression l b = \case+ EValue term -> applyVariable b term+ EUnary op e' -> evalUnary op =<< evaluateExpression l b e'+ EBinary op e' e'' -> uncurry (evalBinary l op) =<< join bitraverse (evaluateExpression l b) (e', e'')
+ src/Auth/Biscuit/Datalog/Parser.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{- HLINT ignore "Reduce duplication" -}+module Auth.Biscuit.Datalog.Parser+ ( block+ , check+ , fact+ , predicate+ , rule+ , verifier+ -- these are only exported for testing purposes+ , checkParser+ , expressionParser+ , policyParser+ , predicateParser+ , ruleParser+ , termParser+ , verifierParser+ , HasParsers+ , HasTermParsers+ ) where++import Control.Applicative (liftA2, optional, (<|>))+import qualified Control.Monad.Combinators.Expr as Expr+import Data.Attoparsec.Text+import Data.ByteString (ByteString)+import Data.ByteString.Base16 as Hex+import Data.Char (isSpace)+import Data.Either (partitionEithers)+import Data.Foldable (fold)+import Data.Functor (void, ($>))+import qualified Data.Set as Set+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (encodeUtf8)+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.Syntax (Lift)++import Auth.Biscuit.Datalog.AST++class ConditionalParse a v where+ ifPresent :: String -> Parser a -> Parser v++instance ConditionalParse a Void where+ ifPresent name _ = fail $ name <> " is not available in this context"++instance ConditionalParse m m where+ ifPresent _ p = p++class SetParser (inSet :: IsWithinSet) (ctx :: ParsedAs) where+ parseSet :: Parser (SetType inSet ctx)++instance SetParser 'WithinSet ctx where+ parseSet = fail "nested sets are forbidden"++instance SetParser 'NotWithinSet 'QuasiQuote where+ parseSet = Set.fromList <$> (char '[' *> commaList0 termParser <* char ']')++instance SetParser 'NotWithinSet 'RegularString where+ parseSet = Set.fromList <$> (char '[' *> commaList0 termParser <* char ']')++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++-- | Parser for an identifier (predicate name, variable name, symbol name, …)+nameParser :: Parser Text+nameParser = takeWhile1 $ inClass "a-zA-Z0-9_"++delimited :: Parser x+ -> Parser y+ -> Parser a+ -> Parser a+delimited before after p = before *> p <* after++parens :: Parser a -> Parser a+parens = delimited (char '(') (skipSpace *> char ')')++commaList :: Parser a -> Parser [a]+commaList p =+ sepBy1 p (skipSpace *> char ',')++commaList0 :: Parser a -> Parser [a]+commaList0 p =+ sepBy p (skipSpace *> char ',')++predicateParser :: HasParsers pof ctx => Parser (Predicate' pof ctx)+predicateParser = do+ skipSpace+ name <- nameParser+ skipSpace+ terms <- parens (commaList termParser)+ pure Predicate{name,terms}++unary :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)+unary = choice+ [ unaryParens+ , unaryNegate+ , unaryLength+ ]++unaryParens :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)+unaryParens = do+ skipSpace+ _ <- char '('+ skipSpace+ e <- expressionParser+ skipSpace+ _ <- char ')'+ pure $ EUnary Parens e++unaryNegate :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)+unaryNegate = do+ skipSpace+ _ <- char '!'+ skipSpace+ EUnary Negate <$> expressionParser++unaryLength :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)+unaryLength = do+ skipSpace+ e <- choice+ [ EValue <$> termParser+ , unaryParens+ ]+ skipSpace+ _ <- string ".length()"+ pure $ EUnary Length e++exprTerm :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)+exprTerm = choice+ [ unary+ , EValue <$> termParser+ ]++methodParser :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)+methodParser = do+ e1 <- exprTerm+ _ <- char '.'+ method <- choice+ [ Contains <$ string "contains"+ , Intersection <$ string "intersection"+ , Union <$ string "union"+ , Prefix <$ string "starts_with"+ , Suffix <$ string "ends_with"+ , Regex <$ string "matches"+ ]+ _ <- char '('+ skipSpace+ e2 <- expressionParser+ skipSpace+ _ <- 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:"+ (digits, "") <- Hex.decode . encodeUtf8 <$> takeWhile1 (inClass "0-9a-fA-F")+ pure digits++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 '"'++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++termParser :: forall inSet pof ctx+ . ( HasTermParsers inSet pof ctx+ )+ => Parser (ID' inSet pof ctx)+termParser = skipSpace *> choice+ [ Antiquote <$> ifPresent "slice" (Slice <$> (string "${" *> many1 letter <* char '}'))+ , Variable <$> ifPresent "var" (char '$' *> nameParser)+ , TermSet <$> parseSet @inSet @ctx+ , Symbol <$> (char '#' *> nameParser)+ , LBytes <$> hexBsParser+ , LDate <$> rfc3339DateParser+ , LInteger <$> signed decimal+ , LString <$> litStringParser+ , LBool <$> choice [ string "true" $> True+ , string "false" $> False+ ]+ ]++-- | same as a predicate, but allows empty+-- | terms list+ruleHeadParser :: HasParsers 'InPredicate ctx => Parser (Predicate' 'InPredicate ctx)+ruleHeadParser = do+ skipSpace+ name <- nameParser+ skipSpace+ terms <- parens (commaList0 termParser)+ pure Predicate{name,terms}++ruleBodyParser :: HasParsers 'InPredicate ctx+ => Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])+ruleBodyParser = do+ let predicateOrExprParser =+ Right <$> expressionParser+ <|> Left <$> predicateParser+ elems <- sepBy1 (skipSpace *> predicateOrExprParser)+ (skipSpace *> char ',')+ pure $ partitionEithers elems++ruleParser :: HasParsers 'InPredicate ctx => Parser (Rule' ctx)+ruleParser = do+ rhead <- ruleHeadParser+ skipSpace+ void $ string "<-"+ (body, expressions) <- ruleBodyParser+ pure Rule{rhead, body, expressions}++queryParser :: HasParsers 'InPredicate ctx => Parser (Query' ctx)+queryParser =+ fmap (uncurry QueryItem) <$> sepBy1 ruleBodyParser (skipSpace *> asciiCI "or" <* satisfy isSpace)++checkParser :: HasParsers 'InPredicate ctx => Parser (Check' ctx)+checkParser = string "check if" *> queryParser++commentParser :: Parser ()+commentParser = do+ skipSpace+ _ <- string "//"+ _ <- skipWhile ((&&) <$> (/= '\r') <*> (/= '\n'))+ void $ choice [ void (char '\n')+ , void (string "\r\n")+ , endOfInput+ ]++blockElementParser :: HasParsers 'InPredicate ctx => Parser (BlockElement' ctx)+blockElementParser = choice+ [ BlockRule <$> ruleParser <* skipSpace <* char ';'+ , BlockFact <$> predicateParser <* skipSpace <* char ';'+ , BlockCheck <$> checkParser <* skipSpace <* char ';'+ , BlockComment <$ commentParser+ ]++verifierElementParser :: HasParsers 'InPredicate ctx => Parser (VerifierElement' ctx)+verifierElementParser = choice+ [ VerifierPolicy <$> policyParser <* skipSpace <* char ';'+ , BlockElement <$> blockElementParser+ ]++verifierParser :: ( HasParsers 'InPredicate ctx+ , HasParsers 'InFact ctx+ , Show (VerifierElement' ctx)+ )+ => Parser (Verifier' ctx)+verifierParser = do+ elems <- many1 (skipSpace *> verifierElementParser)+ pure $ foldMap elementToVerifier elems++blockParser :: ( HasParsers 'InPredicate ctx+ , HasParsers 'InFact ctx+ , Show (BlockElement' ctx)+ )+ => Parser (Block' ctx)+blockParser = do+ elems <- many1 (skipSpace *> blockElementParser)+ pure $ foldMap elementToBlock elems++policyParser :: HasParsers 'InPredicate ctx => Parser (Policy' ctx)+policyParser = do+ policy <- choice+ [ Allow <$ string "allow if"+ , Deny <$ string "deny if"+ ]+ (policy, ) <$> queryParser++compileParser :: Lift a => Parser a -> String -> Q Exp+compileParser p str = case parseOnly p (pack str) of+ Right result -> [| result |]+ Left e -> fail e++-- | Quasiquoter for a rule expression. You can reference haskell variables+-- like this: @${variableName}@.+--+-- You most likely want to directly use 'block' or 'verifier' instead.+rule :: QuasiQuoter+rule = QuasiQuoter+ { quoteExp = compileParser (ruleParser @'QuasiQuote)+ , 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}@.+--+-- You most likely want to directly use 'block' or 'verifier' instead.+predicate :: QuasiQuoter+predicate = QuasiQuoter+ { quoteExp = compileParser (predicateParser @'InPredicate @'QuasiQuote)+ , 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}@.+--+-- You most likely want to directly use 'block' or 'verifier' instead.+fact :: QuasiQuoter+fact = QuasiQuoter+ { quoteExp = compileParser (predicateParser @'InFact @'QuasiQuote)+ , 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}@.+--+-- You most likely want to directly use 'block' or 'verifier' instead.+check :: QuasiQuoter+check = QuasiQuoter+ { quoteExp = compileParser (checkParser @'QuasiQuote)+ , quotePat = error "not supported"+ , quoteType = error "not supported"+ , quoteDec = error "not supported"+ }++-- | Quasiquoter for a block expression. You can reference haskell variables+-- like this: @${variableName}@.+--+-- A typical use of 'block' looks like this:+--+-- > [block|+-- > resource(#authority, ${fileName});+-- > rule($variable) <- fact($value), other_fact($value);+-- > check if operation(#ambient, #read);+-- > |]+block :: QuasiQuoter+block = QuasiQuoter+ { quoteExp = compileParser (blockParser @'QuasiQuote)+ , quotePat = error "not supported"+ , quoteType = error "not supported"+ , quoteDec = error "not supported"+ }++-- | Quasiquoter for a verifier expression. You can reference haskell variables+-- like this: @${variableName}@.+--+-- A typical use of 'block' looks like this:+--+-- > [verifier|+-- > current_time(#ambient, ${now});+-- > allow if resource(#authority, "file1");+-- > deny if true;+-- > |]+verifier :: QuasiQuoter+verifier = QuasiQuoter+ { quoteExp = compileParser (verifierParser @'QuasiQuote)+ , quotePat = error "not supported"+ , quoteType = error "not supported"+ , quoteDec = error "not supported"+ }
+ src/Auth/Biscuit/Example.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Auth.Biscuit.Example where++import Data.ByteString (ByteString)+import Data.Functor (($>))+import Data.Time (getCurrentTime)++import Auth.Biscuit++privateKey' :: PrivateKey+privateKey' = maybe (error "Error parsing private key") id $ parsePrivateKeyHex "todo"++publicKey' :: PublicKey+publicKey' = maybe (error "Error parsing public key") id $ parsePublicKeyHex "todo"++creation :: IO ByteString+creation = do+ let authority = [block|+ // toto+ resource(#authority,"file1");+ |]+ keypair <- fromPrivateKey privateKey'+ biscuit <- mkBiscuit keypair authority+ let block1 = [block|check if current_time(#ambient, $time), $time < 2021-05-08T00:00:00Z;|]+ newBiscuit <- addBlock block1 biscuit+ pure $ serializeB64 newBiscuit++verification :: ByteString -> IO Bool+verification serialized = do+ now <- getCurrentTime+ biscuit <- either (fail . show) pure $ parseB64 serialized+ let verifier' = [verifier|current_time(#ambient, ${now});|]+ result <- verifyBiscuit biscuit verifier' publicKey'+ case result of+ Left e -> print e $> False+ Right _ -> pure True
+ src/Auth/Biscuit/Proto.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-|+ Module : Auth.Biscuit.Proto+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ Haskell data structures mapping the biscuit protobuf definitions+-}++module Auth.Biscuit.Proto+ ( Biscuit (..)+ , Signature (..)+ , Block (..)+ , FactV1 (..)+ , RuleV1 (..)+ , CheckV1 (..)+ , PredicateV1 (..)+ , IDV1 (..)+ , ExpressionV1 (..)+ , IDSet (..)+ , Op (..)+ , OpUnary (..)+ , UnaryKind (..)+ , OpBinary (..)+ , BinaryKind (..)+ , getField+ , putField+ , decodeBlockList+ , decodeBlock+ , encodeBlockList+ , encodeBlock+ ) where++import Data.ByteString (ByteString)+import Data.Int+import Data.ProtocolBuffers+import Data.Serialize+import Data.Text+import GHC.Generics (Generic)++data Biscuit = Biscuit+ { authority :: Required 1 (Value ByteString)+ , blocks :: Repeated 2 (Value ByteString)+ , keys :: Repeated 3 (Value ByteString)+ , signature :: Required 4 (Message Signature)+ } deriving (Generic, Show)+ deriving anyclass (Decode, Encode)++data CBiscuit = CBiscuit+ { cAuthority :: Required 1 (Message Block)+ , cBlocks :: Repeated 2 (Message Block)+ , cKeys :: Repeated 3 (Value ByteString)+ , cSignature :: Required 4 (Message Signature)+ } deriving (Generic, Show)+ deriving anyclass (Decode, Encode)++data SealedBiscuit = SealedBiscuit+ { sAuthority :: Required 1 (Value ByteString)+ , sBlocks :: Repeated 2 (Value ByteString)+ , sSignature :: Required 3 (Value ByteString)+ } deriving (Generic, Show)+ deriving anyclass (Decode, Encode)++data Signature = Signature+ { parameters :: Repeated 1 (Value ByteString)+ , z :: Required 2 (Value ByteString)+ } deriving (Generic, Show)+ deriving anyclass (Decode, Encode)++data Block = Block {+ index :: Required 1 (Value Int32)+ , symbols :: Repeated 2 (Value Text)+ -- , facts_v0 :: Repeated 3 (Message FactV0)+ -- , rules_v0 :: Repeated 4 (Message RuleV0)+ -- , caveats_v0 :: Repeated 5 (Message CaveatV0)+ , context :: Optional 6 (Value Text)+ , version :: Optional 7 (Value Int32)+ , facts_v1 :: Repeated 8 (Message FactV1)+ , rules_v1 :: Repeated 9 (Message RuleV1)+ , checks_v1 :: Repeated 10 (Message CheckV1)+ } deriving (Generic, Show)+ deriving anyclass (Decode, Encode)++newtype FactV1 = FactV1+ { predicate :: Required 1 (Message PredicateV1)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data RuleV1 = RuleV1+ { head :: Required 1 (Message PredicateV1)+ , body :: Repeated 2 (Message PredicateV1)+ , expressions :: Repeated 3 (Message ExpressionV1)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++newtype CheckV1 = CheckV1+ { queries :: Repeated 1 (Message RuleV1)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data PredicateV1 = PredicateV1+ { name :: Required 1 (Value Int64)+ , ids :: Repeated 2 (Message IDV1)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data IDV1 =+ IDSymbol (Required 1 (Value Int64))+ | IDVariable (Required 2 (Value Int32))+ | IDInteger (Required 3 (Value Int64))+ | IDString (Required 4 (Value Text))+ | IDDate (Required 5 (Value Int64))+ | IDBytes (Required 6 (Value ByteString))+ | IDBool (Required 7 (Value Bool))+ | IDIDSet (Required 8 (Message IDSet))+ deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)+++newtype IDSet = IDSet+ { set :: Repeated 1 (Message IDV1)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++type CV1Id = Required 1 (Value Int32)+data ConstraintV1 =+ CV1Int CV1Id (Required 2 (Message IntConstraintV1))+ | CV1String CV1Id (Required 3 (Message StringConstraintV1))+ | CV1Date CV1Id (Required 4 (Message DateConstraintV1))+ | CV1Symbol CV1Id (Required 5 (Message SymbolConstraintV1))+ | CV1Bytes CV1Id (Required 6 (Message BytesConstraintV1))+ deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data IntConstraintV1 =+ ICV1LessThan (Required 1 (Value Int64))+ | ICV1GreaterThan (Required 2 (Value Int64))+ | ICV1LessOrEqual (Required 3 (Value Int64))+ | ICV1GreaterOrEqual (Required 4 (Value Int64))+ | ICV1Equal (Required 5 (Value Int64))+ | ICV1InSet (Required 6 (Message IntSet))+ | ICV1NotInSet (Required 7 (Message IntSet))+ 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 StringConstraintV1 =+ SCV1Prefix (Required 1 (Value Text))+ | SCV1Suffix (Required 2 (Value Text))+ | SCV1Equal (Required 3 (Value Text))+ | SCV1InSet (Required 4 (Message StringSet))+ | SCV1NotInSet (Required 5 (Message StringSet))+ | SCV1Regex (Required 6 (Value Text))+ 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 DateConstraintV1 =+ DCV1Before (Required 1 (Value Int64))+ | DCV1After (Required 2 (Value Int64))+ deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data SymbolConstraintV1 =+ SyCV1InSet (Required 1 (Message SymbolSet))+ | SyCV1NotInSet (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 BytesConstraintV1 =+ BCV1Equal (Required 1 (Value ByteString))+ | BCV1InSet (Required 2 (Message BytesSet))+ | BCV1NotInSet (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 ExpressionV1 = ExpressionV1+ { ops :: Repeated 1 (Message Op)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data Op =+ OpVValue (Required 1 (Message IDV1))+ | OpVUnary (Required 2 (Message OpUnary))+ | OpVBinary (Required 3 (Message OpBinary))+ deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data UnaryKind = Negate | Parens | Length+ deriving stock (Show, Enum, Bounded)++newtype OpUnary = OpUnary+ { kind :: Required 1 (Enumeration UnaryKind)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data BinaryKind =+ LessThan+ | GreaterThan+ | LessOrEqual+ | GreaterOrEqual+ | Equal+ | Contains+ | Prefix+ | Suffix+ | Regex+ | Add+ | Sub+ | Mul+ | Div+ | And+ | Or+ | Intersection+ | Union+ deriving stock (Show, Enum, Bounded)++newtype OpBinary = OpBinary+ { kind :: Required 1 (Enumeration BinaryKind)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data PolicyKind = Allow | Deny+ deriving stock (Show, Enum, Bounded)++data Policy = Policy+ { queries :: Repeated 1 (Message RuleV1)+ , kind :: Required 2 (Enumeration PolicyKind)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++data VerifierPolicies = VerifierPolicies+ { symbols :: Repeated 1 (Value Text)+ , version :: Optional 2 (Value Int32)+ , facts :: Repeated 3 (Message FactV1)+ , rules :: Repeated 4 (Message RuleV1)+ , checks :: Repeated 5 (Message CheckV1)+ , policies :: Repeated 6 (Message Policy)+ } deriving stock (Generic, Show)+ deriving anyclass (Decode, Encode)++decodeBlockList :: ByteString+ -> Either String Biscuit+decodeBlockList = runGet decodeMessage++decodeBlock :: ByteString+ -> Either String Block+decodeBlock = runGet decodeMessage++encodeBlockList :: Biscuit -> ByteString+encodeBlockList = runPut . encodeMessage++encodeBlock :: Block -> ByteString+encodeBlock = runPut . encodeMessage
+ src/Auth/Biscuit/ProtoBufAdapter.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-|+ Module : Auth.Biscuit.Utils+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ Conversion functions between biscuit components and protobuf-encoded components+-}+module Auth.Biscuit.ProtoBufAdapter+ ( Symbols+ , extractSymbols+ , commonSymbols+ , buildSymbolTable+ , pbToBlock+ , blockToPb+ ) where++import Control.Monad (when)+import Data.Int (Int32, Int64)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds)+import Data.Void (absurd)++import Auth.Biscuit.Datalog.AST+import qualified Auth.Biscuit.Proto as PB+import Auth.Biscuit.Utils (maybeToRight)++-- | A map to get symbol names from symbol ids+type Symbols = Map Int32 Text+-- | A map to get symbol ids from symbol names+type ReverseSymbols = Map Text Int32++-- | The common symbols defined in the biscuit spec+commonSymbols :: Symbols+commonSymbols = Map.fromList $ zip [0..]+ [ "authority"+ , "ambient"+ , "resource"+ , "operation"+ , "right"+ , "time"+ , "revocation_id"+ ]++-- | Given existing symbols and a series of protobuf blocks,+-- compute the complete symbol mapping+extractSymbols :: Symbols -> [PB.Block] -> Symbols+extractSymbols existingSymbols blocks =+ let blocksSymbols = PB.getField . PB.symbols =<< blocks+ startingIndex = fromIntegral $ length existingSymbols+ in existingSymbols <> Map.fromList (zip [startingIndex..] blocksSymbols)++-- | Given existing symbols and a biscuit block, compute the+-- symbol table for the given block. Already existing symbols+-- won't be included+buildSymbolTable :: Symbols -> Block -> Symbols+buildSymbolTable existingSymbols block =+ let allSymbols = listSymbolsInBlock block+ newSymbols = Set.difference allSymbols (Set.fromList $ Map.elems existingSymbols)+ newSymbolsWithIndices = zip (fromIntegral <$> [length existingSymbols..]) (Set.toList newSymbols)+ in Map.fromList newSymbolsWithIndices++reverseSymbols :: Symbols -> ReverseSymbols+reverseSymbols =+ let swap (a,b) = (b,a)+ in Map.fromList . fmap swap . Map.toList++getSymbolCode :: Integral i => ReverseSymbols -> Text -> i+getSymbolCode = (fromIntegral .) . (Map.!)++-- | Parse a protobuf block into a proper biscuit block+pbToBlock :: Symbols -> PB.Block -> Either String Block+pbToBlock s PB.Block{..} = do+ let bContext = PB.getField context+ bVersion = PB.getField version+ bFacts <- traverse (pbToFact s) $ PB.getField facts_v1+ bRules <- traverse (pbToRule s) $ PB.getField rules_v1+ bChecks <- traverse (pbToCheck s) $ PB.getField checks_v1+ when (bVersion /= Just 1) $ Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only version 1 is supported"+ pure Block{ .. }++-- | Turn a biscuit block into a protobuf block, for serialization,+-- along with the newly defined symbols+blockToPb :: Symbols -> Int -> Block -> (Symbols, PB.Block)+blockToPb existingSymbols bIndex b@Block{..} =+ let+ bSymbols = buildSymbolTable existingSymbols b+ s = reverseSymbols $ existingSymbols <> bSymbols+ index = PB.putField $ fromIntegral bIndex+ symbols = PB.putField $ Map.elems bSymbols+ context = PB.putField bContext+ version = PB.putField $ Just 1+ facts_v1 = PB.putField $ factToPb s <$> bFacts+ rules_v1 = PB.putField $ ruleToPb s <$> bRules+ checks_v1 = PB.putField $ checkToPb s <$> bChecks+ in (bSymbols, PB.Block {..})++pbToFact :: Symbols -> PB.FactV1 -> Either String Fact+pbToFact s PB.FactV1{predicate} = do+ let pbName = PB.getField $ PB.name $ PB.getField predicate+ pbIds = PB.getField $ PB.ids $ PB.getField predicate+ name <- getSymbol s pbName+ terms <- traverse (pbToValue s) pbIds+ pure Predicate{..}++factToPb :: ReverseSymbols -> Fact -> PB.FactV1+factToPb s Predicate{..} =+ let+ predicate = PB.PredicateV1+ { name = PB.putField $ getSymbolCode s name+ , ids = PB.putField $ valueToPb s <$> terms+ }+ in PB.FactV1{predicate = PB.putField predicate}++pbToRule :: Symbols -> PB.RuleV1 -> Either String Rule+pbToRule s pbRule = do+ let pbHead = PB.getField $ PB.head pbRule+ pbBody = PB.getField $ PB.body pbRule+ pbExpressions = PB.getField $ PB.expressions pbRule+ rhead <- pbToPredicate s pbHead+ body <- traverse (pbToPredicate s) pbBody+ expressions <- traverse (pbToExpression s) pbExpressions+ pure Rule {..}++ruleToPb :: ReverseSymbols -> Rule -> PB.RuleV1+ruleToPb s Rule{..} =+ PB.RuleV1+ { head = PB.putField $ predicateToPb s rhead+ , body = PB.putField $ predicateToPb s <$> body+ , expressions = PB.putField $ expressionToPb s <$> expressions+ }++pbToCheck :: Symbols -> PB.CheckV1 -> Either String Check+pbToCheck s PB.CheckV1{queries} = do+ let toCheck Rule{body,expressions} = QueryItem{qBody = body, qExpressions = expressions }+ rules <- traverse (pbToRule s) $ PB.getField queries+ pure $ toCheck <$> rules++checkToPb :: ReverseSymbols -> Check -> PB.CheckV1+checkToPb s items =+ let dummyHead = Predicate "query" []+ toQuery QueryItem{..} =+ ruleToPb s $ Rule dummyHead qBody qExpressions+ in PB.CheckV1 { queries = PB.putField $ toQuery <$> items }++getSymbol :: (Show i, Integral i) => Symbols -> i -> Either String Text+getSymbol s i = maybeToRight ("Missing symbol at id " <> show i) $ Map.lookup (fromIntegral i) s++pbToPredicate :: Symbols -> PB.PredicateV1 -> Either String (Predicate' 'InPredicate 'RegularString)+pbToPredicate s pbPredicate = do+ let pbName = PB.getField $ PB.name pbPredicate+ pbIds = PB.getField $ PB.ids pbPredicate+ name <- getSymbol s pbName+ terms <- traverse (pbToTerm s) pbIds+ pure Predicate{..}++predicateToPb :: ReverseSymbols -> Predicate -> PB.PredicateV1+predicateToPb s Predicate{..} =+ PB.PredicateV1+ { name = PB.putField $ getSymbolCode s name+ , ids = PB.putField $ termToPb s <$> terms+ }++pbTimeToUtcTime :: Int64 -> UTCTime+pbTimeToUtcTime = posixSecondsToUTCTime . fromIntegral++pbToTerm :: Symbols -> PB.IDV1 -> Either String ID+pbToTerm s = \case+ PB.IDSymbol f -> Symbol <$> getSymbol s (PB.getField f)+ PB.IDInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f+ PB.IDString f -> pure $ LString $ PB.getField f+ PB.IDDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f+ PB.IDBytes f -> pure $ LBytes $ PB.getField f+ PB.IDBool f -> pure $ LBool $ PB.getField f+ PB.IDVariable f -> Variable <$> getSymbol s (PB.getField f)+ PB.IDIDSet f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f)++termToPb :: ReverseSymbols -> ID -> PB.IDV1+termToPb s = \case+ Variable n -> PB.IDVariable $ PB.putField $ getSymbolCode s n+ Symbol n -> PB.IDSymbol $ PB.putField $ getSymbolCode s n+ LInteger v -> PB.IDInteger $ PB.putField $ fromIntegral v+ LString v -> PB.IDString $ PB.putField v+ LDate v -> PB.IDDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v+ LBytes v -> PB.IDBytes $ PB.putField v+ LBool v -> PB.IDBool $ PB.putField v+ TermSet vs -> PB.IDIDSet $ PB.putField $ PB.IDSet $ PB.putField $ setValueToPb s <$> Set.toList vs++ Antiquote v -> absurd v++pbToValue :: Symbols -> PB.IDV1 -> Either String Value+pbToValue s = \case+ PB.IDSymbol f -> Symbol <$> getSymbol s (PB.getField f)+ PB.IDInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f+ PB.IDString f -> pure $ LString $ PB.getField f+ PB.IDDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f+ PB.IDBytes f -> pure $ LBytes $ PB.getField f+ PB.IDBool f -> pure $ LBool $ PB.getField f+ PB.IDVariable _ -> Left "Variables can't appear in facts"+ PB.IDIDSet f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f)++valueToPb :: ReverseSymbols -> Value -> PB.IDV1+valueToPb s = \case+ Symbol n -> PB.IDSymbol $ PB.putField $ getSymbolCode s n+ LInteger v -> PB.IDInteger $ PB.putField $ fromIntegral v+ LString v -> PB.IDString $ PB.putField v+ LDate v -> PB.IDDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v+ LBytes v -> PB.IDBytes $ PB.putField v+ LBool v -> PB.IDBool $ PB.putField v+ TermSet vs -> PB.IDIDSet $ PB.putField $ PB.IDSet $ PB.putField $ setValueToPb s <$> Set.toList vs++ Variable v -> absurd v+ Antiquote v -> absurd v++pbToSetValue :: Symbols -> PB.IDV1 -> Either String (ID' 'WithinSet 'InFact 'RegularString)+pbToSetValue s = \case+ PB.IDSymbol f -> Symbol <$> getSymbol s (PB.getField f)+ PB.IDInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f+ PB.IDString f -> pure $ LString $ PB.getField f+ PB.IDDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f+ PB.IDBytes f -> pure $ LBytes $ PB.getField f+ PB.IDBool f -> pure $ LBool $ PB.getField f+ PB.IDVariable _ -> Left "Variables can't appear in facts or sets"+ PB.IDIDSet _ -> Left "Sets can't be nested"++setValueToPb :: ReverseSymbols -> ID' 'WithinSet 'InFact 'RegularString -> PB.IDV1+setValueToPb s = \case+ Symbol n -> PB.IDSymbol $ PB.putField $ getSymbolCode s n+ LInteger v -> PB.IDInteger $ PB.putField $ fromIntegral v+ LString v -> PB.IDString $ PB.putField v+ LDate v -> PB.IDDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v+ LBytes v -> PB.IDBytes $ PB.putField v+ LBool v -> PB.IDBool $ PB.putField v++ TermSet v -> absurd v+ Variable v -> absurd v+ Antiquote v -> absurd v++pbToExpression :: Symbols -> PB.ExpressionV1 -> Either String Expression+pbToExpression s PB.ExpressionV1{ops} = do+ parsedOps <- traverse (pbToOp s) $ PB.getField ops+ fromStack parsedOps++expressionToPb :: ReverseSymbols -> Expression -> PB.ExpressionV1+expressionToPb s e =+ let ops = opToPb s <$> toStack e+ in PB.ExpressionV1 { ops = PB.putField ops }++pbToOp :: Symbols -> PB.Op -> Either String Op+pbToOp s = \case+ PB.OpVValue v -> VOp <$> pbToTerm s (PB.getField v)+ PB.OpVUnary v -> pure . UOp . pbToUnary $ PB.getField v+ PB.OpVBinary v -> pure . BOp . pbToBinary $ PB.getField v++opToPb :: ReverseSymbols -> Op -> PB.Op+opToPb s = \case+ VOp t -> PB.OpVValue $ PB.putField $ termToPb s t+ UOp o -> PB.OpVUnary $ PB.putField $ unaryToPb o+ BOp o -> PB.OpVBinary $ PB.putField $ binaryToPb o++pbToUnary :: PB.OpUnary -> Unary+pbToUnary PB.OpUnary{kind} = case PB.getField kind of+ PB.Negate -> Negate+ PB.Parens -> Parens+ PB.Length -> Length++unaryToPb :: Unary -> PB.OpUnary+unaryToPb = PB.OpUnary . PB.putField . \case+ Negate -> PB.Negate+ Parens -> PB.Parens+ Length -> PB.Length++pbToBinary :: PB.OpBinary -> Binary+pbToBinary PB.OpBinary{kind} = case PB.getField kind of+ PB.LessThan -> LessThan+ PB.GreaterThan -> GreaterThan+ PB.LessOrEqual -> LessOrEqual+ PB.GreaterOrEqual -> GreaterOrEqual+ PB.Equal -> Equal+ PB.Contains -> Contains+ PB.Prefix -> Prefix+ PB.Suffix -> Suffix+ PB.Regex -> Regex+ PB.Add -> Add+ PB.Sub -> Sub+ PB.Mul -> Mul+ PB.Div -> Div+ PB.And -> And+ PB.Or -> Or+ PB.Intersection -> Intersection+ PB.Union -> Union++binaryToPb :: Binary -> PB.OpBinary+binaryToPb = PB.OpBinary . PB.putField . \case+ LessThan -> PB.LessThan+ GreaterThan -> PB.GreaterThan+ LessOrEqual -> PB.LessOrEqual+ GreaterOrEqual -> PB.GreaterOrEqual+ Equal -> PB.Equal+ Contains -> PB.Contains+ Prefix -> PB.Prefix+ Suffix -> PB.Suffix+ Regex -> PB.Regex+ Add -> PB.Add+ Sub -> PB.Sub+ Mul -> PB.Mul+ Div -> PB.Div+ And -> PB.And+ Or -> PB.Or+ Intersection -> PB.Intersection+ Union -> PB.Union
+ src/Auth/Biscuit/Sel.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{- HLINT ignore "Reduce duplication" -}+{-|+ Module : Auth.Biscuit.Sel+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ Cryptographic primitives necessary to sign and verify biscuit tokens+-}+module Auth.Biscuit.Sel+ ( Keypair (..)+ , PrivateKey+ , PublicKey+ , Signature (..)+ , parsePrivateKey+ , parsePublicKey+ , serializePrivateKey+ , serializePublicKey+ , newKeypair+ , fromPrivateKey+ , signBlock+ , aggregate+ , verifySignature+ , hashBytes+ ) where++import Control.Monad.Cont (ContT (..), runContT)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString, packCStringLen,+ useAsCStringLen)+import qualified Data.ByteString as BS+import Data.ByteString.Base16 as Hex+import Data.Foldable (for_)+import Data.Functor (void)+import Data.List.NonEmpty (NonEmpty)+import Data.Primitive.Ptr (copyPtr)+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Libsodium++-- | A private key used to generate a biscuit+newtype PrivateKey = PrivateKey ByteString+ deriving newtype (Eq, Ord)++instance Show PrivateKey where+ show (PrivateKey bs) = show $ Hex.encode bs++-- | Parse a private key from raw bytes.+-- This returns `Nothing` if the raw bytes don't have the expected length+parsePrivateKey :: ByteString -> Maybe PrivateKey+parsePrivateKey bs = if BS.length bs == cs2int crypto_core_ristretto255_scalarbytes+ then Just (PrivateKey bs)+ else Nothing++-- | Serialize a private key to raw bytes+serializePrivateKey :: PrivateKey -> ByteString+serializePrivateKey (PrivateKey bs) = bs++-- | A public key used to generate a biscuit+newtype PublicKey = PublicKey ByteString+ deriving newtype (Eq, Ord)++-- | Parse a public key from raw bytes.+-- This returns `Nothing` if the raw bytes don't have the expected length+parsePublicKey :: ByteString -> Maybe PublicKey+parsePublicKey bs = if BS.length bs == cs2int crypto_core_ristretto255_bytes+ then Just (PublicKey bs)+ else Nothing++-- | Serialize a public key to raw bytes+serializePublicKey :: PublicKey -> ByteString+serializePublicKey (PublicKey bs) = bs++instance Show PublicKey where+ show (PublicKey bs) = show $ Hex.encode bs++-- | A keypair containing both a private key and a public key+data Keypair+ = Keypair+ { privateKey :: PrivateKey+ -- ^ the private key+ , publicKey :: PublicKey+ -- ^ the public key+ } deriving (Eq, Ord)++instance Show Keypair where+ show Keypair{privateKey, publicKey} =+ show privateKey <> "/" <> show publicKey++keypairFromScalar :: Scalar -> CIO a Keypair+keypairFromScalar scalarBuf = do+ pointBuf <- scalarToPoint scalarBuf+ privateKey <- PrivateKey <$> scalarToByteString scalarBuf+ publicKey <- PublicKey <$> pointToByteString pointBuf+ pure Keypair{..}++-- | Generate a random keypair+newKeypair :: IO Keypair+newKeypair = runCIO $ do+ scalar <- randomScalar+ keypairFromScalar scalar++-- | Construct a keypair from a private key+fromPrivateKey :: PrivateKey -> IO Keypair+fromPrivateKey (PrivateKey privBs) = runCIO $ do+ (privBuf, _) <- withBSLen privBs+ keypairFromScalar privBuf++-- | The signature of a series of blocks (raw bytestrings)+data Signature+ = Signature+ { parameters :: [ByteString]+ -- ^ the list of parameters used to sign each block+ , z :: ByteString+ -- ^ the aggregated signature+ } deriving (Eq, Show)++type Scalar = Ptr CUChar+type Point = Ptr CUChar++-- | Pointer allocations are written in a continuation passing style,+-- this type alias allows to use monadic notation instead of nesting+-- callbacks+type CIO a = ContT a IO++-- | Run a continuation to get back an IO value.+runCIO :: ContT a IO a -> IO a+runCIO = (`runContT` pure)++voidIO :: IO a -> CIO b ()+voidIO = void . liftIO++scalarToByteString :: MonadIO m => Ptr CUChar -> m ByteString+scalarToByteString ptr =+ let scalarIntSize = cs2int crypto_core_ristretto255_scalarbytes+ in liftIO $ packCStringLen (castPtr ptr, scalarIntSize)++pointToByteString :: MonadIO m => Ptr CUChar -> m ByteString+pointToByteString ptr =+ let pointIntSize = cs2int crypto_core_ristretto255_bytes+ in liftIO $ packCStringLen (castPtr ptr, pointIntSize)++randomScalar :: CIO a Scalar+randomScalar = do+ scalarBuf <- withScalar+ liftIO $ crypto_core_ristretto255_scalar_random scalarBuf+ pure scalarBuf++withScalar :: CIO a Scalar+withScalar =+ let intScalarSize = cs2int crypto_core_ristretto255_scalarbytes+ in ContT $ allocaBytes intScalarSize++withPoint :: CIO a Point+withPoint =+ let intPointSize = cs2int crypto_core_ristretto255_bytes+ in ContT $ allocaBytes intPointSize++scalarToPoint :: Scalar+ -> CIO a Point+scalarToPoint scalar = do+ pointBuf <- withPoint+ voidIO $ crypto_scalarmult_ristretto255_base pointBuf scalar+ pure pointBuf++withBSLen :: ByteString+ -> ContT a IO (Ptr CUChar, CULLong)+withBSLen bs = do+ (buf, int) <- ContT $ useAsCStringLen bs+ pure (castPtr buf, toEnum int)++scalarAdd :: Scalar -> Scalar -> CIO a Scalar+scalarAdd x y = do+ z <- withScalar+ liftIO $ crypto_core_ristretto255_scalar_add z x y+ pure z++scalarAddBs :: ByteString -> ByteString -> CIO a ByteString+scalarAddBs xBs yBs = do+ (x, _) <- withBSLen xBs+ (y, _) <- withBSLen yBs+ z <- scalarAdd x y+ scalarToByteString z++scalarMul :: Scalar -> Scalar -> CIO a Scalar+scalarMul x y = do+ z <- withScalar+ z <$ liftIO (crypto_core_ristretto255_scalar_mul z x y)++scalarSub :: Scalar -> Scalar -> CIO a Scalar+scalarSub x y = do+ z <- withScalar+ z <$ liftIO (crypto_core_ristretto255_scalar_sub z x y)++scalarReduce :: Ptr CUChar -> CIO a Scalar+scalarReduce bytes = do+ z <- withScalar+ z <$ liftIO (crypto_core_ristretto255_scalar_reduce z bytes)++scalarMulPoint :: Scalar -> Point -> CIO a Point+scalarMulPoint p q = do+ n <- withScalar+ n <$ liftIO (crypto_scalarmult_ristretto255 n p q)++pointAdd :: Point -> Point -> CIO a Point+pointAdd p q = do+ r <- withPoint+ r <$ liftIO (crypto_core_ristretto255_add r p q)++pointSub :: Point -> Point -> CIO a Point+pointSub p q = do+ r <- withPoint+ r <$ liftIO (crypto_core_ristretto255_sub r p q)++zeroPoint :: CIO a Point+zeroPoint = do+ p <- withPoint+ p <$ zeroizePoint p++zeroizePoint :: MonadIO m => Point -> m ()+zeroizePoint p = liftIO $ sodium_memzero p crypto_core_ristretto255_bytes++isZeroPoint :: MonadIO m => Point -> m Bool+isZeroPoint p = liftIO $+ (== 1) <$> sodium_is_zero p crypto_core_ristretto255_scalarbytes++-- | Hash a bytestring with SHA256+hashBytes :: ByteString+ -> IO ByteString+hashBytes message = runCIO $ do+ out <- ContT $ allocaBytes $ cs2int crypto_hash_sha256_bytes+ (buf, len) <- withBSLen message+ voidIO $ crypto_hash_sha256 out buf len+ liftIO $ packCStringLen (castPtr out, cs2int crypto_hash_sha256_bytes)++hashPoint :: Point+ -> ContT a IO Scalar+hashPoint point = do+ hash <- ContT $ allocaBytes (cs2int crypto_hash_sha512_bytes)+ voidIO $ crypto_hash_sha512 hash point (fromInteger $ toInteger crypto_core_ristretto255_bytes)+ scalarReduce hash++copyPointFrom :: Point -> Point -> IO ()+copyPointFrom to from = copyPtr to from (cs2int crypto_core_ristretto255_bytes)++hashMessage :: ByteString+ -> ByteString+ -> CIO a Scalar+hashMessage publicKey message = do+ (kpBuf, kpLen) <- withBSLen publicKey+ (msgBuf, msgLen) <- withBSLen message+ state <- liftIO crypto_hash_sha512_state'malloc+ statePtr <- ContT $ crypto_hash_sha512_state'ptr state+ voidIO $ crypto_hash_sha512_init statePtr+ voidIO $ crypto_hash_sha512_update statePtr kpBuf kpLen+ voidIO $ crypto_hash_sha512_update statePtr msgBuf msgLen+ hash <- ContT $ allocaBytes (cs2int crypto_hash_sha512_bytes)+ voidIO $ crypto_hash_sha512_final statePtr hash+ scalar <- withScalar+ voidIO $ crypto_core_ristretto255_scalar_reduce scalar hash+ pure scalar++-- | Sign a single block with the given keypair+signBlock :: Keypair -> ByteString -> IO Signature+signBlock Keypair{publicKey,privateKey} message = do+ let PublicKey pubBs = publicKey+ PrivateKey prvBs = privateKey+ (`runContT` pure) $ do+ (pk, _) <- withBSLen prvBs++ r <- randomScalar+ aa <- scalarToPoint r+ d <- hashPoint aa+ e <- hashMessage pubBs message+ rd <- scalarMul r d+ epk <- scalarMul e pk+ z <- scalarSub rd epk+ aaBs <- pointToByteString aa+ zBs <- scalarToByteString z+ pure Signature { parameters = [aaBs]+ , z = zBs+ }++-- | Aggregate two signatures into a single one+aggregate :: Signature -> Signature -> IO Signature+aggregate first second = runCIO $ do+ z <- scalarAddBs (z first) (z second)+ pure Signature+ { parameters = parameters first <> parameters second+ , z+ }++-- | Verify a signature, given a list of messages and associated+-- public keys+verifySignature :: NonEmpty (PublicKey, ByteString)+ -> Signature+ -> IO Bool+verifySignature messagesAndPks Signature{parameters,z} = runCIO $ do+ zP <- scalarToPoint . fst =<< withBSLen z+ eiXiRes <- computeHashMSums messagesAndPks+ diAiRes <- computeHashPSums parameters+ resTmp <- pointAdd zP eiXiRes+ res <- pointSub resTmp diAiRes+ isZeroPoint res++computeHashMSums :: NonEmpty (PublicKey, ByteString)+ -> ContT a IO Point+computeHashMSums messagesAndPks = do+ eiXiRes <- zeroPoint+ for_ messagesAndPks $ \(PublicKey publicKey, message) -> do+ ei <- hashMessage publicKey message+ eiXi <- scalarMulPoint ei . fst =<< withBSLen publicKey+ eiXiResTmp <- pointAdd eiXiRes eiXi+ liftIO $ copyPointFrom eiXiRes eiXiResTmp+ pure eiXiRes++computeHashPSums :: [ByteString] -- parameters+ -> ContT a IO Point+computeHashPSums parameters = do+ diAiRes <- zeroPoint+ for_ parameters $ \aa -> do+ (aaBuf, _) <- withBSLen aa+ di <- hashPoint aaBuf+ diAi <- scalarMulPoint di aaBuf+ diAiResTmp <- pointAdd diAiRes diAi+ liftIO $ copyPointFrom diAiRes diAiResTmp+ pure diAiRes++cs2int :: CSize -> Int+cs2int = fromInteger . toInteger
+ src/Auth/Biscuit/Timer.hs view
@@ -0,0 +1,27 @@+{-|+ Module : Auth.Biscuit.Timer+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ Helper function making sure an IO action runs in an alloted time+-}+module Auth.Biscuit.Timer+ ( timer+ ) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race)++-- | Given a maximum execution time, run the provide action, and+-- fail (by returning `Nothing`) if it takes too much time.+-- Else, the action result is returned in a `Just`+timer :: Int+ -> IO a+ -> IO (Maybe a)+timer timeout job = do+ let watchDog = threadDelay timeout+ result <- race watchDog job+ pure $ case result of+ Left _ -> Nothing+ Right a -> Just a+
+ src/Auth/Biscuit/Token.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-|+ Module : Auth.Biscuit.Token+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+ Module defining the main biscuit-related operations+-}+module Auth.Biscuit.Token+ ( Biscuit (..)+ , ParseError (..)+ , VerificationError (..)+ , ExistingBlock+ , mkBiscuit+ , addBlock+ , checkBiscuitSignature+ , parseBiscuit+ , serializeBiscuit+ , verifyBiscuit+ , verifyBiscuitWithLimits++ , BlockWithRevocationIds (..)+ , getRevocationIds+ ) where++import Control.Monad (when)+import Control.Monad.Except (runExceptT, throwError)+import Control.Monad.IO.Class (liftIO)+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE++import Auth.Biscuit.Datalog.AST (Block, Query, Verifier)+import Auth.Biscuit.Datalog.Executor (BlockWithRevocationIds (..),+ ExecutionError, Limits,+ defaultLimits,+ runVerifierWithLimits)+import qualified Auth.Biscuit.Proto as PB+import Auth.Biscuit.ProtoBufAdapter (Symbols, blockToPb,+ commonSymbols, extractSymbols,+ pbToBlock)+import Auth.Biscuit.Sel (Keypair (publicKey), PublicKey,+ Signature (..), aggregate,+ hashBytes, newKeypair,+ parsePublicKey,+ serializePublicKey, signBlock,+ verifySignature)+import Auth.Biscuit.Utils (maybeToRight)++-- | 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)++-- | A parsed biscuit+data Biscuit+ = Biscuit+ { symbols :: Symbols+ -- ^ The symbols already defined in the contained blocks+ , authority :: (PublicKey, ExistingBlock)+ -- ^ The authority block, along with the associated public key. The public key+ -- is kept around since it's embedded in the serialized biscuit, but should not+ -- be used for verification. An externally provided public key should be used instead.+ , blocks :: [(PublicKey, ExistingBlock)]+ -- ^ The extra blocks, along with the public keys needed+ , signature :: Signature+ }+ deriving (Eq, Show)++-- | Create a new biscuit with the provided authority block+mkBiscuit :: Keypair -> Block -> IO Biscuit+mkBiscuit keypair authority = do+ let authorityPub = publicKey keypair+ (s, authoritySerialized) = PB.encodeBlock <$> blockToPb commonSymbols 0 authority+ signature <- signBlock keypair authoritySerialized+ pure $ Biscuit { authority = (authorityPub, (authoritySerialized, authority))+ , blocks = []+ , symbols = commonSymbols <> s+ , signature+ }++-- | Add a block to an existing biscuit. The block will be signed+-- with a randomly-generated keypair+addBlock :: Block -> Biscuit -> IO Biscuit+addBlock newBlock b@Biscuit{..} = do+ let (s, newBlockSerialized) = PB.encodeBlock <$> blockToPb symbols (length blocks) newBlock+ keypair <- newKeypair+ newSig <- signBlock keypair newBlockSerialized+ endSig <- aggregate signature newSig+ pure $ b { blocks = blocks <> [(publicKey keypair, (newBlockSerialized, newBlock))]+ , symbols = symbols <> s+ , signature = endSig+ }++-- | Only check a biscuit signature. This can be used to perform an early check, before+-- bothering with constructing a verifier.+checkBiscuitSignature :: Biscuit -> PublicKey -> IO Bool+checkBiscuitSignature Biscuit{..} publicKey =+ let publicKeysAndMessages = (publicKey, fst $ snd authority) :| (fmap fst <$> blocks)+ in verifySignature publicKeysAndMessages signature++-- | Errors that can happen when parsing a biscuit+data ParseError+ = InvalidHexEncoding+ -- ^ The provided ByteString is not hex-encoded+ | InvalidB64Encoding+ -- ^ The provided ByteString is not base64-encoded+ | InvalidProtobufSer String+ -- ^ The provided ByteString does not contain properly serialized protobuf values+ | InvalidProtobuf String+ -- ^ The bytestring was correctly deserialized from protobuf, but the values can't be turned into a proper biscuit+ deriving (Eq, Show)++-- | Parse a biscuit from a raw bytestring.+parseBiscuit :: ByteString -> Either ParseError Biscuit+parseBiscuit bs = do+ blockList <- first InvalidProtobufSer $ PB.decodeBlockList bs+ let pbBlocks = PB.getField $ PB.blocks blockList+ pbKeys = PB.getField $ PB.keys blockList+ pbAuthority = PB.getField $ PB.authority blockList+ pbSignature = PB.getField $ PB.signature blockList+ when (length pbBlocks + 1 /= length pbKeys) $ Left (InvalidProtobufSer $ "Length mismatch " <> show (length pbBlocks, length pbKeys))+ rawAuthority <- first InvalidProtobufSer $ PB.decodeBlock pbAuthority+ rawBlocks <- traverse (first InvalidProtobufSer . PB.decodeBlock) pbBlocks+ let s = extractSymbols commonSymbols $ rawAuthority : rawBlocks+++ parsedAuthority <- (pbAuthority,) <$> blockFromPB s rawAuthority+ parsedBlocks <- zip pbBlocks <$> traverse (blockFromPB s) rawBlocks+ parsedKeys <- maybeToRight (InvalidProtobufSer "Invalid pubkeys") $ traverse parsePublicKey pbKeys+ let blocks = zip (drop 1 parsedKeys) parsedBlocks+ authority = (head parsedKeys, parsedAuthority)+ symbols = s+ signature = Signature { parameters = PB.getField $ PB.parameters pbSignature+ , z = PB.getField $ PB.z pbSignature+ }+ pure Biscuit{..}++-- | Serialize a biscuit to a raw bytestring+serializeBiscuit :: Biscuit -> ByteString+serializeBiscuit Biscuit{..} =+ let authorityBs = fst $ snd authority+ blocksBs = fst . snd <$> blocks+ keys = serializePublicKey . fst <$> authority : blocks+ Signature{..} = signature+ sigPb = PB.Signature+ { parameters = PB.putField parameters+ , z = PB.putField z+ }+ in PB.encodeBlockList PB.Biscuit+ { authority = PB.putField authorityBs+ , blocks = PB.putField blocksBs+ , keys = PB.putField keys+ , signature = PB.putField sigPb+ }++-- | Parse a single block from a protobuf value+blockFromPB :: Symbols -> PB.Block -> Either ParseError Block+blockFromPB s pbBlock = first InvalidProtobuf $ pbToBlock s pbBlock++-- | An error that can happen when verifying a biscuit+data VerificationError+ = SignatureError+ -- ^ The signature is invalid+ | DatalogError ExecutionError+ -- ^ The checks and policies could not be verified+ deriving (Eq, Show)++-- | Given a provided verifier (a set of facts, rules, checks and policies),+-- and a public key, verify a biscuit:+--+-- - make sure the biscuit has been signed with the private key associated to the public key+-- - make sure the biscuit is valid for the provided verifier+verifyBiscuitWithLimits :: Limits -> Biscuit -> Verifier -> PublicKey -> IO (Either VerificationError Query)+verifyBiscuitWithLimits l b verifier pub = runExceptT $ do+ sigCheck <- liftIO $ checkBiscuitSignature b pub+ when (not sigCheck) $ throwError SignatureError+ authorityBlock :| attBlocks <- liftIO $ getRevocationIds b+ verifResult <- liftIO $ runVerifierWithLimits l authorityBlock attBlocks verifier+ case verifResult of+ Left e -> throwError $ DatalogError e+ Right p -> pure p++-- | Same as `verifyBiscuitWithLimits`, but with default limits (1ms timeout, max 1000 facts, max 100 iterations)+verifyBiscuit :: Biscuit -> Verifier -> PublicKey -> IO (Either VerificationError Query)+verifyBiscuit = verifyBiscuitWithLimits defaultLimits++-- | Get the components needed to compute revocation ids+getRidComponents :: (PublicKey, ExistingBlock) -> ByteString+ -> ((ByteString, ByteString), Block)+getRidComponents (pub, (blockBs, block)) param =+ ( ( blockBs <> serializePublicKey pub+ , blockBs <> serializePublicKey pub <> param+ )+ , block+ )++-- | Given revocation ids components and a block, compute the revocation ids+-- and attach them to the block+mkBRID :: ((ByteString, ByteString), Block) -> IO BlockWithRevocationIds+mkBRID ((g,u), bBlock) = do+ genericRevocationId <- hashBytes g+ uniqueRevocationId <- hashBytes u+ pure BlockWithRevocationIds{..}++-- | Compute the revocation ids for a given biscuit+getRevocationIds :: Biscuit -> IO (NonEmpty BlockWithRevocationIds)+getRevocationIds Biscuit{..} = do+ params <- maybe (fail "") pure . NE.nonEmpty $ parameters signature+ let allBlocks = authority :| blocks+ blocksAndParams = NE.zipWith getRidComponents allBlocks params+ conc ((g1, u1), _) ((g2, u2), b) = ((g1 <> g2, u1 <> u2), b)+ withPreviousBlocks :: NonEmpty ((ByteString, ByteString), Block)+ withPreviousBlocks = NE.scanl1 conc blocksAndParams+ traverse mkBRID withPreviousBlocks
+ src/Auth/Biscuit/Utils.hs view
@@ -0,0 +1,14 @@+{-|+ Module : Auth.Biscuit.Utils+ Copyright : © Clément Delafargue, 2021+ License : MIT+ Maintainer : clement@delafargue.name+-}+module Auth.Biscuit.Utils+ ( maybeToRight+ ) 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
+ test/Spec.hs view
@@ -0,0 +1,24 @@+module Main (main) where++import Test.Tasty++import qualified Spec.Crypto as Crypto+import qualified Spec.Executor as Executor+import qualified Spec.Parser as Parser+import qualified Spec.Quasiquoter as Quasiquoter+import qualified Spec.RevocationIds as RevocationIds+import qualified Spec.Roundtrip as Roundtrip+import qualified Spec.Samples as Samples+import qualified Spec.Verification as Verification++main :: IO ()+main = defaultMain $ testGroup "biscuit-haskell"+ [ Crypto.specs+ , Executor.specs+ , Parser.specs+ , Quasiquoter.specs+ , RevocationIds.specs+ , Roundtrip.specs+ , Samples.specs+ , Verification.specs+ ]
+ test/Spec/Crypto.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{- HLINT ignore "Reduce duplication" -}+module Spec.Crypto (specs) where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit+import qualified Auth.Biscuit.Sel as Sel+import Auth.Biscuit.Token (Biscuit (..))++specs :: TestTree+specs = testGroup "biscuit crypto"+ [ testGroup "signature algorithm"+ [ singleBlockRoundtrip+ , multiBlockRoundtrip+ , tamperedAuthority+ , tamperedBlock+ ]+ , testGroup "high-level functions"+ [ singleBlockRoundtrip'+ , multiBlockRoundtrip'+ , tamperedAuthority'+ , tamperedBlock'+ ]+ ]++singleBlockRoundtrip :: TestTree+singleBlockRoundtrip = testCase "Single block roundtrip" $ do+ rootKp <- newKeypair+ let pub = publicKey rootKp+ content = "content"+ token = (pub, content) :| []+ sig <- Sel.signBlock rootKp content+ result <- Sel.verifySignature token sig+ result @?= True++multiBlockRoundtrip :: TestTree+multiBlockRoundtrip = testCase "Multi block roundtrip" $ do+ kp' <- newKeypair+ kp <- newKeypair+ let pub = publicKey kp+ pub' = publicKey kp'+ content = "content"+ content' = "block"+ token = (pub, content) :| [(pub', content')]+ sig <- Sel.signBlock kp content+ sig' <- Sel.aggregate sig =<< Sel.signBlock kp' content'+ result <- Sel.verifySignature token sig'+ result @?= True++tamperedAuthority :: TestTree+tamperedAuthority = testCase "Tampered authority" $ do+ kp' <- newKeypair+ kp <- newKeypair+ let pub = publicKey kp+ pub' = publicKey kp'+ content = "content"+ content' = "block"+ token = (pub, "modified") :| []+ token' = (pub, "modified") :| [(pub', content')]+ sig <- Sel.signBlock kp content+ sig' <- Sel.aggregate sig =<< Sel.signBlock kp' content'+ result <- Sel.verifySignature token sig'+ result @?= False+ result' <- Sel.verifySignature token' sig'+ result' @?= False++tamperedBlock :: TestTree+tamperedBlock = testCase "Tampered block" $ do+ kp' <- newKeypair+ kp <- newKeypair+ let pub = publicKey kp+ pub' = publicKey kp'+ content = "content"+ content' = "block"+ token = (pub, content) :| [(pub', "modified")]+ sig <- Sel.signBlock kp content+ sig' <- Sel.aggregate sig =<< Sel.signBlock kp' content'+ result <- Sel.verifySignature token sig'+ result @?= False++singleBlockRoundtrip' :: TestTree+singleBlockRoundtrip' = testCase "Single block roundtrip" $ do+ rootKp <- newKeypair+ let pub = publicKey rootKp+ b <- mkBiscuit rootKp [block|right(#authority,#read);|]+ result <- checkBiscuitSignature b pub+ result @?= True++multiBlockRoundtrip' :: TestTree+multiBlockRoundtrip' = testCase "Multi block roundtrip" $ do+ kp <- newKeypair+ let pub = publicKey kp+ b <- mkBiscuit kp [block|right(#authority,#read);|]+ b' <- addBlock [block|check if true;|] b+ result <- checkBiscuitSignature b' pub+ result @?= True++tamper :: (PublicKey, (ByteString, Block))+ -> (PublicKey, (ByteString, Block))+tamper (pk, (_, b)) = (pk, ("tampered", b))++tamperedAuthority' :: TestTree+tamperedAuthority' = testCase "Tampered authority" $ do+ kp <- newKeypair+ let pub = publicKey kp+ b <- mkBiscuit kp [block|right(#authority,#read);|]+ b' <- addBlock [block|check if true;|] b+ let modified = b'+ { authority = tamper $ authority b+ }+ result <- checkBiscuitSignature modified pub+ result @?= False++tamperedBlock' :: TestTree+tamperedBlock' = testCase "Tampered block" $ do+ kp <- newKeypair+ let pub = publicKey kp+ b <- mkBiscuit kp [block|right(#authority,#read);|]+ b' <- addBlock [block|check if true;|] b+ let modified = b'+ { blocks = tamper <$> blocks b+ }+ result <- checkBiscuitSignature modified pub+ result @?= False
+ test/Spec/Executor.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Spec.Executor (specs) where++import Data.Attoparsec.Text (parseOnly)+import Data.Map.Strict as Map+import Data.Set as Set+import Data.Text (Text, unpack)+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit.Datalog.AST+import Auth.Biscuit.Datalog.Executor+import Auth.Biscuit.Datalog.Parser (expressionParser, fact, rule)++specs :: TestTree+specs = testGroup "Datalog evaluation"+ [ grandparent+ , exprEval+ , exprEvalError+ , rulesWithConstraints+ , ruleHeadWithNoVars+ , limits+ ]++grandparent :: TestTree+grandparent = testCase "Basic grandparent rule" $+ let world = World+ { rules = Set.fromList+ [ [rule|grandparent($a,$b) <- parent($a,$c), parent($c,$b)|]+ ]+ , blockRules = mempty+ , facts = Set.fromList+ [ [fact|parent("alice", "bob")|]+ , [fact|parent("bob", "jean-pierre")|]+ , [fact|parent("alice", "toto")|]+ ]+ }+ in computeAllFacts defaultLimits world @?= Right (Set.fromList+ [ [fact|parent("alice", "bob")|]+ , [fact|parent("bob", "jean-pierre")|]+ , [fact|parent("alice", "toto")|]+ , [fact|grandparent("alice", "jean-pierre")|]+ ])++expr :: Text -> Expression+expr = either error id . parseOnly expressionParser++exprEval :: TestTree+exprEval = do+ let bindings = Map.fromList+ [ ("var1", LInteger 0)+ ]+ eval (e, r) = testCase (unpack e) $+ evaluateExpression defaultLimits bindings (expr e) @?= Right r++ -- ("1 / 0") @?= Left "Divide by 0"+ testGroup "Expressions evaluation" $ eval <$>+ [ ("!(1 < $var1)", LBool True)+ , ("[0].contains($var1)", LBool True)+ , ("1 + 2 * 3", LInteger 7)+ , ("!(1 + 2 * 3 > 4)", LBool False)+ , ("!true", LBool False)+ , ("!false", LBool True)+ , ("(true)", LBool True)+ , ("\"test\".length()", LInteger 4)+ , ("hex:ababab.length()", LInteger 3)+ , ("[].length()", LInteger 0)+ , ("[#test, #test].length()", LInteger 1)+ , ("#toto == #toto", LBool True)+ , ("#toto == #truc", LBool False)+ , ("1 == 1", LBool True)+ , ("2 == 1", LBool False)+ , ("\"toto\" == \"toto\"", LBool True)+ , ("\"toto\" == \"truc\"", LBool False)+ , ("\"toto\".matches(\"to(to)?\")", LBool True)+ , ("\"toto\".matches(\"^to$\")", LBool False)+ , ("2021-05-07T18:00:00Z == 2021-05-07T18:00:00Z", LBool True)+ , ("2021-05-07T18:00:00Z == 2021-05-07T19:00:00Z", LBool False)+ , ("hex:ababab == hex:ababab", LBool True)+ , ("hex:ababab == hex:ababac", LBool False)+ , ("true == true", LBool True)+ , ("true == false", LBool False)+ , ("[1,2,3] == [1,2,3]", LBool True)+ , ("[1,2,3] == [1,2,4]", LBool False)+ , ("1 < 2", LBool True)+ , ("2 < 1", LBool False)+ , ("2021-05-07T18:00:00Z < 2021-05-07T19:00:00Z", LBool True)+ , ("2021-05-07T19:00:00Z < 2021-05-07T18:00:00Z", LBool False)+ , ("2 > 1", LBool True)+ , ("1 > 2", LBool False)+ , ("2021-05-07T19:00:00Z > 2021-05-07T18:00:00Z", LBool True)+ , ("2021-05-07T18:00:00Z > 2021-05-07T19:00:00Z", LBool False)+ , ("1 <= 2", LBool True)+ , ("1 <= 1", LBool True)+ , ("2 <= 1", LBool False)+ , ("2021-05-07T18:00:00Z <= 2021-05-07T19:00:00Z", LBool True)+ , ("2021-05-07T18:00:00Z <= 2021-05-07T18:00:00Z", LBool True)+ , ("2021-05-07T19:00:00Z <= 2021-05-07T18:00:00Z", LBool False)+ , ("2 >= 1", LBool True)+ , ("2 >= 2", LBool True)+ , ("1 >= 2", LBool False)+ , ("2021-05-07T19:00:00Z >= 2021-05-07T18:00:00Z", LBool True)+ , ("2021-05-07T18:00:00Z >= 2021-05-07T18:00:00Z", LBool True)+ , ("2021-05-07T18:00:00Z >= 2021-05-07T19:00:00Z", LBool False)+ , ("\"my string\".starts_with(\"my\")", LBool True)+ , ("\"my string\".starts_with(\"string\")", LBool False)+ , ("\"my string\".ends_with(\"string\")", LBool True)+ , ("\"my string\".ends_with(\"my\")", LBool False)+ , ("2 + 1", LInteger 3)+ , ("2 - 1", LInteger 1)+ , ("5 / 2", LInteger 2)+ , ("2 * 1", LInteger 2)+ , ("true && true", LBool True)+ , ("true && false", LBool False)+ , ("false && true", LBool False)+ , ("false && false", LBool False)+ , ("true || true", LBool True)+ , ("true || false", LBool True)+ , ("false || true", LBool True)+ , ("false || false", LBool False)+ , ("[#test].contains([#test])", LBool True)+ , ("[#test].contains(#test)", LBool True)+ , ("[].contains(#test)", LBool False)+ , ("[\"test\"].contains(#test)", LBool False)+ , ("[#test].intersection([#test])", TermSet (Set.fromList [Symbol "test"]))+ , ("[#test].intersection([\"test\"])", TermSet (Set.fromList []))+ , ("[#test].union([#test])", TermSet (Set.fromList [Symbol "test"]))+ , ("[#test].union([\"test\"])", TermSet (Set.fromList [Symbol "test", LString "test"]))+ ]++exprEvalError :: TestTree+exprEvalError = do+ let bindings = Map.fromList+ [ ("var1", LInteger 0)+ ]+ l = defaultLimits { allowRegexes = False }+ evalFail (e, r) = testCase (unpack e) $+ evaluateExpression l bindings (expr e) @?= Left r++ testGroup "Expressions evaluation (expected errors)" $ evalFail <$>+ [ ("1 / 0", "Divide by 0")+ , ("\"toto\".matches(\"to\")", "Regex evaluation is disabled")+ ]++rulesWithConstraints :: TestTree+rulesWithConstraints = testCase "Rule with constraints" $+ let world = World+ { rules = Set.fromList+ [ [rule|valid_date("file1") <- time(#ambient, $0), resource(#ambient, "file1"), $0 <= 2019-12-04T09:46:41+00:00|]+ , [rule|valid_date("file2") <- time(#ambient, $0), resource(#ambient, "file2"), $0 <= 2010-12-04T09:46:41+00:00|]+ ]+ , blockRules = mempty+ , facts = Set.fromList+ [ [fact|time(#ambient, 2019-12-04T01:00:00Z)|]+ , [fact|resource(#ambient, "file1")|]+ , [fact|resource(#ambient, "file2")|]+ ]+ }+ in computeAllFacts defaultLimits world @?= Right (Set.fromList+ [ [fact|time(#ambient, 2019-12-04T01:00:00Z)|]+ , [fact|resource(#ambient, "file1")|]+ , [fact|resource(#ambient, "file2")|]+ , [fact|valid_date("file1")|]+ ])++ruleHeadWithNoVars :: TestTree+ruleHeadWithNoVars = testCase "Rule head with no variables" $+ let world = World+ { rules = Set.fromList+ [ [rule|operation(#authority,#read) <- test($yolo, #nothing)|]+ ]+ , blockRules = mempty+ , facts = Set.fromList+ [ [fact|test(#whatever, #notNothing)|]+ ]+ }+ in computeAllFacts defaultLimits world @?= Right (Set.fromList+ [ [fact|test(#whatever, #notNothing)|]+ ])++limits :: TestTree+limits =+ let world = World+ { rules = Set.fromList+ [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|]+ , [rule|ancestor($a,$b) <- parent($a,$b)|]+ ]+ , blockRules = mempty+ , facts = Set.fromList+ [ [fact|parent("alice", "bob")|]+ , [fact|parent("bob", "jean-pierre")|]+ , [fact|parent("bob", "marielle")|]+ , [fact|parent("alice", "toto")|]+ ]+ }+ factLimits = defaultLimits { maxFacts = 10 }+ iterLimits = defaultLimits { maxIterations = 2 }+ in testGroup "Facts generation limits"+ [ testCase "max facts" $+ computeAllFacts factLimits world @?= Left TooManyFacts+ , testCase "max iterations" $+ computeAllFacts iterLimits world @?= Left TooManyIterations+ ]
+ test/Spec/Parser.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Spec.Parser (specs) where++import Data.Attoparsec.Text (parseOnly)+import qualified Data.Set as Set+import Data.Text (Text)+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit.Datalog.AST+import Auth.Biscuit.Datalog.Parser (checkParser, expressionParser,+ policyParser, predicateParser,+ ruleParser, termParser,+ verifierParser)++parseTerm :: Text -> Either String ID+parseTerm = parseOnly termParser++parseTermQQ :: Text -> Either String QQID+parseTermQQ = parseOnly termParser++parsePredicate :: Text -> Either String Predicate+parsePredicate = parseOnly predicateParser++parseRule :: Text -> Either String Rule+parseRule = parseOnly ruleParser++parseExpression :: Text -> Either String Expression+parseExpression = parseOnly expressionParser++parseCheck :: Text -> Either String Check+parseCheck = parseOnly checkParser++parseVerifier :: Text -> Either String Verifier+parseVerifier = parseOnly verifierParser++parsePolicy :: Text -> Either String Policy+parsePolicy = parseOnly policyParser++specs :: TestTree+specs = testGroup "datalog parser"+ [ factWithDate+ , simpleFact+ , simpleRule+ , multilineRule+ , termsGroup+ , termsGroupQQ+ , constraints+ , constrainedRule+ , constrainedRuleOrdering+ , checkParsing+ , policyParsing+ , verifierParsing+ ]++termsGroup :: TestTree+termsGroup = testGroup "Parse terms"+ [ testCase "Symbol" $ parseTerm "#ambient" @?= Right (Symbol "ambient")+ , testCase "String" $ parseTerm "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")+ , testCase "Positive integer" $ parseTerm "123" @?= Right (LInteger 123)+ , testCase "Negative integer" $ parseTerm "-42" @?= Right (LInteger (-42))+ , 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"+ ]++termsGroupQQ :: TestTree+termsGroupQQ = testGroup "Parse terms (in a QQ setting)"+ [ testCase "Symbol" $ parseTermQQ "#ambient" @?= Right (Symbol "ambient")+ , testCase "String" $ parseTermQQ "\"file1 a hello - 123_\"" @?= Right (LString "file1 a hello - 123_")+ , testCase "Positive integer" $ parseTermQQ "123" @?= Right (LInteger 123)+ , testCase "Negative integer" $ parseTermQQ "-42" @?= Right (LInteger (-42))+ , 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")+ ]++simpleFact :: TestTree+simpleFact = testCase "Parse simple fact" $+ parsePredicate "right(#authority, \"file1\", #read)" @?=+ Right (Predicate "right" [Symbol "authority", LString "file1", Symbol "read"])++factWithDate :: TestTree+factWithDate = testCase "Parse fact containing a date" $+ parsePredicate "date(#ambient,2019-12-02T13:49:53Z)" @?=+ Right (Predicate "date" [Symbol "ambient", LDate $ read "2019-12-02 13:49:53 UTC"])++simpleRule :: TestTree+simpleRule = testCase "Parse simple rule" $+ parseRule "right(#authority, $0, #read) <- resource( #ambient, $0), operation(#ambient, #read)" @?=+ Right (Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])+ [ Predicate "resource" [Symbol "ambient", Variable "0"]+ , Predicate "operation" [Symbol "ambient", Symbol "read"]+ ] [])++multilineRule :: TestTree+multilineRule = testCase "Parse multiline rule" $+ parseRule "right(#authority, $0, #read) <-\n resource( #ambient, $0),\n operation(#ambient, #read)" @?=+ Right (Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])+ [ Predicate "resource" [Symbol "ambient", Variable "0"]+ , Predicate "operation" [Symbol "ambient", Symbol "read"]+ ] [])++constrainedRule :: TestTree+constrainedRule = testCase "Parse constained rule" $+ parseRule "valid_date(\"file1\") <- time(#ambient, $0), resource(#ambient, \"file1\"), $0 <= 2019-12-04T09:46:41+00:00" @?=+ Right (Rule (Predicate "valid_date" [LString "file1"])+ [ Predicate "time" [Symbol "ambient", Variable "0"]+ , Predicate "resource" [Symbol "ambient", LString "file1"]+ ]+ [ EBinary LessOrEqual+ (EValue $ Variable "0")+ (EValue $ LDate $ read "2019-12-04 09:46:41 UTC")+ ])++constrainedRuleOrdering :: TestTree+constrainedRuleOrdering = testCase "Parse constained rule (interleaved)" $+ parseRule "valid_date(\"file1\") <- time(#ambient, $0), $0 <= 2019-12-04T09:46:41+00:00, resource(#ambient, \"file1\")" @?=+ Right (Rule (Predicate "valid_date" [LString "file1"])+ [ Predicate "time" [Symbol "ambient", Variable "0"]+ , Predicate "resource" [Symbol "ambient", LString "file1"]+ ]+ [ EBinary LessOrEqual+ (EValue $ Variable "0")+ (EValue $ LDate $ read "2019-12-04 09:46:41 UTC")+ ])++constraints :: TestTree+constraints = testGroup "Parse expressions"+ [ testCase "date comparison (LTE)" $+ parseExpression "$0 <= 2030-12-31T12:59:59+00:00" @?=+ Right (EBinary LessOrEqual+ (EValue (Variable "0"))+ (EValue (LDate $ read "2030-12-31 12:59:59 UTC"))+ )+ , testCase "date comparison (GTE)" $+ parseExpression "$0 >= 2030-12-31T12:59:59+00:00" @?=+ Right (EBinary GreaterOrEqual+ (EValue (Variable "0"))+ (EValue (LDate $ read "2030-12-31 12:59:59 UTC"))+ )+ , testCase "int comparison (LT)" $+ parseExpression "$0 < 1234" @?=+ Right (EBinary LessThan+ (EValue (Variable "0"))+ (EValue (LInteger 1234))+ )+ , testCase "int comparison (GT)" $+ parseExpression "$0 > 1234" @?=+ Right (EBinary GreaterThan+ (EValue (Variable "0"))+ (EValue (LInteger 1234))+ )+ , testCase "int comparison (LTE)" $+ parseExpression "$0 <= 1234" @?=+ Right (EBinary LessOrEqual+ (EValue (Variable "0"))+ (EValue (LInteger 1234))+ )+ , testCase "int comparison (EQ)" $+ parseExpression "$0 == 1" @?=+ Right (EBinary Equal+ (EValue (Variable "0"))+ (EValue (LInteger 1))+ )+ , testCase "negative int comparison (GTE)" $+ parseExpression "$0 >= -1234" @?=+ Right (EBinary GreaterOrEqual+ (EValue (Variable "0"))+ (EValue (LInteger (-1234)))+ )+ , testCase "string comparison" $+ parseExpression "$0 == \"abc\"" @?=+ Right (EBinary Equal+ (EValue (Variable "0"))+ (EValue (LString "abc"))+ )+ , testCase "string comparison (starts_with)" $+ parseExpression "$0.starts_with(\"abc\")" @?=+ Right (EBinary Prefix+ (EValue (Variable "0"))+ (EValue (LString "abc"))+ )+ , testCase "string comparison (ends_with)" $+ parseExpression "$0.ends_with(\"abc\")" @?=+ Right (EBinary Suffix+ (EValue (Variable "0"))+ (EValue (LString "abc"))+ )+ , testCase "string comparison (matches)" $+ parseExpression "$0.matches(\"abc\")" @?=+ Right (EBinary Regex+ (EValue (Variable "0"))+ (EValue (LString "abc"))+ )+ , testCase "int set operation" $+ parseExpression "[1, 2].contains($0)" @?=+ Right (EBinary Contains+ (EValue (TermSet $ Set.fromList [LInteger 1, LInteger 2]))+ (EValue (Variable "0"))+ )+ , testCase "negated int set operation" $+ parseExpression "![1, 2].contains($0)" @?=+ Right (EUnary Negate+ (EBinary Contains+ (EValue (TermSet $ Set.fromList [LInteger 1, LInteger 2]))+ (EValue (Variable "0"))+ ))+ , testCase "string set operation" $+ parseExpression "[\"abc\", \"def\"].contains($0)" @?=+ Right (EBinary Contains+ (EValue (TermSet $ Set.fromList [LString "abc", LString "def"]))+ (EValue (Variable "0"))+ )+ , testCase "negated string set operation" $+ parseExpression "![\"abc\", \"def\"].contains($0)" @?=+ Right (EUnary Negate+ (EBinary Contains+ (EValue (TermSet $ Set.fromList [LString "abc", LString "def"]))+ (EValue (Variable "0"))+ ))+ , testCase "symbol set operation" $+ parseExpression "[#abc, #def].contains($0)" @?=+ Right (EBinary Contains+ (EValue (TermSet $ Set.fromList [Symbol "abc", Symbol "def"]))+ (EValue (Variable "0"))+ )+ , testCase "negated symbol set operation" $+ parseExpression "![#abc, #def].contains($0)" @?=+ Right (EUnary Negate+ (EBinary Contains+ (EValue (TermSet $ Set.fromList [Symbol "abc", Symbol "def"]))+ (EValue (Variable "0"))+ ))+ , operatorPrecedences+ ]++operatorPrecedences :: TestTree+operatorPrecedences = testGroup "mixed-precedence operators"+ [ testCase "< +" $+ parseExpression " 1 < $test + 2 " @?=+ Right (EBinary LessThan+ (EValue $ LInteger 1)+ (EBinary Add+ (EValue $ Variable "test")+ (EValue $ LInteger 2)+ )+ )+ , testCase "< && starts_with" $+ parseExpression " 2 < $test && $var2.starts_with(\"test\") && true " @?=+ Right (EBinary And+ (EBinary And+ (EBinary LessThan+ (EValue $ LInteger 2)+ (EValue $ Variable "test")+ )+ (EBinary Prefix+ (EValue $ Variable "var2")+ (EValue $ LString "test")+ )+ )+ (EValue $ LBool True)+ )+ , testCase "+ *" $+ parseExpression "1 + 2 * 3" @?=+ Right (EBinary Add+ (EValue $ LInteger 1)+ (EBinary Mul+ (EValue $ LInteger 2)+ (EValue $ LInteger 3)+ )+ )+ , testCase "+ * parens" $+ parseExpression "(1 + 2) * 3" @?=+ Right (EBinary Mul+ (EUnary Parens+ (EBinary Add+ (EValue $ LInteger 1)+ (EValue $ LInteger 2)+ )+ )+ (EValue $ LInteger 3)+ )+ ]++checkParsing :: TestTree+checkParsing = testGroup "check blocks"+ [ testCase "Simple check" $+ parseCheck "check if true" @?=+ Right [QueryItem [] [EValue $ LBool True]]+ , testCase "Multiple groups" $+ parseCheck+ "check if fact(#ambient, $var), $var == true or \+ \other(#authority, $var), $var == 2" @?=+ Right+ [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+ , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+ ]+ ]++policyParsing :: TestTree+policyParsing = testGroup "policy blocks"+ [ testCase "Simple allow policy" $+ parsePolicy "allow if true" @?=+ Right (Allow, [QueryItem [] [EValue $ LBool True]])+ , testCase "Simple deny policy" $+ parsePolicy "deny if true" @?=+ Right (Deny, [QueryItem [] [EValue $ LBool True]])+ , testCase "Allow with multiple groups" $+ parsePolicy+ "allow if fact(#ambient, $var), $var == true or \+ \other(#authority, $var), $var == 2" @?=+ Right+ ( Allow+ , [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+ , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+ ]+ )+ , testCase "Deny with multiple groups" $+ parsePolicy+ "deny if fact(#ambient, $var), $var == true or \+ \other(#authority, $var), $var == 2" @?=+ Right+ ( Deny+ , [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+ , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+ ]+ )+ , testCase "Deny with multiple groups, multiline" $+ parsePolicy+ "deny if\n\+ \fact(#ambient, $var), $var == true or\n\+ \other(#authority, $var), $var == 2" @?=+ Right+ ( Deny+ , [ QueryItem [Predicate "fact" [Symbol "ambient", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LBool True))]+ , QueryItem [Predicate "other" [Symbol "authority", Variable "var"]]+ [EBinary Equal (EValue (Variable "var")) (EValue (LInteger 2))]+ ]+ )+ ]++verifierParsing :: TestTree+verifierParsing = testGroup "Simple verifiers"+ [ testCase "Just a deny" $+ parseVerifier "deny if true;" @?=+ Right (Verifier [(Deny, [QueryItem [] [EValue (LBool True)]])] mempty+ )+ , testCase "Allow and deny" $+ parseVerifier "allow if operation(#ambient, #read);\n deny if true;" @?=+ Right (Verifier+ [ (Allow, [QueryItem [Predicate "operation" [Symbol "ambient", Symbol "read"]] []])+ , (Deny, [QueryItem [] [EValue (LBool True)]])+ ]+ mempty+ )+ , testCase "Complete verifier" $ do+ let spec :: Text+ spec =+ "// the owner has all rights\n\+ \right(#authority, $blog_id, $article_id, $operation) <-\n\+ \ article(#ambient, $blog_id, $article_id),\n\+ \ operation(#ambient, $operation),\n\+ \ user(#authority, $user_id),\n\+ \ owner(#authority, $user_id, $blog_id);\n\+ \// premium users can access some restricted articles\n\+ \right(#authority, $blog_id, $article_id, #read) <-\n\+ \ article(#ambient, $blog_id, $article_id),\n\+ \ premium_readable(#authority, $blog_id, $article_id),\n\+ \ user(#authority, $user_id),\n\+ \ premium_user(#authority, $user_id, $blog_id);\n\+ \// define teams and roles\n\+ \right(#authority, $blog_id, $article_id, $operation) <-\n\+ \ article(#ambient, $blog_id, $article_id),\n\+ \ operation(#ambient, $operation),\n\+ \ user(#authority, $user_id),\n\+ \ member(#authority, $user_id, $team_id),\n\+ \ team_role(#authority, $team_id, $blog_id, #contributor),\n\+ \ [#read, #write].contains($operation);\n\+ \// unauthenticated users have read access on published articles\n\+ \allow if\n\+ \ operation(#ambient, #read),\n\+ \ article(#ambient, $blog_id, $article_id),\n\+ \ readable(#authority, $blog_id, $article_id);\n\+ \// authorize if got the rights on this blog and article\n\+ \allow if\n\+ \ blog(#ambient, $blog_id),\n\+ \ article(#ambient, $blog_id, $article_id),\n\+ \ operation(#ambient, $operation),\n\+ \ right(#authority, $blog_id, $article_id, $operation);\n\+ \// catch all rule in case the allow did not match\n\+ \deny if true;\+ \ "+ p = Predicate+ sAuth = Symbol "authority"+ sAmb = Symbol "ambient"+ sRead = Symbol "read"+ sWrite = Symbol "write"+ sContributor = Symbol "contributor"+ vBlogId = Variable "blog_id"+ vArticleId = Variable "article_id"+ vUserId = Variable "user_id"+ vTeamId = Variable "team_id"+ vOp = Variable "operation"+ bRules =+ [ Rule (p "right" [sAuth, vBlogId, vArticleId, vOp])+ [ p "article" [sAmb, vBlogId, vArticleId]+ , p "operation" [sAmb, vOp]+ , p "user" [sAuth, vUserId]+ , p "owner" [sAuth, vUserId, vBlogId]+ ] []+ , Rule (p "right" [sAuth, vBlogId, vArticleId, sRead])+ [ p "article" [sAmb, vBlogId, vArticleId]+ , p "premium_readable" [sAuth, vBlogId, vArticleId]+ , p "user" [sAuth, vUserId]+ , p "premium_user" [sAuth, vUserId, vBlogId]+ ] []+ , Rule (p "right" [sAuth, vBlogId, vArticleId, vOp])+ [ p "article" [sAmb, vBlogId, vArticleId]+ , p "operation" [sAmb, vOp]+ , p "user" [sAuth, vUserId]+ , p "member" [sAuth, vUserId, vTeamId]+ , p "team_role" [sAuth, vTeamId, vBlogId, sContributor]+ ] [EBinary Contains (EValue (TermSet $ Set.fromList [sRead, sWrite]))+ (EValue vOp)]+ ]+ bFacts = []+ bChecks = []+ bContext = Nothing+ vPolicies =+ [ (Allow, [QueryItem [ p "operation" [sAmb, sRead]+ , p "article" [sAmb, vBlogId, vArticleId]+ , p "readable" [sAuth, vBlogId, vArticleId]+ ] []])+ , (Allow, [QueryItem [ p "blog" [sAmb, vBlogId]+ , p "article" [sAmb, vBlogId, vArticleId]+ , p "operation" [sAmb, vOp]+ , p "right" [sAuth, vBlogId, vArticleId, vOp]+ ] []])+ , (Deny, [QueryItem [] [EValue (LBool True)]])+ ]+ parseVerifier spec @?= Right Verifier{vBlock = Block{..}, ..}+ ]
+ test/Spec/Quasiquoter.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Spec.Quasiquoter (specs) where++import Data.Text (Text)+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit.Datalog.AST+import Auth.Biscuit.Datalog.Parser (fact, rule)++specs :: TestTree+specs = testGroup "Datalog quasiquoter"+ [ basicFact+ , basicRule+ , antiquotedFact+ , antiquotedRule+ ]++basicFact :: TestTree+basicFact = testCase "Basic fact" $+ let actual :: Fact+ actual = [fact|right(#authority, "file1", #read)|]+ in actual @?=+ Predicate "right" [ Symbol "authority"+ , LString "file1"+ , Symbol "read"+ ]++basicRule :: TestTree+basicRule = testCase "Basic rule" $+ let actual :: Rule+ actual = [rule|right(#authority, $0, #read) <- resource( #ambient, $0), operation(#ambient, #read)|]+ in actual @?=+ Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])+ [ Predicate "resource" [Symbol "ambient", Variable "0"]+ , Predicate "operation" [Symbol "ambient", Symbol "read"]+ ] []++antiquotedFact :: TestTree+antiquotedFact = testCase "Sliced fact" $+ let toto :: Text+ toto = "test"+ actual :: Fact+ actual = [fact|right(#authority, ${toto}, #read)|]+ in actual @?=+ Predicate "right" [ Symbol "authority"+ , LString "test"+ , Symbol "read"+ ]++antiquotedRule :: TestTree+antiquotedRule = testCase "Sliced rule" $+ let toto :: Text+ toto = "test"+ actual :: Rule+ actual = [rule|right(#authority, $0, #read) <- resource( #ambient, $0), operation(#ambient, #read, ${toto})|]+ in actual @?=+ Rule (Predicate "right" [Symbol "authority", Variable "0", Symbol "read"])+ [ Predicate "resource" [Symbol "ambient", Variable "0"]+ , Predicate "operation" [Symbol "ambient", Symbol "read", LString "test"]+ ] []
+ test/Spec/RevocationIds.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Spec.RevocationIds+ ( specs+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base16 as Hex+import qualified Data.List.NonEmpty as NE+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit+import Auth.Biscuit.Token (BlockWithRevocationIds (..),+ getRevocationIds)++readFromFile :: FilePath -> IO Biscuit+readFromFile path = do+ result <- parse <$> ByteString.readFile ("test/samples/" <> path)+ case result of+ Left x -> fail $ show x+ Right b -> pure b++getHex :: Biscuit -> IO [ByteString]+getHex b = do+ let gi BlockWithRevocationIds{..} =+ Hex.encode genericRevocationId+ rids <- getRevocationIds b+ pure . NE.toList $ gi <$> rids++specs :: TestTree+specs = testGroup "Revocation ids"+ [ token1+ , token16+ ]++token1 :: TestTree+token1 = testCase "Token 1" $ do+ b <- readFromFile "test1_basic.bc"+ rids <- getHex b+ rids @?=+ [ "596a24631a8eeec5cbc0d84fc6c22fec1a524c7367bc8926827201ddd218f4bb"+ , "dec4e0a7f817fe6c5964a18e9f0eae5564c12531b05dc4525f553570519baa87"+ ]++token16 :: TestTree+token16 = testCase "Token 16" $ do+ b <- readFromFile "test16_caveat_head_name.bc"+ rids <- getHex b+ rids @?=+ [ "8f03890eeaa997cd03da71115168e41425b2be82731026225b0c5b87163e4d8e"+ , "94fff36a9fa4d4149ab1488bf4aa84ed0bab0075cc7d051270367fb9c9688795"+ ]
+ test/Spec/Roundtrip.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+module Spec.Roundtrip+ ( specs+ ) where++-- import qualified Data.ByteString as ByteString+import Data.List.NonEmpty (NonEmpty ((:|)))+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit+import Auth.Biscuit.Token (Biscuit (..))++specs :: TestTree+specs = testGroup "Serde roundtrips"+ [ singleBlock+ , multipleBlocks+ ]++roundtrip :: NonEmpty Block+ -> Assertion+roundtrip i@(authority' :| blocks') = do+ let addBlocks bs biscuit = case bs of+ (b:rest) -> addBlocks rest =<< addBlock b biscuit+ [] -> pure biscuit+ keypair <- newKeypair+ init' <- mkBiscuit keypair authority'+ final <- addBlocks blocks' init'+ let serialized = serialize final+ parsed = parse serialized+ getBlocks Biscuit{..} = snd (snd authority) :| (snd . snd <$> blocks)+ getBlocks <$> parsed @?= Right i++singleBlock :: TestTree+singleBlock = testCase "Single block" $ roundtrip $ pure+ [block|+ right(#authority, "file1", #read);+ right(#authority, "file2", #read);+ right(#authority, "file1", #write);+ |]++multipleBlocks :: TestTree+multipleBlocks = testCase "Multiple block" $ roundtrip $+ [block|+ right(#authority, "file1", #read);+ right(#authority, "file2", #read);+ right(#authority, "file1", #write);+ |] :|+ [ [block|+ valid_date("file1") <- time(#ambient, $0), resource(#ambient, "file1"), $0 <= 2030-12-31T12:59:59+00:00;+ valid_date($1) <- time(#ambient, $0), resource(#ambient, $1), $0 <= 1999-12-31T12:59:59+00:00, !["file1"].contains($1);+ check if valid_date($0), resource(#ambient, $0);+ |]+ ] {-+ , [block|+ check if true;+ check if !false;+ check if !false;+ check if false or true;+ check if 1 < 2;+ check if 2 > 1;+ check if 1 <= 2;+ check if 1 <= 1;+ check if 2 >= 1;+ check if 2 >= 2;+ check if 3 == 3;+ check if 1 + 2 * 3 - 4 / 2 == 5;+ check if "hello world".starts_with("hello") && "hello world".ends_with("world");+ check if "aaabde".matches("a*c?.e");+ check if "abcD12" == "abcD12";+ check if 2019-12-04T09:46:41+00:00 < 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 > 2019-12-04T09:46:41+00:00;+ check if 2019-12-04T09:46:41+00:00 <= 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 >= 2019-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 == 2020-12-04T09:46:41+00:00;+ check if #abc == #abc;+ check if hex:12ab == hex:12ab;+ check if [1, 2].contains(2);+ check if [2019-12-04T09:46:41+00:00, 2020-12-04T09:46:41+00:00].contains(2020-12-04T09:46:41+00:00);+ check if [false, true].contains(true);+ check if ["abc", "def"].contains("abc");+ check if [hex:12ab, hex:34de].contains(hex:34de);+ check if [#hello, #world].contains(#hello);+ |]+ , [block|+ check if+ resource(#ambient, $0),+ operation(#ambient, #read),+ right(#authority, $0, #read);+ |]+ , [block|+ check if resource(#ambient, "file1");+ check if time(#ambient, $date), $date <= 2018-12-20T00:00:00+00:00;+ |]+ ]-}
+ test/Spec/Samples.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Spec.Samples+ ( specs+ ) where++import qualified Data.ByteString as ByteString+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit (ParseError (..), parse)+import Auth.Biscuit.Datalog.AST (Block)+import Auth.Biscuit.Datalog.Parser (block)+import Auth.Biscuit.Token (Biscuit (..))++readFromFile :: FilePath -> IO (Either ParseError Biscuit)+readFromFile path =+ parse <$> ByteString.readFile ("test/samples/" <> path)++getAuthority :: Biscuit -> Block+getAuthority = snd . snd . authority++getBlocks :: Biscuit -> [Block]+getBlocks = fmap (snd . snd) . blocks++specs :: TestTree+specs = testGroup "Biscuit samples"+ [ testCase "test1_basic" $ do+ result <- readFromFile "test1_basic.bc"+ getAuthority <$> result @?= Right+ [block|+ right(#authority, "file1", #read);+ right(#authority, "file2", #read);+ right(#authority, "file1", #write);+ |]+ getBlocks <$> result @?= Right+ [ [block|+ check if+ resource(#ambient, $0),+ operation(#ambient, #read),+ right(#authority, $0, #read);+ |]+ ]+ , testCase "test9_expired_token" $ do+ result <- readFromFile "test9_expired_token.bc"+ getAuthority <$> result @?= Right mempty+ getBlocks <$> result @?= Right+ [ [block|+ check if resource(#ambient, "file1");+ check if time(#ambient, $date), $date <= 2018-12-20T00:00:00+00:00;+ |]+ ]+ , testCase "test13_block_rules" $ do+ result <- readFromFile "test13_block_rules.bc"+ getAuthority <$> result @?= Right+ [block|+ right(#authority, "file1", #read);+ right(#authority, "file2", #read);+ |]+ getBlocks <$> result @?= Right+ [ [block|+ valid_date("file1") <- time(#ambient, $0), resource(#ambient, "file1"), $0 <= 2030-12-31T12:59:59+00:00;+ valid_date($1) <- time(#ambient, $0), resource(#ambient, $1), $0 <= 1999-12-31T12:59:59+00:00, !["file1"].contains($1);+ check if valid_date($0), resource(#ambient, $0);+ |]+ ]+ , testCase "test17_expressions" $ do+ result <- readFromFile "test17_expressions.bc"+ getAuthority <$> result @?= Right+ [block|+ check if true;+ check if !false;+ check if !false;+ check if false or true;+ check if 1 < 2;+ check if 2 > 1;+ check if 1 <= 2;+ check if 1 <= 1;+ check if 2 >= 1;+ check if 2 >= 2;+ check if 3 == 3;+ check if 1 + 2 * 3 - 4 / 2 == 5;+ check if "hello world".starts_with("hello") && "hello world".ends_with("world");+ check if "aaabde".matches("a*c?.e");+ check if "abcD12" == "abcD12";+ check if 2019-12-04T09:46:41+00:00 < 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 > 2019-12-04T09:46:41+00:00;+ check if 2019-12-04T09:46:41+00:00 <= 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 >= 2019-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00;+ check if 2020-12-04T09:46:41+00:00 == 2020-12-04T09:46:41+00:00;+ check if #abc == #abc;+ check if hex:12ab == hex:12ab;+ check if [1, 2].contains(2);+ check if [2019-12-04T09:46:41+00:00, 2020-12-04T09:46:41+00:00].contains(2020-12-04T09:46:41+00:00);+ check if [false, true].contains(true);+ check if ["abc", "def"].contains("abc");+ check if [hex:12ab, hex:34de].contains(hex:34de);+ check if [#hello, #world].contains(#hello);+ |]+ getBlocks <$> result @?= Right []+ ]
+ test/Spec/Verification.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+module Spec.Verification+ ( specs+ ) where++import Data.List.NonEmpty (NonEmpty ((:|)))+import Test.Tasty+import Test.Tasty.HUnit++import Auth.Biscuit+import Auth.Biscuit.Datalog.AST (Expression' (..), ID' (..),+ Query, QueryItem' (..))+import Auth.Biscuit.Datalog.Executor (ResultError (..))+import qualified Auth.Biscuit.Datalog.Executor as Executor+import Auth.Biscuit.Datalog.Parser (check)++specs :: TestTree+specs = testGroup "Datalog checks"+ [ singleBlock+ , errorAccumulation+ , unboundVarRule+ , symbolRestrictions+ , factsRestrictions+ ]++ifTrue :: Query+ifTrue = [QueryItem [] [EValue $ LBool True]]++ifFalse :: Query+ifFalse = [QueryItem [] [EValue $ LBool False]]++singleBlock :: TestTree+singleBlock = testCase "Single block" $ do+ keypair <- newKeypair+ biscuit <- mkBiscuit keypair [block|right(#authority, "file1", #read);|]+ res <- verifyBiscuit biscuit [verifier|check if right(#authority, "file1", #read);allow if true;|] (publicKey keypair)+ res @?= Right ifTrue++resultError :: Executor.ResultError+ -> Either VerificationError a+resultError = Left . DatalogError . Executor.ResultError++errorAccumulation :: TestTree+errorAccumulation = testGroup "Error accumulation"+ [ testCase "Only checks" $ do+ keypair <- newKeypair+ biscuit <- mkBiscuit keypair [block|check if false; check if false;|]+ res <- verifyBiscuit biscuit [verifier|allow if true;|] (publicKey keypair)+ res @?= resultError (FailedChecks $ ifFalse :| [ifFalse])+ , testCase "Checks and deny policies" $ do+ keypair <- newKeypair+ biscuit <- mkBiscuit keypair [block|check if false; check if false;|]+ res <- verifyBiscuit biscuit [verifier|deny if true;|] (publicKey keypair)+ res @?= resultError (DenyRuleMatched [ifFalse, ifFalse] ifTrue)+ , testCase "Checks and no policies matched" $ do+ keypair <- newKeypair+ biscuit <- mkBiscuit keypair [block|check if false; check if false;|]+ res <- verifyBiscuit biscuit [verifier|allow if false;|] (publicKey keypair)+ res @?= resultError (NoPoliciesMatched [ifFalse, ifFalse])+ ]++unboundVarRule :: TestTree+unboundVarRule = testCase "Rule with unbound variable" $ do+ keypair <- newKeypair+ b1 <- mkBiscuit keypair [block|check if operation(#ambient, #read);|]+ b2 <- addBlock [block|operation($unbound, #read) <- operation($any1, $any2);|] b1+ res <- verifyBiscuit b2 [verifier|operation(#ambient,#write);allow if true;|] (publicKey keypair)+ res @?= Left (DatalogError $ Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation(#ambient, #read)|])++symbolRestrictions :: TestTree+symbolRestrictions = testGroup "Restricted symbols in blocks"+ [ testCase "In facts" $ do+ keypair <- newKeypair+ b1 <- mkBiscuit keypair [block|check if operation(#ambient, #read);|]+ b2 <- addBlock [block|operation(#ambient, #read);|] b1+ res <- verifyBiscuit b2 [verifier|allow if true;|] (publicKey keypair)+ res @?= Left (DatalogError $ Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation(#ambient, #read)|])+ , testCase "In rules" $ do+ keypair <- newKeypair+ b1 <- mkBiscuit keypair [block|check if operation(#ambient, #read);|]+ b2 <- addBlock [block|operation($ambient, #read) <- operation($ambient, $any);|] b1+ res <- verifyBiscuit b2 [verifier|operation(#ambient,#write);allow if true;|] (publicKey keypair)+ res @?= Left (DatalogError $ Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation(#ambient, #read)|])+ ]++factsRestrictions :: TestTree+factsRestrictions =+ let limits = defaultLimits { allowBlockFacts = False }+ in testGroup "No facts or rules in blocks"+ [ testCase "No facts" $ do+ keypair <- newKeypair+ b1 <- mkBiscuit keypair [block|right(#read);|]+ b2 <- addBlock [block|right(#write);|] b1+ res <- verifyBiscuitWithLimits limits b2 [verifier|allow if right(#write);|] (publicKey keypair)+ res @?= Left (DatalogError $ Executor.ResultError $ Executor.NoPoliciesMatched [])+ , testCase "No rules" $ do+ keypair <- newKeypair+ b1 <- mkBiscuit keypair [block|right(#read);|]+ b2 <- addBlock [block|right(#write) <- right(#read);|] b1+ res <- verifyBiscuitWithLimits limits b2 [verifier|allow if right(#write);|] (publicKey keypair)+ res @?= Left (DatalogError $ Executor.ResultError $ Executor.NoPoliciesMatched [])+ ]