{-# 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                 (fold, 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PureExecError -> PureExecError -> Bool
$c/= :: PureExecError -> PureExecError -> Bool
== :: PureExecError -> PureExecError -> Bool
$c== :: PureExecError -> PureExecError -> Bool
Eq, Int -> PureExecError -> ShowS
[PureExecError] -> ShowS
PureExecError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PureExecError] -> ShowS
$cshowList :: [PureExecError] -> ShowS
show :: PureExecError -> String
$cshow :: PureExecError -> String
showsPrec :: Int -> PureExecError -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
$c/= :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
== :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
$c== :: AuthorizationSuccess -> AuthorizationSuccess -> Bool
Eq, Int -> AuthorizationSuccess -> ShowS
[AuthorizationSuccess] -> ShowS
AuthorizationSuccess -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthorizationSuccess] -> ShowS
$cshowList :: [AuthorizationSuccess] -> ShowS
show :: AuthorizationSuccess -> String
$cshow :: AuthorizationSuccess -> String
showsPrec :: Int -> AuthorizationSuccess -> ShowS
$cshowsPrec :: Int -> 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 :: MatchedQuery -> Set Bindings
bindings :: 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
allowRegexes :: Limits -> Bool
maxTime :: Limits -> Int
maxIterations :: Limits -> Int
maxFacts :: Limits -> Int
allowRegexes :: Bool
maxTime :: Int
maxIterations :: Int
maxFacts :: Int
..} BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
v = do
  Maybe (Either ExecutionError AuthorizationSuccess)
resultOrTimeout <- forall a. Int -> IO a -> IO (Maybe a)
timer Int
maxTime forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Limits
-> BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> Either ExecutionError AuthorizationSuccess
runAuthorizerNoTimeout Limits
l BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
v
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe (Either ExecutionError AuthorizationSuccess)
resultOrTimeout of
    Maybe (Either ExecutionError AuthorizationSuccess)
Nothing -> 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 = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ forall {a} {b} {c}. (a, b, c) -> b
snd' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockWithRevocationId
authority 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 forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall {t} {t}.
(ToTerm t 'NotWithinSet 'InFact, ToTerm t 'NotWithinSet 'InFact) =>
(t, t) -> Fact
mkFact 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ComputeState -> ComputeState -> Bool
$c/= :: ComputeState -> ComputeState -> Bool
== :: ComputeState -> ComputeState -> Bool
$c== :: ComputeState -> ComputeState -> Bool
Eq, Int -> ComputeState -> ShowS
[ComputeState] -> ShowS
ComputeState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ComputeState] -> ShowS
$cshowList :: [ComputeState] -> ShowS
show :: ComputeState -> String
$cshow :: ComputeState -> String
showsPrec :: Int -> ComputeState -> ShowS
$cshowsPrec :: Int -> 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 forall a. Num a => a -> a -> a
+ forall i a. Num i => [a] -> i
genericLength [BlockWithRevocationId]
blocks
      externalKeys :: [Maybe PublicKey]
externalKeys = forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: (forall {a} {b} {c}. (a, b, c) -> c
trd' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks)
      revocationWorld :: (Map Natural (Set EvalRule), FactGroup)
revocationWorld = (forall a. Monoid a => a
mempty, Map (Set Natural) (Set Fact) -> FactGroup
FactGroup forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall a. a -> Set a
Set.singleton Natural
sBlockCount) forall a b. (a -> b) -> a -> b
$ BlockWithRevocationId -> [BlockWithRevocationId] -> Set Fact
mkRevocationIdFacts BlockWithRevocationId
authority [BlockWithRevocationId]
blocks)
      firstBlock :: Block
firstBlock = forall {a} {b} {c}. (a, b, c) -> a
fst' BlockWithRevocationId
authority
      otherBlocks :: [Block]
otherBlocks = forall {a} {b} {c}. (a, b, c) -> a
fst' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks
      allBlocks :: [(Natural, Block)]
allBlocks = forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
0..] (Block
firstBlock forall a. a -> [a] -> [a]
: [Block]
otherBlocks) forall a. Semigroup a => a -> a -> a
<> [(Natural
sBlockCount, 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 forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup)
collectWorld forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
[Maybe PublicKey]
-> elem 'Repr 'Representation -> elem 'Eval 'Representation
toEvaluation [Maybe PublicKey]
externalKeys) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Natural, Block)]
allBlocks)
   in ComputeState
        { $sel:sLimits:ComputeState :: Limits
sLimits = Limits
limits
        , Map Natural (Set EvalRule)
sRules :: Map Natural (Set EvalRule)
$sel:sRules:ComputeState :: Map Natural (Set EvalRule)
sRules
        , Natural
sBlockCount :: Natural
$sel:sBlockCount:ComputeState :: Natural
sBlockCount
        , $sel:sIterations:ComputeState :: Int
sIterations = Int
0
        , FactGroup
sFacts :: FactGroup
$sel:sFacts:ComputeState :: 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 forall a. Num a => a -> a -> a
+ forall i a. Num i => [a] -> i
genericLength [BlockWithRevocationId]
blocks
      externalKeys :: [Maybe PublicKey]
externalKeys = forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: (forall {a} {b} {c}. (a, b, c) -> c
trd' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks)
      <$$> :: (a -> b) -> [(Natural, a)] -> [(Natural, b)]
(<$$>) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      <$$$> :: (a -> b) -> [(Natural, [a])] -> [(Natural, [b])]
(<$$$>) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PureExecError -> ExecutionError
toExecutionError forall a b. (a -> b) -> a -> b
$ ComputeState -> Either PureExecError FactGroup
computeAllFacts ComputeState
initState
  let checks :: [(Natural, [Check])]
checks = forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Check' evalCtx ctx]
bChecks forall {a} {b}. (a -> b) -> [(Natural, a)] -> [(Natural, b)]
<$$> ( forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
0..] (forall {a} {b} {c}. (a, b, c) -> a
fst' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockWithRevocationId
authority forall a. a -> [a] -> [a]
: [BlockWithRevocationId]
blocks)
                           forall a. Semigroup a => a -> a -> a
<> [(Natural
blockCount,forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Authorizer' evalCtx ctx -> Block' evalCtx ctx
vBlock Authorizer
authorizer)]
                            )
      policies :: [Policy' 'Repr 'Representation]
policies = 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 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 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)  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError forall a b. (a -> b) -> a -> b
$ [Check] -> ResultError
NoPoliciesMatched []
    (Success (), Left (Just MatchedQuery
p)) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError forall a b. (a -> b) -> a -> b
$ [Check] -> MatchedQuery -> ResultError
DenyRuleMatched [] MatchedQuery
p
    (Failure NonEmpty Check
cs, Left Maybe MatchedQuery
Nothing)  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError forall a b. (a -> b) -> a -> b
$ [Check] -> ResultError
NoPoliciesMatched (forall a. NonEmpty a -> [a]
NE.toList NonEmpty Check
cs)
    (Failure NonEmpty Check
cs, Left (Just MatchedQuery
p)) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError forall a b. (a -> b) -> a -> b
$ [Check] -> MatchedQuery -> ResultError
DenyRuleMatched (forall a. NonEmpty a -> [a]
NE.toList NonEmpty Check
cs) MatchedQuery
p
    (Failure NonEmpty Check
cs, Right MatchedQuery
_)       -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError forall a b. (a -> b) -> a -> b
$ NonEmpty Check -> ResultError
FailedChecks NonEmpty Check
cs
    (Success (), Right MatchedQuery
p)       -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ AuthorizationSuccess { $sel:matchedAllowQuery:AuthorizationSuccess :: MatchedQuery
matchedAllowQuery = MatchedQuery
p
                                                                , FactGroup
allFacts :: FactGroup
$sel:allFacts:AuthorizationSuccess :: FactGroup
allFacts
                                                                , Limits
limits :: Limits
$sel:limits:AuthorizationSuccess :: Limits
limits
                                                                }

runStep :: StateT ComputeState (Either PureExecError) Int
runStep :: StateT ComputeState (Either PureExecError) Int
runStep = do
  state :: ComputeState
state@ComputeState{Limits
sLimits :: Limits
$sel:sLimits:ComputeState :: ComputeState -> Limits
sLimits,FactGroup
sFacts :: FactGroup
$sel:sFacts:ComputeState :: ComputeState -> FactGroup
sFacts,Map Natural (Set EvalRule)
sRules :: Map Natural (Set EvalRule)
$sel:sRules:ComputeState :: ComputeState -> Map Natural (Set EvalRule)
sRules,Natural
sBlockCount :: Natural
$sel:sBlockCount:ComputeState :: ComputeState -> Natural
sBlockCount,Int
sIterations :: Int
$sel:sIterations:ComputeState :: ComputeState -> Int
sIterations} <- forall s (m :: * -> *). MonadState s m => m s
get
  let Limits{Int
maxFacts :: Int
maxFacts :: Limits -> Int
maxFacts, Int
maxIterations :: Int
maxIterations :: Limits -> Int
maxIterations} = Limits
sLimits
      previousCount :: Int
previousCount = FactGroup -> Int
countFacts FactGroup
sFacts
      newFacts :: FactGroup
newFacts = FactGroup
sFacts 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 forall a. Num a => a -> a -> a
- Int
previousCount
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newCount forall a. Ord a => a -> a -> Bool
>= Int
maxFacts) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left PureExecError
Facts
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sIterations forall a. Ord a => a -> a -> Bool
>= Int
maxIterations) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left PureExecError
Iterations
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ComputeState
state { $sel:sIterations:ComputeState :: Int
sIterations = Int
sIterations forall a. Num a => a -> a -> a
+ Int
1
              , $sel:sFacts:ComputeState :: FactGroup
sFacts = FactGroup
newFacts
              }
  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 :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> Predicate' 'InPredicate ctx
rhead :: Predicate' 'InPredicate 'Representation
rhead, [Predicate' 'InPredicate 'Representation]
body :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> [Predicate' 'InPredicate ctx]
body :: [Predicate' 'InPredicate 'Representation]
body} =
  let headVars :: Set Text
headVars = forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Text
extractVariables [Predicate' 'InPredicate 'Representation
rhead]
      bodyVars :: Set Text
bodyVars = forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Text
extractVariables [Predicate' 'InPredicate 'Representation]
body
   in Set Text
headVars 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)
sRules :: Map Natural (Set EvalRule)
$sel:sRules:ComputeState :: ComputeState -> Map Natural (Set EvalRule)
sRules} = do
  let checkRules :: Bool
checkRules = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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 forall a. Ord a => a -> a -> Bool
> Int
0 then StateT ComputeState (Either PureExecError) FactGroup
go else forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ComputeState -> FactGroup
sFacts

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
checkRules forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left PureExecError
BadRule
  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
sFacts :: FactGroup
sRules :: Map Natural (Set EvalRule)
sBlockCount :: Natural
sLimits :: Limits
$sel:sFacts:ComputeState :: FactGroup
$sel:sBlockCount:ComputeState :: Natural
$sel:sRules:ComputeState :: Map Natural (Set EvalRule)
$sel:sLimits:ComputeState :: Limits
..}
   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 =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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 =
  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 = 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]
_ -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just Either MatchedQuery MatchedQuery
p
        []    -> forall a b. a -> Either a b
Left 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 :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
scope :: Set (RuleScope' 'Eval 'Representation)
scope} = Limits -> Set (Scoped Fact) -> EvalRule -> Set (Scoped Fact)
getFactsForRule Limits
l (FactGroup -> Set (Scoped Fact)
toScopedFacts 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith forall a. Semigroup a => a -> a -> a
(<>) (forall a. Ord a => a -> Set a -> Set a
Set.insert Natural
ruleBlockId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactGroup -> Map (Set Natural) (Set Fact)
getFactGroup
         in FactGroup -> FactGroup
addRuleOrigin forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Scoped Fact) -> FactGroup
fromScopedFacts forall a b. (a -> b) -> a -> b
$ Natural -> Set EvalRule -> FactGroup -> Set (Scoped Fact)
buildFacts Natural
ruleBlockId Set EvalRule
ruleGroup FactGroup
authorizedFacts

   in forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Natural -> Set EvalRule -> FactGroup
extendRuleGroup) forall a b. (a -> b) -> a -> b
$ 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)
bScope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
bContext :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> Maybe Text
bFacts :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Predicate' 'InFact ctx]
bRules :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Rule' evalCtx ctx]
bScope :: Set (RuleScope' 'Eval 'Representation)
bContext :: Maybe Text
bChecks :: [EvalCheck]
bFacts :: [Fact]
bRules :: [EvalRule]
bChecks :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Block' evalCtx ctx -> [Check' 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 :: Set (RuleScope' 'Eval 'Representation)
scope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
scope} = EvalRule
r { scope :: Set (RuleScope' 'Eval 'Representation)
scope = if 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 ( forall k a. k -> a -> Map k a
Map.singleton Natural
blockId forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map EvalRule -> EvalRule
applyScope forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [EvalRule]
bRules
      , Map (Set Natural) (Set Fact) -> FactGroup
FactGroup forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall a. a -> Set a
Set.singleton Natural
blockId) forall a b. (a -> b) -> a -> b
$ 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
allFacts :: FactGroup
$sel:allFacts:AuthorizationSuccess :: AuthorizationSuccess -> FactGroup
allFacts, Limits
limits :: Limits
$sel:limits:AuthorizationSuccess :: AuthorizationSuccess -> 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 = forall i a. Num i => [a] -> i
genericLength [Maybe PublicKey]
ePks
      getBindingsForQueryItem :: QueryItem' 'Eval 'Representation -> Set Bindings
getBindingsForQueryItem QueryItem{[Predicate' 'InPredicate 'Representation]
qBody :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Predicate' 'InPredicate ctx]
qBody :: [Predicate' 'InPredicate 'Representation]
qBody,[Expression' 'Representation]
qExpressions :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Expression' ctx]
qExpressions :: [Expression' 'Representation]
qExpressions,Set (RuleScope' 'Eval 'Representation)
qScope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
qScope :: Set (RuleScope' 'Eval 'Representation)
qScope} =
        let facts :: Set (Scoped Fact)
facts = FactGroup -> Set (Scoped Fact)
toScopedFacts 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 forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a b. (a, b) -> b
snd 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 forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (QueryItem' 'Eval 'Representation -> Set Bindings
getBindingsForQueryItem forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. a -> Set a
Set.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t a
f)
      getVar :: Bindings -> Maybe b
getVar Bindings
vars = forall t.
FromValue t =>
Term' 'NotWithinSet 'InFact 'Representation -> Maybe t
fromValue forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bindings
vars forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
variableName
   in forall {a} {t :: * -> *} {t :: * -> *} {a}.
(Ord a, Foldable t, Foldable t) =>
(a -> t a) -> t a -> Set a
mapMaybeS 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 = forall t. (Ord t, FromValue t) => Set Bindings -> Text -> Set t
getVariableValues Set Bindings
bindings Text
variableName
   in case forall a. Set a -> [a]
Set.toList Set t
values of
        [t
v] -> forall a. a -> Maybe a
Just t
v
        [t]
_   -> forall a. Maybe a
Nothing