diff options
Diffstat (limited to 'src/Run.hs')
| -rw-r--r-- | src/Run.hs | 26 |
1 files changed, 21 insertions, 5 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 @@ -38,6 +41,7 @@ import Process import Run.Monad import Script.Expr import Script.Module +import Script.Object import Script.Shell import Test import Test.Builtins @@ -53,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 @@ -65,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 @@ -94,7 +102,7 @@ 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 runStep =<< eval (testSteps test) when (optWait opts) $ do @@ -103,7 +111,7 @@ runTest out opts gdefs test = do 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) @@ -144,7 +152,15 @@ runBlock (TestBlockStep prev step) = runBlock prev >> runStep step runStep :: TestStep () -> TestRun () runStep = \case Scope block -> do - runBlock block + ( 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) $ runStep . inner @@ -299,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) |