summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2021-11-26 21:05:32 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2021-11-26 21:05:32 +0100
commitb03a763688267781cb252681679ac8e11b03c479 (patch)
tree43277ae20201e383d43937052b19e6cf2fd69c10 /src
parente30d876d4839ab70f655adf893e85b1b1312192c (diff)
Initial support for running GDB
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs86
1 files changed, 73 insertions, 13 deletions
diff --git a/src/Main.hs b/src/Main.hs
index ca4ff8c..ae4ca4c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -13,6 +13,7 @@ import qualified Data.Text.IO as T
import Text.Regex.TDFA
import Text.Regex.TDFA.Text
+import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
@@ -48,11 +49,20 @@ data Process = Process
, procKillWith :: Maybe Signal
}
+data Options = Options
+ { optGDB :: Bool
+ }
+
+defaultOptions :: Options
+defaultOptions = Options
+ { optGDB = False
+ }
+
testDir :: FilePath
testDir = "./.test"
-initNetwork :: Output -> IO Network
-initNetwork out = do
+initNetwork :: Output -> Bool -> IO Network
+initNetwork out useGDB = do
exists <- doesPathExist testDir
when exists $ ioError $ userError $ testDir ++ " exists"
createDirectoryIfMissing True testDir
@@ -62,20 +72,46 @@ initNetwork out = do
callCommand "ip link set dev br0 up"
callCommand "ip link set dev lo up"
net <- Network <$> newMVar [] <*> newMVar [] <*> pure testDir
+
void $ spawnOn out (Left net) (ProcName (T.pack "tcpdump")) (Just softwareTermination) $
"tcpdump -i br0 -w '" ++ testDir ++ "/br0.pcap' -U -Z root"
+
+ when useGDB $ do
+ gdb <- spawnOn out (Left net) (ProcName (T.pack "gdb")) Nothing $
+ "gdb --quiet --interpreter=mi3"
+ send gdb $ T.pack "-gdb-set schedule-multiple on"
+ send gdb $ T.pack "-gdb-set mi-async on"
+ send gdb $ T.pack "-gdb-set print symbol-loading off"
+
return net
exitNetwork :: Output -> Network -> Bool -> IO ()
exitNetwork out net okTest = do
processes <- readMVar (netProcesses net)
- okProc <- fmap and $ forM processes $ \p -> do
- hClose (procStdin p)
+ forM_ processes $ \p -> do
+ when (procName p /= ProcName (T.pack "gdb")) $ 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 == ProcName (T.pack "gdb")) $ do
+ let gdbSession = do
+ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) >>= \case
+ Just line -> do
+ send p (T.pack "-interpreter-exec console \"" `T.append` line `T.append` T.pack "\"")
+ gdbSession
+ Nothing -> return ()
+
+ outPrompt out $ T.pack "gdb> "
+ gdbSession
+ outClearPrompt out
+ hClose (procStdin p)
+
+ okProc <- fmap and $ forM processes $ \p -> do
waitForProcess (procHandle p) >>= \case
ExitSuccess -> return True
ExitFailure code -> do
@@ -151,7 +187,19 @@ spawnOn out target pname killWith cmd = do
, procKillWith = killWith
}
- modifyMVar_ (netProcesses (either id nodeNetwork target)) $ return . (process:)
+ let net = either id nodeNetwork target
+ when (pname /= ProcName (T.pack "gdb")) $ do
+ getPid handle >>= \case
+ Just pid -> void $ do
+ ps <- readMVar (netProcesses net)
+ forM_ ps $ \gdb -> do
+ when (procName gdb == ProcName (T.pack "gdb")) $ do
+ send gdb $ T.pack $ "-add-inferior"
+ send gdb $ T.pack $ "-target-attach --thread-group i" ++ show (length ps) ++ " " ++ show pid
+ send gdb $ T.pack $ "-exec-continue --thread-group i" ++ show (length ps)
+ Nothing -> return ()
+
+ modifyMVar_ (netProcesses net) $ return . (process:)
return process
getProcess :: Network -> ProcName -> IO Process
@@ -182,19 +230,18 @@ expect out p re pat = do
outLine out OutputMatchFail (Just $ procName p) $ T.pack "expect failed /" `T.append` pat `T.append` T.pack "/"
return False
-send :: Process -> Text -> IO Bool
+send :: Process -> Text -> IO ()
send p line = do
T.hPutStrLn (procStdin p) line
hFlush (procStdin p)
- return True
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
-runTest :: Output -> String -> Test -> IO ()
-runTest out tool test = do
- net <- initNetwork out
+runTest :: Output -> String -> Bool -> Test -> IO ()
+runTest out tool useGDB test = do
+ net <- initNetwork out useGDB
let sigHandler SignalInfo { siginfoSpecific = chld } = do
processes <- readMVar (netProcesses net)
@@ -218,6 +265,7 @@ runTest out tool test = do
Send pname line -> do
p <- getProcess net pname
send p line
+ return True
Expect pname regex pat -> do
p <- getProcess net pname
@@ -232,10 +280,22 @@ runTest out tool test = do
_ <- installHandler processStatusChanged oldHandler Nothing
exitNetwork out net ok
+
+options :: [OptDescr (Options -> Options)]
+options =
+ [ Option ['g'] ["gdb"]
+ (NoArg (\opts -> opts { optGDB = True }))
+ "run GDB and attach spawned pracesses"
+ ]
+
main :: IO ()
main = do
tool <- getEnv "EREBOS_TEST_TOOL"
- files <- getArgs
- out <- startOutput
+ args <- getArgs
+ (opts, files) <- case getOpt Permute options args of
+ (o, files, []) -> return (foldl (flip id) defaultOptions o, files)
+ (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
+ where header = "Usage: erebos-tester [OPTION...]"
- forM_ files $ mapM_ (runTest out tool) <=< parseTestFile
+ out <- startOutput
+ forM_ files $ mapM_ (runTest out tool (optGDB opts)) <=< parseTestFile