Skip to content

Commit 0bc8ad3

Browse files
divarveldivarvel
committed
expose a monad-polymorphic version of authorizeBiscuit for use with effect systems
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.
1 parent 543a140 commit 0bc8ad3

File tree

4 files changed

+48
-44
lines changed

4 files changed

+48
-44
lines changed

‎biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs‎

Lines changed: 18 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
{-# LANGUAGE NamedFieldPuns #-}
77
{-# LANGUAGE OverloadedStrings #-}
88
{-# LANGUAGE QuasiQuotes #-}
9+
{-# LANGUAGE RankNTypes #-}
910
{-# LANGUAGE RecordWildCards #-}
1011
{-# LANGUAGE TupleSections #-}
1112
{-|
@@ -17,8 +18,7 @@
1718
-}
1819
module Auth.Biscuit.Datalog.ScopedExecutor
1920
( BlockWithRevocationId
20-
, runAuthorizer
21-
, runAuthorizerWithLimits
21+
, runAuthorizerWithTimer
2222
, runAuthorizerNoTimeout
2323
, runFactGeneration
2424
, PureExecError (..)
@@ -44,6 +44,7 @@ import qualified Data.List.NonEmpty as NE
4444
import Data.Map (Map)
4545
import qualified Data.Map as Map
4646
import Data.Map.Strict ((!?))
47+
import Data.Maybe (fromMaybe)
4748
import Data.Set (Set)
4849
import qualified Data.Set as Set
4950
import Data.Text (Text)
@@ -57,13 +58,11 @@ import Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..),
5758
MatchedQuery (..),
5859
ResultError (..), Scoped,
5960
checkCheck, checkPolicy,
60-
countFacts, defaultLimits,
61-
fromScopedFacts,
61+
countFacts, fromScopedFacts,
6262
getBindingsForRuleBody,
6363
getFactsForRule,
6464
keepAuthorized', toScopedFacts)
6565
import Auth.Biscuit.Datalog.Parser (fact)
66-
import Auth.Biscuit.Timer (timer)
6766
import Auth.Biscuit.Utils (foldMapM, mapMaybeM)
6867
import Data.Bitraversable (bisequence)
6968

@@ -94,35 +93,22 @@ data AuthorizationSuccess
9493
getBindings :: AuthorizationSuccess -> Set Bindings
9594
getBindings AuthorizationSuccess{matchedAllowQuery=MatchedQuery{bindings}} = bindings
9695

97-
-- | Given a series of blocks and an authorizer, ensure that all
98-
-- the checks and policies match
99-
runAuthorizer :: BlockWithRevocationId
100-
-- ^ The authority block
101-
-> [BlockWithRevocationId]
102-
-- ^ The extra blocks
103-
-> Authorizer
104-
-- ^ A authorizer
105-
-> IO (Either ExecutionError AuthorizationSuccess)
106-
runAuthorizer = runAuthorizerWithLimits defaultLimits
10796

108-
-- | Given a series of blocks and an authorizer, ensure that all
109-
-- the checks and policies match, with provided execution
110-
-- constraints
111-
runAuthorizerWithLimits :: Limits
112-
-- ^ custom limits
113-
-> BlockWithRevocationId
114-
-- ^ The authority block
115-
-> [BlockWithRevocationId]
116-
-- ^ The extra blocks
117-
-> Authorizer
118-
-- ^ A authorizer
119-
-> IO (Either ExecutionError AuthorizationSuccess)
120-
runAuthorizerWithLimits l@Limits{..} authority blocks v = do
121-
resultOrTimeout <- timer maxTime $ pure $ runAuthorizerNoTimeout l authority blocks v
122-
pure $ case resultOrTimeout of
123-
Nothing -> Left Timeout
124-
Just r -> r
12597

98+
runAuthorizerWithTimer :: Functor f
99+
=> (forall a. Int -> a -> f (Maybe a))
100+
-- ^ time making sure evaluation does not last longer than the provided amount of microseconds
101+
-> Limits
102+
-- ^ custom limits
103+
-> BlockWithRevocationId
104+
-- ^ The authority block
105+
-> [BlockWithRevocationId]
106+
-- ^ The extra blocks
107+
-> Authorizer
108+
-- ^ An authorizer
109+
-> f (Either ExecutionError AuthorizationSuccess)
110+
runAuthorizerWithTimer timer l@Limits{maxTime} authority blocks v =
111+
fromMaybe (Left Timeout) <$> timer maxTime (runAuthorizerNoTimeout l authority blocks v)
126112

127113
mkRevocationIdFacts :: BlockWithRevocationId -> [BlockWithRevocationId]
128114
-> Set Fact

‎biscuit/src/Auth/Biscuit/Timer.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@
66
Helper function making sure an IO action runs in an alloted time
77
-}
88
module Auth.Biscuit.Timer
9-
( timer
9+
( timerIO
1010
) where
1111

1212
import Control.Concurrent (threadDelay)
@@ -15,12 +15,12 @@ import Control.Concurrent.Async (race)
1515
-- | Given a maximum execution time, run the provide action, and
1616
-- fail (by returning `Nothing`) if it takes too much time.
1717
-- Else, the action result is returned in a `Just`
18-
timer :: Int
19-
-> IO a
20-
-> IO (Maybe a)
21-
timer timeout job = do
18+
timerIO :: Int
19+
-> a
20+
-> IO (Maybe a)
21+
timerIO timeout job = do
2222
let watchDog = threadDelay timeout
23-
result <- race watchDog job
23+
result <- race watchDog (pure job)
2424
pure $ case result of
2525
Left _ -> Nothing
2626
Right a -> Just a

‎biscuit/src/Auth/Biscuit/Token.hs‎

Lines changed: 13 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
{-# LANGUAGE FlexibleInstances #-}
44
{-# LANGUAGE KindSignatures #-}
55
{-# LANGUAGE NamedFieldPuns #-}
6+
{-# LANGUAGE RankNTypes #-}
67
{-# LANGUAGE RecordWildCards #-}
78
{- HLINT ignore "Reduce duplication" -}
89
{-|
@@ -92,7 +93,7 @@ import Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess,
9293
collectWorld,
9394
queryAvailableFacts,
9495
queryGeneratedFacts,
95-
runAuthorizerWithLimits)
96+
runAuthorizerWithTimer)
9697
import qualified Auth.Biscuit.Proto as PB
9798
import Auth.Biscuit.ProtoBufAdapter (blockToPb, pbToBlock,
9899
pbToProof,
@@ -103,6 +104,7 @@ import Auth.Biscuit.ProtoBufAdapter (blockToPb, pbToBlock,
103104
thirdPartyBlockContentsToPb,
104105
thirdPartyBlockRequestToPb)
105106
import Auth.Biscuit.Symbols
107+
import Auth.Biscuit.Timer (timerIO)
106108

107109
-- | Protobuf serialization does not have a guaranteed deterministic behaviour,
108110
-- so we need to keep the initial serialized payload around in order to compute
@@ -555,9 +557,10 @@ getRevocationIds Biscuit{authority, blocks} =
555557
getRevocationId (_, sig, _, _, _) = sigBytes sig
556558
in getRevocationId <$> allBlocks
557559

558-
-- | Generic version of 'authorizeBiscuitWithLimits' which takes custom 'Limits'.
559-
authorizeBiscuitWithLimits :: Limits -> Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof))
560-
authorizeBiscuitWithLimits l biscuit@Biscuit{..} authorizer =
560+
authorizeBiscuitWithTimer :: Functor f =>
561+
(forall a. Int -> a -> f (Maybe a)) ->
562+
Limits -> Biscuit proof Verified -> Authorizer -> f (Either ExecutionError (AuthorizedBiscuit proof))
563+
authorizeBiscuitWithTimer timer l biscuit@Biscuit{..} authorizer =
561564
let toBlockWithRevocationId ((_, block), sig, _, eSig, _) = (block, sigBytes sig, snd <$> eSig)
562565
-- the authority block can't be externally signed. If it carries a signature, it won't be
563566
-- 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 =
569572
, authorizationSuccess
570573
}
571574
in fmap withBiscuit <$>
572-
runAuthorizerWithLimits l
575+
runAuthorizerWithTimer timer l
573576
(dropExternalPk $ toBlockWithRevocationId authority)
574577
(toBlockWithRevocationId <$> blocks)
575578
authorizer
576579

580+
-- | Generic version of 'authorizeBiscuitWithLimits' which takes custom 'Limits'.
581+
authorizeBiscuitWithLimits :: Limits -> Biscuit proof Verified -> Authorizer -> IO (Either ExecutionError (AuthorizedBiscuit proof))
582+
authorizeBiscuitWithLimits =
583+
authorizeBiscuitWithTimer timerIO
584+
577585
-- | Given a biscuit with a verified signature and an authorizer (a set of facts, rules, checks
578586
-- and policies), verify a biscuit:
579587
--

‎biscuit/test/Spec/ScopedExecutor.hs‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ import Data.Either (isRight)
1212
import Data.Map.Strict as Map
1313
import Data.Set as Set
1414
import Data.Text (Text, unpack)
15-
import Test.Tasty
15+
import Test.Tasty hiding (Timeout)
1616
import Test.Tasty.HUnit
1717

1818
import Auth.Biscuit (addBlock, addSignedBlock,
@@ -29,6 +29,7 @@ import Auth.Biscuit.Datalog.Executor (ExecutionError (..),
2929
import Auth.Biscuit.Datalog.Parser (authorizer, block, check,
3030
query, run)
3131
import Auth.Biscuit.Datalog.ScopedExecutor
32+
import Auth.Biscuit.Timer (timerIO)
3233

3334
specs :: TestTree
3435
specs = testGroup "Block-scoped Datalog Evaluation"
@@ -44,6 +45,7 @@ specs = testGroup "Block-scoped Datalog Evaluation"
4445
, revocationIdsAreInjected
4546
, authorizerFactsAreQueried
4647
, biscuitFactsAreQueried
48+
, evaluationReachesTimeout
4749
]
4850

4951
authorizerOnlySeesAuthority :: TestTree
@@ -334,3 +336,11 @@ biscuitFactsAreQueried = testGroup "Biscuit can be queried"
334336
]
335337
user @?= Right expected
336338
]
339+
340+
evaluationReachesTimeout :: TestTree
341+
evaluationReachesTimeout = testCase "Timeout is reached while runnning authorization" $ do
342+
let limits = defaultLimits { maxTime = 0 }
343+
authority = [block|fact(true);rule($t) <- fact($t), "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa".matches("/^a?a?a?a?a?a?a?a?a?a?a?a?aaaaaaaaaaaa$/");|]
344+
auth = [authorizer|allow if rule(true);|]
345+
res <- runAuthorizerWithTimer timerIO limits (authority, "", Nothing) [] auth
346+
res @?= Left Timeout

0 commit comments

Comments
 (0)