summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/GDB.hs66
-rw-r--r--src/Main.hs23
-rw-r--r--src/Process.hs12
4 files changed, 70 insertions, 32 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 4c16133..f7152f5 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -41,6 +41,7 @@ executable erebos-tester-core
Test
Util
other-extensions: TemplateHaskell
+ OverloadedStrings
default-extensions: ExistentialQuantification
FlexibleContexts
FlexibleInstances
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