From cd43896891dc7c6779af0f1d2d8f3f045edc162a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 30 Apr 2022 08:37:45 +0200
Subject: Separate GDB support module

---
 erebos-tester.cabal |  3 ++-
 src/GDB.hs          | 36 ++++++++++++++++++++++++++++++++++++
 src/Main.hs         | 25 ++++---------------------
 src/Process.hs      |  7 +++++++
 4 files changed, 49 insertions(+), 22 deletions(-)
 create mode 100644 src/GDB.hs

diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index bae7d1e..4964b6f 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -33,7 +33,8 @@ executable erebos-tester
 executable erebos-tester-core
   ghc-options:         -Wall -threaded
   main-is:             Main.hs
-  other-modules:       Output
+  other-modules:       GDB
+                       Output
                        Parser
                        Process
                        Test
diff --git a/src/GDB.hs b/src/GDB.hs
new file mode 100644
index 0000000..40a4e8f
--- /dev/null
+++ b/src/GDB.hs
@@ -0,0 +1,36 @@
+module GDB (
+    gdbCmd, gdbInit,
+    addInferior,
+    gdbSession,
+) where
+
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.IO.Error
+import System.Process
+
+import Process
+
+gdbCmd :: String
+gdbCmd = "gdb --quiet --interpreter=mi3"
+
+gdbInit :: Process -> IO ()
+gdbInit gdb = do
+    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"
+
+addInferior :: Process -> Int -> Pid -> IO ()
+addInferior gdb i pid = do
+    send gdb $ T.pack $ "-add-inferior"
+    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 :: Process -> IO ()
+gdbSession gdb = do
+    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
+        Nothing -> return ()
diff --git a/src/Main.hs b/src/Main.hs
index 6444058..20e01e6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -27,6 +27,7 @@ import System.Posix.Process
 import System.Posix.Signals
 import System.Process
 
+import GDB
 import Output
 import Parser
 import Process
@@ -78,11 +79,7 @@ initNetwork out useGDB = do
         "tcpdump -i br0 -w '" ++ testDir ++ "/br0.pcap' -U -Z root"
 
     when useGDB $ do
-        gdb <- spawnOn out (Left net) (ProcNameGDB) 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"
+        gdbInit =<< spawnOn out (Left net) ProcNameGDB Nothing gdbCmd
 
     return net
 
@@ -100,15 +97,8 @@ exitNetwork out net okTest = do
 
     forM_ processes $ \p -> do
         when (procName p == ProcNameGDB) $ 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
+            gdbSession p
             outClearPrompt out
             hClose (procStdin p)
 
@@ -194,9 +184,7 @@ spawnOn out target pname killWith cmd = do
                 ps <- readMVar (netProcesses net)
                 forM_ ps $ \gdb -> do
                     when (procName gdb == ProcNameGDB) $ 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)
+                        addInferior gdb (length ps) pid
             Nothing -> return ()
 
     modifyMVar_ (netProcesses net) $ return . (process:)
@@ -230,11 +218,6 @@ expect out opts 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 ()
-send p line = do
-    T.hPutStrLn (procStdin p) line
-    hFlush (procStdin p)
-
 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
diff --git a/src/Process.hs b/src/Process.hs
index f409720..9943d30 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -2,12 +2,14 @@ module Process (
     Process(..),
     ProcName(..),
     textProcName, unpackProcName,
+    send,
 ) where
 
 import Control.Concurrent.STM
 
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.IO as T
 
 import System.IO
 import System.Posix.Signals
@@ -33,3 +35,8 @@ textProcName ProcNameGDB = T.pack "gdb"
 
 unpackProcName :: ProcName -> String
 unpackProcName = T.unpack . textProcName
+
+send :: Process -> Text -> IO ()
+send p line = do
+    T.hPutStrLn (procStdin p) line
+    hFlush (procStdin p)
-- 
cgit v1.2.3