{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveLift            #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{- HLINT ignore "Reduce duplication" -}
module Auth.Biscuit.Datalog.Parser
  ( block
  , check
  , fact
  , predicate
  , rule
  , authorizer
  , query
  -- these are only exported for testing purposes
  , checkParser
  , expressionParser
  , policyParser
  , predicateParser
  , ruleParser
  , termParser
  , blockParser
  , authorizerParser
  , HasParsers
  , HasTermParsers
  ) where

import           Control.Applicative            (liftA2, optional, (<|>))
import qualified Control.Monad.Combinators.Expr as Expr
import           Data.Attoparsec.Text
import qualified Data.Attoparsec.Text           as A
import           Data.ByteString                (ByteString)
import           Data.ByteString.Base16         as Hex
import           Data.Char                      (isAlphaNum, isLetter, isLower,
                                                 isSpace)
import           Data.Either                    (partitionEithers)
import           Data.Foldable                  (fold)
import           Data.Functor                   (void, ($>))
import           Data.Maybe                     (isJust)
import qualified Data.Set                       as Set
import           Data.Text                      (Text, pack, singleton, unpack)
import           Data.Text.Encoding             (encodeUtf8)
import           Data.Time                      (UTCTime, defaultTimeLocale,
                                                 parseTimeM)
import           Data.Void                      (Void)
import           Instances.TH.Lift              ()
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax     (Lift)

import           Auth.Biscuit.Datalog.AST

class ConditionalParse a v where
  ifPresent :: String -> Parser a -> Parser v

instance ConditionalParse a Void where
  ifPresent :: String -> Parser a -> Parser Void
ifPresent String
name Parser a
_ = String -> Parser Void
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Void) -> String -> Parser Void
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not available in this context"

instance ConditionalParse m m where
  ifPresent :: String -> Parser m -> Parser m
ifPresent String
_ Parser m
p = Parser m
p

class SetParser (inSet :: IsWithinSet) (ctx :: ParsedAs) where
  parseSet :: Parser (SetType inSet ctx)

instance SetParser 'WithinSet ctx where
  parseSet :: Parser (SetType 'WithinSet ctx)
parseSet = String -> Parser Void
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"nested sets are forbidden"

instance SetParser 'NotWithinSet 'QuasiQuote where
  parseSet :: Parser (SetType 'NotWithinSet 'QuasiQuote)
parseSet = [Term' 'WithinSet 'InFact 'QuasiQuote]
-> Set (Term' 'WithinSet 'InFact 'QuasiQuote)
forall a. Ord a => [a] -> Set a
Set.fromList ([Term' 'WithinSet 'InFact 'QuasiQuote]
 -> Set (Term' 'WithinSet 'InFact 'QuasiQuote))
-> Parser Text [Term' 'WithinSet 'InFact 'QuasiQuote]
-> Parser Text (Set (Term' 'WithinSet 'InFact 'QuasiQuote))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
'[' Parser Char
-> Parser Text [Term' 'WithinSet 'InFact 'QuasiQuote]
-> Parser Text [Term' 'WithinSet 'InFact 'QuasiQuote]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Term' 'WithinSet 'InFact 'QuasiQuote)
-> Parser Text [Term' 'WithinSet 'InFact 'QuasiQuote]
forall a. Parser a -> Parser [a]
commaList0 Parser (Term' 'WithinSet 'InFact 'QuasiQuote)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
HasTermParsers inSet pof ctx =>
Parser (Term' inSet pof ctx)
termParser Parser Text [Term' 'WithinSet 'InFact 'QuasiQuote]
-> Parser Char
-> Parser Text [Term' 'WithinSet 'InFact 'QuasiQuote]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
']')

instance SetParser 'NotWithinSet 'RegularString where
  parseSet :: Parser (SetType 'NotWithinSet 'RegularString)
parseSet = [Term' 'WithinSet 'InFact 'RegularString]
-> Set (Term' 'WithinSet 'InFact 'RegularString)
forall a. Ord a => [a] -> Set a
Set.fromList ([Term' 'WithinSet 'InFact 'RegularString]
 -> Set (Term' 'WithinSet 'InFact 'RegularString))
-> Parser Text [Term' 'WithinSet 'InFact 'RegularString]
-> Parser Text (Set (Term' 'WithinSet 'InFact 'RegularString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
'[' Parser Char
-> Parser Text [Term' 'WithinSet 'InFact 'RegularString]
-> Parser Text [Term' 'WithinSet 'InFact 'RegularString]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Term' 'WithinSet 'InFact 'RegularString)
-> Parser Text [Term' 'WithinSet 'InFact 'RegularString]
forall a. Parser a -> Parser [a]
commaList0 Parser (Term' 'WithinSet 'InFact 'RegularString)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
HasTermParsers inSet pof ctx =>
Parser (Term' inSet pof ctx)
termParser Parser Text [Term' 'WithinSet 'InFact 'RegularString]
-> Parser Char
-> Parser Text [Term' 'WithinSet 'InFact 'RegularString]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
']')

type HasTermParsers inSet pof ctx =
  ( ConditionalParse (SliceType 'QuasiQuote)                   (SliceType ctx)
  , ConditionalParse (VariableType 'NotWithinSet 'InPredicate) (VariableType inSet pof)
  , SetParser inSet ctx
  )
type HasParsers pof ctx = HasTermParsers 'NotWithinSet pof ctx

-- | Parser for a datalog predicate name
predicateNameParser :: Parser Text
predicateNameParser :: Parser Text
predicateNameParser = do
  Char
first <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isLetter
  Text
rest  <- (Char -> Bool) -> Parser Text
A.takeWhile ((Char -> Bool) -> Parser Text) -> (Char -> Bool) -> Parser Text
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c
  Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Char -> Text
singleton Char
first Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest

variableNameParser :: Parser Text
variableNameParser :: Parser Text
variableNameParser = Char -> Parser Char
char Char
'$' Parser Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c)

haskellVariableParser :: Parser Text
haskellVariableParser :: Parser Text
haskellVariableParser = do
  Maybe Char
leadingUS <- Parser Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Char -> Parser Text (Maybe Char))
-> Parser Char -> Parser Text (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
'_'
  Char
first <- if Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust Maybe Char
leadingUS
           then (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isLetter
           else (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
c)
  Text
rest  <- (Char -> Bool) -> Parser Text
A.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c)
  Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> Maybe Char -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> Text
singleton Maybe Char
leadingUS Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
singleton Char
first Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest

delimited :: Parser x
          -> Parser y
          -> Parser a
          -> Parser a
delimited :: Parser x -> Parser y -> Parser a -> Parser a
delimited Parser x
before Parser y
after Parser a
p = Parser x
before Parser x -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser y -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser y
after

parens :: Parser a -> Parser a
parens :: Parser a -> Parser a
parens = Parser Char -> Parser Char -> Parser a -> Parser a
forall x y a. Parser x -> Parser y -> Parser a -> Parser a
delimited (Char -> Parser Char
char Char
'(') (Parser ()
skipSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
')')

commaList :: Parser a -> Parser [a]
commaList :: Parser a -> Parser [a]
commaList Parser a
p =
  Parser a -> Parser Char -> Parser [a]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 Parser a
p (Parser ()
skipSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
',')

commaList0 :: Parser a -> Parser [a]
commaList0 :: Parser a -> Parser [a]
commaList0 Parser a
p =
  Parser a -> Parser Char -> Parser [a]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy Parser a
p (Parser ()
skipSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
',')

predicateParser :: HasParsers pof ctx => Parser (Predicate' pof ctx)
predicateParser :: Parser (Predicate' pof ctx)
predicateParser = do
  Parser ()
skipSpace
  Text
name <- Parser Text
predicateNameParser
  Parser ()
skipSpace
  [Term' 'NotWithinSet pof ctx]
terms <- Parser [Term' 'NotWithinSet pof ctx]
-> Parser [Term' 'NotWithinSet pof ctx]
forall a. Parser a -> Parser a
parens (Parser (Term' 'NotWithinSet pof ctx)
-> Parser [Term' 'NotWithinSet pof ctx]
forall a. Parser a -> Parser [a]
commaList Parser (Term' 'NotWithinSet pof ctx)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
HasTermParsers inSet pof ctx =>
Parser (Term' inSet pof ctx)
termParser)
  Predicate' pof ctx -> Parser (Predicate' pof ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Predicate :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Text -> [Term' 'NotWithinSet pof ctx] -> Predicate' pof ctx
Predicate{Text
name :: Text
name :: Text
name,[Term' 'NotWithinSet pof ctx]
terms :: [Term' 'NotWithinSet pof ctx]
terms :: [Term' 'NotWithinSet pof ctx]
terms}

unary :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)
unary :: Parser (Expression' ctx)
unary = [Parser (Expression' ctx)] -> Parser (Expression' ctx)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
  [ Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
unaryParens
  , Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
unaryNegate
  , Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
unaryLength
  ]

unaryParens :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)
unaryParens :: Parser (Expression' ctx)
unaryParens = do
  Parser ()
skipSpace
  Char
_ <- Char -> Parser Char
char Char
'('
  Parser ()
skipSpace
  Expression' ctx
e <- Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
expressionParser
  Parser ()
skipSpace
  Char
_ <- Char -> Parser Char
char Char
')'
  Expression' ctx -> Parser (Expression' ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression' ctx -> Parser (Expression' ctx))
-> Expression' ctx -> Parser (Expression' ctx)
forall a b. (a -> b) -> a -> b
$ Unary -> Expression' ctx -> Expression' ctx
forall (ctx :: ParsedAs).
Unary -> Expression' ctx -> Expression' ctx
EUnary Unary
Parens Expression' ctx
e

unaryNegate :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)
unaryNegate :: Parser (Expression' ctx)
unaryNegate = do
  Parser ()
skipSpace
  Char
_ <- Char -> Parser Char
char Char
'!'
  Parser ()
skipSpace
  Unary -> Expression' ctx -> Expression' ctx
forall (ctx :: ParsedAs).
Unary -> Expression' ctx -> Expression' ctx
EUnary Unary
Negate (Expression' ctx -> Expression' ctx)
-> Parser (Expression' ctx) -> Parser (Expression' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
expressionParser

unaryLength :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)
unaryLength :: Parser (Expression' ctx)
unaryLength = do
  Parser ()
skipSpace
  Expression' ctx
e <- [Parser (Expression' ctx)] -> Parser (Expression' ctx)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
         [ Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx
forall (ctx :: ParsedAs).
Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx
EValue (Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx)
-> Parser Text (Term' 'NotWithinSet 'InPredicate ctx)
-> Parser (Expression' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Term' 'NotWithinSet 'InPredicate ctx)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
HasTermParsers inSet pof ctx =>
Parser (Term' inSet pof ctx)
termParser
         , Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
unaryParens
         ]
  Parser ()
skipSpace
  Text
_ <- Text -> Parser Text
string Text
".length()"
  Expression' ctx -> Parser (Expression' ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression' ctx -> Parser (Expression' ctx))
-> Expression' ctx -> Parser (Expression' ctx)
forall a b. (a -> b) -> a -> b
$ Unary -> Expression' ctx -> Expression' ctx
forall (ctx :: ParsedAs).
Unary -> Expression' ctx -> Expression' ctx
EUnary Unary
Length Expression' ctx
e

exprTerm :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)
exprTerm :: Parser (Expression' ctx)
exprTerm = [Parser (Expression' ctx)] -> Parser (Expression' ctx)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
  [ Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
unary
  , Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx
forall (ctx :: ParsedAs).
Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx
EValue (Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx)
-> Parser Text (Term' 'NotWithinSet 'InPredicate ctx)
-> Parser (Expression' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Term' 'NotWithinSet 'InPredicate ctx)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
HasTermParsers inSet pof ctx =>
Parser (Term' inSet pof ctx)
termParser
  ]

methodParser :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)
methodParser :: Parser (Expression' ctx)
methodParser = do
  Expression' ctx
e1 <- Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
exprTerm
  Char
_ <- Char -> Parser Char
char Char
'.'
  Binary
method <- [Parser Text Binary] -> Parser Text Binary
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
    [ Binary
Contains     Binary -> Parser Text -> Parser Text Binary
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"contains"
    , Binary
Intersection Binary -> Parser Text -> Parser Text Binary
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"intersection"
    , Binary
Union        Binary -> Parser Text -> Parser Text Binary
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"union"
    , Binary
Prefix       Binary -> Parser Text -> Parser Text Binary
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"starts_with"
    , Binary
Suffix       Binary -> Parser Text -> Parser Text Binary
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"ends_with"
    , Binary
Regex        Binary -> Parser Text -> Parser Text Binary
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"matches"
    ]
  Char
_ <- Char -> Parser Char
char Char
'('
  Parser ()
skipSpace
  Expression' ctx
e2 <- Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
expressionParser
  Parser ()
skipSpace
  Char
_ <- Char -> Parser Char
char Char
')'
  Expression' ctx -> Parser (Expression' ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression' ctx -> Parser (Expression' ctx))
-> Expression' ctx -> Parser (Expression' ctx)
forall a b. (a -> b) -> a -> b
$ Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
forall (ctx :: ParsedAs).
Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
EBinary Binary
method Expression' ctx
e1 Expression' ctx
e2

expressionParser :: HasParsers 'InPredicate ctx => Parser (Expression' ctx)
expressionParser :: Parser (Expression' ctx)
expressionParser = Parser (Expression' ctx)
-> [[Operator (Parser Text) (Expression' ctx)]]
-> Parser (Expression' ctx)
forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
Expr.makeExprParser (Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
methodParser Parser (Expression' ctx)
-> Parser (Expression' ctx) -> Parser (Expression' ctx)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
exprTerm) [[Operator (Parser Text) (Expression' ctx)]]
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
[[Operator (Parser Text) (Expression' ctx)]]
table

table :: HasParsers 'InPredicate ctx
      => [[Expr.Operator Parser (Expression' ctx)]]
table :: [[Operator (Parser Text) (Expression' ctx)]]
table = [ [ Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"*" Binary
Mul
          , Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"/" Binary
Div
          ]
        , [ Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"+" Binary
Add
          , Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"-" Binary
Sub
          ]
        , [ Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"<=" Binary
LessOrEqual
          , Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
">=" Binary
GreaterOrEqual
          , Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"<"  Binary
LessThan
          , Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
">"  Binary
GreaterThan
          , Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"==" Binary
Equal
          ]
        , [ Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"&&" Binary
And
          , Text -> Binary -> Operator (Parser Text) (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary  Text
"||" Binary
Or
          ]
        ]

binary :: HasParsers 'InPredicate ctx
       => Text
       -> Binary
       -> Expr.Operator Parser (Expression' ctx)
binary :: Text -> Binary -> Operator (Parser Text) (Expression' ctx)
binary Text
name Binary
op = Parser Text (Expression' ctx -> Expression' ctx -> Expression' ctx)
-> Operator (Parser Text) (Expression' ctx)
forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
Expr.InfixL  (Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
forall (ctx :: ParsedAs).
Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
EBinary Binary
op (Expression' ctx -> Expression' ctx -> Expression' ctx)
-> Parser Text
-> Parser
     Text (Expression' ctx -> Expression' ctx -> Expression' ctx)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Parser ()
skipSpace Parser () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
name))

hexBsParser :: Parser ByteString
hexBsParser :: Parser ByteString
hexBsParser = do
  Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
string Text
"hex:"
  (String -> Parser ByteString)
-> (ByteString -> Parser ByteString)
-> Either String ByteString
-> Parser ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ByteString -> Parser ByteString)
-> (Text -> Either String ByteString) -> Text -> Parser ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Hex.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> Parser ByteString) -> Parser Text -> Parser ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser Text
takeWhile1 (String -> Char -> Bool
inClass String
"0-9a-fA-F")

litStringParser :: Parser Text
litStringParser :: Parser Text
litStringParser =
  let regularChars :: Parser Text
regularChars = (Char -> Bool) -> Parser Text
takeTill (String -> Char -> Bool
inClass String
"\"\\")
      escaped :: Parser Text
escaped = [Parser Text] -> Parser Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
        [ Text -> Parser Text
string Text
"\\n" Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
"\n"
        , Text -> Parser Text
string Text
"\\\"" Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
"\""
        , Text -> Parser Text
string Text
"\\\\"  Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
"\\"
        ]
      str :: Parser Text
str = do
        Text
f <- Parser Text
regularChars
        Maybe Text
r <- Parser Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((Text -> Text -> Text) -> Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) Parser Text
escaped Parser Text
str)
        Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Text
r
   in Char -> Parser Char
char Char
'"' Parser Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
str Parser Text -> Parser Char -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'"'

rfc3339DateParser :: Parser UTCTime
rfc3339DateParser :: Parser UTCTime
rfc3339DateParser =
  -- get all the chars until the end of the term
  -- a term can be terminated by
  --  - a space (before another delimiter)
  --  - a comma (before another term)
  --  - a closing paren (the end of a term list)
  --  - a closing bracket (the end of a set)
  let getDateInput :: Parser Text
getDateInput = (Char -> Bool) -> Parser Text
takeWhile1 (String -> Char -> Bool
notInClass String
", )];")
      parseDate :: String -> Parser UTCTime
parseDate = Bool -> TimeLocale -> String -> String -> Parser UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale String
"%FT%T%Q%EZ"
   in String -> Parser UTCTime
parseDate (String -> Parser UTCTime)
-> (Text -> String) -> Text -> Parser UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> Parser UTCTime) -> Parser Text -> Parser UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Text
getDateInput

termParser :: forall inSet pof ctx
            . ( HasTermParsers inSet pof ctx
              )
           => Parser (Term' inSet pof ctx)
termParser :: Parser (Term' inSet pof ctx)
termParser = Parser ()
skipSpace Parser ()
-> Parser (Term' inSet pof ctx) -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser (Term' inSet pof ctx)] -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
  [ SliceType ctx -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SliceType ctx -> Term' inSet pof ctx
Antiquote (SliceType ctx -> Term' inSet pof ctx)
-> Parser Text (SliceType ctx) -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser Slice -> Parser Text (SliceType ctx)
forall a v. ConditionalParse a v => String -> Parser a -> Parser v
ifPresent String
"slice" (Text -> Slice
Slice (Text -> Slice) -> Parser Text -> Parser Slice
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Text
string Text
"${" Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
haskellVariableParser Parser Text -> Parser Char -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'}'))
  , VariableType inSet pof -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
VariableType inSet pof -> Term' inSet pof ctx
Variable (VariableType inSet pof -> Term' inSet pof ctx)
-> Parser Text (VariableType inSet pof)
-> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser Text -> Parser Text (VariableType inSet pof)
forall a v. ConditionalParse a v => String -> Parser a -> Parser v
ifPresent String
"var" Parser Text
variableNameParser
  , SetType inSet ctx -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet (SetType inSet ctx -> Term' inSet pof ctx)
-> Parser Text (SetType inSet ctx) -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SetParser inSet ctx => Parser Text (SetType inSet ctx)
forall (inSet :: IsWithinSet) (ctx :: ParsedAs).
SetParser inSet ctx =>
Parser (SetType inSet ctx)
parseSet @inSet @ctx
  , ByteString -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ByteString -> Term' inSet pof ctx
LBytes (ByteString -> Term' inSet pof ctx)
-> Parser ByteString -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
hexBsParser
  , UTCTime -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
UTCTime -> Term' inSet pof ctx
LDate (UTCTime -> Term' inSet pof ctx)
-> Parser UTCTime -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UTCTime
rfc3339DateParser
  , Int -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int -> Term' inSet pof ctx)
-> Parser Text Int -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int -> Parser Text Int
forall a. Num a => Parser a -> Parser a
signed Parser Text Int
forall a. Integral a => Parser a
decimal
  , Text -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Text -> Term' inSet pof ctx
LString (Text -> Term' inSet pof ctx)
-> Parser Text -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
litStringParser
  , Bool -> Term' inSet pof ctx
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Bool -> Term' inSet pof ctx)
-> Parser Text Bool -> Parser (Term' inSet pof ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser Text Bool] -> Parser Text Bool
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ Text -> Parser Text
string Text
"true"  Parser Text -> Bool -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
                     , Text -> Parser Text
string Text
"false" Parser Text -> Bool -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
                     ]
  ]

-- | same as a predicate, but allows empty
-- | terms list
ruleHeadParser :: HasParsers 'InPredicate ctx => Parser (Predicate' 'InPredicate ctx)
ruleHeadParser :: Parser (Predicate' 'InPredicate ctx)
ruleHeadParser = do
  Parser ()
skipSpace
  Text
name <- Parser Text
predicateNameParser
  Parser ()
skipSpace
  [Term' 'NotWithinSet 'InPredicate ctx]
terms <- Parser [Term' 'NotWithinSet 'InPredicate ctx]
-> Parser [Term' 'NotWithinSet 'InPredicate ctx]
forall a. Parser a -> Parser a
parens (Parser (Term' 'NotWithinSet 'InPredicate ctx)
-> Parser [Term' 'NotWithinSet 'InPredicate ctx]
forall a. Parser a -> Parser [a]
commaList0 Parser (Term' 'NotWithinSet 'InPredicate ctx)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
HasTermParsers inSet pof ctx =>
Parser (Term' inSet pof ctx)
termParser)
  Predicate' 'InPredicate ctx -> Parser (Predicate' 'InPredicate ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Predicate :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Text -> [Term' 'NotWithinSet pof ctx] -> Predicate' pof ctx
Predicate{Text
name :: Text
name :: Text
name,[Term' 'NotWithinSet 'InPredicate ctx]
terms :: [Term' 'NotWithinSet 'InPredicate ctx]
terms :: [Term' 'NotWithinSet 'InPredicate ctx]
terms}

ruleBodyParser :: HasParsers 'InPredicate ctx
               => Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])
ruleBodyParser :: Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])
ruleBodyParser = do
  let predicateOrExprParser :: Parser
  Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
predicateOrExprParser =
            Expression' ctx
-> Either (Predicate' 'InPredicate ctx) (Expression' ctx)
forall a b. b -> Either a b
Right (Expression' ctx
 -> Either (Predicate' 'InPredicate ctx) (Expression' ctx))
-> Parser Text (Expression' ctx)
-> Parser
     Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Expression' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Expression' ctx)
expressionParser
        Parser
  Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
-> Parser
     Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
-> Parser
     Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Predicate' 'InPredicate ctx
-> Either (Predicate' 'InPredicate ctx) (Expression' ctx)
forall a b. a -> Either a b
Left (Predicate' 'InPredicate ctx
 -> Either (Predicate' 'InPredicate ctx) (Expression' ctx))
-> Parser Text (Predicate' 'InPredicate ctx)
-> Parser
     Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Predicate' 'InPredicate ctx)
forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
HasParsers pof ctx =>
Parser (Predicate' pof ctx)
predicateParser
  [Either (Predicate' 'InPredicate ctx) (Expression' ctx)]
elems <- Parser
  Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
-> Parser Char
-> Parser
     Text [Either (Predicate' 'InPredicate ctx) (Expression' ctx)]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 (Parser ()
skipSpace Parser ()
-> Parser
     Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
-> Parser
     Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser
  Text (Either (Predicate' 'InPredicate ctx) (Expression' ctx))
predicateOrExprParser)
                  (Parser ()
skipSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
',')
  ([Predicate' 'InPredicate ctx], [Expression' ctx])
-> Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Predicate' 'InPredicate ctx], [Expression' ctx])
 -> Parser ([Predicate' 'InPredicate ctx], [Expression' ctx]))
-> ([Predicate' 'InPredicate ctx], [Expression' ctx])
-> Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])
forall a b. (a -> b) -> a -> b
$ [Either (Predicate' 'InPredicate ctx) (Expression' ctx)]
-> ([Predicate' 'InPredicate ctx], [Expression' ctx])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (Predicate' 'InPredicate ctx) (Expression' ctx)]
elems

ruleParser :: HasParsers 'InPredicate ctx => Parser (Rule' ctx)
ruleParser :: Parser (Rule' ctx)
ruleParser = do
  Predicate' 'InPredicate ctx
rhead <- Parser (Predicate' 'InPredicate ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Predicate' 'InPredicate ctx)
ruleHeadParser
  Parser ()
skipSpace
  Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
string Text
"<-"
  ([Predicate' 'InPredicate ctx]
body, [Expression' ctx]
expressions) <- Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])
ruleBodyParser
  Rule' ctx -> Parser (Rule' ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule :: forall (ctx :: ParsedAs).
Predicate' 'InPredicate ctx
-> [Predicate' 'InPredicate ctx]
-> [Expression' ctx]
-> Maybe RuleScope
-> Rule' ctx
Rule{Predicate' 'InPredicate ctx
rhead :: Predicate' 'InPredicate ctx
rhead :: Predicate' 'InPredicate ctx
rhead, [Predicate' 'InPredicate ctx]
body :: [Predicate' 'InPredicate ctx]
body :: [Predicate' 'InPredicate ctx]
body, [Expression' ctx]
expressions :: [Expression' ctx]
expressions :: [Expression' ctx]
expressions, scope :: Maybe RuleScope
scope = Maybe RuleScope
forall a. Maybe a
Nothing} -- todo parse scope

queryParser :: HasParsers 'InPredicate ctx => Parser (Query' ctx)
queryParser :: Parser (Query' ctx)
queryParser =
  let mkQueryItem :: ([Predicate' 'InPredicate ctx], [Expression' ctx])
-> QueryItem' ctx
mkQueryItem ([Predicate' 'InPredicate ctx]
qBody, [Expression' ctx]
qExpressions) = QueryItem :: forall (ctx :: ParsedAs).
[Predicate' 'InPredicate ctx]
-> [Expression' ctx] -> Maybe RuleScope -> QueryItem' ctx
QueryItem { [Predicate' 'InPredicate ctx]
qBody :: [Predicate' 'InPredicate ctx]
qBody :: [Predicate' 'InPredicate ctx]
qBody, [Expression' ctx]
qExpressions :: [Expression' ctx]
qExpressions :: [Expression' ctx]
qExpressions, qScope :: Maybe RuleScope
qScope = Maybe RuleScope
forall a. Maybe a
Nothing } -- todo parse scope
   in (([Predicate' 'InPredicate ctx], [Expression' ctx])
 -> QueryItem' ctx)
-> [([Predicate' 'InPredicate ctx], [Expression' ctx])]
-> Query' ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Predicate' 'InPredicate ctx], [Expression' ctx])
-> QueryItem' ctx
forall (ctx :: ParsedAs).
([Predicate' 'InPredicate ctx], [Expression' ctx])
-> QueryItem' ctx
mkQueryItem ([([Predicate' 'InPredicate ctx], [Expression' ctx])]
 -> Query' ctx)
-> Parser Text [([Predicate' 'InPredicate ctx], [Expression' ctx])]
-> Parser (Query' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text ([Predicate' 'InPredicate ctx], [Expression' ctx])
-> Parser Text
-> Parser Text [([Predicate' 'InPredicate ctx], [Expression' ctx])]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 Parser Text ([Predicate' 'InPredicate ctx], [Expression' ctx])
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser ([Predicate' 'InPredicate ctx], [Expression' ctx])
ruleBodyParser (Parser ()
skipSpace Parser () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
asciiCI Text
"or" Parser Text -> Parser Char -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isSpace)

checkParser :: HasParsers 'InPredicate ctx => Parser (Check' ctx)
checkParser :: Parser (Check' ctx)
checkParser = Text -> Parser Text
string Text
"check if" Parser Text -> Parser (Check' ctx) -> Parser (Check' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Check' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Query' ctx)
queryParser

commentParser :: Parser ()
commentParser :: Parser ()
commentParser = do
  Parser ()
skipSpace
  Text
_ <- Text -> Parser Text
string Text
"//"
  ()
_ <- (Char -> Bool) -> Parser ()
skipWhile (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') (Char -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n'))
  Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Parser ()] -> Parser ()
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'\n')
                , Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> Parser Text
string Text
"\r\n")
                , Parser ()
forall t. Chunk t => Parser t ()
endOfInput
                ]

blockElementParser :: HasParsers 'InPredicate ctx => Parser (BlockElement' ctx)
blockElementParser :: Parser (BlockElement' ctx)
blockElementParser = [Parser (BlockElement' ctx)] -> Parser (BlockElement' ctx)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
  [ Rule' ctx -> BlockElement' ctx
forall (ctx :: ParsedAs). Rule' ctx -> BlockElement' ctx
BlockRule    (Rule' ctx -> BlockElement' ctx)
-> Parser Text (Rule' ctx) -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Rule' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Rule' ctx)
ruleParser Parser (BlockElement' ctx)
-> Parser () -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser (BlockElement' ctx)
-> Parser Char -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
';'
  , Predicate' 'InFact ctx -> BlockElement' ctx
forall (ctx :: ParsedAs).
Predicate' 'InFact ctx -> BlockElement' ctx
BlockFact    (Predicate' 'InFact ctx -> BlockElement' ctx)
-> Parser Text (Predicate' 'InFact ctx)
-> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Predicate' 'InFact ctx)
forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
HasParsers pof ctx =>
Parser (Predicate' pof ctx)
predicateParser Parser (BlockElement' ctx)
-> Parser () -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser (BlockElement' ctx)
-> Parser Char -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
';'
  , Check' ctx -> BlockElement' ctx
forall (ctx :: ParsedAs). Check' ctx -> BlockElement' ctx
BlockCheck   (Check' ctx -> BlockElement' ctx)
-> Parser Text (Check' ctx) -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Check' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Query' ctx)
checkParser Parser (BlockElement' ctx)
-> Parser () -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser (BlockElement' ctx)
-> Parser Char -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
';'
  , BlockElement' ctx
forall (ctx :: ParsedAs). BlockElement' ctx
BlockComment BlockElement' ctx -> Parser () -> Parser (BlockElement' ctx)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
commentParser
  ]

authorizerElementParser :: HasParsers 'InPredicate ctx => Parser (AuthorizerElement' ctx)
authorizerElementParser :: Parser (AuthorizerElement' ctx)
authorizerElementParser = [Parser (AuthorizerElement' ctx)]
-> Parser (AuthorizerElement' ctx)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
  [ Policy' ctx -> AuthorizerElement' ctx
forall (ctx :: ParsedAs). Policy' ctx -> AuthorizerElement' ctx
AuthorizerPolicy  (Policy' ctx -> AuthorizerElement' ctx)
-> Parser Text (Policy' ctx) -> Parser (AuthorizerElement' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Policy' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Policy' ctx)
policyParser Parser (AuthorizerElement' ctx)
-> Parser () -> Parser (AuthorizerElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser (AuthorizerElement' ctx)
-> Parser Char -> Parser (AuthorizerElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
';'
  , BlockElement' ctx -> AuthorizerElement' ctx
forall (ctx :: ParsedAs).
BlockElement' ctx -> AuthorizerElement' ctx
BlockElement    (BlockElement' ctx -> AuthorizerElement' ctx)
-> Parser Text (BlockElement' ctx)
-> Parser (AuthorizerElement' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (BlockElement' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (BlockElement' ctx)
blockElementParser
  ]

authorizerParser :: ( HasParsers 'InPredicate ctx
                  , HasParsers 'InFact ctx
                  , Show (AuthorizerElement' ctx)
                  )
               => Parser (Authorizer' ctx)
authorizerParser :: Parser (Authorizer' ctx)
authorizerParser = do
  [AuthorizerElement' ctx]
elems <- Parser Text (AuthorizerElement' ctx)
-> Parser Text [AuthorizerElement' ctx]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser ()
skipSpace Parser ()
-> Parser Text (AuthorizerElement' ctx)
-> Parser Text (AuthorizerElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text (AuthorizerElement' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (AuthorizerElement' ctx)
authorizerElementParser)
  Authorizer' ctx -> Parser (Authorizer' ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Authorizer' ctx -> Parser (Authorizer' ctx))
-> Authorizer' ctx -> Parser (Authorizer' ctx)
forall a b. (a -> b) -> a -> b
$ (AuthorizerElement' ctx -> Authorizer' ctx)
-> [AuthorizerElement' ctx] -> Authorizer' ctx
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap AuthorizerElement' ctx -> Authorizer' ctx
forall (ctx :: ParsedAs). AuthorizerElement' ctx -> Authorizer' ctx
elementToAuthorizer [AuthorizerElement' ctx]
elems

blockParser :: ( HasParsers 'InPredicate ctx
               , HasParsers 'InFact ctx
               , Show (BlockElement' ctx)
               )
            => Parser (Block' ctx)
blockParser :: Parser (Block' ctx)
blockParser = do
  [BlockElement' ctx]
elems <- Parser Text (BlockElement' ctx) -> Parser Text [BlockElement' ctx]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser ()
skipSpace Parser ()
-> Parser Text (BlockElement' ctx)
-> Parser Text (BlockElement' ctx)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text (BlockElement' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (BlockElement' ctx)
blockElementParser)
  Block' ctx -> Parser (Block' ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block' ctx -> Parser (Block' ctx))
-> Block' ctx -> Parser (Block' ctx)
forall a b. (a -> b) -> a -> b
$ (BlockElement' ctx -> Block' ctx)
-> [BlockElement' ctx] -> Block' ctx
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap BlockElement' ctx -> Block' ctx
forall (ctx :: ParsedAs). BlockElement' ctx -> Block' ctx
elementToBlock [BlockElement' ctx]
elems

policyParser :: HasParsers 'InPredicate ctx => Parser (Policy' ctx)
policyParser :: Parser (Policy' ctx)
policyParser = do
  PolicyType
policy <- [Parser Text PolicyType] -> Parser Text PolicyType
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
              [ PolicyType
Allow PolicyType -> Parser Text -> Parser Text PolicyType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"allow if"
              , PolicyType
Deny  PolicyType -> Parser Text -> Parser Text PolicyType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"deny if"
              ]
  (PolicyType
policy, ) (Query' ctx -> Policy' ctx)
-> Parser Text (Query' ctx) -> Parser (Policy' ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Query' ctx)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Query' ctx)
queryParser

compileParser :: Lift a => Parser a -> String -> Q Exp
compileParser :: Parser a -> String -> Q Exp
compileParser Parser a
p String
str = case Parser a -> Text -> Either String a
forall a. Parser a -> Text -> Either String a
parseOnly (Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput) (String -> Text
pack String
str) of
  Right a
result -> [| result |]
  Left String
e       -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e

-- | 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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Parser (Rule' 'QuasiQuote) -> String -> Q Exp
forall a. Lift a => Parser a -> String -> Q Exp
compileParser (HasParsers 'InPredicate 'QuasiQuote => Parser (Rule' 'QuasiQuote)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Rule' ctx)
ruleParser @'QuasiQuote)
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Parser (Predicate' 'InPredicate 'QuasiQuote) -> String -> Q Exp
forall a. Lift a => Parser a -> String -> Q Exp
compileParser (HasParsers 'InPredicate 'QuasiQuote =>
Parser (Predicate' 'InPredicate 'QuasiQuote)
forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
HasParsers pof ctx =>
Parser (Predicate' pof ctx)
predicateParser @'InPredicate @'QuasiQuote)
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Parser (Predicate' 'InFact 'QuasiQuote) -> String -> Q Exp
forall a. Lift a => Parser a -> String -> Q Exp
compileParser (HasParsers 'InFact 'QuasiQuote =>
Parser (Predicate' 'InFact 'QuasiQuote)
forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
HasParsers pof ctx =>
Parser (Predicate' pof ctx)
predicateParser @'InFact @'QuasiQuote)
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Parser (Check' 'QuasiQuote) -> String -> Q Exp
forall a. Lift a => Parser a -> String -> Q Exp
compileParser (HasParsers 'InPredicate 'QuasiQuote => Parser (Check' 'QuasiQuote)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Query' ctx)
checkParser @'QuasiQuote)
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Parser (Block' 'QuasiQuote) -> String -> Q Exp
forall a. Lift a => Parser a -> String -> Q Exp
compileParser ((HasParsers 'InPredicate 'QuasiQuote,
 HasParsers 'InFact 'QuasiQuote,
 Show (BlockElement' 'QuasiQuote)) =>
Parser (Block' 'QuasiQuote)
forall (ctx :: ParsedAs).
(HasParsers 'InPredicate ctx, HasParsers 'InFact ctx,
 Show (BlockElement' ctx)) =>
Parser (Block' ctx)
blockParser @'QuasiQuote)
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Parser (Authorizer' 'QuasiQuote) -> String -> Q Exp
forall a. Lift a => Parser a -> String -> Q Exp
compileParser ((HasParsers 'InPredicate 'QuasiQuote,
 HasParsers 'InFact 'QuasiQuote,
 Show (AuthorizerElement' 'QuasiQuote)) =>
Parser (Authorizer' 'QuasiQuote)
forall (ctx :: ParsedAs).
(HasParsers 'InPredicate ctx, HasParsers 'InFact ctx,
 Show (AuthorizerElement' ctx)) =>
Parser (Authorizer' ctx)
authorizerParser @'QuasiQuote)
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Parser (Check' 'QuasiQuote) -> String -> Q Exp
forall a. Lift a => Parser a -> String -> Q Exp
compileParser (HasParsers 'InPredicate 'QuasiQuote => Parser (Check' 'QuasiQuote)
forall (ctx :: ParsedAs).
HasParsers 'InPredicate ctx =>
Parser (Query' ctx)
queryParser @'QuasiQuote)
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"not supported"
  }