{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
  Module      : Auth.Biscuit.Datalog.Executor
  Copyright   : © Clément Delafargue, 2021
  License     : MIT
  Maintainer  : clement@delafargue.name
  The Datalog engine, tasked with deriving new facts from existing facts and rules, as well as matching available facts against checks and policies
-}
module Auth.Biscuit.Datalog.Executor
  ( ExecutionError (..)
  , Limits (..)
  , ResultError (..)
  , Bindings
  , Name
  , MatchedQuery (..)
  , defaultLimits
  , evaluateExpression

  --
  , getFactsForRule
  , checkCheck
  , checkPolicy
  , getBindingsForRuleBody
  ) where

import           Control.Monad            (join, mfilter, zipWithM)
import           Data.Bitraversable       (bitraverse)
import qualified Data.ByteString          as ByteString
import           Data.Foldable            (fold)
import           Data.List.NonEmpty       (NonEmpty)
import qualified Data.List.NonEmpty       as NE
import           Data.Map.Strict          (Map, (!?))
import qualified Data.Map.Strict          as Map
import           Data.Maybe               (isJust, mapMaybe)
import           Data.Set                 (Set)
import qualified Data.Set                 as Set
import           Data.Text                (Text)
import qualified Data.Text                as Text
import           Data.Void                (absurd)
import qualified Text.Regex.TDFA          as Regex
import qualified Text.Regex.TDFA.Text     as Regex
import           Validation               (Validation (..), failure)

import           Auth.Biscuit.Datalog.AST
import           Auth.Biscuit.Utils       (maybeToRight)

-- | A variable name
type Name = Text

-- | A list of bound variables, with the associated value
type Bindings  = Map Name Value

-- | A datalog query that was matched, along with the values
-- that matched
data MatchedQuery
  = MatchedQuery
  { MatchedQuery -> Query
matchedQuery :: Query
  , MatchedQuery -> Set Bindings
bindings     :: Set Bindings
  }
  deriving (MatchedQuery -> MatchedQuery -> Bool
(MatchedQuery -> MatchedQuery -> Bool)
-> (MatchedQuery -> MatchedQuery -> Bool) -> Eq MatchedQuery
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MatchedQuery -> MatchedQuery -> Bool
$c/= :: MatchedQuery -> MatchedQuery -> Bool
== :: MatchedQuery -> MatchedQuery -> Bool
$c== :: MatchedQuery -> MatchedQuery -> Bool
Eq, Int -> MatchedQuery -> ShowS
[MatchedQuery] -> ShowS
MatchedQuery -> String
(Int -> MatchedQuery -> ShowS)
-> (MatchedQuery -> String)
-> ([MatchedQuery] -> ShowS)
-> Show MatchedQuery
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatchedQuery] -> ShowS
$cshowList :: [MatchedQuery] -> ShowS
show :: MatchedQuery -> String
$cshow :: MatchedQuery -> String
showsPrec :: Int -> MatchedQuery -> ShowS
$cshowsPrec :: Int -> MatchedQuery -> ShowS
Show)

-- | The result of matching the checks and policies against all the available
-- facts.
data ResultError
  = NoPoliciesMatched [Check]
  -- ^ No policy matched. additionally some checks may have failed
  | FailedChecks      (NonEmpty Check)
  -- ^ An allow rule matched, but at least one check failed
  | DenyRuleMatched   [Check] MatchedQuery
  -- ^ A deny rule matched. additionally some checks may have failed
  deriving (ResultError -> ResultError -> Bool
(ResultError -> ResultError -> Bool)
-> (ResultError -> ResultError -> Bool) -> Eq ResultError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResultError -> ResultError -> Bool
$c/= :: ResultError -> ResultError -> Bool
== :: ResultError -> ResultError -> Bool
$c== :: ResultError -> ResultError -> Bool
Eq, Int -> ResultError -> ShowS
[ResultError] -> ShowS
ResultError -> String
(Int -> ResultError -> ShowS)
-> (ResultError -> String)
-> ([ResultError] -> ShowS)
-> Show ResultError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResultError] -> ShowS
$cshowList :: [ResultError] -> ShowS
show :: ResultError -> String
$cshow :: ResultError -> String
showsPrec :: Int -> ResultError -> ShowS
$cshowsPrec :: Int -> ResultError -> ShowS
Show)

-- | An error that can happen while running a datalog verification.
-- The datalog computation itself can be aborted by runtime failsafe
-- mechanisms, or it can run to completion but fail to fullfil checks
-- and policies ('ResultError').
data ExecutionError
  = Timeout
  -- ^ Verification took too much time
  | TooManyFacts
  -- ^ Too many facts were generated during evaluation
  | TooManyIterations
  -- ^ Evaluation did not converge in the alloted number of iterations
  | FactsInBlocks
  -- ^ Some blocks contained either rules or facts while it was forbidden
  | ResultError ResultError
  -- ^ The evaluation ran to completion, but checks and policies were not
  -- fulfilled.
  deriving (ExecutionError -> ExecutionError -> Bool
(ExecutionError -> ExecutionError -> Bool)
-> (ExecutionError -> ExecutionError -> Bool) -> Eq ExecutionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExecutionError -> ExecutionError -> Bool
$c/= :: ExecutionError -> ExecutionError -> Bool
== :: ExecutionError -> ExecutionError -> Bool
$c== :: ExecutionError -> ExecutionError -> Bool
Eq, Int -> ExecutionError -> ShowS
[ExecutionError] -> ShowS
ExecutionError -> String
(Int -> ExecutionError -> ShowS)
-> (ExecutionError -> String)
-> ([ExecutionError] -> ShowS)
-> Show ExecutionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExecutionError] -> ShowS
$cshowList :: [ExecutionError] -> ShowS
show :: ExecutionError -> String
$cshow :: ExecutionError -> String
showsPrec :: Int -> ExecutionError -> ShowS
$cshowsPrec :: Int -> ExecutionError -> ShowS
Show)

-- | Settings for the executor runtime restrictions.
-- See `defaultLimits` for default values.
data Limits
  = Limits
  { Limits -> Int
maxFacts        :: Int
  -- ^ maximum number of facts that can be produced before throwing `TooManyFacts`
  , Limits -> Int
maxIterations   :: Int
  -- ^ maximum number of iterations before throwing `TooManyIterations`
  , Limits -> Int
maxTime         :: Int
  -- ^ maximum duration the verification can take (in μs)
  , Limits -> Bool
allowRegexes    :: Bool
  -- ^ whether or not allowing `.matches()` during verification (untrusted regex computation
  -- can enable DoS attacks). This security risk is mitigated by the 'maxTime' setting.
  , Limits -> Bool
allowBlockFacts :: Bool
  -- ^ whether or not accept facts and rules in blocks
  }
  deriving (Limits -> Limits -> Bool
(Limits -> Limits -> Bool)
-> (Limits -> Limits -> Bool) -> Eq Limits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Limits -> Limits -> Bool
$c/= :: Limits -> Limits -> Bool
== :: Limits -> Limits -> Bool
$c== :: Limits -> Limits -> Bool
Eq, Int -> Limits -> ShowS
[Limits] -> ShowS
Limits -> String
(Int -> Limits -> ShowS)
-> (Limits -> String) -> ([Limits] -> ShowS) -> Show Limits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Limits] -> ShowS
$cshowList :: [Limits] -> ShowS
show :: Limits -> String
$cshow :: Limits -> String
showsPrec :: Int -> Limits -> ShowS
$cshowsPrec :: Int -> Limits -> ShowS
Show)

-- | Default settings for the executor restrictions.
--   - 1000 facts
--   - 100 iterations
--   - 1000μs max
--   - regexes are allowed
--   - facts and rules are allowed in blocks
defaultLimits :: Limits
defaultLimits :: Limits
defaultLimits = Limits :: Int -> Int -> Int -> Bool -> Bool -> Limits
Limits
  { maxFacts :: Int
maxFacts = Int
1000
  , maxIterations :: Int
maxIterations = Int
100
  , maxTime :: Int
maxTime = Int
1000
  , allowRegexes :: Bool
allowRegexes = Bool
True
  , allowBlockFacts :: Bool
allowBlockFacts = Bool
True
  }

checkCheck :: Limits -> Set Fact -> Check -> Validation (NonEmpty Check) ()
checkCheck :: Limits -> Set Fact -> Query -> Validation (NonEmpty Query) ()
checkCheck Limits
l Set Fact
facts Query
items =
  if (QueryItem' 'RegularString -> Bool) -> Query -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe (Set Bindings) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Set Bindings) -> Bool)
-> (QueryItem' 'RegularString -> Maybe (Set Bindings))
-> QueryItem' 'RegularString
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Limits
-> Set Fact -> QueryItem' 'RegularString -> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Set Fact
facts) Query
items
  then () -> Validation (NonEmpty Query) ()
forall e a. a -> Validation e a
Success ()
  else Query -> Validation (NonEmpty Query) ()
forall e a. e -> Validation (NonEmpty e) a
failure Query
items

checkPolicy :: Limits -> Set Fact -> Policy -> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy :: Limits
-> Set Fact -> Policy -> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy Limits
l Set Fact
facts (PolicyType
pType, Query
query) =
  let bindings :: Set Bindings
bindings = [Set Bindings] -> Set Bindings
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Set Bindings] -> Set Bindings) -> [Set Bindings] -> Set Bindings
forall a b. (a -> b) -> a -> b
$ (QueryItem' 'RegularString -> Maybe (Set Bindings))
-> Query -> [Set Bindings]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Limits
-> Set Fact -> QueryItem' 'RegularString -> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Set Fact
facts) Query
query
   in if Bool -> Bool
not (Set Bindings -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Bindings
bindings)
      then Either MatchedQuery MatchedQuery
-> Maybe (Either MatchedQuery MatchedQuery)
forall a. a -> Maybe a
Just (Either MatchedQuery MatchedQuery
 -> Maybe (Either MatchedQuery MatchedQuery))
-> Either MatchedQuery MatchedQuery
-> Maybe (Either MatchedQuery MatchedQuery)
forall a b. (a -> b) -> a -> b
$ case PolicyType
pType of
        PolicyType
Allow -> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. b -> Either a b
Right (MatchedQuery -> Either MatchedQuery MatchedQuery)
-> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. (a -> b) -> a -> b
$ MatchedQuery :: Query -> Set Bindings -> MatchedQuery
MatchedQuery{matchedQuery :: Query
matchedQuery = Query
query, Set Bindings
bindings :: Set Bindings
bindings :: Set Bindings
bindings}
        PolicyType
Deny  -> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. a -> Either a b
Left (MatchedQuery -> Either MatchedQuery MatchedQuery)
-> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. (a -> b) -> a -> b
$ MatchedQuery :: Query -> Set Bindings -> MatchedQuery
MatchedQuery{matchedQuery :: Query
matchedQuery = Query
query, Set Bindings
bindings :: Set Bindings
bindings :: Set Bindings
bindings}
      else Maybe (Either MatchedQuery MatchedQuery)
forall a. Maybe a
Nothing

isQueryItemSatisfied :: Limits -> Set Fact -> QueryItem' 'RegularString -> Maybe (Set Bindings)
isQueryItemSatisfied :: Limits
-> Set Fact -> QueryItem' 'RegularString -> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Set Fact
facts 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} =
  let bindings :: Set Bindings
bindings = Limits
-> Set Fact
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set Bindings
getBindingsForRuleBody Limits
l Set Fact
facts [Predicate' 'InPredicate 'RegularString]
qBody [Expression' 'RegularString]
qExpressions
   in if Set Bindings -> Int
forall a. Set a -> Int
Set.size Set Bindings
bindings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Set Bindings -> Maybe (Set Bindings)
forall a. a -> Maybe a
Just Set Bindings
bindings
      else Maybe (Set Bindings)
forall a. Maybe a
Nothing

getFactsForRule :: Limits -> Set Fact -> Rule -> Set Fact
getFactsForRule :: Limits -> Set Fact -> Rule -> Set Fact
getFactsForRule Limits
l Set Fact
facts 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, [Expression' 'RegularString]
expressions :: forall (ctx :: ParsedAs). Rule' ctx -> [Expression' ctx]
expressions :: [Expression' 'RegularString]
expressions} =
  let legalBindings :: Set Bindings
legalBindings = Limits
-> Set Fact
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set Bindings
getBindingsForRuleBody Limits
l Set Fact
facts [Predicate' 'InPredicate 'RegularString]
body [Expression' 'RegularString]
expressions
      newFacts :: [Fact]
newFacts = (Bindings -> Maybe Fact) -> [Bindings] -> [Fact]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Predicate' 'InPredicate 'RegularString -> Bindings -> Maybe Fact
applyBindings Predicate' 'InPredicate 'RegularString
rhead) ([Bindings] -> [Fact]) -> [Bindings] -> [Fact]
forall a b. (a -> b) -> a -> b
$ Set Bindings -> [Bindings]
forall a. Set a -> [a]
Set.toList Set Bindings
legalBindings
   in [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList [Fact]
newFacts

getBindingsForRuleBody :: Limits -> Set Fact -> [Predicate] -> [Expression] -> Set Bindings
getBindingsForRuleBody :: Limits
-> Set Fact
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set Bindings
getBindingsForRuleBody Limits
l Set Fact
facts [Predicate' 'InPredicate 'RegularString]
body [Expression' 'RegularString]
expressions =
  let candidateBindings :: [Set Bindings]
candidateBindings = Set Fact
-> [Predicate' 'InPredicate 'RegularString] -> [Set Bindings]
getCandidateBindings Set Fact
facts [Predicate' 'InPredicate 'RegularString]
body
      allVariables :: Set Name
allVariables = [Predicate' 'InPredicate 'RegularString] -> Set Name
extractVariables [Predicate' 'InPredicate 'RegularString]
body
      legalBindingsForFacts :: Set Bindings
legalBindingsForFacts = Set Name -> [Set Bindings] -> Set Bindings
reduceCandidateBindings Set Name
allVariables [Set Bindings]
candidateBindings
   in (Bindings -> Bool) -> Set Bindings -> Set Bindings
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Bindings
b -> (Expression' 'RegularString -> Bool)
-> [Expression' 'RegularString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Limits -> Bindings -> Expression' 'RegularString -> Bool
satisfies Limits
l Bindings
b) [Expression' 'RegularString]
expressions) Set Bindings
legalBindingsForFacts

satisfies :: Limits
          -> Bindings
          -> Expression
          -> Bool
satisfies :: Limits -> Bindings -> Expression' 'RegularString -> Bool
satisfies Limits
l Bindings
b Expression' 'RegularString
e = Limits
-> Bindings -> Expression' 'RegularString -> Either String Value
evaluateExpression Limits
l Bindings
b Expression' 'RegularString
e Either String Value -> Either String Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Either String Value
forall a b. b -> Either a b
Right (Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool Bool
True)

extractVariables :: [Predicate] -> Set Name
extractVariables :: [Predicate' 'InPredicate 'RegularString] -> Set Name
extractVariables [Predicate' 'InPredicate 'RegularString]
predicates =
  let keepVariable :: Term' inSet pof ctx -> Maybe (VariableType inSet pof)
keepVariable = \case
        Variable VariableType inSet pof
name -> VariableType inSet pof -> Maybe (VariableType inSet pof)
forall a. a -> Maybe a
Just VariableType inSet pof
name
        Term' inSet pof ctx
_             -> Maybe (VariableType inSet pof)
forall a. Maybe a
Nothing
      extractVariables' :: Predicate' pof ctx -> [VariableType 'NotWithinSet pof]
extractVariables' Predicate{[Term' 'NotWithinSet pof ctx]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms :: [Term' 'NotWithinSet pof ctx]
terms} = (Term' 'NotWithinSet pof ctx
 -> Maybe (VariableType 'NotWithinSet pof))
-> [Term' 'NotWithinSet pof ctx]
-> [VariableType 'NotWithinSet pof]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term' 'NotWithinSet pof ctx
-> Maybe (VariableType 'NotWithinSet pof)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Term' inSet pof ctx -> Maybe (VariableType inSet pof)
keepVariable [Term' 'NotWithinSet pof ctx]
terms
   in [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ Predicate' 'InPredicate 'RegularString -> [Name]
forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [VariableType 'NotWithinSet pof]
extractVariables' (Predicate' 'InPredicate 'RegularString -> [Name])
-> [Predicate' 'InPredicate 'RegularString] -> [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Predicate' 'InPredicate 'RegularString]
predicates


applyBindings :: Predicate -> Bindings -> Maybe Fact
applyBindings :: Predicate' 'InPredicate 'RegularString -> Bindings -> Maybe Fact
applyBindings p :: Predicate' 'InPredicate 'RegularString
p@Predicate{[Term' 'NotWithinSet 'InPredicate 'RegularString]
terms :: [Term' 'NotWithinSet 'InPredicate 'RegularString]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms} Bindings
bindings =
  let newTerms :: Maybe [Value]
newTerms = (Term' 'NotWithinSet 'InPredicate 'RegularString -> Maybe Value)
-> [Term' 'NotWithinSet 'InPredicate 'RegularString]
-> Maybe [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Term' 'NotWithinSet 'InPredicate 'RegularString -> Maybe Value
replaceTerm [Term' 'NotWithinSet 'InPredicate 'RegularString]
terms
      replaceTerm :: Term -> Maybe Value
      replaceTerm :: Term' 'NotWithinSet 'InPredicate 'RegularString -> Maybe Value
replaceTerm (Variable VariableType 'NotWithinSet 'InPredicate
n)  = Name -> Bindings -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
VariableType 'NotWithinSet 'InPredicate
n Bindings
bindings
      replaceTerm (LInteger Int
t)  = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger Int
t
      replaceTerm (LString Name
t)   = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Name -> Term' inSet pof ctx
LString Name
t
      replaceTerm (LDate UTCTime
t)     = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ UTCTime -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
UTCTime -> Term' inSet pof ctx
LDate UTCTime
t
      replaceTerm (LBytes ByteString
t)    = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ByteString -> Term' inSet pof ctx
LBytes ByteString
t
      replaceTerm (LBool Bool
t)     = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool Bool
t
      replaceTerm (TermSet SetType 'NotWithinSet 'RegularString
t)   = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet SetType 'NotWithinSet 'RegularString
t
      replaceTerm (Antiquote SliceType 'RegularString
t) = Void -> Maybe Value
forall a. Void -> a
absurd Void
SliceType 'RegularString
t
   in (\[Value]
nt -> Predicate' 'InPredicate 'RegularString
p { terms :: [Value]
terms = [Value]
nt}) ([Value] -> Fact) -> Maybe [Value] -> Maybe Fact
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Value]
newTerms

getCombinations :: [[a]] -> [[a]]
getCombinations :: [[a]] -> [[a]]
getCombinations ([a]
x:[[a]]
xs) = do
  a
y <- [a]
x
  (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> [[a]] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
getCombinations [[a]]
xs
getCombinations []     = [[]]

mergeBindings :: [Bindings] -> Bindings
mergeBindings :: [Bindings] -> Bindings
mergeBindings =
  -- group all the values unified with each variable
  let combinations :: [Bindings] -> Map Name (NonEmpty Value)
combinations = (NonEmpty Value -> NonEmpty Value -> NonEmpty Value)
-> [Map Name (NonEmpty Value)] -> Map Name (NonEmpty Value)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith NonEmpty Value -> NonEmpty Value -> NonEmpty Value
forall a. Semigroup a => a -> a -> a
(<>) ([Map Name (NonEmpty Value)] -> Map Name (NonEmpty Value))
-> ([Bindings] -> [Map Name (NonEmpty Value)])
-> [Bindings]
-> Map Name (NonEmpty Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bindings -> Map Name (NonEmpty Value))
-> [Bindings] -> [Map Name (NonEmpty Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> NonEmpty Value) -> Bindings -> Map Name (NonEmpty Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> NonEmpty Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      sameValues :: NonEmpty Value -> Maybe Value
sameValues = (NonEmpty Value -> Value) -> Maybe (NonEmpty Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Value -> Value
forall a. NonEmpty a -> a
NE.head (Maybe (NonEmpty Value) -> Maybe Value)
-> (NonEmpty Value -> Maybe (NonEmpty Value))
-> NonEmpty Value
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Value -> Bool)
-> Maybe (NonEmpty Value) -> Maybe (NonEmpty Value)
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (NonEmpty Value -> Int) -> NonEmpty Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Value -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (Maybe (NonEmpty Value) -> Maybe (NonEmpty Value))
-> (NonEmpty Value -> Maybe (NonEmpty Value))
-> NonEmpty Value
-> Maybe (NonEmpty Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Value -> Maybe (NonEmpty Value)
forall a. a -> Maybe a
Just (NonEmpty Value -> Maybe (NonEmpty Value))
-> (NonEmpty Value -> NonEmpty Value)
-> NonEmpty Value
-> Maybe (NonEmpty Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Value -> NonEmpty Value
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub
  -- only keep
      keepConsistent :: Map k (NonEmpty Value) -> Map k Value
keepConsistent = (NonEmpty Value -> Maybe Value)
-> Map k (NonEmpty Value) -> Map k Value
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe NonEmpty Value -> Maybe Value
sameValues
   in Map Name (NonEmpty Value) -> Bindings
forall k. Map k (NonEmpty Value) -> Map k Value
keepConsistent (Map Name (NonEmpty Value) -> Bindings)
-> ([Bindings] -> Map Name (NonEmpty Value))
-> [Bindings]
-> Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bindings] -> Map Name (NonEmpty Value)
combinations

reduceCandidateBindings :: Set Name
                        -> [Set Bindings]
                        -> Set Bindings
reduceCandidateBindings :: Set Name -> [Set Bindings] -> Set Bindings
reduceCandidateBindings Set Name
allVariables [Set Bindings]
matches =
  let allCombinations :: [[Bindings]]
      allCombinations :: [[Bindings]]
allCombinations = [[Bindings]] -> [[Bindings]]
forall a. [[a]] -> [[a]]
getCombinations ([[Bindings]] -> [[Bindings]]) -> [[Bindings]] -> [[Bindings]]
forall a b. (a -> b) -> a -> b
$ Set Bindings -> [Bindings]
forall a. Set a -> [a]
Set.toList (Set Bindings -> [Bindings]) -> [Set Bindings] -> [[Bindings]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Set Bindings]
matches
      isComplete :: Bindings -> Bool
      isComplete :: Bindings -> Bool
isComplete = (Set Name -> Set Name -> Bool
forall a. Eq a => a -> a -> Bool
== Set Name
allVariables) (Set Name -> Bool) -> (Bindings -> Set Name) -> Bindings -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name)
-> (Bindings -> [Name]) -> Bindings -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bindings -> [Name]
forall k a. Map k a -> [k]
Map.keys
   in [Bindings] -> Set Bindings
forall a. Ord a => [a] -> Set a
Set.fromList ([Bindings] -> Set Bindings) -> [Bindings] -> Set Bindings
forall a b. (a -> b) -> a -> b
$ (Bindings -> Bool) -> [Bindings] -> [Bindings]
forall a. (a -> Bool) -> [a] -> [a]
filter Bindings -> Bool
isComplete ([Bindings] -> [Bindings]) -> [Bindings] -> [Bindings]
forall a b. (a -> b) -> a -> b
$ [Bindings] -> Bindings
mergeBindings ([Bindings] -> Bindings) -> [[Bindings]] -> [Bindings]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Bindings]]
allCombinations

getCandidateBindings :: Set Fact
                     -> [Predicate]
                     -> [Set Bindings]
getCandidateBindings :: Set Fact
-> [Predicate' 'InPredicate 'RegularString] -> [Set Bindings]
getCandidateBindings Set Fact
facts [Predicate' 'InPredicate 'RegularString]
predicates =
   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)
       keepFacts :: Predicate' 'InPredicate 'RegularString -> Set Bindings
keepFacts Predicate' 'InPredicate 'RegularString
p = (Fact -> Maybe Bindings) -> Set Fact -> Set Bindings
forall a (t :: * -> *) (t :: * -> *) a.
(Ord a, Foldable t, Foldable t) =>
(a -> t a) -> t a -> Set a
mapMaybeS (Predicate' 'InPredicate 'RegularString -> Fact -> Maybe Bindings
factMatchesPredicate Predicate' 'InPredicate 'RegularString
p) Set Fact
facts
    in Predicate' 'InPredicate 'RegularString -> Set Bindings
keepFacts (Predicate' 'InPredicate 'RegularString -> Set Bindings)
-> [Predicate' 'InPredicate 'RegularString] -> [Set Bindings]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate' 'InPredicate 'RegularString]
predicates

isSame :: Term -> Value -> Bool
isSame :: Term' 'NotWithinSet 'InPredicate 'RegularString -> Value -> Bool
isSame (LInteger Int
t) (LInteger Int
t') = Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
t'
isSame (LString Name
t)  (LString Name
t')  = Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
t'
isSame (LDate UTCTime
t)    (LDate UTCTime
t')    = UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
t'
isSame (LBytes ByteString
t)   (LBytes ByteString
t')   = ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
t'
isSame (LBool Bool
t)    (LBool Bool
t')    = Bool
t Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
t'
isSame (TermSet SetType 'NotWithinSet 'RegularString
t)  (TermSet SetType 'NotWithinSet 'RegularString
t')  = Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t'
isSame Term' 'NotWithinSet 'InPredicate 'RegularString
_ Value
_                        = Bool
False

factMatchesPredicate :: Predicate -> Fact -> Maybe Bindings
factMatchesPredicate :: Predicate' 'InPredicate 'RegularString -> Fact -> Maybe Bindings
factMatchesPredicate Predicate{name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Name
name = Name
predicateName, terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms = [Term' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms }
                     Predicate{name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Name
name = Name
factName, terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms = [Value]
factTerms } =
  let namesMatch :: Bool
namesMatch = Name
predicateName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
factName
      lengthsMatch :: Bool
lengthsMatch = [Term' 'NotWithinSet 'InPredicate 'RegularString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
factTerms
      allMatches :: Maybe [Bindings]
allMatches = (Term' 'NotWithinSet 'InPredicate 'RegularString
 -> Value -> Maybe Bindings)
-> [Term' 'NotWithinSet 'InPredicate 'RegularString]
-> [Value]
-> Maybe [Bindings]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Term' 'NotWithinSet 'InPredicate 'RegularString
-> Value -> Maybe Bindings
yolo [Term' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms [Value]
factTerms
      yolo :: Term -> Value -> Maybe Bindings
      yolo :: Term' 'NotWithinSet 'InPredicate 'RegularString
-> Value -> Maybe Bindings
yolo (Variable VariableType 'NotWithinSet 'InPredicate
vname) Value
value = Bindings -> Maybe Bindings
forall a. a -> Maybe a
Just (Name -> Value -> Bindings
forall k a. k -> a -> Map k a
Map.singleton Name
VariableType 'NotWithinSet 'InPredicate
vname Value
value)
      yolo Term' 'NotWithinSet 'InPredicate 'RegularString
t Value
t' | Term' 'NotWithinSet 'InPredicate 'RegularString -> Value -> Bool
isSame Term' 'NotWithinSet 'InPredicate 'RegularString
t Value
t' = Bindings -> Maybe Bindings
forall a. a -> Maybe a
Just Bindings
forall a. Monoid a => a
mempty
                | Bool
otherwise   = Maybe Bindings
forall a. Maybe a
Nothing
   in if Bool
namesMatch Bool -> Bool -> Bool
&& Bool
lengthsMatch
      then [Bindings] -> Bindings
mergeBindings ([Bindings] -> Bindings) -> Maybe [Bindings] -> Maybe Bindings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Bindings]
allMatches
      else Maybe Bindings
forall a. Maybe a
Nothing

applyVariable :: Bindings
              -> Term
              -> Either String Value
applyVariable :: Bindings
-> Term' 'NotWithinSet 'InPredicate 'RegularString
-> Either String Value
applyVariable Bindings
bindings = \case
  Variable VariableType 'NotWithinSet 'InPredicate
n  -> String -> Maybe Value -> Either String Value
forall b a. b -> Maybe a -> Either b a
maybeToRight String
"Unbound variable" (Maybe Value -> Either String Value)
-> Maybe Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bindings
bindings Bindings -> Name -> Maybe Value
forall k a. Ord k => Map k a -> k -> Maybe a
!? Name
VariableType 'NotWithinSet 'InPredicate
n
  LInteger Int
t  -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger Int
t
  LString Name
t   -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Name -> Term' inSet pof ctx
LString Name
t
  LDate UTCTime
t     -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ UTCTime -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
UTCTime -> Term' inSet pof ctx
LDate UTCTime
t
  LBytes ByteString
t    -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ByteString -> Term' inSet pof ctx
LBytes ByteString
t
  LBool Bool
t     -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool Bool
t
  TermSet SetType 'NotWithinSet 'RegularString
t   -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet SetType 'NotWithinSet 'RegularString
t
  Antiquote SliceType 'RegularString
v -> Void -> Either String Value
forall a. Void -> a
absurd Void
SliceType 'RegularString
v

evalUnary :: Unary -> Value -> Either String Value
evalUnary :: Unary -> Value -> Either String Value
evalUnary Unary
Parens Value
t = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
t
evalUnary Unary
Negate (LBool Bool
b) = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b)
evalUnary Unary
Negate Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only booleans support negation"
evalUnary Unary
Length (LString Name
t) = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name -> Int
Text.length Name
t
evalUnary Unary
Length (LBytes ByteString
bs) = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
bs
evalUnary Unary
Length (TermSet SetType 'NotWithinSet 'RegularString
s) = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ Set (Term' 'WithinSet 'InFact 'RegularString) -> Int
forall a. Set a -> Int
Set.size Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
s
evalUnary Unary
Length Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings, bytes and sets support `.length()`"

evalBinary :: Limits -> Binary -> Value -> Value -> Either String Value
-- eq / ord operations
evalBinary :: Limits -> Binary -> Value -> Value -> Either String Value
evalBinary Limits
_ Binary
Equal (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i')
evalBinary Limits
_ Binary
Equal (LString Name
t) (LString Name
t')   = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
t')
evalBinary Limits
_ Binary
Equal (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
t')
evalBinary Limits
_ Binary
Equal (LBytes ByteString
t) (LBytes ByteString
t')     = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
t')
evalBinary Limits
_ Binary
Equal (LBool Bool
t) (LBool Bool
t')       = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Bool
t Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
t')
evalBinary Limits
_ Binary
Equal (TermSet SetType 'NotWithinSet 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t')   = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t')
evalBinary Limits
_ Binary
Equal Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"Equality mismatch"
evalBinary Limits
_ Binary
LessThan (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i')
evalBinary Limits
_ Binary
LessThan (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
t')
evalBinary Limits
_ Binary
LessThan Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"< mismatch"
evalBinary Limits
_ Binary
GreaterThan (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i')
evalBinary Limits
_ Binary
GreaterThan (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
t')
evalBinary Limits
_ Binary
GreaterThan Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"> mismatch"
evalBinary Limits
_ Binary
LessOrEqual (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i')
evalBinary Limits
_ Binary
LessOrEqual (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
t')
evalBinary Limits
_ Binary
LessOrEqual Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"<= mismatch"
evalBinary Limits
_ Binary
GreaterOrEqual (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i')
evalBinary Limits
_ Binary
GreaterOrEqual (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
t')
evalBinary Limits
_ Binary
GreaterOrEqual Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
">= mismatch"
-- string-related operations
evalBinary Limits
_ Binary
Prefix (LString Name
t) (LString Name
t') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Name
t' Name -> Name -> Bool
`Text.isPrefixOf` Name
t)
evalBinary Limits
_ Binary
Prefix Value
_ Value
_                      = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings support `.starts_with()`"
evalBinary Limits
_ Binary
Suffix (LString Name
t) (LString Name
t') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Name
t' Name -> Name -> Bool
`Text.isSuffixOf` Name
t)
evalBinary Limits
_ Binary
Suffix Value
_ Value
_                      = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings support `.ends_with()`"
evalBinary Limits{Bool
allowRegexes :: Bool
allowRegexes :: Limits -> Bool
allowRegexes} Binary
Regex  (LString Name
t) (LString Name
r) | Bool
allowRegexes = Name -> Name -> Either String Value
regexMatch Name
t Name
r
                                                               | Bool
otherwise    = String -> Either String Value
forall a b. a -> Either a b
Left String
"Regex evaluation is disabled"
evalBinary Limits
_ Binary
Regex Value
_ Value
_                       = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings support `.matches()`"
-- num operations
evalBinary Limits
_ Binary
Add (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i')
evalBinary Limits
_ Binary
Add Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support addition"
evalBinary Limits
_ Binary
Sub (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i')
evalBinary Limits
_ Binary
Sub Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support subtraction"
evalBinary Limits
_ Binary
Mul (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i')
evalBinary Limits
_ Binary
Mul Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support multiplication"
evalBinary Limits
_ Binary
Div (LInteger Int
_) (LInteger Int
0) = String -> Either String Value
forall a b. a -> Either a b
Left String
"Divide by 0"
evalBinary Limits
_ Binary
Div (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
i')
evalBinary Limits
_ Binary
Div Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support division"
-- boolean operations
evalBinary Limits
_ Binary
And (LBool Bool
b) (LBool Bool
b') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Bool
b Bool -> Bool -> Bool
&& Bool
b')
evalBinary Limits
_ Binary
And Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only booleans support &&"
evalBinary Limits
_ Binary
Or (LBool Bool
b) (LBool Bool
b') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Bool
b Bool -> Bool -> Bool
|| Bool
b')
evalBinary Limits
_ Binary
Or Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only booleans support ||"
-- set operations
evalBinary Limits
_ Binary
Contains (TermSet SetType 'NotWithinSet 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t' Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t)
evalBinary Limits
_ Binary
Contains (TermSet SetType 'NotWithinSet 'RegularString
t) Value
t' = case Value -> Maybe (Term' 'WithinSet 'InFact 'RegularString)
toSetTerm Value
t' of
    Just Term' 'WithinSet 'InFact 'RegularString
t'' -> Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Term' 'WithinSet 'InFact 'RegularString
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Term' 'WithinSet 'InFact 'RegularString
t'' Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t)
    Maybe (Term' 'WithinSet 'InFact 'RegularString)
Nothing  -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Sets cannot contain nested sets nor variables"
evalBinary Limits
_ Binary
Contains Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets support `.contains()`"
evalBinary Limits
_ Binary
Intersection (TermSet SetType 'NotWithinSet 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet (Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t')
evalBinary Limits
_ Binary
Intersection Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets support `.intersection()`"
evalBinary Limits
_ Binary
Union (TermSet SetType 'NotWithinSet 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet (Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t')
evalBinary Limits
_ Binary
Union Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets support `.union()`"

regexMatch :: Text -> Text -> Either String Value
regexMatch :: Name -> Name -> Either String Value
regexMatch Name
text Name
regexT = do
  Regex
regex  <- CompOption -> ExecOption -> Name -> Either String Regex
Regex.compile CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
Regex.defaultCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
Regex.defaultExecOpt Name
regexT
  Maybe MatchArray
result <- Regex -> Name -> Either String (Maybe MatchArray)
Regex.execute Regex
regex Name
text
  Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Bool -> Value) -> Bool -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Bool -> Either String Value) -> Bool -> Either String Value
forall a b. (a -> b) -> a -> b
$ Maybe MatchArray -> Bool
forall a. Maybe a -> Bool
isJust Maybe MatchArray
result

-- | Given bindings for variables, reduce an expression to a single
-- datalog value
evaluateExpression :: Limits
                   -> Bindings
                   -> Expression
                   -> Either String Value
evaluateExpression :: Limits
-> Bindings -> Expression' 'RegularString -> Either String Value
evaluateExpression Limits
l Bindings
b = \case
    EValue Term' 'NotWithinSet 'InPredicate 'RegularString
term -> Bindings
-> Term' 'NotWithinSet 'InPredicate 'RegularString
-> Either String Value
applyVariable Bindings
b Term' 'NotWithinSet 'InPredicate 'RegularString
term
    EUnary Unary
op Expression' 'RegularString
e' -> Unary -> Value -> Either String Value
evalUnary Unary
op (Value -> Either String Value)
-> Either String Value -> Either String Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Limits
-> Bindings -> Expression' 'RegularString -> Either String Value
evaluateExpression Limits
l Bindings
b Expression' 'RegularString
e'
    EBinary Binary
op Expression' 'RegularString
e' Expression' 'RegularString
e'' -> (Value -> Value -> Either String Value)
-> (Value, Value) -> Either String Value
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Limits -> Binary -> Value -> Value -> Either String Value
evalBinary Limits
l Binary
op) ((Value, Value) -> Either String Value)
-> Either String (Value, Value) -> Either String Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Expression' 'RegularString -> Either String Value)
 -> (Expression' 'RegularString -> Either String Value)
 -> (Expression' 'RegularString, Expression' 'RegularString)
 -> Either String (Value, Value))
-> (Expression' 'RegularString -> Either String Value)
-> (Expression' 'RegularString, Expression' 'RegularString)
-> Either String (Value, Value)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Expression' 'RegularString -> Either String Value)
-> (Expression' 'RegularString -> Either String Value)
-> (Expression' 'RegularString, Expression' 'RegularString)
-> Either String (Value, Value)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (Limits
-> Bindings -> Expression' 'RegularString -> Either String Value
evaluateExpression Limits
l Bindings
b) (Expression' 'RegularString
e', Expression' 'RegularString
e'')