From 90b15b0ecc6fc153120e0d01288697dfe10e28f9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Mon, 26 Sep 2022 22:17:52 +0200
Subject: Process lifetime determined by scope
---
src/Main.hs | 70 ++++++++++++++++++++++++++++------------------------------
src/Output.hs | 8 +++----
src/Process.hs | 29 +++++++++++++++++++++++-
3 files changed, 65 insertions(+), 42 deletions(-)
(limited to 'src')
diff --git a/src/Main.hs b/src/Main.hs
index 6306c17..81da048 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -84,7 +84,7 @@ newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (Excep
instance MonadFail TestRun where
fail str = do
- outLine OutputError Nothing $ T.pack str
+ outLine OutputError T.empty $ T.pack str
throwError ()
instance MonadError () TestRun where
@@ -145,28 +145,15 @@ initNetwork inner = do
exitNetwork :: Network -> TestRun ()
exitNetwork net = do
processes <- liftIO $ readMVar (netProcesses net)
- liftIO $ forM_ processes $ \p -> do
- when (procName p /= ProcNameGDB) $ do
- hClose (procStdin p)
- case procKillWith p of
- Nothing -> return ()
- Just sig -> getPid (procHandle p) >>= \case
- Nothing -> return ()
- Just pid -> signalProcess sig pid
forM_ processes $ \p -> do
when (procName p == ProcNameGDB) $ do
outPrompt $ T.pack "gdb> "
gdbSession p
outClearPrompt
- liftIO $ hClose (procStdin p)
forM_ processes $ \p -> do
- liftIO (waitForProcess (procHandle p)) >>= \case
- ExitSuccess -> return ()
- ExitFailure code -> do
- outLine OutputChildFail (Just $ procName p) $ T.pack $ "exit code: " ++ show code
- liftIO . atomically . flip writeTVar False =<< asks (teFailed . fst)
+ closeProcess p `catchError` \_ -> return ()
liftIO $ do
callCommand $ "ip -all netns del"
@@ -224,31 +211,31 @@ spawnOn target pname killWith cmd = do
}
pout <- liftIO $ newTVarIO []
+ let process = Process
+ { procName = pname
+ , procHandle = handle
+ , procStdin = hin
+ , procOutput = pout
+ , procKillWith = killWith
+ }
+
let readingLoop :: Handle -> (Text -> TestRun ()) -> TestRun ()
readingLoop h act =
liftIO (tryIOError (T.hGetLine h)) >>= \case
Left err
| isEOFError err -> return ()
- | otherwise -> outLine OutputChildFail (Just pname) $ T.pack $ "IO error: " ++ show err
+ | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err
Right line -> do
act line
readingLoop h act
forkTest $ readingLoop hout $ \line -> do
- outLine OutputChildStdout (Just pname) line
+ outProc OutputChildStdout process line
liftIO $ atomically $ modifyTVar pout (++[line])
forkTest $ readingLoop herr $ \line -> do
case pname of
ProcNameTcpdump -> return ()
- _ -> outLine OutputChildStderr (Just pname) line
-
- let process = Process
- { procName = pname
- , procHandle = handle
- , procStdin = hin
- , procOutput = pout
- , procKillWith = killWith
- }
+ _ -> outProc OutputChildStderr process line
let net = either id nodeNetwork target
when (pname /= ProcNameGDB) $ liftIO $ do
@@ -276,10 +263,11 @@ tryMatch _ [] = Nothing
exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun ()
exprFailed desc (SourceLine sline) pname expr = do
+ let prompt = maybe T.empty textProcName pname
exprVars <- gatherVars expr
- outLine OutputMatchFail pname $ T.concat [desc, T.pack " failed on ", sline]
+ outLine OutputMatchFail prompt $ T.concat [desc, T.pack " failed on ", sline]
forM_ exprVars $ \(name, value) ->
- outLine OutputMatchFail pname $ T.concat [T.pack " ", textVarName name, T.pack " = ", textSomeVarValue value]
+ outLine OutputMatchFail prompt $ T.concat [T.pack " ", textVarName name, T.pack " = ", textSomeVarValue value]
throwError ()
expect :: SourceLine -> Process -> Expr Regex -> [VarName] -> TestRun () -> TestRun ()
@@ -297,16 +285,16 @@ expect (SourceLine sline) p expr vars inner = do
case mbmatch of
Just (line, capture) -> do
when (length vars /= length capture) $ do
- outLine OutputMatchFail (Just $ procName p) $ T.pack "mismatched number of capture variables on " `T.append` sline
+ outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline
throwError ()
forM_ vars $ \name -> do
cur <- asks (lookup name . tsVars . snd)
when (isJust cur) $ do
- outLine OutputError (Just $ procName p) $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+ outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
throwError ()
- outLine OutputMatch (Just $ procName p) line
+ outProc OutputMatch p line
local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner
Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr
@@ -320,12 +308,18 @@ allM :: Monad m => [a] -> (a -> m Bool) -> m Bool
allM (x:xs) p = p x >>= \case True -> allM xs p; False -> return False
allM [] _ = return True
+finally :: MonadError e m => m a -> m b -> m a
+finally act handler = do
+ x <- act `catchError` \e -> handler >> throwError e
+ void handler
+ return x
+
evalSteps :: [TestStep] -> TestRun ()
evalSteps = mapM_ $ \case
Let (SourceLine sline) name expr inner -> do
cur <- asks (lookup name . tsVars . snd)
when (isJust cur) $ do
- outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+ outLine OutputError T.empty $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
throwError ()
value <- eval expr
local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s }) $ do
@@ -334,9 +328,13 @@ evalSteps = mapM_ $ \case
Spawn pname nname inner -> do
getNode nname $ \node -> do
opts <- asks $ teOptions . fst
- void $ spawnOn (Right node) pname Nothing $
+ p <- spawnOn (Right node) pname Nothing $
fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
- evalSteps inner
+ evalSteps inner `finally` do
+ net <- asks $ tsNetwork . snd
+ ps <- liftIO $ takeMVar (netProcesses net)
+ closeProcess p `finally` do
+ liftIO $ putMVar (netProcesses net) $ filter (/=p) ps
Send pname expr -> do
p <- getProcess pname
@@ -370,9 +368,9 @@ runTest out opts test = do
forM_ processes $ \p -> do
mbpid <- getPid (procHandle p)
when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do
- let err detail = outLine OutputChildFail (Just $ procName p) detail
+ let err detail = outProc OutputChildFail p detail
case siginfoStatus chld of
- Exited ExitSuccess -> outLine OutputChildInfo (Just $ procName p) $ T.pack $ "child exited successfully"
+ Exited ExitSuccess -> outProc OutputChildInfo p $ T.pack $ "child exited successfully"
Exited (ExitFailure code) -> err $ T.pack $ "child process exited with status " ++ show code
Terminated sig _ -> err $ T.pack $ "child terminated with signal " ++ show sig
Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
diff --git a/src/Output.hs b/src/Output.hs
index 0bf757a..ca7f862 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -18,8 +18,6 @@ import Data.Text.Lazy.IO qualified as TL
import System.IO
-import Test
-
data Output = Output
{ outState :: MVar OutputState
, outConfig :: OutputConfig
@@ -91,14 +89,14 @@ showPrompt _ = return ()
ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a
ioWithOutput act = liftIO . act =<< getOutput
-outLine :: MonadOutput m => OutputType -> Maybe ProcName -> Text -> m ()
-outLine otype mbproc line = ioWithOutput $ \out ->
+outLine :: MonadOutput m => OutputType -> Text -> Text -> m ()
+outLine otype prompt line = ioWithOutput $ \out ->
when (outVerbose (outConfig out) || printWhenQuiet otype) $ do
withMVar (outState out) $ \st -> do
clearPrompt st
TL.putStrLn $ TL.fromChunks
[ T.pack "\ESC[", outColor otype, T.pack "m"
- , maybe T.empty textProcName mbproc
+ , prompt
, outSign otype
, T.pack "> "
, line
diff --git a/src/Process.hs b/src/Process.hs
index 958910d..bb33953 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -3,19 +3,25 @@ module Process (
ProcName(..),
textProcName, unpackProcName,
send,
+ outProc,
+ closeProcess,
) where
import Control.Concurrent.STM
-import Control.Monad.IO.Class
+import Control.Monad.Except
+import Data.Function
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
+import System.Exit
import System.IO
import System.Posix.Signals
import System.Process
+import Output
+
data Process = Process
{ procName :: ProcName
, procHandle :: ProcessHandle
@@ -24,6 +30,9 @@ data Process = Process
, procKillWith :: Maybe Signal
}
+instance Eq Process where
+ (==) = (==) `on` procStdin
+
data ProcName = ProcName Text
| ProcNameTcpdump
| ProcNameGDB
@@ -41,3 +50,21 @@ send :: MonadIO m => Process -> Text -> m ()
send p line = liftIO $ do
T.hPutStrLn (procStdin p) line
hFlush (procStdin p)
+
+outProc :: MonadOutput m => OutputType -> Process -> Text -> m ()
+outProc otype p line = outLine otype (textProcName $ procName p) line
+
+closeProcess :: (MonadIO m, MonadOutput m, MonadError () m) => Process -> m ()
+closeProcess p = do
+ liftIO $ hClose $ procStdin p
+ case procKillWith p of
+ Nothing -> return ()
+ Just sig -> liftIO $ getPid (procHandle p) >>= \case
+ Nothing -> return ()
+ Just pid -> signalProcess sig pid
+
+ liftIO (waitForProcess (procHandle p)) >>= \case
+ ExitSuccess -> return ()
+ ExitFailure code -> do
+ outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
+ throwError ()
--
cgit v1.2.3