{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
module Auth.Biscuit.Datalog.ScopedExecutor
  ( BlockWithRevocationId
  , runAuthorizer
  , runAuthorizerWithLimits
  , runAuthorizerNoTimeout
  , World (..)
  , computeAllFacts
  , runFactGeneration
  , PureExecError (..)
  , AuthorizationSuccess (..)
  , getBindings
  , queryAuthorizerFacts
  , getVariableValues
  , getSingleVariableValue
  ) where

import           Control.Monad                 (join, when)
import           Control.Monad.State           (StateT (..), get, lift, modify,
                                                put, runStateT)
import           Data.Bifunctor                (first)
import           Data.ByteString               (ByteString)
import           Data.Foldable                 (traverse_)
import           Data.List.NonEmpty            (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty            as NE
import           Data.Map.Strict               ((!?))
import           Data.Maybe                    (mapMaybe)
import           Data.Set                      (Set)
import qualified Data.Set                      as Set
import           Data.Text                     (Text, intercalate, unpack)
import           Validation                    (Validation (..), validation)

import           Auth.Biscuit.Datalog.AST
import           Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..),
                                                Limits (..), MatchedQuery (..),
                                                ResultError (..), checkCheck,
                                                checkPolicy, defaultLimits,
                                                getBindingsForRuleBody,
                                                getFactsForRule)
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
  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)

-- | State maintained by the datalog computation.
data ComputeState
  = ComputeState
  { ComputeState -> Set Fact
sFacts          :: Set Fact
  -- ^ All the facts generated so far
  , ComputeState -> Set Fact
sAuthorityFacts :: Set Fact
  -- ^ Facts generated by the authority block (and the authorizer). Those are kept separate
  -- because they are provided by a trusted party (the one which has the root 'SecretKey').
  -- Block facts are not as trustworthy as they can be added by anyone.
  , ComputeState -> Int
sIterations     :: Int
  -- ^ The current count of iterations
  , ComputeState -> Limits
sLimits         :: Limits
  -- ^ The configured limits for this computation. This field is effectively read-only
  , ComputeState -> [Check]
sFailedChecks   :: [Check]
  -- ^ The failed checks gathered so far. The computation carries on even if some checks
  -- fail, in order to be able to report all the failing checks in one go
  , ComputeState -> Either (Maybe MatchedQuery) MatchedQuery
sPolicyResult   :: Either (Maybe MatchedQuery) MatchedQuery
  -- ^ The result of the authorizer-defined policies. 'Left' represents failure:
  --  - @Left Nothing@ if no policies matched
  --  - @Left (Just q)@ if a deny policy matched
  --  - @Right q@ if an allow policy matched
  }

mkInitState :: Limits -> ComputeState
mkInitState :: Limits -> ComputeState
mkInitState Limits
sLimits = ComputeState :: Set Fact
-> Set Fact
-> Int
-> Limits
-> [Check]
-> Either (Maybe MatchedQuery) MatchedQuery
-> ComputeState
ComputeState
  { sFacts :: Set Fact
sFacts = Set Fact
forall a. Set a
Set.empty -- no facts have been generated yet
  , sAuthorityFacts :: Set Fact
sAuthorityFacts = Set Fact
forall a. Set a
Set.empty -- no authority facts have been generated yet
  , sIterations :: Int
sIterations = Int
0    -- no evaluation iteration has taken place yet
  , Limits
sLimits :: Limits
sLimits :: Limits
sLimits            -- this field is read-only
  , sFailedChecks :: [Check]
sFailedChecks = [] -- no checks have failed yet
  , sPolicyResult :: Either (Maybe MatchedQuery) MatchedQuery
sPolicyResult = Maybe MatchedQuery -> Either (Maybe MatchedQuery) MatchedQuery
forall a b. a -> Either a b
Left Maybe MatchedQuery
forall a. Maybe a
Nothing -- no policies have matched yet
  }

data World
  = World
  { World -> Set Fact
facts :: Set Fact
  , World -> Set Rule
rules :: Set Rule
  }

instance Semigroup World where
  World
w1 <> :: World -> World -> World
<> World
w2 = World :: Set Fact -> Set Rule -> World
World
               { rules :: Set Rule
rules = World -> Set Rule
rules World
w1 Set Rule -> Set Rule -> Set Rule
forall a. Semigroup a => a -> a -> a
<> World -> Set Rule
rules World
w2
               , facts :: Set Fact
facts = World -> Set Fact
facts World
w1 Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
<> World -> Set Fact
facts World
w2
               }

instance Monoid World where
  mempty :: World
mempty = Set Fact -> Set Rule -> World
World Set Fact
forall a. Monoid a => a
mempty Set Rule
forall a. Monoid a => a
mempty

instance Show World where
  show :: World -> String
show World{Set Rule
Set Fact
rules :: Set Rule
facts :: Set Fact
rules :: World -> Set Rule
facts :: World -> Set Fact
..} = Text -> String
unpack (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
intercalate Text
"\n" ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
    [ [ Text
"Block Rules" ]
    , Rule -> Text
renderRule (Rule -> Text) -> [Rule] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Rule -> [Rule]
forall a. Set a -> [a]
Set.toList Set Rule
rules
    , [ Text
"Facts" ]
    , Fact -> Text
renderFact (Fact -> Text) -> [Fact] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Fact -> [Fact]
forall a. Set a -> [a]
Set.toList Set Fact
facts
    ]

-- | 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 -> Set Fact
authorityFacts    :: Set Fact
  -- ^ All the facts generated by the authority block (and the authorizer)
  , AuthorizationSuccess -> Set Fact
allGeneratedFacts :: Set Fact
  -- ^ All the facts that were generated by the biscuit. Be careful, the
  -- biscuit signature check only guarantees that 'authorityFacts' are
  -- signed with the corresponding 'SecretKey'.
  , 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{matchedAllowQuery :: AuthorizationSuccess -> MatchedQuery
matchedAllowQuery=MatchedQuery{Set Bindings
bindings :: MatchedQuery -> Set Bindings
bindings :: Set Bindings
bindings}} = Set Bindings
bindings

withFacts :: World -> Set Fact -> World
withFacts :: World -> Set Fact -> World
withFacts w :: World
w@World{Set Fact
facts :: Set Fact
facts :: World -> Set Fact
facts} Set Fact
newFacts = World
w { facts :: Set Fact
facts = Set Fact
newFacts Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
<> Set Fact
facts }

-- | 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
allowBlockFacts :: Limits -> Bool
allowRegexes :: Limits -> Bool
maxTime :: Limits -> Int
maxIterations :: Limits -> Int
maxFacts :: Limits -> Int
allowBlockFacts :: Bool
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


runAllBlocks :: BlockWithRevocationId
             -> [BlockWithRevocationId]
             -> Authorizer
             -> StateT ComputeState (Either PureExecError) ()
runAllBlocks :: BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> StateT ComputeState (Either PureExecError) ()
runAllBlocks BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
authorizer = do
  (ComputeState -> ComputeState)
-> StateT ComputeState (Either PureExecError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ComputeState -> ComputeState)
 -> StateT ComputeState (Either PureExecError) ())
-> (ComputeState -> ComputeState)
-> StateT ComputeState (Either PureExecError) ()
forall a b. (a -> b) -> a -> b
$ \ComputeState
state -> ComputeState
state { sFacts :: Set Fact
sFacts = BlockWithRevocationId -> [BlockWithRevocationId] -> Set Fact
mkRevocationIdFacts BlockWithRevocationId
authority [BlockWithRevocationId]
blocks }
  BlockWithRevocationId
-> Authorizer -> StateT ComputeState (Either PureExecError) ()
runAuthority BlockWithRevocationId
authority Authorizer
authorizer
  (BlockWithRevocationId
 -> StateT ComputeState (Either PureExecError) ())
-> [BlockWithRevocationId]
-> StateT ComputeState (Either PureExecError) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ BlockWithRevocationId
-> StateT ComputeState (Either PureExecError) ()
runBlock [BlockWithRevocationId]
blocks

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

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 result :: Either PureExecError ((), ComputeState)
result = (StateT ComputeState (Either PureExecError) ()
-> ComputeState -> Either PureExecError ((), ComputeState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` Limits -> ComputeState
mkInitState Limits
limits) (StateT ComputeState (Either PureExecError) ()
 -> Either PureExecError ((), ComputeState))
-> StateT ComputeState (Either PureExecError) ()
-> Either PureExecError ((), ComputeState)
forall a b. (a -> b) -> a -> b
$ BlockWithRevocationId
-> [BlockWithRevocationId]
-> Authorizer
-> StateT ComputeState (Either PureExecError) ()
runAllBlocks BlockWithRevocationId
authority [BlockWithRevocationId]
blocks Authorizer
authorizer
  case Either PureExecError ((), ComputeState)
result of
    Left PureExecError
Facts      -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left ExecutionError
TooManyFacts
    Left PureExecError
Iterations -> ExecutionError -> Either ExecutionError AuthorizationSuccess
forall a b. a -> Either a b
Left ExecutionError
TooManyIterations
    Right ((), ComputeState{Int
[Check]
Either (Maybe MatchedQuery) MatchedQuery
Set Fact
Limits
sPolicyResult :: Either (Maybe MatchedQuery) MatchedQuery
sFailedChecks :: [Check]
sLimits :: Limits
sIterations :: Int
sAuthorityFacts :: Set Fact
sFacts :: Set Fact
sPolicyResult :: ComputeState -> Either (Maybe MatchedQuery) MatchedQuery
sFailedChecks :: ComputeState -> [Check]
sLimits :: ComputeState -> Limits
sIterations :: ComputeState -> Int
sAuthorityFacts :: ComputeState -> Set Fact
sFacts :: ComputeState -> Set Fact
..}) -> case ([Check] -> Maybe (NonEmpty Check)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Check]
sFailedChecks, Either (Maybe MatchedQuery) MatchedQuery
sPolicyResult) of
      (Maybe (NonEmpty Check)
Nothing, 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
-> Set Fact -> Set Fact -> Limits -> AuthorizationSuccess
AuthorizationSuccess { matchedAllowQuery :: MatchedQuery
matchedAllowQuery = MatchedQuery
p
                                                               , authorityFacts :: Set Fact
authorityFacts = Set Fact
sAuthorityFacts
                                                               , allGeneratedFacts :: Set Fact
allGeneratedFacts = Set Fact
sFacts
                                                               , Limits
limits :: Limits
limits :: Limits
limits
                                                               }
      (Maybe (NonEmpty Check)
Nothing, 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 []
      (Maybe (NonEmpty Check)
Nothing, 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
      (Just 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)
      (Just 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
      (Just 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


runFactGeneration :: Limits -> World -> Either PureExecError (Set Fact)
runFactGeneration :: Limits -> World -> Either PureExecError (Set Fact)
runFactGeneration Limits
limits World
w =
  let getFacts :: (a, ComputeState) -> Set Fact
getFacts = ComputeState -> Set Fact
sFacts (ComputeState -> Set Fact)
-> ((a, ComputeState) -> ComputeState)
-> (a, ComputeState)
-> Set Fact
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, ComputeState) -> ComputeState
forall a b. (a, b) -> b
snd
   in ((), ComputeState) -> Set Fact
forall a. (a, ComputeState) -> Set Fact
getFacts (((), ComputeState) -> Set Fact)
-> Either PureExecError ((), ComputeState)
-> Either PureExecError (Set Fact)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ComputeState (Either PureExecError) ()
-> ComputeState -> Either PureExecError ((), ComputeState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (World -> StateT ComputeState (Either PureExecError) ()
computeAllFacts World
w) (Limits -> ComputeState
mkInitState Limits
limits)

runAuthority :: BlockWithRevocationId
             -> Authorizer
             -> StateT ComputeState (Either PureExecError) ()
runAuthority :: BlockWithRevocationId
-> Authorizer -> StateT ComputeState (Either PureExecError) ()
runAuthority (Block
block, ByteString
_rid) Authorizer{[Policy' 'RegularString]
Block
vBlock :: forall (ctx :: ParsedAs). Authorizer' ctx -> Block' ctx
vPolicies :: forall (ctx :: ParsedAs). Authorizer' ctx -> [Policy' ctx]
vBlock :: Block
vPolicies :: [Policy' 'RegularString]
..} = do
  let world :: World
world = Block -> World
collectWorld Block
block World -> World -> World
forall a. Semigroup a => a -> a -> a
<> Block -> World
collectWorld Block
vBlock
  World -> StateT ComputeState (Either PureExecError) ()
computeAllFacts World
world
  -- store the facts generated by the authority block (and the authorizer)
  -- in a dedicated `sAuthorityFacts` so that they can be queried independently
  -- later: we trust the authority facts, not the block facts
  (ComputeState -> ComputeState)
-> StateT ComputeState (Either PureExecError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ComputeState -> ComputeState)
 -> StateT ComputeState (Either PureExecError) ())
-> (ComputeState -> ComputeState)
-> StateT ComputeState (Either PureExecError) ()
forall a b. (a -> b) -> a -> b
$ \c :: ComputeState
c@ComputeState{Set Fact
sFacts :: Set Fact
sFacts :: ComputeState -> Set Fact
sFacts} -> ComputeState
c { sAuthorityFacts :: Set Fact
sAuthorityFacts = Set Fact
sFacts }
  state :: ComputeState
state@ComputeState{Set Fact
sFacts :: Set Fact
sFacts :: ComputeState -> Set Fact
sFacts, Limits
sLimits :: Limits
sLimits :: ComputeState -> Limits
sLimits} <- StateT ComputeState (Either PureExecError) ComputeState
forall s (m :: * -> *). MonadState s m => m s
get
  let checkResults :: Validation (NonEmpty Check) ()
checkResults = Limits -> [Check] -> Set Fact -> Validation (NonEmpty Check) ()
checkChecks Limits
sLimits (Block -> [Check]
forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bChecks Block
block [Check] -> [Check] -> [Check]
forall a. Semigroup a => a -> a -> a
<> Block -> [Check]
forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bChecks Block
vBlock) Set Fact
sFacts
  let policyResult :: Either (Maybe MatchedQuery) MatchedQuery
policyResult = Limits
-> [Policy' 'RegularString]
-> Set Fact
-> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies Limits
sLimits [Policy' 'RegularString]
vPolicies Set Fact
sFacts
  ComputeState -> StateT ComputeState (Either PureExecError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ComputeState
state { sPolicyResult :: Either (Maybe MatchedQuery) MatchedQuery
sPolicyResult = Either (Maybe MatchedQuery) MatchedQuery
policyResult
            , sFailedChecks :: [Check]
sFailedChecks = (NonEmpty Check -> [Check])
-> (() -> [Check]) -> Validation (NonEmpty Check) () -> [Check]
forall e x a. (e -> x) -> (a -> x) -> Validation e a -> x
validation NonEmpty Check -> [Check]
forall a. NonEmpty a -> [a]
NE.toList () -> [Check]
forall a. Monoid a => a
mempty Validation (NonEmpty Check) ()
checkResults
            }

runBlock :: BlockWithRevocationId
         -> StateT ComputeState (Either PureExecError) ()
runBlock :: BlockWithRevocationId
-> StateT ComputeState (Either PureExecError) ()
runBlock (block :: Block
block@Block{[Check]
bChecks :: [Check]
bChecks :: forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bChecks}, ByteString
_rid) = do
  let world :: World
world = Block -> World
collectWorld Block
block
  World -> StateT ComputeState (Either PureExecError) ()
computeAllFacts World
world
  state :: ComputeState
state@ComputeState{Set Fact
sFacts :: Set Fact
sFacts :: ComputeState -> Set Fact
sFacts, Limits
sLimits :: Limits
sLimits :: ComputeState -> Limits
sLimits, [Check]
sFailedChecks :: [Check]
sFailedChecks :: ComputeState -> [Check]
sFailedChecks} <- StateT ComputeState (Either PureExecError) ComputeState
forall s (m :: * -> *). MonadState s m => m s
get
  let checkResults :: Validation (NonEmpty Check) ()
checkResults = Limits -> [Check] -> Set Fact -> Validation (NonEmpty Check) ()
checkChecks Limits
sLimits [Check]
bChecks Set Fact
sFacts
  ComputeState -> StateT ComputeState (Either PureExecError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ComputeState
state { sFailedChecks :: [Check]
sFailedChecks = (NonEmpty Check -> [Check])
-> (() -> [Check]) -> Validation (NonEmpty Check) () -> [Check]
forall e x a. (e -> x) -> (a -> x) -> Validation e a -> x
validation NonEmpty Check -> [Check]
forall a. NonEmpty a -> [a]
NE.toList () -> [Check]
forall a. Monoid a => a
mempty Validation (NonEmpty Check) ()
checkResults [Check] -> [Check] -> [Check]
forall a. Semigroup a => a -> a -> a
<> [Check]
sFailedChecks
            }

checkChecks :: Limits -> [Check] -> Set Fact -> Validation (NonEmpty Check) ()
checkChecks :: Limits -> [Check] -> Set Fact -> Validation (NonEmpty Check) ()
checkChecks Limits
limits [Check]
checks Set Fact
facts = (Check -> Validation (NonEmpty Check) ())
-> [Check] -> Validation (NonEmpty Check) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Limits -> Set Fact -> Check -> Validation (NonEmpty Check) ()
checkCheck Limits
limits Set Fact
facts) [Check]
checks

checkPolicies :: Limits -> [Policy] -> Set Fact -> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies :: Limits
-> [Policy' 'RegularString]
-> Set Fact
-> Either (Maybe MatchedQuery) MatchedQuery
checkPolicies Limits
limits [Policy' 'RegularString]
policies Set Fact
facts =
  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
-> Set Fact
-> Policy' 'RegularString
-> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy Limits
limits Set Fact
facts) [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

computeAllFacts :: World
                -> StateT ComputeState (Either PureExecError) ()
computeAllFacts :: World -> StateT ComputeState (Either PureExecError) ()
computeAllFacts World
world = do
  state :: ComputeState
state@ComputeState{Int
[Check]
Either (Maybe MatchedQuery) MatchedQuery
Set Fact
Limits
sPolicyResult :: Either (Maybe MatchedQuery) MatchedQuery
sFailedChecks :: [Check]
sLimits :: Limits
sIterations :: Int
sAuthorityFacts :: Set Fact
sFacts :: Set Fact
sPolicyResult :: ComputeState -> Either (Maybe MatchedQuery) MatchedQuery
sFailedChecks :: ComputeState -> [Check]
sLimits :: ComputeState -> Limits
sIterations :: ComputeState -> Int
sAuthorityFacts :: ComputeState -> Set Fact
sFacts :: ComputeState -> Set Fact
..} <- StateT ComputeState (Either PureExecError) ComputeState
forall s (m :: * -> *). MonadState s m => m s
get
  let Limits{Bool
Int
allowBlockFacts :: Bool
allowRegexes :: Bool
maxTime :: Int
maxIterations :: Int
maxFacts :: Int
allowBlockFacts :: Limits -> Bool
allowRegexes :: Limits -> Bool
maxTime :: Limits -> Int
maxIterations :: Limits -> Int
maxFacts :: Limits -> Int
..} = Limits
sLimits
  let newFacts :: Set Fact
newFacts = Limits -> World -> Set Fact
extend Limits
sLimits (World
world World -> Set Fact -> World
`withFacts` Set Fact
sFacts)
      allFacts :: Set Fact
allFacts = Set Fact
sFacts Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
<> World -> Set Fact
facts World
world Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
<> Set Fact
newFacts
  Bool
-> StateT ComputeState (Either PureExecError) ()
-> StateT ComputeState (Either PureExecError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set Fact -> Int
forall a. Set a -> Int
Set.size Set Fact
allFacts 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 { sIterations :: Int
sIterations = Int
sIterations Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              , sFacts :: Set Fact
sFacts = Set Fact
allFacts
              }
  if Set Fact -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Fact
newFacts
  then () -> StateT ComputeState (Either PureExecError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else World -> StateT ComputeState (Either PureExecError) ()
computeAllFacts World
world

extend :: Limits -> World -> Set Fact
extend :: Limits -> World -> Set Fact
extend Limits
l World{Set Rule
Set Fact
rules :: Set Rule
facts :: Set Fact
rules :: World -> Set Rule
facts :: World -> Set Fact
..} =
  let buildFacts :: Set Rule -> Set Fact
buildFacts = (Rule -> Set Fact) -> Set Rule -> Set Fact
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Limits -> Set Fact -> Rule -> Set Fact
getFactsForRule Limits
l Set Fact
facts)
      allNewFacts :: Set Fact
allNewFacts = Set Rule -> Set Fact
buildFacts Set Rule
rules
   in Set Fact -> Set Fact -> Set Fact
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Fact
allNewFacts Set Fact
facts

collectWorld :: Block -> World
collectWorld :: Block -> World
collectWorld Block{[Check]
[Rule]
[Fact]
Maybe Text
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]
bContext :: Maybe Text
bChecks :: [Check]
bFacts :: [Fact]
bRules :: [Rule]
bChecks :: forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
..} = World :: Set Fact -> Set Rule -> World
World
  { facts :: Set Fact
facts = [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList [Fact]
bFacts
  , rules :: Set Rule
rules = [Rule] -> Set Rule
forall a. Ord a => [a] -> Set a
Set.fromList [Rule]
bRules
  }

-- | 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 -> Set Bindings
queryAuthorizerFacts AuthorizationSuccess{Set Fact
authorityFacts :: Set Fact
authorityFacts :: AuthorizationSuccess -> Set Fact
authorityFacts, Limits
limits :: Limits
limits :: AuthorizationSuccess -> Limits
limits} Check
q =
  let 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} =
        Limits
-> Set Fact
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set Bindings
getBindingsForRuleBody Limits
limits Set Fact
authorityFacts [Predicate' 'InPredicate 'RegularString]
qBody [Expression' 'RegularString]
qExpressions
   in (QueryItem' 'RegularString -> Set Bindings)
-> Check -> Set Bindings
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap QueryItem' 'RegularString -> Set Bindings
getBindingsForQueryItem Check
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