{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# 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
  , queryAuthorizerFacts
  , getVariableValues
  , getSingleVariableValue
  , FactGroup (..)
  ) where

import           Control.Applicative           ((<|>))
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.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.Datalog.AST
import           Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..),
                                                FactGroup (..), Limits (..),
                                                MatchedQuery (..),
                                                ResultError (..), Scoped,
                                                checkCheck, checkPolicy,
                                                countFacts, defaultLimits,
                                                extractVariables,
                                                fromScopedFacts,
                                                getBindingsForRuleBody,
                                                getFactsForRule,
                                                keepAuthorized', toScopedFacts)
import           Auth.Biscuit.Datalog.Parser   (fact)
import           Auth.Biscuit.Timer            (timer)

type BlockWithRevocationId = (Block, ByteString)

-- | 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
/= :: PureExecError -> PureExecError -> Bool
$c/= :: PureExecError -> PureExecError -> Bool
== :: PureExecError -> PureExecError -> Bool
$c== :: 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
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
(AuthorizationSuccess -> AuthorizationSuccess -> Bool)
-> (AuthorizationSuccess -> AuthorizationSuccess -> Bool)
-> Eq AuthorizationSuccess
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
(Int -> AuthorizationSuccess -> ShowS)
-> (AuthorizationSuccess -> String)
-> ([AuthorizationSuccess] -> ShowS)
-> Show AuthorizationSuccess
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 <- 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 (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 (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. (a, b) -> 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
      mkFact :: (t, t) -> Predicate' pof 'RegularString
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 (pof :: PredicateOrFact).
(ToTerm t, ToTerm t) =>
(t, t) -> Predicate' pof 'RegularString
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 Rule)
sRules      :: Map Natural (Set Rule) -- readonly
  -- 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
/= :: ComputeState -> ComputeState -> Bool
$c/= :: ComputeState -> ComputeState -> Bool
== :: ComputeState -> ComputeState -> Bool
$c== :: 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
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 revocationWorld :: (Map Natural (Set Rule), FactGroup)
revocationWorld = (Map Natural (Set Rule)
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
0) (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. (a, b) -> a
fst BlockWithRevocationId
authority Block -> Block -> Block
forall a. Semigroup a => a -> a -> a
<> Authorizer -> Block
forall (ctx :: ParsedAs). Authorizer' ctx -> Block' ctx
vBlock Authorizer
authorizer
      otherBlocks :: [Block]
otherBlocks = BlockWithRevocationId -> Block
forall a b. (a, b) -> a
fst (BlockWithRevocationId -> Block)
-> [BlockWithRevocationId] -> [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks
      allBlocks :: [Block]
allBlocks = Block
firstBlock Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
otherBlocks
      (Map Natural (Set Rule)
sRules, FactGroup
sFacts) = (Map Natural (Set Rule), FactGroup)
revocationWorld (Map Natural (Set Rule), FactGroup)
-> (Map Natural (Set Rule), FactGroup)
-> (Map Natural (Set Rule), FactGroup)
forall a. Semigroup a => a -> a -> a
<> [(Map Natural (Set Rule), FactGroup)]
-> (Map Natural (Set Rule), FactGroup)
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((Natural -> Block -> (Map Natural (Set Rule), FactGroup))
-> [Natural] -> [Block] -> [(Map Natural (Set Rule), FactGroup)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Natural -> Block -> (Map Natural (Set Rule), FactGroup)
collectWorld [Natural
0..] [Block]
allBlocks)
   in ComputeState :: Limits
-> Map Natural (Set Rule) -> Int -> FactGroup -> ComputeState
ComputeState
        { $sel:sLimits:ComputeState :: Limits
sLimits = Limits
limits
        , Map Natural (Set Rule)
sRules :: Map Natural (Set Rule)
$sel:sRules:ComputeState :: Map Natural (Set Rule)
sRules
        , FactGroup
sFacts :: FactGroup
$sel:sFacts:ComputeState :: FactGroup
sFacts
        , $sel:sIterations:ComputeState :: Int
sIterations = Int
0
        }

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 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 (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' 'RegularString])]
checks = [Natural]
-> [[Check' 'RegularString]]
-> [(Natural, [Check' 'RegularString])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
0..] ([[Check' 'RegularString]] -> [(Natural, [Check' 'RegularString])])
-> [[Check' 'RegularString]]
-> [(Natural, [Check' 'RegularString])]
forall a b. (a -> b) -> a -> b
$ Block -> [Check' 'RegularString]
forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bChecks (Block -> [Check' 'RegularString])
-> [Block] -> [[Check' 'RegularString]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BlockWithRevocationId -> Block
forall a b. (a, b) -> a
fst BlockWithRevocationId
authority Block -> Block -> Block
forall a. Semigroup a => a -> a -> a
<> Authorizer -> Block
forall (ctx :: ParsedAs). Authorizer' ctx -> Block' ctx
vBlock Authorizer
authorizer) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: (BlockWithRevocationId -> Block
forall a b. (a, b) -> a
fst (BlockWithRevocationId -> Block)
-> [BlockWithRevocationId] -> [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockWithRevocationId]
blocks))
      policies :: [Policy' 'RegularString]
policies = Authorizer -> [Policy' 'RegularString]
forall (ctx :: ParsedAs). Authorizer' ctx -> [Policy' ctx]
vPolicies Authorizer
authorizer
      checkResults :: Validation (NonEmpty (Check' 'RegularString)) ()
checkResults = Limits
-> FactGroup
-> [(Natural, [Check' 'RegularString])]
-> Validation (NonEmpty (Check' 'RegularString)) ()
checkChecks Limits
limits FactGroup
allFacts [(Natural, [Check' 'RegularString])]
checks
      policyResults :: Either (Maybe MatchedQuery) MatchedQuery
policyResults = Limits
-> FactGroup
-> [Policy' 'RegularString]
-> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies Limits
limits FactGroup
allFacts [Policy' 'RegularString]
policies
  case (Validation (NonEmpty (Check' 'RegularString)) ()
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' 'RegularString] -> 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' 'RegularString] -> MatchedQuery -> ResultError
DenyRuleMatched [] MatchedQuery
p
    (Failure NonEmpty (Check' 'RegularString)
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' 'RegularString] -> ResultError
NoPoliciesMatched (NonEmpty (Check' 'RegularString) -> [Check' 'RegularString]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Check' 'RegularString)
cs)
    (Failure NonEmpty (Check' 'RegularString)
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' 'RegularString] -> MatchedQuery -> ResultError
DenyRuleMatched (NonEmpty (Check' 'RegularString) -> [Check' 'RegularString]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Check' 'RegularString)
cs) MatchedQuery
p
    (Failure NonEmpty (Check' 'RegularString)
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' 'RegularString) -> ResultError
FailedChecks NonEmpty (Check' 'RegularString)
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 :: MatchedQuery -> FactGroup -> Limits -> AuthorizationSuccess
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 Rule)
sRules :: Map Natural (Set Rule)
$sel:sRules:ComputeState :: ComputeState -> Map Natural (Set Rule)
sRules,Int
sIterations :: Int
$sel:sIterations:ComputeState :: ComputeState -> Int
sIterations} <- StateT ComputeState (Either PureExecError) ComputeState
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 FactGroup -> FactGroup -> FactGroup
forall a. Semigroup a => a -> a -> a
<> Limits -> Map Natural (Set Rule) -> FactGroup -> FactGroup
extend Limits
sLimits Map Natural (Set Rule)
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Int
addedFactsCount

-- | Check if every variable from the head is present in the body
checkRuleHead :: Rule -> Bool
checkRuleHead :: Rule -> Bool
checkRuleHead Rule{Predicate' 'InPredicate 'RegularString
rhead :: forall (ctx :: ParsedAs). Rule' ctx -> Predicate' 'InPredicate ctx
rhead :: Predicate' 'InPredicate 'RegularString
rhead, [Predicate' 'InPredicate 'RegularString]
body :: forall (ctx :: ParsedAs).
Rule' ctx -> [Predicate' 'InPredicate ctx]
body :: [Predicate' 'InPredicate 'RegularString]
body} =
  let headVars :: Set Text
headVars = [Predicate' 'InPredicate 'RegularString] -> Set Text
extractVariables [Predicate' 'InPredicate 'RegularString
rhead]
      bodyVars :: Set Text
bodyVars = [Predicate' 'InPredicate 'RegularString] -> Set Text
extractVariables [Predicate' 'InPredicate 'RegularString]
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 Rule)
sRules :: Map Natural (Set Rule)
$sel:sRules:ComputeState :: ComputeState -> Map Natural (Set Rule)
sRules} = do
  let checkRules :: Bool
checkRules = (Set Rule -> Bool) -> Map Natural (Set Rule) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Rule -> Bool) -> Set Rule -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Rule -> Bool
checkRuleHead) Map Natural (Set Rule)
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 -> Map Natural (Set Rule) -> FactGroup -> Either PureExecError FactGroup
runFactGeneration :: Limits
-> Map Natural (Set Rule)
-> FactGroup
-> Either PureExecError FactGroup
runFactGeneration Limits
sLimits Map Natural (Set Rule)
sRules FactGroup
sFacts =
  let initState :: ComputeState
initState = ComputeState :: Limits
-> Map Natural (Set Rule) -> Int -> FactGroup -> ComputeState
ComputeState{$sel:sIterations:ComputeState :: Int
sIterations = Int
0, Map Natural (Set Rule)
FactGroup
Limits
sFacts :: FactGroup
sRules :: Map Natural (Set Rule)
sLimits :: Limits
$sel:sFacts:ComputeState :: FactGroup
$sel:sRules:ComputeState :: Map Natural (Set Rule)
$sel:sLimits:ComputeState :: Limits
..}
   in ComputeState -> Either PureExecError FactGroup
computeAllFacts ComputeState
initState

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

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

checkPolicies :: Limits -> FactGroup -> [Policy] -> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies :: Limits
-> FactGroup
-> [Policy' 'RegularString]
-> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies Limits
limits FactGroup
allFacts [Policy' 'RegularString]
policies =
  let results :: [Either MatchedQuery MatchedQuery]
results = (Policy' 'RegularString
 -> Maybe (Either MatchedQuery MatchedQuery))
-> [Policy' 'RegularString] -> [Either MatchedQuery MatchedQuery]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Limits
-> FactGroup
-> Policy' 'RegularString
-> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy Limits
limits FactGroup
allFacts) [Policy' 'RegularString]
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 (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 -> Map Natural (Set Rule) -> FactGroup -> FactGroup
extend :: Limits -> Map Natural (Set Rule) -> FactGroup -> FactGroup
extend Limits
l Map Natural (Set Rule)
rules FactGroup
facts =
  let buildFacts :: Natural -> Set Rule -> FactGroup -> Set (Scoped Fact)
      buildFacts :: Natural -> Set Rule -> FactGroup -> Set (Scoped Fact)
buildFacts Natural
ruleBlockId Set Rule
ruleGroup FactGroup
factGroup =
        let extendRule :: Rule -> Set (Scoped Fact)
            extendRule :: Rule -> Set (Scoped Fact)
extendRule r :: Rule
r@Rule{Maybe RuleScope
scope :: forall (ctx :: ParsedAs). Rule' ctx -> Maybe RuleScope
scope :: Maybe RuleScope
scope} = Limits -> Set (Scoped Fact) -> Rule -> 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
$ FactGroup -> Maybe RuleScope -> Natural -> FactGroup
keepAuthorized' FactGroup
factGroup Maybe RuleScope
scope Natural
ruleBlockId) Rule
r
         in (Rule -> Set (Scoped Fact)) -> Set Rule -> Set (Scoped Fact)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Rule -> Set (Scoped Fact)
extendRule Set Rule
ruleGroup

      extendRuleGroup :: Natural -> Set Rule -> FactGroup
      extendRuleGroup :: Natural -> Set Rule -> FactGroup
extendRuleGroup Natural
ruleBlockId Set Rule
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 Rule -> FactGroup -> Set (Scoped Fact)
buildFacts Natural
ruleBlockId Set Rule
ruleGroup FactGroup
authorizedFacts

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


collectWorld :: Natural -> Block -> (Map Natural (Set Rule), FactGroup)
collectWorld :: Natural -> Block -> (Map Natural (Set Rule), FactGroup)
collectWorld Natural
blockId Block{[Check' 'RegularString]
[Rule]
[Fact]
Maybe Text
Maybe RuleScope
bScope :: forall (ctx :: ParsedAs). Block' ctx -> Maybe RuleScope
bContext :: forall (ctx :: ParsedAs). Block' ctx -> Maybe Text
bFacts :: forall (ctx :: ParsedAs). Block' ctx -> [Predicate' 'InFact ctx]
bRules :: forall (ctx :: ParsedAs). Block' ctx -> [Rule' ctx]
bScope :: Maybe RuleScope
bContext :: Maybe Text
bChecks :: [Check' 'RegularString]
bFacts :: [Fact]
bRules :: [Rule]
bChecks :: forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
..} =
  let -- a block can define a default scope for its rule
      -- which is used unless the rule itself has defined a scope
      applyScope :: Rule' ctx -> Rule' ctx
applyScope r :: Rule' ctx
r@Rule{Maybe RuleScope
scope :: Maybe RuleScope
scope :: forall (ctx :: ParsedAs). Rule' ctx -> Maybe RuleScope
scope} = Rule' ctx
r { scope :: Maybe RuleScope
scope = Maybe RuleScope
scope Maybe RuleScope -> Maybe RuleScope -> Maybe RuleScope
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe RuleScope
bScope }
   in ( Natural -> Set Rule -> Map Natural (Set Rule)
forall k a. k -> a -> Map k a
Map.singleton Natural
blockId (Set Rule -> Map Natural (Set Rule))
-> Set Rule -> Map Natural (Set Rule)
forall a b. (a -> b) -> a -> b
$ (Rule -> Rule) -> Set Rule -> Set Rule
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Rule -> Rule
forall (ctx :: ParsedAs). Rule' ctx -> Rule' ctx
applyScope (Set Rule -> Set Rule) -> Set Rule -> Set Rule
forall a b. (a -> b) -> a -> b
$ [Rule] -> Set Rule
forall a. Ord a => [a] -> Set a
Set.fromList [Rule]
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
      )

-- | Query the facts generated by the authority and authorizer blocks
-- during authorization. This can be used in conjuction with 'getVariableValues'
-- and 'getSingleVariableValue' to retrieve actual values.
--
-- ⚠ Only the facts generated by the authority and authorizer blocks are queried.
-- Block facts are not queried (since they can't be trusted).
--
-- 💁 If the facts you want to query are part of an allow query in the authorizer,
-- you can directly get values from 'AuthorizationSuccess'.
queryAuthorizerFacts :: AuthorizationSuccess -> Query -> Set Bindings
queryAuthorizerFacts :: AuthorizationSuccess -> Check' 'RegularString -> Set Bindings
queryAuthorizerFacts AuthorizationSuccess{FactGroup
allFacts :: FactGroup
$sel:allFacts:AuthorizationSuccess :: AuthorizationSuccess -> FactGroup
allFacts, Limits
limits :: Limits
$sel:limits:AuthorizationSuccess :: AuthorizationSuccess -> Limits
limits} Check' 'RegularString
q =
  let authorityFacts :: Set Fact
authorityFacts = Maybe (Set Fact) -> Set Fact
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Set Natural -> Map (Set Natural) (Set Fact) -> Maybe (Set Fact)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Natural -> Set Natural
forall a. a -> Set a
Set.singleton Natural
0) (Map (Set Natural) (Set Fact) -> Maybe (Set Fact))
-> Map (Set Natural) (Set Fact) -> Maybe (Set Fact)
forall a b. (a -> b) -> a -> b
$ FactGroup -> Map (Set Natural) (Set Fact)
getFactGroup FactGroup
allFacts)
      -- we've already ensured that we've kept only authority facts, we don't
      -- need to track their origin further
      getBindingsForQueryItem :: QueryItem' 'RegularString -> Set Bindings
getBindingsForQueryItem QueryItem{[Predicate' 'InPredicate 'RegularString]
qBody :: forall (ctx :: ParsedAs).
QueryItem' ctx -> [Predicate' 'InPredicate ctx]
qBody :: [Predicate' 'InPredicate 'RegularString]
qBody,[Expression' 'RegularString]
qExpressions :: forall (ctx :: ParsedAs). QueryItem' ctx -> [Expression' ctx]
qExpressions :: [Expression' 'RegularString]
qExpressions} = ((Set Natural, Bindings) -> Bindings)
-> Set (Set Natural, Bindings) -> Set Bindings
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Set Natural, Bindings) -> Bindings
forall a b. (a, b) -> b
snd (Set (Set Natural, Bindings) -> Set Bindings)
-> Set (Set Natural, Bindings) -> Set Bindings
forall a b. (a -> b) -> a -> b
$
        Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set (Set Natural, Bindings)
getBindingsForRuleBody Limits
limits ((Fact -> Scoped Fact) -> Set Fact -> Set (Scoped Fact)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Set Natural
forall a. Monoid a => a
mempty,) Set Fact
authorityFacts) [Predicate' 'InPredicate 'RegularString]
qBody [Expression' 'RegularString]
qExpressions
   in (QueryItem' 'RegularString -> Set Bindings)
-> Check' 'RegularString -> Set Bindings
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap QueryItem' 'RegularString -> Set Bindings
getBindingsForQueryItem Check' 'RegularString
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 :: 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 (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> Set a) -> t a -> Set a
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 = Value -> Maybe b
forall t. FromValue t => Value -> Maybe t
fromValue (Value -> Maybe b) -> Maybe Value -> Maybe b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bindings
vars Bindings -> Text -> Maybe Value
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 :: 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