GDB process type and separate start function

3 files changed, 69 insertions, 32 deletions

diff --git a/src/GDB.hs b/src/GDB.hs
index 8e04c42..abe0cf9 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -1,10 +1,16 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module GDB (
-    gdbCmd, gdbInit,
+    GDB, gdbProcess,
+    gdbStart,
     addInferior,
     gdbSession,
 ) where
 
+import Control.Concurrent
+import Control.Concurrent.STM
 import Control.Monad.IO.Class
+import Control.Monad.Reader
 
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
@@ -15,29 +21,61 @@ import System.Process
 import Output
 import Process
 
+data GDB = GDB
+    { gdbProcess_ :: Process
+    }
+
+gdbProcess :: GDB -> Process
+gdbProcess = gdbProcess_
+
 gdbCmd :: String
 gdbCmd = "gdb --quiet --interpreter=mi3"
 
-gdbInit :: MonadIO m => Process -> m ()
-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"
+gdbStart :: (MonadOutput m, MonadFail m) => m GDB
+gdbStart = do
+    (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell gdbCmd)
+        { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
+        }
+    pout <- liftIO $ newTVarIO []
+
+    let process = Process
+            { procName = ProcNameGDB
+            , procHandle = handle
+            , procStdin = hin
+            , procOutput = pout
+            , procKillWith = Nothing
+            , procNode = undefined
+            }
+        gdb = GDB
+            { gdbProcess_ = process
+            }
+
+    out <- getOutput
+    liftIO $ void $ forkIO $ flip runReaderT out $
+        lineReadingLoop process hout $ outProc OutputChildStdout process
+    liftIO $ void $ forkIO $ flip runReaderT out $
+        lineReadingLoop process herr $ outProc OutputChildStderr process
+
+    send process "-gdb-set schedule-multiple on"
+    send process "-gdb-set mi-async on"
+    send process "-gdb-set print symbol-loading off"
+
+    return gdb
 
-addInferior :: MonadIO m => Process -> Int -> Pid -> m ()
-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
+addInferior :: MonadIO m => GDB -> Int -> Pid -> m ()
+addInferior GDB { gdbProcess_ = process } i pid = do
+    send process $ "-add-inferior"
+    send process $ "-target-attach --thread-group i" <> T.pack (show i) <> " " <> T.pack (show pid)
+    send process $ "-exec-continue --thread-group i" <> T.pack (show i)
 
-gdbSession :: MonadOutput m => Process -> m ()
+gdbSession :: MonadOutput m => GDB -> m ()
 gdbSession gdb = do
-    outPrompt $ T.pack "gdb> "
+    outPrompt "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 "\"")
+            send (gdbProcess gdb) ("-interpreter-exec console \"" <> line <> "\"")
             loop
         Nothing -> return ()
diff --git a/src/Main.hs b/src/Main.hs
index 38c4099..0330733 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -14,7 +14,6 @@ import Data.Maybe
 import Data.Scientific
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.IO as T
 
 import Text.Read (readMaybe)
 
@@ -23,8 +22,6 @@ import System.Directory
 import System.Environment
 import System.Exit
 import System.FilePath
-import System.IO
-import System.IO.Error
 import System.Posix.Process
 import System.Posix.Signals
 import System.Process
@@ -61,7 +58,7 @@ data TestEnv = TestEnv
     { teOutput :: Output
     , teFailed :: TVar (Maybe Failed)
     , teOptions :: Options
-    , teGDB :: Maybe (MVar Process)
+    , teGDB :: Maybe (MVar GDB)
     }
 
 data TestState = TestState
@@ -153,8 +150,8 @@ initNetwork inner = do
     useGDB <- asks $ optGDB . teOptions . fst
     mgdb <- if useGDB
         then do
-            gdb <- spawnOn (Left net) ProcNameGDB Nothing gdbCmd
-            gdbInit gdb
+            gdb <- gdbStart
+            liftIO $ modifyMVar_ (netProcesses net) $ return . (gdbProcess gdb:)
             Just <$> liftIO (newMVar gdb)
         else return Nothing
 
@@ -226,20 +223,10 @@ spawnOn target pname killWith cmd = do
             , procNode = either (const undefined) id target
             }
 
-    let readingLoop :: Handle -> (Text -> TestRun ()) -> TestRun ()
-        readingLoop h act =
-            liftIO (tryIOError (T.hGetLine h)) >>= \case
-                Left err
-                    | isEOFError err -> return ()
-                    | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err
-                Right line -> do
-                    act line
-                    readingLoop h act
-
-    forkTest $ readingLoop hout $ \line -> do
+    forkTest $ lineReadingLoop process hout $ \line -> do
         outProc OutputChildStdout process line
         liftIO $ atomically $ modifyTVar pout (++[line])
-    forkTest $ readingLoop herr $ \line -> do
+    forkTest $ lineReadingLoop process herr $ \line -> do
         case pname of
              ProcNameTcpdump -> return ()
              _ -> outProc OutputChildStderr process line
diff --git a/src/Process.hs b/src/Process.hs
index 153eb2b..de834a5 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -4,6 +4,7 @@ module Process (
     textProcName, unpackProcName,
     send,
     outProc,
+    lineReadingLoop,
     closeProcess,
 ) where
 
@@ -18,6 +19,7 @@ import qualified Data.Text.IO as T
 
 import System.Exit
 import System.IO
+import System.IO.Error
 import System.Posix.Signals
 import System.Process
 
@@ -68,6 +70,16 @@ send p line = liftIO $ do
 outProc :: MonadOutput m => OutputType -> Process -> Text -> m ()
 outProc otype p line = outLine otype (textProcName $ procName p) line
 
+lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m ()
+lineReadingLoop process h act =
+    liftIO (tryIOError (T.hGetLine h)) >>= \case
+        Left err
+            | isEOFError err -> return ()
+            | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err
+        Right line -> do
+            act line
+            lineReadingLoop process h act
+
 closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()
 closeProcess p = do
     liftIO $ hClose $ procStdin p