From 1c5cc6281d1320b3ad3ee586368c0c1dacce0cbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 18 Aug 2021 22:00:27 +0200 Subject: Parser of test scripts --- erebos-tester.cabal | 6 ++- src/Main.hs | 27 ++--------- src/Parser.hs | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 141 insertions(+), 23 deletions(-) create mode 100644 src/Parser.hs 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 -- cgit v1.2.3