diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for biscuit-haskell + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# biscuit-haskell diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "todo" diff --git a/biscuit-haskell.cabal b/biscuit-haskell.cabal new file mode 100644 --- /dev/null +++ b/biscuit-haskell.cabal @@ -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 +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 diff --git a/src/Auth/Biscuit.hs b/src/Auth/Biscuit.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit.hs @@ -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 +-- +-- 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 diff --git a/src/Auth/Biscuit/Datalog/AST.hs b/src/Auth/Biscuit/Datalog/AST.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Datalog/AST.hs @@ -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) diff --git a/src/Auth/Biscuit/Datalog/Executor.hs b/src/Auth/Biscuit/Datalog/Executor.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Datalog/Executor.hs @@ -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'') diff --git a/src/Auth/Biscuit/Datalog/Parser.hs b/src/Auth/Biscuit/Datalog/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Datalog/Parser.hs @@ -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" + } diff --git a/src/Auth/Biscuit/Example.hs b/src/Auth/Biscuit/Example.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Example.hs @@ -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 diff --git a/src/Auth/Biscuit/Proto.hs b/src/Auth/Biscuit/Proto.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Proto.hs @@ -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 diff --git a/src/Auth/Biscuit/ProtoBufAdapter.hs b/src/Auth/Biscuit/ProtoBufAdapter.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/ProtoBufAdapter.hs @@ -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 diff --git a/src/Auth/Biscuit/Sel.hs b/src/Auth/Biscuit/Sel.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Sel.hs @@ -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 diff --git a/src/Auth/Biscuit/Timer.hs b/src/Auth/Biscuit/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Timer.hs @@ -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 + diff --git a/src/Auth/Biscuit/Token.hs b/src/Auth/Biscuit/Token.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Token.hs @@ -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 diff --git a/src/Auth/Biscuit/Utils.hs b/src/Auth/Biscuit/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Utils.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/Spec/Crypto.hs b/test/Spec/Crypto.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Crypto.hs @@ -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 diff --git a/test/Spec/Executor.hs b/test/Spec/Executor.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Executor.hs @@ -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 + ] diff --git a/test/Spec/Parser.hs b/test/Spec/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Parser.hs @@ -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{..}, ..} + ] diff --git a/test/Spec/Quasiquoter.hs b/test/Spec/Quasiquoter.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Quasiquoter.hs @@ -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"] + ] [] diff --git a/test/Spec/RevocationIds.hs b/test/Spec/RevocationIds.hs new file mode 100644 --- /dev/null +++ b/test/Spec/RevocationIds.hs @@ -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" + ] diff --git a/test/Spec/Roundtrip.hs b/test/Spec/Roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Roundtrip.hs @@ -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; + |] + ]-} diff --git a/test/Spec/Samples.hs b/test/Spec/Samples.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Samples.hs @@ -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 [] + ] diff --git a/test/Spec/Verification.hs b/test/Spec/Verification.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Verification.hs @@ -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 []) + ]