From 2eb00fc91c5a283520dde74fba0b3f7ae274b9da Mon Sep 17 00:00:00 2001
From: Clement Delafargue <clement@delafargue.name>
Date: Wed, 20 Oct 2021 15:51:46 +0200
Subject: [PATCH] biscuit: update parser to conform to the EBNF grammar

The EBNF grammar defined in https://github.com/CleverCloud/biscuit/issues/82
makes the parsing rules a bit more explicit:

- fact names can only start with a letter
---
 biscuit/src/Auth/Biscuit/Datalog/Parser.hs | 23 ++++++++++++++--------
 biscuit/test/Spec/Parser.hs                |  6 ++++++
 2 files changed, 21 insertions(+), 8 deletions(-)

diff --git a/biscuit/src/Auth/Biscuit/Datalog/Parser.hs b/biscuit/src/Auth/Biscuit/Datalog/Parser.hs
index 315cf98..487c537 100644
--- a/biscuit/src/Auth/Biscuit/Datalog/Parser.hs
+++ b/biscuit/src/Auth/Biscuit/Datalog/Parser.hs
@@ -38,14 +38,15 @@ module Auth.Biscuit.Datalog.Parser
 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, isSpace)
+import           Data.Char                      (isAlphaNum, isLetter, isSpace)
 import           Data.Either                    (partitionEithers)
 import           Data.Foldable                  (fold)
 import           Data.Functor                   (void, ($>))
 import qualified Data.Set                       as Set
-import           Data.Text                      (Text, pack, unpack)
+import           Data.Text                      (Text, pack, singleton, unpack)
 import           Data.Text.Encoding             (encodeUtf8)
 import           Data.Time                      (UTCTime, defaultTimeLocale,
                                                  parseTimeM)
@@ -85,9 +86,15 @@ type HasTermParsers inSet pof ctx =
   )
 type HasParsers pof ctx = HasTermParsers 'NotWithinSet pof ctx
 
--- | Parser for an identifier (predicate name, variable name, …)
-nameParser :: Parser Text
-nameParser = takeWhile1 $ \c -> c == '_' || c == ':' || isAlphaNum c
+-- | Parser for a datalog predicate name
+predicateNameParser :: Parser Text
+predicateNameParser = do
+  first <- satisfy isLetter
+  rest  <- A.takeWhile $ \c -> c == '_' || c == ':' || isAlphaNum c
+  pure $ singleton first <> rest
+
+variableNameParser :: Parser Text
+variableNameParser = char '$' *> takeWhile1 (\c -> c == '_' || c == ':' || isAlphaNum c)
 
 delimited :: Parser x
           -> Parser y
@@ -109,7 +116,7 @@ commaList0 p =
 predicateParser :: HasParsers pof ctx => Parser (Predicate' pof ctx)
 predicateParser = do
   skipSpace
-  name <- nameParser
+  name <- predicateNameParser
   skipSpace
   terms <- parens (commaList termParser)
   pure Predicate{name,terms}
@@ -240,7 +247,7 @@ termParser :: forall inSet pof ctx
            => Parser (Term' inSet pof ctx)
 termParser = skipSpace *> choice
   [ Antiquote <$> ifPresent "slice" (Slice <$> (string "${" *> many1 letter <* char '}'))
-  , Variable <$> ifPresent "var" (char '$' *> nameParser)
+  , Variable <$> ifPresent "var" variableNameParser
   , TermSet <$> parseSet @inSet @ctx
   , LBytes <$> hexBsParser
   , LDate <$> rfc3339DateParser
@@ -256,7 +263,7 @@ termParser = skipSpace *> choice
 ruleHeadParser :: HasParsers 'InPredicate ctx => Parser (Predicate' 'InPredicate ctx)
 ruleHeadParser = do
   skipSpace
-  name <- nameParser
+  name <- predicateNameParser
   skipSpace
   terms <- parens (commaList0 termParser)
   pure Predicate{name,terms}
diff --git a/biscuit/test/Spec/Parser.hs b/biscuit/test/Spec/Parser.hs
index f561f3a..a9a3739 100644
--- a/biscuit/test/Spec/Parser.hs
+++ b/biscuit/test/Spec/Parser.hs
@@ -43,6 +43,7 @@ specs :: TestTree
 specs = testGroup "datalog parser"
   [ factWithDate
   , simpleFact
+  , oneLetterFact
   , simpleRule
   , multilineRule
   , termsGroup
@@ -82,6 +83,11 @@ simpleFact = testCase "Parse simple fact" $
   parsePredicate "right(\"file1\", \"read\")" @?=
     Right (Predicate "right" [LString "file1", LString "read"])
 
+oneLetterFact :: TestTree
+oneLetterFact = testCase "Parse one-letter fact" $
+  parsePredicate "a(12)" @?=
+    Right (Predicate "a" [LInteger 12])
+
 factWithDate :: TestTree
 factWithDate = testCase "Parse fact containing a date" $
   parsePredicate "date(2019-12-02T13:49:53Z)" @?=