diff options
Diffstat (limited to 'src/Run.hs')
| -rw-r--r-- | src/Run.hs | 95 |
1 files changed, 73 insertions, 22 deletions
@@ -1,6 +1,7 @@ module Run ( module Run.Monad, runTest, + loadModules, evalGlobalDefs, ) where @@ -11,13 +12,16 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Fix import Control.Monad.Reader +import Control.Monad.Writer +import Data.Bifunctor import Data.Map qualified as M import Data.Maybe -import Data.Set qualified as S +import Data.Proxy import Data.Scientific +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import System.Directory import System.Exit @@ -26,17 +30,23 @@ import System.Posix.Process import System.Posix.Signals import System.Process +import Text.Megaparsec (errorBundlePretty, showErrorComponent) + import GDB import Network import Network.Ip import Output +import Parser import Process import Run.Monad import Script.Expr +import Script.Module +import Script.Object import Script.Shell import Test import Test.Builtins + runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool runTest out opts gdefs test = do let testDir = optTestDir opts @@ -47,7 +57,9 @@ runTest out opts gdefs test = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 procVar <- newMVar [] + timeoutVar <- newMVar $ optTimeout opts mgdb <- if optGDB opts then flip runReaderT out $ do @@ -59,7 +71,9 @@ runTest out opts gdefs test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState @@ -88,16 +102,16 @@ runTest out opts gdefs test = do oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing resetOutputTime out - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do withInternet $ \_ -> do - evalBlock =<< eval (testSteps test) + runStep =<< eval (testSteps test) when (optWait opts) $ do void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." void $ installHandler processStatusChanged oldHandler Nothing Right () <- runExceptT $ flip runReaderT out $ do - maybe (return ()) (closeProcess . snd) mgdb + maybe (return ()) (closeProcess 1 . snd) mgdb [] <- readMVar procVar failed <- atomically $ readTVar (teFailed tenv) @@ -105,23 +119,56 @@ runTest out opts gdefs test = do (Right (), Nothing) -> do when (not $ optKeep opts) $ removeDirectoryRecursive testDir return True - _ -> return False + _ -> do + flip runReaderT out $ do + void $ outLine OutputError Nothing $ "Test ‘" <> testName test <> "’ failed." + return False + + +loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs ) +loadModules files = do + ( modules, allModules ) <- parseTestFiles files >>= \case + Right res -> do + return res + Left err -> do + case err of + ImportModuleError bundle -> + putStr (errorBundlePretty bundle) + _ -> do + putStrLn (showErrorComponent err) + exitFailure + let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules + return ( modules, globalDefs ) evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs evalGlobalDefs exprs = fix $ \gdefs -> builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) -evalBlock :: TestBlock () -> TestRun () -evalBlock EmptyTestBlock = return () -evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of +runBlock :: TestBlock () -> TestRun () +runBlock EmptyTestBlock = return () +runBlock (TestBlockStep prev step) = runBlock prev >> runStep step + +runStep :: TestStep () -> TestRun () +runStep = \case + Scope block -> do + ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left) + mapM_ destroySomeObject (reverse objs) + either throwError return x + + CreateObject (Proxy :: Proxy o) cargs -> do + objIdVar <- asks (teNextObjId . fst) + oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x )) + obj <- createObject @TestRun @o (ObjectId oid) cargs + tell [ toSomeObject obj ] + Subnet name parent inner -> do - withSubnet parent (Just name) $ evalBlock . inner + withSubnet parent (Just name) $ runStep . inner DeclNode name net inner -> do - withNode net (Left name) $ evalBlock . inner + withNode net (Left name) $ runStep . inner - Spawn tvname@(TypedVarName (VarName tname)) target inner -> do + Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do case target of Left net -> withNode net (Right tvname) go Right node -> go node @@ -130,18 +177,22 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - withProcess (Right node) pname Nothing tool $ evalBlock . inner + cmd = unwords $ tool : map (T.unpack . escape) args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + withProcess (Right node) pname Nothing cmd $ runStep . inner - SpawnShell (TypedVarName (VarName tname)) node script inner -> do + SpawnShell mbname node script inner -> do + let tname | Just (TypedVarName (VarName name)) <- mbname = name + | otherwise = "shell" let pname = ProcName tname - withShellProcess node pname script $ evalBlock . inner + withShellProcess node pname script $ runStep . inner Send p line -> do outProc OutputChildStdin p line send p line Expect line p expr captures inner -> do - expect line p expr captures $ evalBlock . inner + expect line p expr captures $ runStep . inner Flush p regex -> do flush p regex @@ -150,18 +201,18 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of testStepGuard line vars expr DisconnectNode node inner -> do - withDisconnectedUp (nodeUpstream node) $ evalBlock inner + withDisconnectedUp (nodeUpstream node) $ runStep inner DisconnectNodes net inner -> do - withDisconnectedBridge (netBridge net) $ evalBlock inner + withDisconnectedBridge (netBridge net) $ runStep inner DisconnectUpstream net inner -> do case netUpstream net of - Just link -> withDisconnectedUp link $ evalBlock inner - Nothing -> evalBlock inner + Just link -> withDisconnectedUp link $ runStep inner + Nothing -> runStep inner PacketLoss loss node inner -> do - withNodePacketLoss node loss $ evalBlock inner + withNodePacketLoss node loss $ runStep inner Wait -> do void $ outPromptGetLine "Waiting..." @@ -264,7 +315,7 @@ exprFailed desc sline pname exprVars = do expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () expect sline p (Traced trace re) tvars inner = do - timeout <- asks $ optTimeout . teOptions . fst + timeout <- liftIO . readMVar =<< asks (teTimeout . fst) delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) |