diff options
| -rw-r--r-- | erebos-tester.cabal | 1 | ||||
| -rw-r--r-- | src/GDB.hs | 66 | ||||
| -rw-r--r-- | src/Main.hs | 23 | ||||
| -rw-r--r-- | src/Process.hs | 12 |
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 @@ -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 |