Parser of test scripts

3 files changed, 141 insertions, 23 deletions

diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 5562d7f..3722a6e 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -33,12 +33,16 @@ executable erebos-tester
 executable erebos-tester-core
   ghc-options:         -Wall -threaded
   main-is:             Main.hs
-  other-modules:       Test
+  other-modules:       Parser
+                       Test
   -- other-extensions:
   default-extensions:  LambdaCase
   build-depends:       base             >=4.13 && <5,
+                       containers ^>=0.6.2.1,
                        directory ^>=1.3.6.0,
                        filepath ^>=1.4.2.1,
+                       megaparsec       >=9.0 && <10,
+                       mtl ^>=2.2.2,
                        process ^>=1.6.9,
                        regex-tdfa ^>=1.3.1.0,
                        stm ^>=2.5.0.1,
diff --git a/src/Main.hs b/src/Main.hs
index ca501bf..2c16a16 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -21,6 +21,7 @@ import System.IO
 import System.IO.Error
 import System.Process
 
+import Parser
 import Test
 
 data Network = Network
@@ -193,25 +194,7 @@ runTest tool test = do
 
 main :: IO ()
 main = do
-    [tool] <- getArgs
-
-    let pat1 = "peer [0-9]+ 192.168.0.11:29665"
-    let pat2 = "peer [0-9]+ 192.168.0.12:29665"
-    Right re1 <- return $ compile defaultCompOpt defaultExecOpt ("^" ++ pat1 ++ "$")
-    Right re2 <- return $ compile defaultCompOpt defaultExecOpt ("^" ++ pat2 ++ "$")
-
-    runTest tool Test
-        { testName = T.pack "Test"
-        , testSteps =
-            [ Spawn (ProcName (T.pack "p1")) (NodeName (T.pack "n1"))
-            , Spawn (ProcName (T.pack "p2")) (NodeName (T.pack "n2"))
-            , Send (ProcName (T.pack "p1")) (T.pack "create-identity Device1")
-            , Send (ProcName (T.pack "p2")) (T.pack "create-identity Device2")
-            , Send (ProcName (T.pack "p1")) (T.pack "start-server")
-            , Send (ProcName (T.pack "p2")) (T.pack "start-server")
-            , Expect (ProcName (T.pack "p1")) re1
-            , Expect (ProcName (T.pack "p1")) re2
-            , Expect (ProcName (T.pack "p2")) re2
-            , Expect (ProcName (T.pack "p2")) re1
-            ]
-        }
+    tool <- getEnv "EREBOS_TEST_TOOL"
+    files <- getArgs
+
+    forM_ files $ mapM_ (runTest tool) <=< parseTestFile
diff --git a/src/Parser.hs b/src/Parser.hs
new file mode 100644
index 0000000..97a64fc
--- /dev/null
+++ b/src/Parser.hs
@@ -0,0 +1,131 @@
+module Parser (
+    parseTestFile,
+) where
+
+import Control.Monad.State
+
+import Data.Char
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO as TL
+import Data.Void
+
+import Text.Megaparsec hiding (State)
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import Text.Regex.TDFA (defaultCompOpt, defaultExecOpt)
+import Text.Regex.TDFA.String
+
+import System.Exit
+
+import Test
+
+type TestParser = ParsecT Void TestStream (State (Set ProcName))
+
+type TestStream = TL.Text
+
+scn :: TestParser ()
+scn = L.space space1 empty empty
+
+sc :: TestParser ()
+sc = L.space (void $ takeWhile1P Nothing f) empty empty
+    where f x = x == ' ' || x == '\t'
+
+wordChar :: TestParser (Token TestStream)
+wordChar = alphaNumChar <|> char '_'
+
+lexeme :: TestParser a -> TestParser a
+lexeme = L.lexeme sc
+
+symbol :: String -> TestParser ()
+symbol = void . L.symbol sc . TL.pack
+
+wsymbol :: String -> TestParser ()
+wsymbol str = void $ lexeme $ string (TL.pack str) <* notFollowedBy wordChar
+
+toplevel :: TestParser a -> TestParser a
+toplevel = L.nonIndented scn
+
+block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
+block merge header item = L.indentBlock scn $ do
+    h <- header
+    choice
+        [ do try $ void $ lexeme $ char ':'
+             return $ L.IndentSome Nothing (merge h) item
+        , L.IndentNone <$> merge h []
+        ]
+
+nodeName :: TestParser NodeName
+nodeName = label "network node name" $ lexeme $ do
+    c <- lowerChar
+    cs <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '-')
+    return $ NodeName $ TL.toStrict (c `TL.cons` cs)
+
+procName :: TestParser ProcName
+procName = label "process name" $ lexeme $ do
+    c <- lowerChar
+    cs <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '-')
+    return $ ProcName $ TL.toStrict (c `TL.cons` cs)
+
+quotedString :: TestParser Text
+quotedString = label "string" $ lexeme $ do
+    symbol "\""
+    str <- takeWhileP Nothing (/='"')
+    symbol "\""
+    return $ TL.toStrict str
+
+regex :: TestParser Regex
+regex = label "regular expression" $ lexeme $ do
+    symbol "/"
+    pat <- takeWhileP Nothing (/='/')
+    symbol "/"
+    case compile defaultCompOpt defaultExecOpt ("^" ++ TL.unpack pat ++ "$") of
+         Left err -> fail err
+         Right re -> return re
+
+testSpawn :: TestParser TestStep
+testSpawn = do
+    wsymbol "spawn"
+    wsymbol "on"
+    nname <- nodeName
+    wsymbol "as"
+    pname <- procName
+    return $ Spawn pname nname
+
+testSend :: TestParser TestStep
+testSend = do
+    wsymbol "send"
+    line <- quotedString
+    wsymbol "to"
+    pname <- procName
+    return $ Send pname line
+
+testExpect :: TestParser TestStep
+testExpect = do
+    wsymbol "expect"
+    re <- regex
+    wsymbol "from"
+    pname <- procName
+    return $ Expect pname re
+
+parseTestDefinition :: TestParser Test
+parseTestDefinition = label "test definition" $ toplevel $ do
+    block (\name steps -> return $ Test name steps) header (testSpawn <|> testSend <|> testExpect)
+    where header = do
+              wsymbol "test"
+              lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
+
+parseTestDefinitions :: TestParser [Test]
+parseTestDefinitions = do
+    tests <- many parseTestDefinition
+    eof
+    return tests
+
+parseTestFile :: FilePath -> IO [Test]
+parseTestFile path = do
+    content <- TL.readFile path
+    case evalState (runParserT parseTestDefinitions path content) S.empty of
+         Left err -> putStr (errorBundlePretty err) >> exitFailure
+         Right tests -> return tests