diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GDB.hs | 3 | ||||
| -rw-r--r-- | src/Network.hs | 4 | ||||
| -rw-r--r-- | src/Process.hs | 20 | ||||
| -rw-r--r-- | src/Run.hs | 2 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 1 | ||||
| -rw-r--r-- | src/Script/Shell.hs | 3 |
6 files changed, 26 insertions, 7 deletions
@@ -75,7 +75,8 @@ gdbStart onCrash = do ignore <- liftIO $ newTVarIO ( 0, [] ) let process = Process - { procName = ProcNameGDB + { procId = ProcessId (-2) + , procName = ProcNameGDB , procHandle = Left handle , procStdin = hin , procOutput = pout diff --git a/src/Network.hs b/src/Network.hs index e12231d..fdc83c6 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -102,11 +102,11 @@ instance HasNetns Node where getNetns = nodeNetns instance ExprType Network where textExprType _ = T.pack "network" - textExprValue n = "s:" <> textNetworkName (netPrefix n) + textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">" instance ExprType Node where textExprType _ = T.pack "node" - textExprValue n = T.pack "n:" <> textNodeName (nodeName n) + textExprValue n = T.pack "<node:" <> textNodeName (nodeName n) <> ">" recordMembers = map (first T.pack) [ ( "ifname", RecordSelector $ const ("veth0" :: Text) ) diff --git a/src/Process.hs b/src/Process.hs index a575e76..7d09b61 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -1,7 +1,7 @@ module Process ( Process(..), - ProcName(..), - textProcName, unpackProcName, + ProcessId(..), textProcId, + ProcName(..), textProcName, unpackProcName, send, outProc, outProcName, lineReadingLoop, @@ -48,7 +48,8 @@ import Script.Expr.Class import Script.Object data Process = Process - { procName :: ProcName + { procId :: ProcessId + , procName :: ProcName , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode ) , procStdin :: Handle , procOutput :: TVar [ Text ] @@ -62,18 +63,23 @@ instance Eq Process where instance ExprType Process where textExprType _ = T.pack "proc" - textExprValue n = T.pack "p:" <> textProcName (procName n) + textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack) [ ("node", RecordSelector $ procNode) ] +newtype ProcessId = ProcessId Int + data ProcName = ProcName Text | ProcNameTcpdump | ProcNameGDB deriving (Eq, Ord) +textProcId :: ProcessId -> Text +textProcId (ProcessId pid) = T.pack (show pid) + textProcName :: ProcName -> Text textProcName (ProcName name) = name textProcName ProcNameTcpdump = T.pack "tcpdump" @@ -139,6 +145,12 @@ spawnOn target procName procKillWith cmd = do return (path' ++ rest) _ -> return cmd + procId <- case procName of + ProcNameTcpdump -> return $ ProcessId (-1) + _ -> do + idVar <- asks $ teNextProcId . fst + liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + let netns = either getNetns getNetns target currentEnv <- liftIO $ getEnvironment (Just procStdin, Just hout, Just herr, handle) <- liftIO $ do @@ -59,6 +59,7 @@ runTest out opts gdefs test = do failedVar <- newTVarIO Nothing objIdVar <- newMVar 1 + procIdVar <- newMVar 1 procVar <- newMVar [] timeoutVar <- newMVar ( optTimeout opts, 0 ) @@ -73,6 +74,7 @@ runTest out opts gdefs test = do , teFailed = failedVar , teOptions = opts , teNextObjId = objIdVar + , teNextProcId = procIdVar , teProcesses = procVar , teTimeout = timeoutVar , teGDB = fst <$> mgdb diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index c742987..f506b62 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -44,6 +44,7 @@ data TestEnv = TestEnv , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions , teNextObjId :: MVar Int + , teNextProcId :: MVar Int , teProcesses :: MVar [ Process ] , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications ) , teGDB :: Maybe (MVar GDB) diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs index 15c0c2c..dea3fe9 100644 --- a/src/Script/Shell.hs +++ b/src/Script/Shell.hs @@ -183,6 +183,9 @@ executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript stateme spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process spawnShell procNode procName script = do + idVar <- asks $ teNextProcId . fst + procId <- liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + procOutput <- liftIO $ newTVarIO [] procIgnore <- liftIO $ newTVarIO ( 0, [] ) seiStatusVar <- liftIO $ newEmptyMVar |