{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
module Auth.Biscuit.Datalog.Parser
  where

import           Auth.Biscuit.Crypto            (PublicKey,
                                                 readEd25519PublicKey)
import           Auth.Biscuit.Datalog.AST
import           Control.Monad                  (join)
import qualified Control.Monad.Combinators.Expr as Expr
import           Data.Bifunctor
import           Data.ByteString                (ByteString)
import           Data.ByteString.Base16         as Hex
import qualified Data.ByteString.Char8          as C8
import           Data.Char
import           Data.Either                    (partitionEithers)
import           Data.List.NonEmpty             (NonEmpty)
import qualified Data.List.NonEmpty             as NE
import           Data.Map.Strict                (Map)
import           Data.Maybe                     (isJust)
import           Data.Set                       (Set)
import qualified Data.Set                       as Set
import           Data.Text                      (Text)
import qualified Data.Text                      as T
import           Data.Time                      (UTCTime, defaultTimeLocale,
                                                 parseTimeM)
import           Instances.TH.Lift              ()
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote      (QuasiQuoter (..))
import           Language.Haskell.TH.Syntax     (Lift)
import           Text.Megaparsec
import qualified Text.Megaparsec.Char           as C
import qualified Text.Megaparsec.Char.Lexer     as L
import           Validation                     (Validation (..),
                                                 validationToEither)

type Parser = Parsec SemanticError Text

type Span = (Int, Int)

data SemanticError =
    VarInFact Span
  | VarInSet  Span
  | NestedSet Span
  | InvalidBs Text Span
  | InvalidPublicKey Text Span
  | UnboundVariables (NonEmpty Text) Span
  | PreviousInAuthorizer Span
  deriving stock (SemanticError -> SemanticError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SemanticError -> SemanticError -> Bool
$c/= :: SemanticError -> SemanticError -> Bool
== :: SemanticError -> SemanticError -> Bool
$c== :: SemanticError -> SemanticError -> Bool
Eq, Eq SemanticError
SemanticError -> SemanticError -> Bool
SemanticError -> SemanticError -> Ordering
SemanticError -> SemanticError -> SemanticError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SemanticError -> SemanticError -> SemanticError
$cmin :: SemanticError -> SemanticError -> SemanticError
max :: SemanticError -> SemanticError -> SemanticError
$cmax :: SemanticError -> SemanticError -> SemanticError
>= :: SemanticError -> SemanticError -> Bool
$c>= :: SemanticError -> SemanticError -> Bool
> :: SemanticError -> SemanticError -> Bool
$c> :: SemanticError -> SemanticError -> Bool
<= :: SemanticError -> SemanticError -> Bool
$c<= :: SemanticError -> SemanticError -> Bool
< :: SemanticError -> SemanticError -> Bool
$c< :: SemanticError -> SemanticError -> Bool
compare :: SemanticError -> SemanticError -> Ordering
$ccompare :: SemanticError -> SemanticError -> Ordering
Ord)

instance ShowErrorComponent SemanticError where
  showErrorComponent :: SemanticError -> [Char]
showErrorComponent = \case
    VarInFact Span
_            -> [Char]
"Variables can't appear in a fact"
    VarInSet  Span
_            -> [Char]
"Variables can't appear in a set"
    NestedSet Span
_            -> [Char]
"Sets cannot be nested"
    InvalidBs Text
e Span
_          -> [Char]
"Invalid bytestring literal: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
e
    InvalidPublicKey Text
e Span
_   -> [Char]
"Invalid public key: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
e
    UnboundVariables NonEmpty Text
e Span
_   -> [Char]
"Unbound variables: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
e)
    PreviousInAuthorizer Span
_ -> [Char]
"'previous' can't appear in an authorizer scope"

run :: Parser a -> Text -> Either String a
run :: forall a. Parser a -> Text -> Either [Char] a
run Parser a
p = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
runParser (forall a. Parser a -> Parser a
l (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser a
l Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) [Char]
""

l :: Parser a -> Parser a
l :: forall a. Parser a -> Parser a
l = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
C.space1 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"//") forall (f :: * -> *) a. Alternative f => f a
empty

getSpan :: Parser a -> Parser (Span, a)
getSpan :: forall a. Parser a -> Parser (Span, a)
getSpan Parser a
p = do
  Int
begin <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  a
a <- Parser a
p
  Int
end <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int
begin, Int
end), a
a)

registerError :: (Span -> SemanticError) -> Span -> Parser a
registerError :: forall a. (Span -> SemanticError) -> Span -> Parser a
registerError Span -> SemanticError
mkError Span
sp = do
  let err :: ParseError s SemanticError
err = forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError (forall a b. (a, b) -> a
fst Span
sp) (forall a. a -> Set a
Set.singleton (forall e. e -> ErrorFancy e
ErrorCustom forall a b. (a -> b) -> a -> b
$ Span -> SemanticError
mkError Span
sp))
  forall e s (m :: * -> *).
MonadParsec e s m =>
ParseError s e -> m ()
registerParseError forall {s}. ParseError s SemanticError
err
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"delayed parsing error"

forbid :: (Span -> SemanticError) -> Parser a -> Parser b
forbid :: forall a b. (Span -> SemanticError) -> Parser a -> Parser b
forbid Span -> SemanticError
mkError Parser a
p = do
  (Span
sp, a
_) <- forall a. Parser a -> Parser (Span, a)
getSpan Parser a
p
  forall a. (Span -> SemanticError) -> Span -> Parser a
registerError Span -> SemanticError
mkError Span
sp

variableParser :: Parser Text
variableParser :: Parser Text
variableParser =
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'$' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just [Char]
"_, :, or any alphanumeric char") (\Token Text
c -> Token Text
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Token Text
c forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Token Text
c)

haskellVariableParser :: Parser Text
haskellVariableParser :: Parser Text
haskellVariableParser = forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ do
  Tokens Text
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"{"
  Maybe Char
leadingUS <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'_'
  Char
x <- if forall a. Maybe a -> Bool
isJust Maybe Char
leadingUS then forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.letterChar else forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.lowerChar
  Text
xs <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just [Char]
"_, ', or any alphanumeric char") (\Token Text
c -> Token Text
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Token Text
c forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Token Text
c)
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'}'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Char -> Text -> Text
T.cons Maybe Char
leadingUS forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
x Text
xs

setParser :: Parser (Set (Term' 'WithinSet 'InFact 'WithSlices))
setParser :: Parser (Set (Term' 'WithinSet 'InFact 'WithSlices))
setParser = do
  Token Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'['
  [Term' 'WithinSet 'InFact 'WithSlices]
ts <- forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy (forall (inSet :: IsWithinSet) (pof :: PredicateOrFact).
Parser (VariableType inSet pof)
-> Parser (SetType inSet 'WithSlices)
-> Parser (Term' inSet pof 'WithSlices)
termParser (forall a b. (Span -> SemanticError) -> Parser a -> Parser b
forbid Span -> SemanticError
VarInSet Parser Text
variableParser) (forall a b. (Span -> SemanticError) -> Parser a -> Parser b
forbid Span -> SemanticError
NestedSet Parser (Set (Term' 'WithinSet 'InFact 'WithSlices))
setParser)) (forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
',')
  Token Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
']'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Term' 'WithinSet 'InFact 'WithSlices]
ts

factTermParser :: Parser (Term' 'NotWithinSet 'InFact 'WithSlices)
factTermParser :: Parser (Term' 'NotWithinSet 'InFact 'WithSlices)
factTermParser = forall (inSet :: IsWithinSet) (pof :: PredicateOrFact).
Parser (VariableType inSet pof)
-> Parser (SetType inSet 'WithSlices)
-> Parser (Term' inSet pof 'WithSlices)
termParser (forall a b. (Span -> SemanticError) -> Parser a -> Parser b
forbid Span -> SemanticError
VarInFact Parser Text
variableParser)
                            Parser (Set (Term' 'WithinSet 'InFact 'WithSlices))
setParser

predicateTermParser :: Parser (Term' 'NotWithinSet 'InPredicate 'WithSlices)
predicateTermParser :: Parser (Term' 'NotWithinSet 'InPredicate 'WithSlices)
predicateTermParser = forall (inSet :: IsWithinSet) (pof :: PredicateOrFact).
Parser (VariableType inSet pof)
-> Parser (SetType inSet 'WithSlices)
-> Parser (Term' inSet pof 'WithSlices)
termParser Parser Text
variableParser
                                 Parser (Set (Term' 'WithinSet 'InFact 'WithSlices))
setParser

termParser :: Parser (VariableType inSet pof)
           -> Parser (SetType inSet 'WithSlices)
           -> Parser (Term' inSet pof 'WithSlices)
termParser :: forall (inSet :: IsWithinSet) (pof :: PredicateOrFact).
Parser (VariableType inSet pof)
-> Parser (SetType inSet 'WithSlices)
-> Parser (Term' inSet pof 'WithSlices)
termParser Parser (VariableType inSet pof)
parseVar Parser (SetType inSet 'WithSlices)
parseSet = forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
SliceType ctx -> Term' inSet pof ctx
Antiquote forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Slice
Slice forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
haskellVariableParser forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"parameter (eg. {paramName})"
  , forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
VariableType inSet pof -> Term' inSet pof ctx
Variable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (VariableType inSet pof)
parseVar forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"datalog variable (eg. $variable)"
  , forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
SetType inSet ctx -> Term' inSet pof ctx
TermSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (SetType inSet 'WithSlices)
parseSet forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"set (eg. [1,2,3])"
  , forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ByteString -> Term' inSet pof ctx
LBytes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"hex:" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT SemanticError Text Identity ByteString
hexParser) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"hex-encoded bytestring (eg. hex:00ff99)"
  , forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
UTCTime -> Term' inSet pof ctx
LDate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UTCTime
rfc3339DateParser forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"RFC3339-formatted timestamp (eg. 2022-11-29T00:00:00Z)"
  , forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int -> Term' inSet pof ctx
LInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
C.space forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"(signed) integer"
  , forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Text -> Term' inSet pof ctx
LString forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'"')) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"string literal"
  , forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"true"
                     , Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"false"
                     ]
          forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"boolean value (eg. true or false)"
  ]

hexParser :: Parser ByteString
hexParser :: ParsecT SemanticError Text Identity ByteString
hexParser = do
  (Span
sp, ByteString
hexStr) <- forall a. Parser a -> Parser (Span, a)
getSpan forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
C8.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.hexDigitChar
  case ByteString -> Either Text ByteString
Hex.decodeBase16 ByteString
hexStr of
    Left Text
e   -> forall a. (Span -> SemanticError) -> Span -> Parser a
registerError (Text -> Span -> SemanticError
InvalidBs Text
e) Span
sp
    Right ByteString
bs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

publicKeyParser :: Parser PublicKey
publicKeyParser :: Parser PublicKey
publicKeyParser = do
  (Span
sp, ByteString
hexStr) <- forall a. Parser a -> Parser (Span, a)
getSpan forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
C8.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"ed25519/" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.hexDigitChar)
  case ByteString -> Either Text ByteString
Hex.decodeBase16 ByteString
hexStr of
    Left Text
e -> forall a. (Span -> SemanticError) -> Span -> Parser a
registerError (Text -> Span -> SemanticError
InvalidPublicKey Text
e) Span
sp
    Right ByteString
bs -> case ByteString -> Maybe PublicKey
readEd25519PublicKey ByteString
bs of
      Maybe PublicKey
Nothing -> forall a. (Span -> SemanticError) -> Span -> Parser a
registerError (Text -> Span -> SemanticError
InvalidPublicKey Text
"Invalid ed25519 public key") Span
sp
      Just PublicKey
pk -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicKey
pk

rfc3339DateParser :: Parser UTCTime
rfc3339DateParser :: Parser UTCTime
rfc3339DateParser = do
  let parseDate :: [Char] -> Parser UTCTime
parseDate = forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale [Char]
"%FT%T%Q%EZ"
  [[Char]]
input <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [
      forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'-',
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'-',
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'T'
      ]),
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
':',
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
':',
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'.',
        forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar
      ]),
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'Z',
        forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [
           forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'+', forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'-'],
           forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
           forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
           forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
':',
           forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar,
           forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.digitChar
        ]
      ]
    ]
  [Char] -> Parser UTCTime
parseDate forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Char]]
input

predicateParser' :: Parser (Term' 'NotWithinSet pof 'WithSlices)
                 -> Parser (Predicate' pof 'WithSlices)
predicateParser' :: forall (pof :: PredicateOrFact).
Parser (Term' 'NotWithinSet pof 'WithSlices)
-> Parser (Predicate' pof 'WithSlices)
predicateParser' Parser (Term' 'NotWithinSet pof 'WithSlices)
parseTerm = forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ do
  Text
name <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"predicate name") forall a b. (a -> b) -> a -> b
$ do
    Char
x      <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
C.letterChar
    Text
xs     <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just [Char]
"_, :, or any alphanumeric char") (\Token Text
c -> Token Text
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Token Text
c forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Token Text
c)
    Token Text
_      <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'('
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
x Text
xs
  [Term' 'NotWithinSet pof 'WithSlices]
terms  <- forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 Parser (Term' 'NotWithinSet pof 'WithSlices)
parseTerm (forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
',')
  Token Text
_      <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
')'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Predicate {
    Text
name :: Text
name :: Text
name,
    [Term' 'NotWithinSet pof 'WithSlices]
terms :: [Term' 'NotWithinSet pof 'WithSlices]
terms :: [Term' 'NotWithinSet pof 'WithSlices]
terms
  }

factParser :: Parser (Predicate' 'InFact 'WithSlices)
factParser :: Parser (Predicate' 'InFact 'WithSlices)
factParser = forall (pof :: PredicateOrFact).
Parser (Term' 'NotWithinSet pof 'WithSlices)
-> Parser (Predicate' pof 'WithSlices)
predicateParser' Parser (Term' 'NotWithinSet 'InFact 'WithSlices)
factTermParser

predicateParser :: Parser (Predicate' 'InPredicate 'WithSlices)
predicateParser :: Parser (Predicate' 'InPredicate 'WithSlices)
predicateParser = forall (pof :: PredicateOrFact).
Parser (Term' 'NotWithinSet pof 'WithSlices)
-> Parser (Predicate' pof 'WithSlices)
predicateParser' Parser (Term' 'NotWithinSet 'InPredicate 'WithSlices)
predicateTermParser

expressionParser :: Parser (Expression' 'WithSlices)
expressionParser :: Parser (Expression' 'WithSlices)
expressionParser =
  let base :: Parser (Expression' 'WithSlices)
base = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser (Expression' 'WithSlices)
binaryMethodParser
                    , forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser (Expression' 'WithSlices)
unaryMethodParser
                    , Parser (Expression' 'WithSlices)
exprTerm
                    ]
   in forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
Expr.makeExprParser Parser (Expression' 'WithSlices)
base [[Operator
    (ParsecT SemanticError Text Identity) (Expression' 'WithSlices)]]
table

table :: [[Expr.Operator Parser (Expression' 'WithSlices)]]
table :: [[Operator
    (ParsecT SemanticError Text Identity) (Expression' 'WithSlices)]]
table =
  let infixL :: Tokens Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL Tokens Text
name Binary
op = forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
Expr.InfixL (forall (ctx :: DatalogContext).
Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
EBinary Binary
op forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Parser a -> Parser a
l (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
name) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"infix operator")
      infixN :: Tokens Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixN Tokens Text
name Binary
op = forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
Expr.InfixN (forall (ctx :: DatalogContext).
Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
EBinary Binary
op forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Parser a -> Parser a
l (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
name) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"infix operator")
      prefix :: Tokens Text
-> Unary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
prefix Tokens Text
name Unary
op = forall (m :: * -> *) a. m (a -> a) -> Operator m a
Expr.Prefix (forall (ctx :: DatalogContext).
Unary -> Expression' ctx -> Expression' ctx
EUnary Unary
op forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  forall a. Parser a -> Parser a
l (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
name) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"prefix operator")
   in [ [ forall {ctx :: DatalogContext}.
Text
-> Unary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
prefix Text
"!" Unary
Negate]
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL  Text
"*" Binary
Mul
        , forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL  Text
"/" Binary
Div
        ]
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL  Text
"+" Binary
Add
        , forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL  Text
"-" Binary
Sub
        ]
      -- TODO find a better way to avoid eager parsing
      -- of && and || by the bitwise operators
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL  Text
"& " Binary
BitwiseAnd ]
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL  Text
"| " Binary
BitwiseOr  ]
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL  Text
"^" Binary
BitwiseXor ]
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixN  Text
"<=" Binary
LessOrEqual
        , forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixN  Text
">=" Binary
GreaterOrEqual
        , forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixN  Text
"<"  Binary
LessThan
        , forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixN  Text
">"  Binary
GreaterThan
        , forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixN  Text
"==" Binary
Equal
        ]
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL Text
"&&" Binary
And ]
      , [ forall {ctx :: DatalogContext}.
Text
-> Binary
-> Operator (ParsecT SemanticError Text Identity) (Expression' ctx)
infixL Text
"||" Binary
Or ]
      ]

binaryMethodParser :: Parser (Expression' 'WithSlices)
binaryMethodParser :: Parser (Expression' 'WithSlices)
binaryMethodParser = do
  Expression' 'WithSlices
e1 <- Parser (Expression' 'WithSlices)
exprTerm
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'.'
  Binary
method <- forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Binary
Contains     forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"contains"
    , Binary
Intersection forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"intersection"
    , Binary
Union        forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"union"
    , Binary
Prefix       forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"starts_with"
    , Binary
Suffix       forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"ends_with"
    , Binary
Regex        forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"matches"
    ]
  Token Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'('
  Expression' 'WithSlices
e2 <- forall a. Parser a -> Parser a
l Parser (Expression' 'WithSlices)
expressionParser
  Token Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
')'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (ctx :: DatalogContext).
Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
EBinary Binary
method Expression' 'WithSlices
e1 Expression' 'WithSlices
e2

unaryMethodParser :: Parser (Expression' 'WithSlices)
unaryMethodParser :: Parser (Expression' 'WithSlices)
unaryMethodParser = do
  Expression' 'WithSlices
e1 <- Parser (Expression' 'WithSlices)
exprTerm
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'.'
  Unary
method <- Unary
Length forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"length"
  Tokens Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"()"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (ctx :: DatalogContext).
Unary -> Expression' ctx -> Expression' ctx
EUnary Unary
method Expression' 'WithSlices
e1

methodParser :: Parser (Expression' 'WithSlices)
methodParser :: Parser (Expression' 'WithSlices)
methodParser = Parser (Expression' 'WithSlices)
binaryMethodParser forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Expression' 'WithSlices)
unaryMethodParser

unaryParens :: Parser (Expression' 'WithSlices)
unaryParens :: Parser (Expression' 'WithSlices)
unaryParens = do
  Token Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
'('
  Expression' 'WithSlices
e <- forall a. Parser a -> Parser a
l Parser (Expression' 'WithSlices)
expressionParser
  Token Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
')'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (ctx :: DatalogContext).
Unary -> Expression' ctx -> Expression' ctx
EUnary Unary
Parens Expression' 'WithSlices
e

exprTerm :: Parser (Expression' 'WithSlices)
exprTerm :: Parser (Expression' 'WithSlices)
exprTerm = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ Parser (Expression' 'WithSlices)
unaryParens forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"parens"
  , forall (ctx :: DatalogContext).
Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx
EValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Term' 'NotWithinSet 'InPredicate 'WithSlices)
predicateTermParser
  ]

ruleParser :: Bool -> Parser (Rule' 'Repr 'WithSlices)
ruleParser :: Bool -> Parser (Rule' 'Repr 'WithSlices)
ruleParser Bool
inAuthorizer = do
  Int
begin <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  Predicate' 'InPredicate 'WithSlices
rhead <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
l Parser (Predicate' 'InPredicate 'WithSlices)
predicateParser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser a -> Parser a
l (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"<-")
  ([Predicate' 'InPredicate 'WithSlices]
body, [Expression' 'WithSlices]
expressions, Set (RuleScope' 'Repr 'WithSlices)
scope) <- Bool
-> Parser
     ([Predicate' 'InPredicate 'WithSlices], [Expression' 'WithSlices],
      Set (RuleScope' 'Repr 'WithSlices))
ruleBodyParser Bool
inAuthorizer
  Int
end <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  case forall (ctx :: DatalogContext).
Predicate' 'InPredicate ctx
-> [Predicate' 'InPredicate ctx]
-> [Expression' ctx]
-> Set (RuleScope' 'Repr ctx)
-> Validation (NonEmpty Text) (Rule' 'Repr ctx)
makeRule Predicate' 'InPredicate 'WithSlices
rhead [Predicate' 'InPredicate 'WithSlices]
body [Expression' 'WithSlices]
expressions Set (RuleScope' 'Repr 'WithSlices)
scope of
    Failure NonEmpty Text
vs -> forall a. (Span -> SemanticError) -> Span -> Parser a
registerError (NonEmpty Text -> Span -> SemanticError
UnboundVariables NonEmpty Text
vs) (Int
begin, Int
end)
    Success Rule' 'Repr 'WithSlices
r  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule' 'Repr 'WithSlices
r

ruleBodyParser :: Bool -> Parser ([Predicate' 'InPredicate 'WithSlices], [Expression' 'WithSlices], Set.Set (RuleScope' 'Repr 'WithSlices))
ruleBodyParser :: Bool
-> Parser
     ([Predicate' 'InPredicate 'WithSlices], [Expression' 'WithSlices],
      Set (RuleScope' 'Repr 'WithSlices))
ruleBodyParser Bool
inAuthorizer = do
  let predicateOrExprParser :: ParsecT
  SemanticError
  Text
  Identity
  (Either
     (Predicate' 'InPredicate 'WithSlices) (Expression' 'WithSlices))
predicateOrExprParser =
            forall a b. a -> Either a b
Left  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (Predicate' 'InPredicate 'WithSlices)
predicateParser forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"predicate")
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (Expression' 'WithSlices)
expressionParser forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"expression")
  [Either
   (Predicate' 'InPredicate 'WithSlices) (Expression' 'WithSlices)]
elems <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 (forall a. Parser a -> Parser a
l ParsecT
  SemanticError
  Text
  Identity
  (Either
     (Predicate' 'InPredicate 'WithSlices) (Expression' 'WithSlices))
predicateOrExprParser)
                      (forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
',')
  Set (RuleScope' 'Repr 'WithSlices)
scope <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ Bool
-> ParsecT
     SemanticError Text Identity (Set (RuleScope' 'Repr 'WithSlices))
scopeParser Bool
inAuthorizer
  let ([Predicate' 'InPredicate 'WithSlices]
predicates, [Expression' 'WithSlices]
expressions) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (Predicate' 'InPredicate 'WithSlices) (Expression' 'WithSlices)]
elems
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Predicate' 'InPredicate 'WithSlices]
predicates, [Expression' 'WithSlices]
expressions, Set (RuleScope' 'Repr 'WithSlices)
scope)

scopeParser :: Bool -> Parser (Set.Set (RuleScope' 'Repr 'WithSlices))
scopeParser :: Bool
-> ParsecT
     SemanticError Text Identity (Set (RuleScope' 'Repr 'WithSlices))
scopeParser Bool
inAuthorizer = (forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"scope annotation") forall a b. (a -> b) -> a -> b
$ do
  Tokens Text
_ <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"trusting "
  let elemParser :: ParsecT SemanticError Text Identity (RuleScope' 'Repr 'WithSlices)
elemParser = do
        (Span
sp, RuleScope' 'Repr 'WithSlices
s) <- forall a. Parser a -> Parser (Span, a)
getSpan forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
RuleScope' evalCtx ctx
OnlyAuthority forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"authority"
                                    , forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
RuleScope' evalCtx ctx
Previous      forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"previous"
                                    , forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
BlockIdType evalCtx ctx -> RuleScope' evalCtx ctx
BlockId       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                       forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ Text -> PkOrSlice
PkSlice forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
haskellVariableParser forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"parameter (eg. {paramName})"
                                              , PublicKey -> PkOrSlice
Pk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PublicKey
publicKeyParser forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"public key (eg. ed25519/00ff99)"
                                              ]
                                    ]
        if Bool
inAuthorizer Bool -> Bool -> Bool
&& RuleScope' 'Repr 'WithSlices
s forall a. Eq a => a -> a -> Bool
== forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
RuleScope' evalCtx ctx
Previous
        then forall a. (Span -> SemanticError) -> Span -> Parser a
registerError Span -> SemanticError
PreviousInAuthorizer Span
sp
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure RuleScope' 'Repr 'WithSlices
s
  forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 (forall a. Parser a -> Parser a
l ParsecT SemanticError Text Identity (RuleScope' 'Repr 'WithSlices)
elemParser)
                          (forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
',')

queryItemParser :: Bool -> Parser (QueryItem' 'Repr 'WithSlices)
queryItemParser :: Bool -> Parser (QueryItem' 'Repr 'WithSlices)
queryItemParser Bool
inAuthorizer = do
  (Span
sp, ([Predicate' 'InPredicate 'WithSlices]
predicates, [Expression' 'WithSlices]
expressions, Set (RuleScope' 'Repr 'WithSlices)
scope)) <- forall a. Parser a -> Parser (Span, a)
getSpan forall a b. (a -> b) -> a -> b
$ Bool
-> Parser
     ([Predicate' 'InPredicate 'WithSlices], [Expression' 'WithSlices],
      Set (RuleScope' 'Repr 'WithSlices))
ruleBodyParser Bool
inAuthorizer
  case forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx]
-> [Expression' ctx]
-> Set (RuleScope' 'Repr ctx)
-> Validation (NonEmpty Text) (QueryItem' 'Repr ctx)
makeQueryItem [Predicate' 'InPredicate 'WithSlices]
predicates [Expression' 'WithSlices]
expressions Set (RuleScope' 'Repr 'WithSlices)
scope of
    Failure NonEmpty Text
e  -> forall a. (Span -> SemanticError) -> Span -> Parser a
registerError (NonEmpty Text -> Span -> SemanticError
UnboundVariables NonEmpty Text
e) Span
sp
    Success QueryItem' 'Repr 'WithSlices
qi -> forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryItem' 'Repr 'WithSlices
qi

queryParser :: Bool -> Parser [QueryItem' 'Repr 'WithSlices]
queryParser :: Bool -> Parser [QueryItem' 'Repr 'WithSlices]
queryParser Bool
inAuthorizer =
   forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 (Bool -> Parser (QueryItem' 'Repr 'WithSlices)
queryItemParser Bool
inAuthorizer) (forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
C.string' Tokens Text
"or" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
C.space)
     forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"datalog query"

checkParser :: Bool -> Parser (Check' 'Repr 'WithSlices)
checkParser :: Bool -> Parser (Check' 'Repr 'WithSlices)
checkParser Bool
inAuthorizer = do
  CheckKind
cKind <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ CheckKind
One forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"check if"
                      , CheckKind
All forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"check all"
                      ]
  [QueryItem' 'Repr 'WithSlices]
cQueries <- Bool -> Parser [QueryItem' 'Repr 'WithSlices]
queryParser Bool
inAuthorizer
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Check{[QueryItem' 'Repr 'WithSlices]
CheckKind
cKind :: CheckKind
cQueries :: [QueryItem' 'Repr 'WithSlices]
cQueries :: [QueryItem' 'Repr 'WithSlices]
cKind :: CheckKind
..}

policyParser :: Parser (Policy' 'Repr 'WithSlices)
policyParser :: Parser (Policy' 'Repr 'WithSlices)
policyParser = do
  PolicyType
policy <- forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ PolicyType
Allow forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"allow if"
                       , PolicyType
Deny  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"deny if"
                       ]
  (PolicyType
policy, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser [QueryItem' 'Repr 'WithSlices]
queryParser Bool
True

blockElementParser :: Bool -> Parser (BlockElement' 'Repr 'WithSlices)
blockElementParser :: Bool -> Parser (BlockElement' 'Repr 'WithSlices)
blockElementParser Bool
inAuthorizer = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Check' evalCtx ctx -> BlockElement' evalCtx ctx
BlockCheck   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser (Check' 'Repr 'WithSlices)
checkParser Bool
inAuthorizer forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
';' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"check"
  , forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> BlockElement' evalCtx ctx
BlockRule    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser (Rule' 'Repr 'WithSlices)
ruleParser  Bool
inAuthorizer forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
';' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"rule"
  , forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Predicate' 'InFact ctx -> BlockElement' evalCtx ctx
BlockFact    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Predicate' 'InFact 'WithSlices)
factParser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
';' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"fact"
  ]

authorizerElementParser :: Parser (AuthorizerElement' 'Repr 'WithSlices)
authorizerElementParser :: Parser (AuthorizerElement' 'Repr 'WithSlices)
authorizerElementParser = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Policy' evalCtx ctx -> AuthorizerElement' evalCtx ctx
AuthorizerPolicy  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Policy' 'Repr 'WithSlices)
policyParser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
';' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"policy"
  , forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
BlockElement' evalCtx ctx -> AuthorizerElement' evalCtx ctx
BlockElement    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser (BlockElement' 'Repr 'WithSlices)
blockElementParser Bool
True
  ]

blockParser :: Parser (Block' 'Repr 'WithSlices)
blockParser :: Parser (Block' 'Repr 'WithSlices)
blockParser = do
  Set (RuleScope' 'Repr 'WithSlices)
bScope <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
l (Bool
-> ParsecT
     SemanticError Text Identity (Set (RuleScope' 'Repr 'WithSlices))
scopeParser Bool
False forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
';' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"scope annotation")
  [BlockElement' 'Repr 'WithSlices]
elems <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
l forall a b. (a -> b) -> a -> b
$ Bool -> Parser (BlockElement' 'Repr 'WithSlices)
blockElementParser Bool
False
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
BlockElement' evalCtx ctx -> Block' evalCtx ctx
elementToBlock [BlockElement' 'Repr 'WithSlices]
elems) { bScope :: Set (RuleScope' 'Repr 'WithSlices)
bScope = Set (RuleScope' 'Repr 'WithSlices)
bScope }

authorizerParser :: Parser (Authorizer' 'Repr 'WithSlices)
authorizerParser :: Parser (Authorizer' 'Repr 'WithSlices)
authorizerParser = do
  Set (RuleScope' 'Repr 'WithSlices)
bScope <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
l (Bool
-> ParsecT
     SemanticError Text Identity (Set (RuleScope' 'Repr 'WithSlices))
scopeParser Bool
True forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
';' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"scope annotation")
  [AuthorizerElement' 'Repr 'WithSlices]
elems <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
l Parser (AuthorizerElement' 'Repr 'WithSlices)
authorizerElementParser
  let addScope :: Authorizer' 'Repr 'WithSlices -> Authorizer' 'Repr 'WithSlices
addScope Authorizer' 'Repr 'WithSlices
a = Authorizer' 'Repr 'WithSlices
a { vBlock :: Block' 'Repr 'WithSlices
vBlock = (forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Authorizer' evalCtx ctx -> Block' evalCtx ctx
vBlock Authorizer' 'Repr 'WithSlices
a) { bScope :: Set (RuleScope' 'Repr 'WithSlices)
bScope = Set (RuleScope' 'Repr 'WithSlices)
bScope } }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Authorizer' 'Repr 'WithSlices -> Authorizer' 'Repr 'WithSlices
addScope forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
AuthorizerElement' evalCtx ctx -> Authorizer' evalCtx ctx
elementToAuthorizer [AuthorizerElement' 'Repr 'WithSlices]
elems

parseWithParams :: Parser (a 'WithSlices)
                -> (Map Text Value -> Map Text PublicKey -> a 'WithSlices -> Validation (NonEmpty Text) (a 'Representation))
                -> Text
                -> Map Text Value -> Map Text PublicKey
                -> Either (NonEmpty Text) (a 'Representation)
parseWithParams :: forall (a :: DatalogContext -> *).
Parser (a 'WithSlices)
-> (Map Text Value
    -> Map Text PublicKey
    -> a 'WithSlices
    -> Validation (NonEmpty Text) (a 'Representation))
-> Text
-> Map Text Value
-> Map Text PublicKey
-> Either (NonEmpty Text) (a 'Representation)
parseWithParams Parser (a 'WithSlices)
parser Map Text Value
-> Map Text PublicKey
-> a 'WithSlices
-> Validation (NonEmpty Text) (a 'Representation)
substitute Text
input Map Text Value
termMapping Map Text PublicKey
keyMapping = do
  a 'WithSlices
withSlices <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either [Char] a
run Parser (a 'WithSlices)
parser Text
input
  forall e a. Validation e a -> Either e a
validationToEither forall a b. (a -> b) -> a -> b
$ Map Text Value
-> Map Text PublicKey
-> a 'WithSlices
-> Validation (NonEmpty Text) (a 'Representation)
substitute Map Text Value
termMapping Map Text PublicKey
keyMapping a 'WithSlices
withSlices

parseBlock :: Text -> Map Text Value -> Map Text PublicKey
           -> Either (NonEmpty Text) Block
parseBlock :: Text
-> Map Text Value
-> Map Text PublicKey
-> Either (NonEmpty Text) Block
parseBlock = forall (a :: DatalogContext -> *).
Parser (a 'WithSlices)
-> (Map Text Value
    -> Map Text PublicKey
    -> a 'WithSlices
    -> Validation (NonEmpty Text) (a 'Representation))
-> Text
-> Map Text Value
-> Map Text PublicKey
-> Either (NonEmpty Text) (a 'Representation)
parseWithParams Parser (Block' 'Repr 'WithSlices)
blockParser Map Text Value
-> Map Text PublicKey
-> Block' 'Repr 'WithSlices
-> Validation (NonEmpty Text) Block
substituteBlock

parseAuthorizer :: Text -> Map Text Value -> Map Text PublicKey
                -> Either (NonEmpty Text) Authorizer
parseAuthorizer :: Text
-> Map Text Value
-> Map Text PublicKey
-> Either (NonEmpty Text) Authorizer
parseAuthorizer = forall (a :: DatalogContext -> *).
Parser (a 'WithSlices)
-> (Map Text Value
    -> Map Text PublicKey
    -> a 'WithSlices
    -> Validation (NonEmpty Text) (a 'Representation))
-> Text
-> Map Text Value
-> Map Text PublicKey
-> Either (NonEmpty Text) (a 'Representation)
parseWithParams Parser (Authorizer' 'Repr 'WithSlices)
authorizerParser Map Text Value
-> Map Text PublicKey
-> Authorizer' 'Repr 'WithSlices
-> Validation (NonEmpty Text) Authorizer
substituteAuthorizer

compileParser :: Lift a => Parser a -> (a -> Q Exp) -> String -> Q Exp
compileParser :: forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser Parser a
p a -> Q Exp
build =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail a -> Q Exp
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either [Char] a
run Parser a
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

-- | Quasiquoter for a rule expression. You can reference haskell variables
-- like this: @{variableName}@.
--
-- You most likely want to directly use 'block' or 'authorizer' instead.
rule :: QuasiQuoter
rule :: QuasiQuoter
rule = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser (Bool -> Parser (Rule' 'Repr 'WithSlices)
ruleParser Bool
False) forall a b. (a -> b) -> a -> b
$ \Rule' 'Repr 'WithSlices
result -> [| result :: Rule |]
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  }

-- | Quasiquoter for a predicate expression. You can reference haskell variables
-- like this: @{variableName}@.
--
-- You most likely want to directly use 'block' or 'authorizer' instead.
predicate :: QuasiQuoter
predicate :: QuasiQuoter
predicate = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser Parser (Predicate' 'InPredicate 'WithSlices)
predicateParser forall a b. (a -> b) -> a -> b
$ \Predicate' 'InPredicate 'WithSlices
result -> [| result :: Predicate |]
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  }

-- | Quasiquoter for a fact expression. You can reference haskell variables
-- like this: @{variableName}@.
--
-- You most likely want to directly use 'block' or 'authorizer' instead.
fact :: QuasiQuoter
fact :: QuasiQuoter
fact = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser Parser (Predicate' 'InFact 'WithSlices)
factParser forall a b. (a -> b) -> a -> b
$ \Predicate' 'InFact 'WithSlices
result -> [| result :: Fact |]
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  }

-- | Quasiquoter for a check expression. You can reference haskell variables
-- like this: @{variableName}@.
--
-- You most likely want to directly use 'block' or 'authorizer' instead.
check :: QuasiQuoter
check :: QuasiQuoter
check = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser (Bool -> Parser (Check' 'Repr 'WithSlices)
checkParser Bool
False) forall a b. (a -> b) -> a -> b
$ \Check' 'Repr 'WithSlices
result -> [| result :: Check |]
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  }

-- | Compile-time parser for a block expression, intended to be used with the
-- @QuasiQuotes@ extension.
--
-- A typical use of 'block' looks like this:
--
-- > let fileName = "data.pdf"
-- >  in [block|
-- >       // datalog can reference haskell variables with {variableName}
-- >       resource({fileName});
-- >       rule($variable) <- fact($value), other_fact($value);
-- >       check if operation("read");
-- >     |]
block :: QuasiQuoter
block :: QuasiQuoter
block = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser Parser (Block' 'Repr 'WithSlices)
blockParser forall a b. (a -> b) -> a -> b
$ \Block' 'Repr 'WithSlices
result -> [| result :: Block |]
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  }

-- | Compile-time parser for an authorizer expression, intended to be used with the
-- @QuasiQuotes@ extension.
--
-- A typical use of 'authorizer' looks like this:
--
-- > do
-- >   now <- getCurrentTime
-- >   pure [authorizer|
-- >          // datalog can reference haskell variables with {variableName}
-- >          current_time({now});
-- >          // authorizers can contain facts, rules and checks like blocks, but
-- >          // also declare policies. While every check has to pass for a biscuit to
-- >          // be valid, policies are tried in order. The first one to match decides
-- >          // if the token is valid or not
-- >          allow if resource("file1");
-- >          deny if true;
-- >        |]
authorizer :: QuasiQuoter
authorizer :: QuasiQuoter
authorizer = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser Parser (Authorizer' 'Repr 'WithSlices)
authorizerParser forall a b. (a -> b) -> a -> b
$ \Authorizer' 'Repr 'WithSlices
result -> [| result :: Authorizer |]
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  }

-- | Compile-time parser for a query expression, intended to be used with the
-- @QuasiQuotes@ extension.
--
-- A typical use of 'query' looks like this:
--
-- > [query|user($user_id) or group($group_id)|]
query :: QuasiQuoter
query :: QuasiQuoter
query = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = forall a. Lift a => Parser a -> (a -> Q Exp) -> [Char] -> Q Exp
compileParser (Bool -> Parser [QueryItem' 'Repr 'WithSlices]
queryParser Bool
False) forall a b. (a -> b) -> a -> b
$ \[QueryItem' 'Repr 'WithSlices]
result -> [| result :: Query |]
  , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"not supported"
  }