From 000209c13299f1c046dc60e3649c17e9520680de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 13 Oct 2022 21:05:31 +0200 Subject: Fail test and start gdb session immediately on process crash --- src/GDB.hs | 13 +++++++--- src/Main.hs | 80 +++++++++++++++++++++++++++++++++------------------------- src/Process.hs | 4 +-- src/Test.hs | 4 +++ 4 files changed, 60 insertions(+), 41 deletions(-) (limited to 'src') 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 -- cgit v1.2.3