diff --git a/biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs b/biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs index 7d0ebb0..c4f1e0d 100644 --- a/biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs +++ b/biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-| @@ -17,8 +18,7 @@ -} module Auth.Biscuit.Datalog.ScopedExecutor ( BlockWithRevocationId - , runAuthorizer - , runAuthorizerWithLimits + , runAuthorizerWithTimer , runAuthorizerNoTimeout , runFactGeneration , PureExecError (..) @@ -44,6 +44,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map import Data.Map.Strict ((!?)) +import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -57,13 +58,11 @@ import Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..), MatchedQuery (..), ResultError (..), Scoped, checkCheck, checkPolicy, - countFacts, defaultLimits, - fromScopedFacts, + countFacts, fromScopedFacts, getBindingsForRuleBody, getFactsForRule, keepAuthorized', toScopedFacts) import Auth.Biscuit.Datalog.Parser (fact) -import Auth.Biscuit.Timer (timer) import Auth.Biscuit.Utils (foldMapM, mapMaybeM) import Data.Bitraversable (bisequence) @@ -94,35 +93,22 @@ data AuthorizationSuccess getBindings :: AuthorizationSuccess -> Set Bindings getBindings AuthorizationSuccess{matchedAllowQuery=MatchedQuery{bindings}} = bindings --- | Given a series of blocks and an authorizer, ensure that all --- the checks and policies match -runAuthorizer :: BlockWithRevocationId - -- ^ The authority block - -> [BlockWithRevocationId] - -- ^ The extra blocks - -> Authorizer - -- ^ A authorizer - -> IO (Either ExecutionError AuthorizationSuccess) -runAuthorizer = runAuthorizerWithLimits defaultLimits --- | Given a series of blocks and an authorizer, ensure that all --- the checks and policies match, with provided execution --- constraints -runAuthorizerWithLimits :: Limits - -- ^ custom limits - -> BlockWithRevocationId - -- ^ The authority block - -> [BlockWithRevocationId] - -- ^ The extra blocks - -> Authorizer - -- ^ A authorizer - -> IO (Either ExecutionError AuthorizationSuccess) -runAuthorizerWithLimits l@Limits{..} authority blocks v = do - resultOrTimeout <- timer maxTime $ pure $ runAuthorizerNoTimeout l authority blocks v - pure $ case resultOrTimeout of - Nothing -> Left Timeout - Just r -> r +runAuthorizerWithTimer :: Functor f + => (forall a. Int -> a -> f (Maybe a)) + -- ^ time making sure evaluation does not last longer than the provided amount of microseconds + -> Limits + -- ^ custom limits + -> BlockWithRevocationId + -- ^ The authority block + -> [BlockWithRevocationId] + -- ^ The extra blocks + -> Authorizer + -- ^ An authorizer + -> f (Either ExecutionError AuthorizationSuccess) +runAuthorizerWithTimer timer l@Limits{maxTime} authority blocks v = + fromMaybe (Left Timeout) <$> timer maxTime (runAuthorizerNoTimeout l authority blocks v) mkRevocationIdFacts :: BlockWithRevocationId -> [BlockWithRevocationId] -> Set Fact diff --git a/biscuit/src/Auth/Biscuit/Timer.hs b/biscuit/src/Auth/Biscuit/Timer.hs index 6bcdd38..48ef877 100644 --- a/biscuit/src/Auth/Biscuit/Timer.hs +++ b/biscuit/src/Auth/Biscuit/Timer.hs @@ -6,21 +6,22 @@ Helper function making sure an IO action runs in an alloted time -} module Auth.Biscuit.Timer - ( timer + ( timerIO ) where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race) +import Control.Exception (evaluate) -- | 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 +timerIO :: Int + -> a + -> IO (Maybe a) +timerIO timeout job = do let watchDog = threadDelay timeout - result <- race watchDog job + result <- race watchDog $ evaluate job pure $ case result of Left _ -> Nothing Right a -> Just a diff --git a/biscuit/src/Auth/Biscuit/Token.hs b/biscuit/src/Auth/Biscuit/Token.hs index 4cc2eb6..749d458 100644 --- a/biscuit/src/Auth/Biscuit/Token.hs +++ b/biscuit/src/Auth/Biscuit/Token.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {- HLINT ignore "Reduce duplication" -} {-| @@ -92,7 +93,7 @@ import Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess, collectWorld, queryAvailableFacts, queryGeneratedFacts, - runAuthorizerWithLimits) + runAuthorizerWithTimer) import qualified Auth.Biscuit.Proto as PB import Auth.Biscuit.ProtoBufAdapter (blockToPb, pbToBlock, pbToProof, @@ -103,6 +104,7 @@ import Auth.Biscuit.ProtoBufAdapter (blockToPb, pbToBlock, thirdPartyBlockContentsToPb, thirdPartyBlockRequestToPb) import Auth.Biscuit.Symbols +import Auth.Biscuit.Timer (timerIO) -- | Protobuf serialization does not have a guaranteed deterministic behaviour, -- so we need to keep the initial serialized payload around in order to compute @@ -555,9 +557,10 @@ getRevocationIds Biscuit{authority, blocks} = getRevocationId (_, sig, _, _, _) = sigBytes sig in getRevocationId <$> allBlocks --- | Generic version of 'authorizeBiscuitWithLimits' which takes custom 'Limits'. -authorizeBiscuitWithLimits :: Limits -> Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof)) -authorizeBiscuitWithLimits l biscuit@Biscuit{..} authorizer = +authorizeBiscuitWithTimer :: Functor f => + (forall a. Int -> a -> f (Maybe a)) -> + Limits -> Biscuit proof Verified -> Authorizer -> f (Either ExecutionError (AuthorizedBiscuit proof)) +authorizeBiscuitWithTimer timer l biscuit@Biscuit{..} authorizer = let toBlockWithRevocationId ((_, block), sig, _, eSig, _) = (block, sigBytes sig, snd <$> eSig) -- the authority block can't be externally signed. If it carries a signature, it won't be -- verified. So we need to make sure there is none, to avoid having facts trusted without @@ -569,11 +572,16 @@ authorizeBiscuitWithLimits l biscuit@Biscuit{..} authorizer = , authorizationSuccess } in fmap withBiscuit <$> - runAuthorizerWithLimits l + runAuthorizerWithTimer timer l (dropExternalPk $ toBlockWithRevocationId authority) (toBlockWithRevocationId <$> blocks) authorizer +-- | Generic version of 'authorizeBiscuitWithLimits' which takes custom 'Limits'. +authorizeBiscuitWithLimits :: Limits -> Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof)) +authorizeBiscuitWithLimits = + authorizeBiscuitWithTimer timerIO + -- | Given a biscuit with a verified signature and an authorizer (a set of facts, rules, checks -- and policies), verify a biscuit: -- diff --git a/biscuit/test/Spec/ScopedExecutor.hs b/biscuit/test/Spec/ScopedExecutor.hs index 84f6fcb..d12bed4 100644 --- a/biscuit/test/Spec/ScopedExecutor.hs +++ b/biscuit/test/Spec/ScopedExecutor.hs @@ -11,8 +11,8 @@ import Control.Arrow ((&&&)) import Data.Either (isRight) import Data.Map.Strict as Map import Data.Set as Set -import Data.Text (Text, unpack) -import Test.Tasty +import Data.Text (Text, pack, unpack) +import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Auth.Biscuit (addBlock, addSignedBlock, @@ -29,6 +29,7 @@ import Auth.Biscuit.Datalog.Executor (ExecutionError (..), import Auth.Biscuit.Datalog.Parser (authorizer, block, check, query, run) import Auth.Biscuit.Datalog.ScopedExecutor +import Auth.Biscuit.Timer (timerIO) specs :: TestTree specs = testGroup "Block-scoped Datalog Evaluation" @@ -44,6 +45,7 @@ specs = testGroup "Block-scoped Datalog Evaluation" , revocationIdsAreInjected , authorizerFactsAreQueried , biscuitFactsAreQueried + , evaluationReachesTimeout ] authorizerOnlySeesAuthority :: TestTree @@ -334,3 +336,13 @@ biscuitFactsAreQueried = testGroup "Biscuit can be queried" ] user @?= Right expected ] + +evaluationReachesTimeout :: TestTree +evaluationReachesTimeout = testCase "Timeout is reached while runnning authorization" $ do + let limits = defaultLimits { maxTime = 10 } + input = pack $ Prelude.take 1000 $ repeat 'a' + regex = pack $ "^" <> Prelude.take 1000 (cycle "a?") <> Prelude.take 1000 (repeat 'a') <> "$" + authority = [block|fact(true);rule($t) <- fact($t), {input}.matches({regex});|] + auth = [authorizer|allow if rule(true);|] + res <- runAuthorizerWithTimer timerIO limits (authority, "", Nothing) [] auth + res @?= Left Timeout