{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TupleSections              #-}
module Auth.Biscuit.Datalog.ScopedExecutor
  ( BlockWithRevocationId
  , runAuthorizer
  , runAuthorizerWithLimits
  , runAuthorizerNoTimeout
  , runFactGeneration
  , PureExecError (..)
  , AuthorizationSuccess (..)
  , getBindings
  , queryGeneratedFacts
  , queryAvailableFacts
  , getVariableValues
  , getSingleVariableValue
  , FactGroup (..)
  , collectWorld
  ) where

import           Control.Monad                 (unless, when)
import           Control.Monad.State           (StateT (..), evalStateT, get,
                                                gets, lift, put)
import           Data.Bifunctor                (first)
import           Data.ByteString               (ByteString)
import           Data.Foldable                 (traverse_)
import           Data.List                     (genericLength)
import           Data.List.NonEmpty            (NonEmpty)
import qualified Data.List.NonEmpty            as NE
import           Data.Map                      (Map)
import qualified Data.Map                      as Map
import           Data.Map.Strict               ((!?))
import           Data.Maybe                    (mapMaybe)
import           Data.Set                      (Set)
import qualified Data.Set                      as Set
import           Data.Text                     (Text)
import           Numeric.Natural               (Natural)
import           Validation                    (Validation (..))

import           Auth.Biscuit.Crypto           (PublicKey)
import           Auth.Biscuit.Datalog.AST
import           Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..),
                                                FactGroup (..), Limits (..),
                                                MatchedQuery (..),
                                                ResultError (..), Scoped,
                                                checkCheck, checkPolicy,
                                                countFacts, defaultLimits,
                                                fromScopedFacts,
                                                getBindingsForRuleBody,
                                                getFactsForRule,
                                                keepAuthorized', toScopedFacts)
import           Auth.Biscuit.Datalog.Parser   (fact)
import           Auth.Biscuit.Timer            (timer)

type BlockWithRevocationId = (Block, ByteString, Maybe PublicKey)

-- | A subset of 'ExecutionError' that can only happen during fact generation
data PureExecError = Facts | Iterations | BadRule
  deriving (PureExecError -> PureExecError -> Bool
(PureExecError -> PureExecError -> Bool)
-> (PureExecError -> PureExecError -> Bool) -> Eq PureExecError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PureExecError -> PureExecError -> Bool
== :: PureExecError -> PureExecError -> Bool
$c/= :: PureExecError -> PureExecError -> Bool
/= :: PureExecError -> PureExecError -> Bool
Eq, Int -> PureExecError -> ShowS
[PureExecError] -> ShowS
PureExecError -> String
(Int -> PureExecError -> ShowS)
-> (PureExecError -> String)
-> ([PureExecError] -> ShowS)
-> Show PureExecError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PureExecError -> ShowS
showsPrec :: Int -> PureExecError -> ShowS
$cshow :: PureExecError -> String
show :: PureExecError -> String
$cshowList :: [PureExecError] -> ShowS
showList :: [PureExecError] -> ShowS
Show)

-- | Proof that a biscuit was authorized successfully. In addition to the matched
-- @allow query@, the generated facts are kept around for further querying.
-- Since only authority facts can be trusted, they are kept separate.
data AuthorizationSuccess
  = AuthorizationSuccess
  { AuthorizationSuccess -> MatchedQuery
matchedAllowQuery :: MatchedQuery
  -- ^ The allow query that matched
  , AuthorizationSuccess -> FactGroup
allFacts          :: FactGroup
  -- ^ All the facts that were generated by the biscuit, grouped by their origin
  , AuthorizationSuccess -> Limits
limits            :: Limits
  -- ^ Limits used when running datalog. It is kept around to allow further
  -- datalog computation when querying facts
  }
  deriving (AuthorizationSuccess -> AuthorizationSuccess -> Bool
(AuthorizationSuccess -> AuthorizationSuccess -> Bool)
-> (AuthorizationSuccess -> AuthorizationSuccess -> Bool)
-> Eq AuthorizationSuccess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
== :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
$c/= :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
/= :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
Eq, Int -> AuthorizationSuccess -> ShowS
[AuthorizationSuccess] -> ShowS
AuthorizationSuccess -> String
(Int -> AuthorizationSuccess -> ShowS)
-> (AuthorizationSuccess -> String)
-> ([AuthorizationSuccess] -> ShowS)
-> Show AuthorizationSuccess
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthorizationSuccess -> ShowS
showsPrec :: Int -> AuthorizationSuccess -> ShowS
$cshow :: AuthorizationSuccess -> String
show :: AuthorizationSuccess -> String
$cshowList :: [AuthorizationSuccess] -> ShowS
showList :: [AuthorizationSuccess] -> ShowS
Show)

-- | Get the matched variables from the @allow@ query used to authorize the biscuit.
-- This can be used in conjuction with 'getVariableValues' or 'getSingleVariableValue'
-- to extract the actual values
getBindings :: AuthorizationSuccess -> Set Bindings
getBindings :: AuthorizationSuccess -> Set Bindings
getBindings AuthorizationSuccess{$sel:matchedAllowQuery:AuthorizationSuccess :: AuthorizationSuccess -> MatchedQuery
matchedAllowQuery=MatchedQuery{Set Bindings
bindings :: Set Bindings
bindings :: MatchedQuery -> Set Bindings
bindings}} = Set 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 :: BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> IO (Either ExecutionError AuthorizationSuccess)
runAuthorizer = Limits
-> BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> IO (Either ExecutionError AuthorizationSuccess)
runAuthorizerWithLimits Limits
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 :: Limits
-> BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> IO (Either ExecutionError AuthorizationSuccess)
runAuthorizerWithLimits l :: Limits
l@Limits{Bool
Int
maxFacts :: Int
maxIterations :: Int
maxTime :: Int
allowRegexes :: Bool
maxFacts :: Limits -> Int
maxIterations :: Limits -> Int
maxTime :: Limits -> Int
allowRegexes :: Limits -> Bool
..} BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
v = do
  Maybe (Either ExecutionError AuthorizationSuccess)
resultOrTimeout <- Int
-> IO (Either ExecutionError AuthorizationSuccess)
-> IO (Maybe (Either ExecutionError AuthorizationSuccess))
forall a. Int -> IO a -> IO (Maybe a)
timer Int
maxTime (IO (Either ExecutionError AuthorizationSuccess)
 -> IO (Maybe (Either ExecutionError AuthorizationSuccess)))
-> IO (Either ExecutionError AuthorizationSuccess)
-> IO (Maybe (Either ExecutionError AuthorizationSuccess))
forall a b. (a -> b) -> a -> b
$ Either ExecutionError AuthorizationSuccess
-> IO (Either ExecutionError AuthorizationSuccess)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExecutionError AuthorizationSuccess
 -> IO (Either ExecutionError AuthorizationSuccess))
-> Either ExecutionError AuthorizationSuccess
-> IO (Either ExecutionError AuthorizationSuccess)
forall a b. (a -> b) -> a -> b
$ Limits
-> BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> Either ExecutionError AuthorizationSuccess
runAuthorizerNoTimeout Limits
l BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
v
  Either ExecutionError AuthorizationSuccess
-> IO (Either ExecutionError AuthorizationSuccess)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExecutionError AuthorizationSuccess
 -> IO (Either ExecutionError AuthorizationSuccess))
-> Either ExecutionError AuthorizationSuccess
-> IO (Either ExecutionError AuthorizationSuccess)
forall a b. (a -> b) -> a -> b
$ case Maybe (Either ExecutionError AuthorizationSuccess)
resultOrTimeout of
    Maybe (Either ExecutionError AuthorizationSuccess)
Nothing -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left ExecutionError
Timeout
    Just Either ExecutionError AuthorizationSuccess
r  -> Either ExecutionError AuthorizationSuccess
r


mkRevocationIdFacts :: BlockWithRevocationId -> [BlockWithRevocationId]
                    -> Set Fact
mkRevocationIdFacts :: BlockWithRevocationId -> [BlockWithRevocationId] -> Set Fact
mkRevocationIdFacts BlockWithRevocationId
authority [BlockWithRevocationId]
blocks =
  let allIds :: [(Int, ByteString)]
      allIds :: [(Int, ByteString)]
allIds = [Int] -> [ByteString] -> [(Int, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([ByteString] -> [(Int, ByteString)])
-> [ByteString] -> [(Int, ByteString)]
forall a b. (a -> b) -> a -> b
$ BlockWithRevocationId -> ByteString
forall {a} {b} {c}. (a, b, c) -> b
snd' (BlockWithRevocationId -> ByteString)
-> [BlockWithRevocationId] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockWithRevocationId
authority BlockWithRevocationId
-> [BlockWithRevocationId] -> [BlockWithRevocationId]
forall a. a -> [a] -> [a]
: [BlockWithRevocationId]
blocks
      snd' :: (a, b, c) -> b
snd' (a
_,b
b,c
_) = b
b
      mkFact :: (t, t) -> Fact
mkFact (t
index, t
rid) = [fact|revocation_id({index}, {rid})|]
   in [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList ([Fact] -> Set Fact) -> [Fact] -> Set Fact
forall a b. (a -> b) -> a -> b
$ (Int, ByteString) -> Fact
forall {t} {t}.
(ToTerm t 'NotWithinSet 'InFact, ToTerm t 'NotWithinSet 'InFact) =>
(t, t) -> Fact
mkFact ((Int, ByteString) -> Fact) -> [(Int, ByteString)] -> [Fact]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, ByteString)]
allIds

data ComputeState
  = ComputeState
  { ComputeState -> Limits
sLimits     :: Limits -- readonly
  , ComputeState -> Map Natural (Set EvalRule)
sRules      :: Map Natural (Set EvalRule) -- readonly
  , ComputeState -> Natural
sBlockCount :: Natural
  -- state
  , ComputeState -> Int
sIterations :: Int -- elapsed iterations
  , ComputeState -> FactGroup
sFacts      :: FactGroup -- facts generated so far
  }
  deriving (ComputeState -> ComputeState -> Bool
(ComputeState -> ComputeState -> Bool)
-> (ComputeState -> ComputeState -> Bool) -> Eq ComputeState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ComputeState -> ComputeState -> Bool
== :: ComputeState -> ComputeState -> Bool
$c/= :: ComputeState -> ComputeState -> Bool
/= :: ComputeState -> ComputeState -> Bool
Eq, Int -> ComputeState -> ShowS
[ComputeState] -> ShowS
ComputeState -> String
(Int -> ComputeState -> ShowS)
-> (ComputeState -> String)
-> ([ComputeState] -> ShowS)
-> Show ComputeState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComputeState -> ShowS
showsPrec :: Int -> ComputeState -> ShowS
$cshow :: ComputeState -> String
show :: ComputeState -> String
$cshowList :: [ComputeState] -> ShowS
showList :: [ComputeState] -> ShowS
Show)

mkInitState :: Limits -> BlockWithRevocationId -> [BlockWithRevocationId] -> Authorizer -> ComputeState
mkInitState :: Limits
-> BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> ComputeState
mkInitState Limits
limits BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
authorizer =
  let fst' :: (a, b, c) -> a
fst' (a
a,b
_,c
_) = a
a
      trd' :: (a, b, c) -> c
trd' (a
_,b
_,c
c) = c
c
      sBlockCount :: Natural
sBlockCount = Natural
1 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ [BlockWithRevocationId] -> Natural
forall i a. Num i => [a] -> i
genericLength [BlockWithRevocationId]
blocks
      externalKeys :: [Maybe PublicKey]
externalKeys = Maybe PublicKey
forall a. Maybe a
Nothing Maybe PublicKey -> [Maybe PublicKey] -> [Maybe PublicKey]
forall a. a -> [a] -> [a]
: (BlockWithRevocationId -> Maybe PublicKey
forall {a} {b} {c}. (a, b, c) -> c
trd' (BlockWithRevocationId -> Maybe PublicKey)
-> [BlockWithRevocationId] -> [Maybe PublicKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks)
      revocationWorld :: (Map Natural (Set EvalRule), FactGroup)
revocationWorld = (Map Natural (Set EvalRule)
forall a. Monoid a => a
mempty, Map (Set Natural) (Set Fact) -> FactGroup
FactGroup (Map (Set Natural) (Set Fact) -> FactGroup)
-> Map (Set Natural) (Set Fact) -> FactGroup
forall a b. (a -> b) -> a -> b
$ Set Natural -> Set Fact -> Map (Set Natural) (Set Fact)
forall k a. k -> a -> Map k a
Map.singleton (Natural -> Set Natural
forall a. a -> Set a
Set.singleton Natural
sBlockCount) (Set Fact -> Map (Set Natural) (Set Fact))
-> Set Fact -> Map (Set Natural) (Set Fact)
forall a b. (a -> b) -> a -> b
$ BlockWithRevocationId -> [BlockWithRevocationId] -> Set Fact
mkRevocationIdFacts BlockWithRevocationId
authority [BlockWithRevocationId]
blocks)
      firstBlock :: Block
firstBlock = BlockWithRevocationId -> Block
forall {a} {b} {c}. (a, b, c) -> a
fst' BlockWithRevocationId
authority
      otherBlocks :: [Block]
otherBlocks = BlockWithRevocationId -> Block
forall {a} {b} {c}. (a, b, c) -> a
fst' (BlockWithRevocationId -> Block)
-> [BlockWithRevocationId] -> [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks
      allBlocks :: [(Natural, Block)]
allBlocks = [Natural] -> [Block] -> [(Natural, Block)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
0..] (Block
firstBlock Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
otherBlocks) [(Natural, Block)] -> [(Natural, Block)] -> [(Natural, Block)]
forall a. Semigroup a => a -> a -> a
<> [(Natural
sBlockCount, Authorizer -> Block
forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Authorizer' evalCtx ctx -> Block' evalCtx ctx
vBlock Authorizer
authorizer)]
      (Map Natural (Set EvalRule)
sRules, FactGroup
sFacts) = (Map Natural (Set EvalRule), FactGroup)
revocationWorld (Map Natural (Set EvalRule), FactGroup)
-> (Map Natural (Set EvalRule), FactGroup)
-> (Map Natural (Set EvalRule), FactGroup)
forall a. Semigroup a => a -> a -> a
<> ((Natural, Block) -> (Map Natural (Set EvalRule), FactGroup))
-> [(Natural, Block)] -> (Map Natural (Set EvalRule), FactGroup)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup))
-> (Natural, EvalBlock) -> (Map Natural (Set EvalRule), FactGroup)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup)
collectWorld ((Natural, EvalBlock) -> (Map Natural (Set EvalRule), FactGroup))
-> ((Natural, Block) -> (Natural, EvalBlock))
-> (Natural, Block)
-> (Map Natural (Set EvalRule), FactGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> EvalBlock) -> (Natural, Block) -> (Natural, EvalBlock)
forall a b. (a -> b) -> (Natural, a) -> (Natural, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Maybe PublicKey] -> Block -> EvalBlock
forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
[Maybe PublicKey]
-> elem 'Repr 'Representation -> elem 'Eval 'Representation
toEvaluation [Maybe PublicKey]
externalKeys)) [(Natural, Block)]
allBlocks
   in ComputeState
        { $sel:sLimits:ComputeState :: Limits
sLimits = Limits
limits
        , Map Natural (Set EvalRule)
$sel:sRules:ComputeState :: Map Natural (Set EvalRule)
sRules :: Map Natural (Set EvalRule)
sRules
        , Natural
$sel:sBlockCount:ComputeState :: Natural
sBlockCount :: Natural
sBlockCount
        , $sel:sIterations:ComputeState :: Int
sIterations = Int
0
        , FactGroup
$sel:sFacts:ComputeState :: FactGroup
sFacts :: FactGroup
sFacts
        }

runAuthorizerNoTimeout :: Limits
                       -> BlockWithRevocationId
                       -> [BlockWithRevocationId]
                       -> Authorizer
                       -> Either ExecutionError AuthorizationSuccess
runAuthorizerNoTimeout :: Limits
-> BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> Either ExecutionError AuthorizationSuccess
runAuthorizerNoTimeout Limits
limits BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
authorizer = do
  let fst' :: (a, b, c) -> a
fst' (a
a,b
_,c
_) = a
a
      trd' :: (a, b, c) -> c
trd' (a
_,b
_,c
c) = c
c
      blockCount :: Natural
blockCount = Natural
1 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ [BlockWithRevocationId] -> Natural
forall i a. Num i => [a] -> i
genericLength [BlockWithRevocationId]
blocks
      externalKeys :: [Maybe PublicKey]
externalKeys = Maybe PublicKey
forall a. Maybe a
Nothing Maybe PublicKey -> [Maybe PublicKey] -> [Maybe PublicKey]
forall a. a -> [a] -> [a]
: (BlockWithRevocationId -> Maybe PublicKey
forall {a} {b} {c}. (a, b, c) -> c
trd' (BlockWithRevocationId -> Maybe PublicKey)
-> [BlockWithRevocationId] -> [Maybe PublicKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks)
      <$$> :: (a -> b) -> [(Natural, a)] -> [(Natural, b)]
(<$$>) = ((Natural, a) -> (Natural, b)) -> [(Natural, a)] -> [(Natural, b)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Natural, a) -> (Natural, b))
 -> [(Natural, a)] -> [(Natural, b)])
-> ((a -> b) -> (Natural, a) -> (Natural, b))
-> (a -> b)
-> [(Natural, a)]
-> [(Natural, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (Natural, a) -> (Natural, b)
forall a b. (a -> b) -> (Natural, a) -> (Natural, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      <$$$> :: (a -> b) -> [(Natural, [a])] -> [(Natural, [b])]
(<$$$>) = ((Natural, [a]) -> (Natural, [b]))
-> [(Natural, [a])] -> [(Natural, [b])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Natural, [a]) -> (Natural, [b]))
 -> [(Natural, [a])] -> [(Natural, [b])])
-> ((a -> b) -> (Natural, [a]) -> (Natural, [b]))
-> (a -> b)
-> [(Natural, [a])]
-> [(Natural, [b])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [b]) -> (Natural, [a]) -> (Natural, [b])
forall a b. (a -> b) -> (Natural, a) -> (Natural, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([a] -> [b]) -> (Natural, [a]) -> (Natural, [b]))
-> ((a -> b) -> [a] -> [b])
-> (a -> b)
-> (Natural, [a])
-> (Natural, [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      initState :: ComputeState
initState = Limits
-> BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> ComputeState
mkInitState Limits
limits BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
authorizer
      toExecutionError :: PureExecError -> ExecutionError
toExecutionError = \case
        PureExecError
Facts      -> ExecutionError
TooManyFacts
        PureExecError
Iterations -> ExecutionError
TooManyIterations
        PureExecError
BadRule    -> ExecutionError
InvalidRule
  FactGroup
allFacts <- (PureExecError -> ExecutionError)
-> Either PureExecError FactGroup
-> Either ExecutionError FactGroup
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PureExecError -> ExecutionError
toExecutionError (Either PureExecError FactGroup -> Either ExecutionError FactGroup)
-> Either PureExecError FactGroup
-> Either ExecutionError FactGroup
forall a b. (a -> b) -> a -> b
$ ComputeState -> Either PureExecError FactGroup
computeAllFacts ComputeState
initState
  let checks :: [(Natural, [Check])]
checks = Block -> [Check]
forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Check' evalCtx ctx]
bChecks (Block -> [Check]) -> [(Natural, Block)] -> [(Natural, [Check])]
forall {a} {b}. (a -> b) -> [(Natural, a)] -> [(Natural, b)]
<$$> ( [Natural] -> [Block] -> [(Natural, Block)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
0..] (BlockWithRevocationId -> Block
forall {a} {b} {c}. (a, b, c) -> a
fst' (BlockWithRevocationId -> Block)
-> [BlockWithRevocationId] -> [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockWithRevocationId
authority BlockWithRevocationId
-> [BlockWithRevocationId] -> [BlockWithRevocationId]
forall a. a -> [a] -> [a]
: [BlockWithRevocationId]
blocks)
                           [(Natural, Block)] -> [(Natural, Block)] -> [(Natural, Block)]
forall a. Semigroup a => a -> a -> a
<> [(Natural
blockCount,Authorizer -> Block
forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Authorizer' evalCtx ctx -> Block' evalCtx ctx
vBlock Authorizer
authorizer)]
                            )
      policies :: [Policy' 'Repr 'Representation]
policies = Authorizer -> [Policy' 'Repr 'Representation]
forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Authorizer' evalCtx ctx -> [Policy' evalCtx ctx]
vPolicies Authorizer
authorizer
      checkResults :: Validation (NonEmpty Check) ()
checkResults = Limits
-> Natural
-> FactGroup
-> [(Natural, [EvalCheck])]
-> Validation (NonEmpty Check) ()
checkChecks Limits
limits Natural
blockCount FactGroup
allFacts ([Maybe PublicKey] -> Check -> EvalCheck
checkToEvaluation [Maybe PublicKey]
externalKeys (Check -> EvalCheck)
-> [(Natural, [Check])] -> [(Natural, [EvalCheck])]
forall {a} {b}. (a -> b) -> [(Natural, [a])] -> [(Natural, [b])]
<$$$> [(Natural, [Check])]
checks)
      policyResults :: Either (Maybe MatchedQuery) MatchedQuery
policyResults = Limits
-> Natural
-> FactGroup
-> [EvalPolicy]
-> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies Limits
limits Natural
blockCount FactGroup
allFacts ([Maybe PublicKey] -> Policy' 'Repr 'Representation -> EvalPolicy
policyToEvaluation [Maybe PublicKey]
externalKeys (Policy' 'Repr 'Representation -> EvalPolicy)
-> [Policy' 'Repr 'Representation] -> [EvalPolicy]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Policy' 'Repr 'Representation]
policies)
  case (Validation (NonEmpty Check) ()
checkResults, Either (Maybe MatchedQuery) MatchedQuery
policyResults) of
    (Success (), Left Maybe MatchedQuery
Nothing)  -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError AuthorizationSuccess)
-> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Check] -> ResultError
NoPoliciesMatched []
    (Success (), Left (Just MatchedQuery
p)) -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError AuthorizationSuccess)
-> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Check] -> MatchedQuery -> ResultError
DenyRuleMatched [] MatchedQuery
p
    (Failure NonEmpty Check
cs, Left Maybe MatchedQuery
Nothing)  -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError AuthorizationSuccess)
-> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Check] -> ResultError
NoPoliciesMatched (NonEmpty Check -> [Check]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Check
cs)
    (Failure NonEmpty Check
cs, Left (Just MatchedQuery
p)) -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError AuthorizationSuccess)
-> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Check] -> MatchedQuery -> ResultError
DenyRuleMatched (NonEmpty Check -> [Check]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Check
cs) MatchedQuery
p
    (Failure NonEmpty Check
cs, Right MatchedQuery
_)       -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError AuthorizationSuccess)
-> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ NonEmpty Check -> ResultError
FailedChecks NonEmpty Check
cs
    (Success (), Right MatchedQuery
p)       -> AuthorizationSuccess -> Either ExecutionError AuthorizationSuccess
forall a b. b -> Either a b
Right (AuthorizationSuccess
 -> Either ExecutionError AuthorizationSuccess)
-> AuthorizationSuccess
-> Either ExecutionError AuthorizationSuccess
forall a b. (a -> b) -> a -> b
$ AuthorizationSuccess { $sel:matchedAllowQuery:AuthorizationSuccess :: MatchedQuery
matchedAllowQuery = MatchedQuery
p
                                                                , FactGroup
$sel:allFacts:AuthorizationSuccess :: FactGroup
allFacts :: FactGroup
allFacts
                                                                , Limits
$sel:limits:AuthorizationSuccess :: Limits
limits :: Limits
limits
                                                                }

runStep :: StateT ComputeState (Either PureExecError) Int
runStep :: StateT ComputeState (Either PureExecError) Int
runStep = do
  state :: ComputeState
state@ComputeState{Limits
$sel:sLimits:ComputeState :: ComputeState -> Limits
sLimits :: Limits
sLimits,FactGroup
$sel:sFacts:ComputeState :: ComputeState -> FactGroup
sFacts :: FactGroup
sFacts,Map Natural (Set EvalRule)
$sel:sRules:ComputeState :: ComputeState -> Map Natural (Set EvalRule)
sRules :: Map Natural (Set EvalRule)
sRules,Natural
$sel:sBlockCount:ComputeState :: ComputeState -> Natural
sBlockCount :: Natural
sBlockCount,Int
$sel:sIterations:ComputeState :: ComputeState -> Int
sIterations :: Int
sIterations} <- StateT ComputeState (Either PureExecError) ComputeState
forall s (m :: * -> *). MonadState s m => m s
get
  let Limits{Int
maxFacts :: Limits -> Int
maxFacts :: Int
maxFacts, Int
maxIterations :: Limits -> Int
maxIterations :: Int
maxIterations} = Limits
sLimits
      previousCount :: Int
previousCount = FactGroup -> Int
countFacts FactGroup
sFacts
      newFacts :: FactGroup
newFacts = FactGroup
sFacts FactGroup -> FactGroup -> FactGroup
forall a. Semigroup a => a -> a -> a
<> Limits
-> Natural -> Map Natural (Set EvalRule) -> FactGroup -> FactGroup
extend Limits
sLimits Natural
sBlockCount Map Natural (Set EvalRule)
sRules FactGroup
sFacts
      newCount :: Int
newCount = FactGroup -> Int
countFacts FactGroup
newFacts
      -- counting the facts returned by `extend` is not equivalent to
      -- comparing complete counts, as `extend` may return facts that
      -- are already present in `sFacts`
      addedFactsCount :: Int
addedFactsCount = Int
newCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
previousCount
  Bool
-> StateT ComputeState (Either PureExecError) ()
-> StateT ComputeState (Either PureExecError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxFacts) (StateT ComputeState (Either PureExecError) ()
 -> StateT ComputeState (Either PureExecError) ())
-> StateT ComputeState (Either PureExecError) ()
-> StateT ComputeState (Either PureExecError) ()
forall a b. (a -> b) -> a -> b
$ Either PureExecError ()
-> StateT ComputeState (Either PureExecError) ()
forall (m :: * -> *) a. Monad m => m a -> StateT ComputeState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either PureExecError ()
 -> StateT ComputeState (Either PureExecError) ())
-> Either PureExecError ()
-> StateT ComputeState (Either PureExecError) ()
forall a b. (a -> b) -> a -> b
$ PureExecError -> Either PureExecError ()
forall a b. a -> Either a b
Left PureExecError
Facts
  Bool
-> StateT ComputeState (Either PureExecError) ()
-> StateT ComputeState (Either PureExecError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sIterations Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxIterations) (StateT ComputeState (Either PureExecError) ()
 -> StateT ComputeState (Either PureExecError) ())
-> StateT ComputeState (Either PureExecError) ()
-> StateT ComputeState (Either PureExecError) ()
forall a b. (a -> b) -> a -> b
$ Either PureExecError ()
-> StateT ComputeState (Either PureExecError) ()
forall (m :: * -> *) a. Monad m => m a -> StateT ComputeState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either PureExecError ()
 -> StateT ComputeState (Either PureExecError) ())
-> Either PureExecError ()
-> StateT ComputeState (Either PureExecError) ()
forall a b. (a -> b) -> a -> b
$ PureExecError -> Either PureExecError ()
forall a b. a -> Either a b
Left PureExecError
Iterations
  ComputeState -> StateT ComputeState (Either PureExecError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ComputeState -> StateT ComputeState (Either PureExecError) ())
-> ComputeState -> StateT ComputeState (Either PureExecError) ()
forall a b. (a -> b) -> a -> b
$ ComputeState
state { $sel:sIterations:ComputeState :: Int
sIterations = Int
sIterations Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              , $sel:sFacts:ComputeState :: FactGroup
sFacts = FactGroup
newFacts
              }
  Int -> StateT ComputeState (Either PureExecError) Int
forall a. a -> StateT ComputeState (Either PureExecError) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
addedFactsCount

-- | Check if every variable from the head is present in the body
checkRuleHead :: EvalRule -> Bool
checkRuleHead :: EvalRule -> Bool
checkRuleHead Rule{Predicate' 'InPredicate 'Representation
rhead :: Predicate' 'InPredicate 'Representation
rhead :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> Predicate' 'InPredicate ctx
rhead, [Predicate' 'InPredicate 'Representation]
body :: [Predicate' 'InPredicate 'Representation]
body :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> [Predicate' 'InPredicate ctx]
body} =
  let headVars :: Set Text
headVars = [Predicate' 'InPredicate 'Representation] -> Set Text
forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Text
extractVariables [Predicate' 'InPredicate 'Representation
rhead]
      bodyVars :: Set Text
bodyVars = [Predicate' 'InPredicate 'Representation] -> Set Text
forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Text
extractVariables [Predicate' 'InPredicate 'Representation]
body
   in Set Text
headVars Set Text -> Set Text -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Text
bodyVars

-- | Repeatedly generate new facts until it converges (no new
-- facts are generated)
computeAllFacts :: ComputeState -> Either PureExecError FactGroup
computeAllFacts :: ComputeState -> Either PureExecError FactGroup
computeAllFacts initState :: ComputeState
initState@ComputeState{Map Natural (Set EvalRule)
$sel:sRules:ComputeState :: ComputeState -> Map Natural (Set EvalRule)
sRules :: Map Natural (Set EvalRule)
sRules} = do
  let checkRules :: Bool
checkRules = (Set EvalRule -> Bool) -> Map Natural (Set EvalRule) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((EvalRule -> Bool) -> Set EvalRule -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all EvalRule -> Bool
checkRuleHead) Map Natural (Set EvalRule)
sRules
      go :: StateT ComputeState (Either PureExecError) FactGroup
go = do
        Int
newFacts <- StateT ComputeState (Either PureExecError) Int
runStep
        if Int
newFacts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then StateT ComputeState (Either PureExecError) FactGroup
go else (ComputeState -> FactGroup)
-> StateT ComputeState (Either PureExecError) FactGroup
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ComputeState -> FactGroup
sFacts

  Bool -> Either PureExecError () -> Either PureExecError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
checkRules (Either PureExecError () -> Either PureExecError ())
-> Either PureExecError () -> Either PureExecError ()
forall a b. (a -> b) -> a -> b
$ PureExecError -> Either PureExecError ()
forall a b. a -> Either a b
Left PureExecError
BadRule
  StateT ComputeState (Either PureExecError) FactGroup
-> ComputeState -> Either PureExecError FactGroup
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT ComputeState (Either PureExecError) FactGroup
go ComputeState
initState

-- | Small helper used in tests to directly provide rules and facts without creating
-- a biscuit token
runFactGeneration :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> Either PureExecError FactGroup
runFactGeneration :: Limits
-> Natural
-> Map Natural (Set EvalRule)
-> FactGroup
-> Either PureExecError FactGroup
runFactGeneration Limits
sLimits Natural
sBlockCount Map Natural (Set EvalRule)
sRules FactGroup
sFacts =
  let initState :: ComputeState
initState = ComputeState{$sel:sIterations:ComputeState :: Int
sIterations = Int
0, Natural
Map Natural (Set EvalRule)
FactGroup
Limits
$sel:sLimits:ComputeState :: Limits
$sel:sRules:ComputeState :: Map Natural (Set EvalRule)
$sel:sBlockCount:ComputeState :: Natural
$sel:sFacts:ComputeState :: FactGroup
sLimits :: Limits
sBlockCount :: Natural
sRules :: Map Natural (Set EvalRule)
sFacts :: FactGroup
..}
   in ComputeState -> Either PureExecError FactGroup
computeAllFacts ComputeState
initState

checkChecks :: Limits -> Natural -> FactGroup -> [(Natural, [EvalCheck])] -> Validation (NonEmpty Check) ()
checkChecks :: Limits
-> Natural
-> FactGroup
-> [(Natural, [EvalCheck])]
-> Validation (NonEmpty Check) ()
checkChecks Limits
limits Natural
blockCount FactGroup
allFacts =
  ((Natural, [EvalCheck]) -> Validation (NonEmpty Check) ())
-> [(Natural, [EvalCheck])] -> Validation (NonEmpty Check) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Natural -> [EvalCheck] -> Validation (NonEmpty Check) ())
-> (Natural, [EvalCheck]) -> Validation (NonEmpty Check) ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Natural -> [EvalCheck] -> Validation (NonEmpty Check) ())
 -> (Natural, [EvalCheck]) -> Validation (NonEmpty Check) ())
-> (Natural -> [EvalCheck] -> Validation (NonEmpty Check) ())
-> (Natural, [EvalCheck])
-> Validation (NonEmpty Check) ()
forall a b. (a -> b) -> a -> b
$ Limits
-> Natural
-> FactGroup
-> Natural
-> [EvalCheck]
-> Validation (NonEmpty Check) ()
checkChecksForGroup Limits
limits Natural
blockCount FactGroup
allFacts)

checkChecksForGroup :: Limits -> Natural -> FactGroup -> Natural -> [EvalCheck] -> Validation (NonEmpty Check) ()
checkChecksForGroup :: Limits
-> Natural
-> FactGroup
-> Natural
-> [EvalCheck]
-> Validation (NonEmpty Check) ()
checkChecksForGroup Limits
limits Natural
blockCount FactGroup
allFacts Natural
checksBlockId =
  (EvalCheck -> Validation (NonEmpty Check) ())
-> [EvalCheck] -> Validation (NonEmpty Check) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Limits
-> Natural
-> Natural
-> FactGroup
-> EvalCheck
-> Validation (NonEmpty Check) ()
checkCheck Limits
limits Natural
blockCount Natural
checksBlockId FactGroup
allFacts)

checkPolicies :: Limits -> Natural -> FactGroup -> [EvalPolicy] -> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies :: Limits
-> Natural
-> FactGroup
-> [EvalPolicy]
-> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies Limits
limits Natural
blockCount FactGroup
allFacts [EvalPolicy]
policies =
  let results :: [Either MatchedQuery MatchedQuery]
results = (EvalPolicy -> Maybe (Either MatchedQuery MatchedQuery))
-> [EvalPolicy] -> [Either MatchedQuery MatchedQuery]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Limits
-> Natural
-> FactGroup
-> EvalPolicy
-> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy Limits
limits Natural
blockCount FactGroup
allFacts) [EvalPolicy]
policies
   in case [Either MatchedQuery MatchedQuery]
results of
        Either MatchedQuery MatchedQuery
p : [Either MatchedQuery MatchedQuery]
_ -> (MatchedQuery -> Maybe MatchedQuery)
-> Either MatchedQuery MatchedQuery
-> Either (Maybe MatchedQuery) MatchedQuery
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MatchedQuery -> Maybe MatchedQuery
forall a. a -> Maybe a
Just Either MatchedQuery MatchedQuery
p
        []    -> Maybe MatchedQuery -> Either (Maybe MatchedQuery) MatchedQuery
forall a b. a -> Either a b
Left Maybe MatchedQuery
forall a. Maybe a
Nothing

-- | Generate new facts by applying rules on existing facts
extend :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> FactGroup
extend :: Limits
-> Natural -> Map Natural (Set EvalRule) -> FactGroup -> FactGroup
extend Limits
l Natural
blockCount Map Natural (Set EvalRule)
rules FactGroup
facts =
  let buildFacts :: Natural -> Set EvalRule -> FactGroup -> Set (Scoped Fact)
      buildFacts :: Natural -> Set EvalRule -> FactGroup -> Set (Scoped Fact)
buildFacts Natural
ruleBlockId Set EvalRule
ruleGroup FactGroup
factGroup =
        let extendRule :: EvalRule -> Set (Scoped Fact)
            extendRule :: EvalRule -> Set (Scoped Fact)
extendRule r :: EvalRule
r@Rule{Set (RuleScope' 'Eval 'Representation)
scope :: Set (RuleScope' 'Eval 'Representation)
scope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
scope} = Limits -> Set (Scoped Fact) -> EvalRule -> Set (Scoped Fact)
getFactsForRule Limits
l (FactGroup -> Set (Scoped Fact)
toScopedFacts (FactGroup -> Set (Scoped Fact)) -> FactGroup -> Set (Scoped Fact)
forall a b. (a -> b) -> a -> b
$ Bool
-> Natural
-> FactGroup
-> Set (RuleScope' 'Eval 'Representation)
-> Natural
-> FactGroup
keepAuthorized' Bool
False Natural
blockCount FactGroup
factGroup Set (RuleScope' 'Eval 'Representation)
scope Natural
ruleBlockId) EvalRule
r
         in (EvalRule -> Set (Scoped Fact))
-> Set EvalRule -> Set (Scoped Fact)
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap EvalRule -> Set (Scoped Fact)
extendRule Set EvalRule
ruleGroup

      extendRuleGroup :: Natural -> Set EvalRule -> FactGroup
      extendRuleGroup :: Natural -> Set EvalRule -> FactGroup
extendRuleGroup Natural
ruleBlockId Set EvalRule
ruleGroup =
            -- todo pre-filter facts based on the weakest rule scope to avoid passing too many facts
            -- to buildFacts
        let authorizedFacts :: FactGroup
authorizedFacts = FactGroup
facts -- test $ keepAuthorized facts $ Set.fromList [0..ruleBlockId]
            addRuleOrigin :: FactGroup -> FactGroup
addRuleOrigin = Map (Set Natural) (Set Fact) -> FactGroup
FactGroup (Map (Set Natural) (Set Fact) -> FactGroup)
-> (FactGroup -> Map (Set Natural) (Set Fact))
-> FactGroup
-> FactGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Fact -> Set Fact -> Set Fact)
-> (Set Natural -> Set Natural)
-> Map (Set Natural) (Set Fact)
-> Map (Set Natural) (Set Fact)
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
(<>) (Natural -> Set Natural -> Set Natural
forall a. Ord a => a -> Set a -> Set a
Set.insert Natural
ruleBlockId) (Map (Set Natural) (Set Fact) -> Map (Set Natural) (Set Fact))
-> (FactGroup -> Map (Set Natural) (Set Fact))
-> FactGroup
-> Map (Set Natural) (Set Fact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactGroup -> Map (Set Natural) (Set Fact)
getFactGroup
         in FactGroup -> FactGroup
addRuleOrigin (FactGroup -> FactGroup)
-> (Set (Scoped Fact) -> FactGroup)
-> Set (Scoped Fact)
-> FactGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Scoped Fact) -> FactGroup
fromScopedFacts (Set (Scoped Fact) -> FactGroup) -> Set (Scoped Fact) -> FactGroup
forall a b. (a -> b) -> a -> b
$ Natural -> Set EvalRule -> FactGroup -> Set (Scoped Fact)
buildFacts Natural
ruleBlockId Set EvalRule
ruleGroup FactGroup
authorizedFacts

   in ((Natural, Set EvalRule) -> FactGroup)
-> [(Natural, Set EvalRule)] -> FactGroup
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Natural -> Set EvalRule -> FactGroup)
-> (Natural, Set EvalRule) -> FactGroup
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Natural -> Set EvalRule -> FactGroup
extendRuleGroup) ([(Natural, Set EvalRule)] -> FactGroup)
-> [(Natural, Set EvalRule)] -> FactGroup
forall a b. (a -> b) -> a -> b
$ Map Natural (Set EvalRule) -> [(Natural, Set EvalRule)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Natural (Set EvalRule)
rules


collectWorld :: Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup)
collectWorld :: Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup)
collectWorld Natural
blockId Block{[EvalRule]
[EvalCheck]
[Fact]
Maybe Text
Set (RuleScope' 'Eval 'Representation)
bChecks :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Check' evalCtx ctx]
bRules :: [EvalRule]
bFacts :: [Fact]
bChecks :: [EvalCheck]
bContext :: Maybe Text
bScope :: Set (RuleScope' 'Eval 'Representation)
bRules :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Rule' evalCtx ctx]
bFacts :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Predicate' 'InFact ctx]
bContext :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> Maybe Text
bScope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
..} =
  let -- a block can define a default scope for its rule
      -- which is used unless the rule itself has defined a scope
      applyScope :: EvalRule -> EvalRule
applyScope r :: EvalRule
r@Rule{Set (RuleScope' 'Eval 'Representation)
scope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
scope :: Set (RuleScope' 'Eval 'Representation)
scope} = EvalRule
r { scope :: Set (RuleScope' 'Eval 'Representation)
scope = if Set (RuleScope' 'Eval 'Representation) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (RuleScope' 'Eval 'Representation)
scope then Set (RuleScope' 'Eval 'Representation)
bScope else Set (RuleScope' 'Eval 'Representation)
scope }
   in ( Natural -> Set EvalRule -> Map Natural (Set EvalRule)
forall k a. k -> a -> Map k a
Map.singleton Natural
blockId (Set EvalRule -> Map Natural (Set EvalRule))
-> Set EvalRule -> Map Natural (Set EvalRule)
forall a b. (a -> b) -> a -> b
$ (EvalRule -> EvalRule) -> Set EvalRule -> Set EvalRule
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map EvalRule -> EvalRule
applyScope (Set EvalRule -> Set EvalRule) -> Set EvalRule -> Set EvalRule
forall a b. (a -> b) -> a -> b
$ [EvalRule] -> Set EvalRule
forall a. Ord a => [a] -> Set a
Set.fromList [EvalRule]
bRules
      , Map (Set Natural) (Set Fact) -> FactGroup
FactGroup (Map (Set Natural) (Set Fact) -> FactGroup)
-> Map (Set Natural) (Set Fact) -> FactGroup
forall a b. (a -> b) -> a -> b
$ Set Natural -> Set Fact -> Map (Set Natural) (Set Fact)
forall k a. k -> a -> Map k a
Map.singleton (Natural -> Set Natural
forall a. a -> Set a
Set.singleton Natural
blockId) (Set Fact -> Map (Set Natural) (Set Fact))
-> Set Fact -> Map (Set Natural) (Set Fact)
forall a b. (a -> b) -> a -> b
$ [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList [Fact]
bFacts
      )

queryGeneratedFacts :: [Maybe PublicKey] -> AuthorizationSuccess -> Query -> Set Bindings
queryGeneratedFacts :: [Maybe PublicKey] -> AuthorizationSuccess -> Query -> Set Bindings
queryGeneratedFacts [Maybe PublicKey]
ePks AuthorizationSuccess{FactGroup
$sel:allFacts:AuthorizationSuccess :: AuthorizationSuccess -> FactGroup
allFacts :: FactGroup
allFacts, Limits
$sel:limits:AuthorizationSuccess :: AuthorizationSuccess -> Limits
limits :: Limits
limits} =
  [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Set Bindings
queryAvailableFacts [Maybe PublicKey]
ePks FactGroup
allFacts Limits
limits

queryAvailableFacts :: [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Set Bindings
queryAvailableFacts :: [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Set Bindings
queryAvailableFacts [Maybe PublicKey]
ePks FactGroup
allFacts Limits
limits Query
q =
  let blockCount :: Natural
blockCount = [Maybe PublicKey] -> Natural
forall i a. Num i => [a] -> i
genericLength [Maybe PublicKey]
ePks
      getBindingsForQueryItem :: QueryItem' 'Eval 'Representation -> Set Bindings
getBindingsForQueryItem QueryItem{[Predicate' 'InPredicate 'Representation]
qBody :: [Predicate' 'InPredicate 'Representation]
qBody :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Predicate' 'InPredicate ctx]
qBody,[Expression' 'Representation]
qExpressions :: [Expression' 'Representation]
qExpressions :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Expression' ctx]
qExpressions,Set (RuleScope' 'Eval 'Representation)
qScope :: Set (RuleScope' 'Eval 'Representation)
qScope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
qScope} =
        let facts :: Set (Scoped Fact)
facts = FactGroup -> Set (Scoped Fact)
toScopedFacts (FactGroup -> Set (Scoped Fact)) -> FactGroup -> Set (Scoped Fact)
forall a b. (a -> b) -> a -> b
$ Bool
-> Natural
-> FactGroup
-> Set (RuleScope' 'Eval 'Representation)
-> Natural
-> FactGroup
keepAuthorized' Bool
True Natural
blockCount FactGroup
allFacts Set (RuleScope' 'Eval 'Representation)
qScope Natural
blockCount
         in (Scoped Bindings -> Bindings)
-> Set (Scoped Bindings) -> Set Bindings
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Scoped Bindings -> Bindings
forall a b. (a, b) -> b
snd (Set (Scoped Bindings) -> Set Bindings)
-> Set (Scoped Bindings) -> Set Bindings
forall a b. (a -> b) -> a -> b
$
            Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Expression' 'Representation]
-> Set (Scoped Bindings)
getBindingsForRuleBody Limits
limits Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
qBody [Expression' 'Representation]
qExpressions
   in (QueryItem' 'Repr 'Representation -> Set Bindings)
-> Query -> Set Bindings
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (QueryItem' 'Eval 'Representation -> Set Bindings
getBindingsForQueryItem (QueryItem' 'Eval 'Representation -> Set Bindings)
-> (QueryItem' 'Repr 'Representation
    -> QueryItem' 'Eval 'Representation)
-> QueryItem' 'Repr 'Representation
-> Set Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe PublicKey]
-> QueryItem' 'Repr 'Representation
-> QueryItem' 'Eval 'Representation
forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
[Maybe PublicKey]
-> elem 'Repr 'Representation -> elem 'Eval 'Representation
toEvaluation [Maybe PublicKey]
ePks) Query
q

-- | Extract a set of values from a matched variable for a specific type.
-- Returning @Set Value@ allows to get all values, whatever their type.
getVariableValues :: (Ord t, FromValue t)
                  => Set Bindings
                  -> Text
                  -> Set t
getVariableValues :: forall t. (Ord t, FromValue t) => Set Bindings -> Text -> Set t
getVariableValues Set Bindings
bindings Text
variableName =
  let mapMaybeS :: (a -> t a) -> t a -> Set a
mapMaybeS a -> t a
f = (a -> Set a) -> t a -> Set a
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> Set a) -> t a -> Set a
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set a
forall a. a -> Set a
Set.singleton (t a -> Set a) -> (a -> t a) -> a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t a
f)
      getVar :: Bindings -> Maybe b
getVar Bindings
vars = Term' 'NotWithinSet 'InFact 'Representation -> Maybe b
forall t.
FromValue t =>
Term' 'NotWithinSet 'InFact 'Representation -> Maybe t
fromValue (Term' 'NotWithinSet 'InFact 'Representation -> Maybe b)
-> Maybe (Term' 'NotWithinSet 'InFact 'Representation) -> Maybe b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bindings
vars Bindings
-> Text -> Maybe (Term' 'NotWithinSet 'InFact 'Representation)
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
variableName
   in (Bindings -> Maybe t) -> Set Bindings -> Set t
forall {a} {t :: * -> *} {t :: * -> *} {a}.
(Ord a, Foldable t, Foldable t) =>
(a -> t a) -> t a -> Set a
mapMaybeS Bindings -> Maybe t
forall {b}. FromValue b => Bindings -> Maybe b
getVar Set Bindings
bindings

-- | Extract exactly one value from a matched variable. If the variable has 0
-- matches or more than one match, 'Nothing' will be returned
getSingleVariableValue :: (Ord t, FromValue t)
                       => Set Bindings
                       -> Text
                       -> Maybe t
getSingleVariableValue :: forall t. (Ord t, FromValue t) => Set Bindings -> Text -> Maybe t
getSingleVariableValue Set Bindings
bindings Text
variableName =
  let values :: Set t
values = Set Bindings -> Text -> Set t
forall t. (Ord t, FromValue t) => Set Bindings -> Text -> Set t
getVariableValues Set Bindings
bindings Text
variableName
   in case Set t -> [t]
forall a. Set a -> [a]
Set.toList Set t
values of
        [t
v] -> t -> Maybe t
forall a. a -> Maybe a
Just t
v
        [t]
_   -> Maybe t
forall a. Maybe a
Nothing