diff options
Diffstat (limited to 'src/Run.hs')
| -rw-r--r-- | src/Run.hs | 124 |
1 files changed, 72 insertions, 52 deletions
@@ -12,15 +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.Proxy import Data.Scientific import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T -import Text.Megaparsec (errorBundlePretty, showErrorComponent) import System.Directory import System.Exit @@ -29,6 +30,8 @@ import System.Posix.Process import System.Posix.Signals import System.Process +import Text.Megaparsec (errorBundlePretty, showErrorComponent) + import GDB import Network import Network.Ip @@ -36,8 +39,10 @@ import Output import Parser import Process import Run.Monad +import Sandbox import Script.Expr import Script.Module +import Script.Object import Script.Shell import Test import Test.Builtins @@ -53,7 +58,9 @@ runTest out opts gdefs test = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 procVar <- newMVar [] + timeoutVar <- newMVar ( optTimeout opts, 0 ) mgdb <- if optGDB opts then flip runReaderT out $ do @@ -65,7 +72,9 @@ runTest out opts gdefs test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState @@ -94,16 +103,26 @@ runTest out opts gdefs test = do oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing resetOutputTime out - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withInternet $ \_ -> do - evalBlock =<< eval (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + testRunResult <- newEmptyMVar + + void $ forkOS $ do + isolateFilesystem testDir >>= \case + True -> do + tres <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + withInternet $ \_ -> do + runStep =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + putMVar testRunResult tres + _ -> do + putMVar testRunResult ( Left Failed, [] ) + + ( res, [] ) <- takeMVar testRunResult 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) @@ -137,14 +156,28 @@ 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 args inner -> do case target of @@ -157,40 +190,40 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) cmd = unwords $ tool : map (T.unpack . escape) args escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" - withProcess (Right node) pname Nothing cmd $ evalBlock . inner + withProcess (Right node) pname Nothing cmd $ runStep . inner 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 timeout captures inner -> do + expect line p expr timeout captures $ runStep . inner Flush p regex -> do - flush p regex + atomicallyTest $ flushProcessOutput p regex - Guard line vars expr -> do - testStepGuard line vars expr + Guard stack expr -> do + testStepGuard stack 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..." @@ -200,11 +233,10 @@ withInternet :: (Network -> TestRun a) -> TestRun a withInternet inner = do testDir <- asks $ optTestDir . teOptions . fst inet <- newInternet testDir - res <- withNetwork (inetRoot inet) $ \net -> do - withTypedVar rootNetworkVar net $ do - inner net - delInternet inet - return res + flip finally (delInternet inet) $ do + withNetwork (inetRoot inet) $ \net -> do + withTypedVar rootNetworkVar net $ do + inner net withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a withSubnet parent tvname inner = do @@ -280,20 +312,15 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ( | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun () -exprFailed desc sline pname exprVars = do +exprFailed :: Text -> CallStack -> Maybe ProcName -> TestRun () +exprFailed desc stack pname = do let prompt = maybe T.empty textProcName pname - outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline] - forM_ exprVars $ \((name, sel), value) -> - outLine OutputMatchFail (Just prompt) $ T.concat - [ " ", textFqVarName name, T.concat (map ("."<>) sel) - , " = ", textSomeVarValue sline value - ] + outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed" throwError Failed -expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () -expect sline p (Traced trace re) tvars inner = do - timeout <- asks $ optTimeout . teOptions . fst +expect :: SourceLine -> Process -> Traced Regex -> Scientific -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () +expect sline p (Traced trace re) etimeout tvars inner = do + timeout <- (etimeout *) <$> getCurrentTimeout delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) @@ -307,21 +334,14 @@ expect sline p (Traced trace re) tvars inner = do let vars = map (\(TypedVarName n) -> n) tvars when (length vars /= length capture) $ do - outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline + outProc (OutputMatchFail (CallStack [ ( sline, [] ) ])) p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline throwError Failed outProc OutputMatch p line inner capture - Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) trace - -flush :: Process -> Maybe Regex -> TestRun () -flush p mbre = do - atomicallyTest $ do - writeTVar (procOutput p) =<< case mbre of - Nothing -> return [] - Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p) + Nothing -> exprFailed (T.pack "expect") (CallStack [ ( sline, trace ) ]) (Just $ procName p) -testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun () -testStepGuard sline vars x = do - when (not x) $ exprFailed (T.pack "guard") sline Nothing vars +testStepGuard :: CallStack -> Bool -> TestRun () +testStepGuard stack x = do + when (not x) $ exprFailed (T.pack "guard") stack Nothing |