summaryrefslogtreecommitdiff
path: root/src/Run.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Run.hs')
-rw-r--r--src/Run.hs134
1 files changed, 94 insertions, 40 deletions
diff --git a/src/Run.hs b/src/Run.hs
index 001d887..d5b0d29 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -1,6 +1,8 @@
module Run (
module Run.Monad,
runTest,
+ loadModules,
+ evalGlobalDefs,
) where
import Control.Applicative
@@ -8,14 +10,18 @@ import Control.Concurrent
import Control.Concurrent.STM
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
@@ -24,17 +30,25 @@ 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 -> Test -> [ ( VarName, SomeExpr ) ] -> IO Bool
-runTest out opts test variables = do
+
+runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool
+runTest out opts gdefs test = do
let testDir = optTestDir opts
when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
if isDoesNotExistError e then return () else ioError e
@@ -43,7 +57,9 @@ runTest out opts test variables = 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
@@ -55,11 +71,14 @@ runTest out opts test variables = do
{ teOutput = out
, teFailed = failedVar
, teOptions = opts
+ , teNextObjId = objIdVar
, teProcesses = procVar
+ , teTimeout = timeoutVar
, teGDB = fst <$> mgdb
}
tstate = TestState
- { tsVars = builtins
+ { tsGlobals = gdefs
+ , tsLocals = []
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
@@ -68,7 +87,7 @@ runTest out opts test variables = do
let sigHandler SignalInfo { siginfoSpecific = chld } = do
processes <- readMVar procVar
forM_ processes $ \p -> do
- mbpid <- getPid (procHandle p)
+ mbpid <- either getPid (\_ -> return Nothing) (procHandle p)
when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do
let err detail = outProc OutputChildFail p detail
case siginfoStatus chld of
@@ -82,23 +101,17 @@ runTest out opts test variables = do
Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
- let withVarExprList (( name, expr ) : rest) act = do
- value <- evalSome expr
- local (fmap $ \s -> s { tsVars = ( name, value ) : tsVars s }) $ do
- withVarExprList rest act
- withVarExprList [] act = act
-
- res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
- withVarExprList variables $ do
- withInternet $ \_ -> do
- evalBlock =<< eval (testSteps test)
- when (optWait opts) $ do
- void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
+ resetOutputTime out
+ ( res, [] ) <- 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..."
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)
@@ -106,17 +119,56 @@ runTest out opts test variables = 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)
+
+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 ]
-evalBlock :: TestBlock -> TestRun ()
-evalBlock (TestBlock steps) = forM_ steps $ \case
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
@@ -125,14 +177,22 @@ evalBlock (TestBlock steps) = forM_ steps $ \case
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 mbname node script inner -> do
+ let tname | Just (TypedVarName (VarName name)) <- mbname = name
+ | otherwise = "shell"
+ let pname = ProcName tname
+ 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
@@ -141,18 +201,18 @@ evalBlock (TestBlock steps) = forM_ steps $ \case
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..."
@@ -248,14 +308,14 @@ exprFailed desc sline pname exprVars = do
outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline]
forM_ exprVars $ \((name, sel), value) ->
outLine OutputMatchFail (Just prompt) $ T.concat
- [ " ", textVarName name, T.concat (map ("."<>) sel)
+ [ " ", textFqVarName name, T.concat (map ("."<>) sel)
, " = ", textSomeVarValue sline value
]
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
+ timeout <- liftIO . readMVar =<< asks (teTimeout . fst)
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
line <- readTVar (procOutput p)
@@ -272,12 +332,6 @@ expect sline p (Traced trace re) tvars inner = do
outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline
throwError Failed
- forM_ vars $ \name -> do
- cur <- asks (lookup name . tsVars . snd)
- when (isJust cur) $ do
- outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` textSourceLine sline
- throwError Failed
-
outProc OutputMatch p line
inner capture
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-02 23:54:40 +0000