summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-10-13 21:05:31 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-10-13 22:16:06 +0200
commit000209c13299f1c046dc60e3649c17e9520680de (patch)
treed0ef2db73b3ed95559cec6037348e03706b116f0
parented4dcb61f8a13a3cbfee1c30ea2cb12b5fd3c1ec (diff)
Fail test and start gdb session immediately on process crash
-rw-r--r--src/GDB.hs13
-rw-r--r--src/Main.hs80
-rw-r--r--src/Process.hs4
-rw-r--r--src/Test.hs4
4 files changed, 60 insertions, 41 deletions
diff --git a/src/GDB.hs b/src/GDB.hs
index 76c33c1..8e04c42 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -12,6 +12,7 @@ import Data.Text.IO qualified as T
import System.IO.Error
import System.Process
+import Output
import Process
gdbCmd :: String
@@ -29,10 +30,14 @@ addInferior gdb i pid = do
send gdb $ T.pack $ "-target-attach --thread-group i" ++ show i ++ " " ++ show pid
send gdb $ T.pack $ "-exec-continue --thread-group i" ++ show i
-gdbSession :: MonadIO m => Process -> m ()
-gdbSession gdb = liftIO $ do
- catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) >>= \case
+gdbSession :: MonadOutput m => Process -> m ()
+gdbSession gdb = do
+ outPrompt $ T.pack "gdb> "
+ liftIO loop
+ outClearPrompt
+ where
+ loop = catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) >>= \case
Just line -> do
send gdb (T.pack "-interpreter-exec console \"" `T.append` line `T.append` T.pack "\"")
- gdbSession gdb
+ loop
Nothing -> return ()
diff --git a/src/Main.hs b/src/Main.hs
index 494b028..38c4099 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,6 @@
module Main (main) where
+import Control.Arrow
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
@@ -58,8 +59,9 @@ testDir = "./.test"
data TestEnv = TestEnv
{ teOutput :: Output
- , teFailed :: TVar Bool
+ , teFailed :: TVar (Maybe Failed)
, teOptions :: Options
+ , teGDB :: Maybe (MVar Process)
}
data TestState = TestState
@@ -68,19 +70,26 @@ data TestState = TestState
, tsNodePacketLoss :: Map NodeName Scientific
}
-newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT () IO) a }
+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
instance MonadFail TestRun where
fail str = do
outLine OutputError T.empty $ T.pack str
- throwError ()
+ throwError Failed
-instance MonadError () TestRun where
- throwError () = do
+instance MonadError Failed TestRun where
+ throwError failed = do
failedVar <- asks $ teFailed . fst
- liftIO $ atomically $ writeTVar failedVar True
- TestRun $ throwError ()
+ liftIO $ atomically $ modifyTVar failedVar (`mplus` Just failed)
+
+ te <- asks fst
+ case failed of
+ ProcessCrashed _ | Just mgdb <- teGDB te -> do
+ maybe (return ()) gdbSession =<< liftIO (tryTakeMVar mgdb)
+ _ -> return ()
+
+ TestRun $ throwError failed
catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler
@@ -111,16 +120,16 @@ forkTest act = do
tenv <- ask
void $ liftIO $ forkIO $ do
runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
- Left () -> atomically $ writeTVar (teFailed $ fst tenv) True
+ Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()
atomicallyTest :: STM a -> TestRun a
atomicallyTest act = do
failedVar <- asks $ teFailed . fst
res <- liftIO $ atomically $ do
- failed <- readTVar failedVar
- if failed then return $ Left ()
- else Right <$> act
+ readTVar failedVar >>= \case
+ Just e -> return $ Left e
+ Nothing -> Right <$> act
case res of
Left e -> throwError e
Right x -> return x
@@ -142,21 +151,18 @@ initNetwork inner = do
"tcpdump -i br0 -w '" ++ testDir ++ "/br0.pcap' -U -Z root"
useGDB <- asks $ optGDB . teOptions . fst
- when useGDB $ do
- gdbInit =<< spawnOn (Left net) ProcNameGDB Nothing gdbCmd
+ mgdb <- if useGDB
+ then do
+ gdb <- spawnOn (Left net) ProcNameGDB Nothing gdbCmd
+ gdbInit gdb
+ Just <$> liftIO (newMVar gdb)
+ else return Nothing
- local (fmap $ \s -> s { tsNetwork = net }) $ inner net
+ local ((\te -> te { teGDB = mgdb }) *** (\s -> s { tsNetwork = net })) $ inner net
exitNetwork :: Network -> TestRun ()
exitNetwork net = do
processes <- liftIO $ readMVar (netProcesses net)
-
- forM_ processes $ \p -> do
- when (procName p == ProcNameGDB) $ do
- outPrompt $ T.pack "gdb> "
- gdbSession p
- outClearPrompt
-
forM_ processes $ \p -> do
closeProcess p `catchError` \_ -> return ()
@@ -164,7 +170,7 @@ exitNetwork net = do
callCommand $ "ip -all netns del"
callCommand $ "ip link del group 1"
- failed <- liftIO . atomically . readTVar =<< asks (teFailed . fst)
+ failed <- return . isJust =<< liftIO . atomically . readTVar =<< asks (teFailed . fst)
liftIO $ if failed then exitFailure
else removeDirectoryRecursive $ netDir net
@@ -239,14 +245,13 @@ spawnOn target pname killWith cmd = do
_ -> outProc OutputChildStderr process line
let net = either id nodeNetwork target
- when (pname /= ProcNameGDB) $ liftIO $ do
- getPid handle >>= \case
- Just pid -> void $ do
+ asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= liftIO . \case
+ Just gdb -> getPid handle >>= \case
+ Just pid -> do
ps <- readMVar (netProcesses net)
- forM_ ps $ \gdb -> do
- when (procName gdb == ProcNameGDB) $ do
- addInferior gdb (length ps) pid
+ addInferior gdb (length ps) pid
Nothing -> return ()
+ Nothing -> return ()
liftIO $ modifyMVar_ (netProcesses net) $ return . (process:)
return process
@@ -263,7 +268,7 @@ exprFailed desc (SourceLine sline) pname expr = do
outLine OutputMatchFail prompt $ T.concat [desc, T.pack " failed on ", sline]
forM_ exprVars $ \(name, value) ->
outLine OutputMatchFail prompt $ T.concat [T.pack " ", textVarName name, T.pack " = ", textSomeVarValue value]
- throwError ()
+ throwError Failed
expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()
expect (SourceLine sline) p expr tvars inner = do
@@ -283,13 +288,13 @@ expect (SourceLine sline) p expr tvars inner = do
when (length vars /= length capture) $ do
outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline
- throwError ()
+ 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` sline
- throwError ()
+ throwError Failed
outProc OutputMatch p line
local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner
@@ -313,7 +318,7 @@ evalSteps = mapM_ $ \case
cur <- asks (lookup name . tsVars . snd)
when (isJust cur) $ do
outLine OutputError T.empty $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
- throwError ()
+ throwError Failed
value <- eval expr
withVar name value $ evalSteps inner
@@ -359,8 +364,9 @@ runTest :: Output -> Options -> Test -> IO Bool
runTest out opts test = do
tenv <- TestEnv
<$> pure out
- <*> newTVarIO False
+ <*> newTVarIO Nothing
<*> pure opts
+ <*> pure Nothing
tstate <- TestState
<$> pure (error "network not initialized")
<*> pure []
@@ -374,8 +380,12 @@ runTest out opts test = do
let err detail = outProc OutputChildFail p detail
case siginfoStatus chld of
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
+ Exited (ExitFailure code) -> do
+ err $ T.pack $ "child process exited with status " ++ show code
+ liftIO $ atomically $ writeTVar (teFailed tenv) $ Just Failed
+ Terminated sig _ -> do
+ err $ T.pack $ "child terminated with signal " ++ show sig
+ liftIO $ atomically $ writeTVar (teFailed tenv) $ Just $ ProcessCrashed p
Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
oldHandler <- liftIO $ installHandler processStatusChanged (CatchInfo sigHandler) Nothing
diff --git a/src/Process.hs b/src/Process.hs
index 0a2c861..153eb2b 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -68,7 +68,7 @@ send p line = liftIO $ do
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 :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()
closeProcess p = do
liftIO $ hClose $ procStdin p
case procKillWith p of
@@ -81,4 +81,4 @@ closeProcess p = do
ExitSuccess -> return ()
ExitFailure code -> do
outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
- throwError ()
+ throwError Failed
diff --git a/src/Test.hs b/src/Test.hs
index 6b04fac..836992c 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -1,6 +1,7 @@
module Test (
Test(..),
TestStep(..),
+ Failed(..),
SourceLine(..),
MonadEval(..),
@@ -41,6 +42,9 @@ data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) [TestSte
| PacketLoss (Expr Scientific) (Expr Node) [TestStep]
| Wait
+data Failed = Failed
+ | ProcessCrashed Process
+
newtype SourceLine = SourceLine Text