expose a monad-polymorphic version of authorizeBiscuit for use with effect systems

divarvel · divarvel · commit f51577f29c62 · 2025-07-09T15:55:22.000+02:00
This takes a timer (polymorphic on the context type) as an argument to avoid coupling the implementation to IO. This primarily meant for integration with effect systems.
diff --git 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
@@ -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
@@ -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
@@ -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
