Move test-executing functions to separate module

2 files changed, 265 insertions, 248 deletions

diff --git a/src/Main.hs b/src/Main.hs
index b49fe09..c9fbf50 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,16 +1,8 @@
 module Main (main) where
 
-import Control.Applicative
-import Control.Concurrent
-import Control.Concurrent.STM
 import Control.Monad
-import Control.Monad.Except
-import Control.Monad.Reader
 
-import Data.Map qualified as M
 import Data.Maybe
-import Data.Scientific
-import Data.Text (Text)
 import qualified Data.Text as T
 
 import Text.Read (readMaybe)
@@ -21,254 +13,15 @@ import System.Environment
 import System.Exit
 import System.FilePath
 import System.FilePath.Glob
-import System.IO.Error
-import System.Posix.Process
-import System.Posix.Signals
-import System.Process
 
 import Config
-import GDB
-import Network
 import Output
 import Parser
 import Process
-import Run.Monad
-import Test
+import Run
 import Util
 import Version
 
-withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a
-withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })
-
-withNodePacketLoss :: Node -> Scientific -> TestRun a -> TestRun a
-withNodePacketLoss node loss inner = do
-    x <- local (fmap $ \s -> s { tsNodePacketLoss = M.insertWith (\l l' -> 1 - (1 - l) * (1 - l')) (nodeName node) loss $ tsNodePacketLoss s }) $ do
-        resetLoss
-        inner
-    resetLoss
-    return x
-  where
-    resetLoss = do
-        tl <- asks $ fromMaybe 0 . M.lookup (nodeName node) . tsNodePacketLoss . snd
-        liftIO $ callOn node $ "tc qdisc replace dev veth0 root netem loss " <> T.pack (show (tl * 100)) <> "%"
-        liftIO $ putStrLn $ "tc qdisc replace dev veth0 root netem loss " <> show (tl * 100) <> "%"
-
-atomicallyTest :: STM a -> TestRun a
-atomicallyTest act = do
-    failedVar <- asks $ teFailed . fst
-    res <- liftIO $ atomically $ do
-        readTVar failedVar >>= \case
-            Just e  -> return $ Left e
-            Nothing -> Right <$> act
-    case res of
-        Left e -> throwError e
-        Right x -> return x
-
-withInternet :: (Network -> TestRun a) -> TestRun a
-withInternet inner = do
-    testDir <- asks $ optTestDir . teOptions . fst
-    inet <- newInternet testDir
-    res <- withNetwork (inetRoot inet) $ \net -> do
-        local (fmap $ \s -> s { tsNetwork = net }) $ inner net
-    delInternet inet
-    return res
-
-withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a
-withSubnet parent tvname inner = do
-    net <- newSubnet parent (fromTypedVarName <$> tvname)
-    withNetwork net inner
-
-withNetwork :: Network -> (Network -> TestRun a) -> TestRun a
-withNetwork net inner = do
-    tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case
-        Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)
-            (path ++ " -i br0 -w '" ++ netDir net ++ "/br0.pcap' -U -Z root") . const
-        Nothing -> id
-
-    tcpdump $ inner net
-
-withNode :: Expr Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a
-withNode netexpr tvname inner = do
-    net <- eval netexpr
-    node <- newNode net (either fromTypedVarName fromTypedVarName tvname)
-    either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node
-
-tryMatch :: Regex -> [Text] -> Maybe ((Text, [Text]), [Text])
-tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ((x, capture), xs)
-                   | otherwise = fmap (x:) <$> tryMatch re xs
-tryMatch _ [] = Nothing
-
-exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun ()
-exprFailed desc (SourceLine sline) pname expr = do
-    let prompt = maybe T.empty textProcName pname
-    exprVars <- gatherVars expr
-    outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]
-    forM_ exprVars $ \(name, value) ->
-        outLine OutputMatchFail (Just prompt) $ T.concat [T.pack "  ", textVarName name, T.pack " = ", textSomeVarValue value]
-    throwError Failed
-
-expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()
-expect (SourceLine sline) p expr tvars inner = do
-    re <- eval expr
-    timeout <- asks $ optTimeout . teOptions . fst
-    delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
-    mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
-        line <- readTVar (procOutput p)
-        case tryMatch re line of
-             Nothing -> retry
-             Just (m, out') -> do
-                 writeTVar (procOutput p) out'
-                 return $ Just m
-    case mbmatch of
-         Just (line, capture) -> do
-             let vars = map (\(TypedVarName n) -> n) tvars
-
-             when (length vars /= length capture) $ do
-                 outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline
-                 throwError Failed
-
-             forM_ vars $ \name -> do
-                 cur <- asks (lookup name . tsVars . snd)
-                 when (isJust cur) $ do
-                     outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
-                     throwError Failed
-
-             outProc OutputMatch p line
-             local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner
-
-         Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr
-
-testStepGuard :: SourceLine -> Expr Bool -> TestRun ()
-testStepGuard sline expr = do
-    x <- eval expr
-    when (not x) $ exprFailed (T.pack "guard") sline Nothing expr
-
-evalSteps :: [TestStep] -> TestRun ()
-evalSteps = mapM_ $ \case
-    Let (SourceLine sline) (TypedVarName name) expr inner -> do
-        cur <- asks (lookup name . tsVars . snd)
-        when (isJust cur) $ do
-            outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
-            throwError Failed
-        value <- eval expr
-        withVar name value $ evalSteps inner
-
-    For (SourceLine sline) (TypedVarName name) expr inner -> do
-        cur <- asks (lookup name . tsVars . snd)
-        when (isJust cur) $ do
-            outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
-            throwError Failed
-        value <- eval expr
-        forM_ value $ \i -> do
-            withVar name i $ evalSteps inner
-
-    Subnet name@(TypedVarName vname) parentExpr inner -> do
-        parent <- eval parentExpr
-        withSubnet parent (Just name) $ \net -> do
-            withVar vname net $ evalSteps inner
-
-    DeclNode name@(TypedVarName vname) net inner -> do
-        withNode net (Left name) $ \node -> do
-            withVar vname node $ evalSteps inner
-
-    Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do
-        case target of
-            Left nname -> withNode RootNetwork (Left nname) go
-            Right (Left net) -> withNode net (Right tvname) go
-            Right (Right node) -> go =<< eval node
-      where
-        go node = do
-            opts <- asks $ teOptions . fst
-            let pname = ProcName tname
-                tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
-            withProcess (Right node) pname Nothing tool $ \p -> do
-                withVar vname p (evalSteps inner)
-
-    Send pname expr -> do
-        p <- eval pname
-        line <- eval expr
-        outProc OutputChildStdin p line
-        send p line
-
-    Expect line pname expr captures inner -> do
-        p <- eval pname
-        expect line p expr captures $ evalSteps inner
-
-    Guard line expr -> do
-        testStepGuard line expr
-
-    PacketLoss loss node inner -> do
-        l <- eval loss
-        n <- eval node
-        withNodePacketLoss n l $ evalSteps inner
-
-    Wait -> do
-        void $ outPromptGetLine "Waiting..."
-
-runTest :: Output -> TestOptions -> Test -> IO Bool
-runTest out opts test = do
-    let testDir = optTestDir opts
-    when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
-        if isDoesNotExistError e then return () else ioError e
-    exists <- doesPathExist testDir
-    when exists $ ioError $ userError $ testDir ++ " exists"
-    createDirectoryIfMissing True testDir
-
-    failedVar <- newTVarIO Nothing
-    procVar <- newMVar []
-
-    mgdb <- if optGDB opts
-        then flip runReaderT out $ do
-            gdb <- gdbStart $ atomically . writeTVar failedVar . Just . ProcessCrashed
-            Just . (, gdbProcess gdb) <$> liftIO (newMVar gdb)
-        else return Nothing
-
-    let tenv = TestEnv
-            { teOutput = out
-            , teFailed = failedVar
-            , teOptions = opts
-            , teProcesses = procVar
-            , teGDB = fst <$> mgdb
-            }
-        tstate = TestState
-            { tsNetwork = error "network not initialized"
-            , tsVars = []
-            , tsNodePacketLoss = M.empty
-            }
-
-    let sigHandler SignalInfo { siginfoSpecific = chld } = do
-            processes <- readMVar procVar
-            forM_ processes $ \p -> do
-                mbpid <- getPid (procHandle p)
-                when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do
-                    let err detail = outProc OutputChildFail p detail
-                    case siginfoStatus chld of
-                        Exited ExitSuccess -> outProc OutputChildInfo p $ T.pack $ "child exited successfully"
-                        Exited (ExitFailure code) -> do
-                            err $ T.pack $ "child process exited with status " ++ show code
-                            liftIO $ atomically $ writeTVar (teFailed tenv) $ Just Failed
-                        Terminated sig _ -> do
-                            err $ T.pack $ "child terminated with signal " ++ show sig
-                            liftIO $ atomically $ writeTVar (teFailed tenv) $ Just $ ProcessCrashed p
-                        Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
-    oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
-
-    res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
-        withInternet $ \_ -> evalSteps (testSteps test)
-
-    void $ installHandler processStatusChanged oldHandler Nothing
-
-    Right () <- runExceptT $ flip runReaderT out $ do
-        maybe (return ()) (closeProcess . snd) mgdb
-    [] <- readMVar procVar
-
-    failed <- atomically $ readTVar (teFailed tenv)
-    case (res, failed) of
-        (Right (), Nothing) -> do
-            removeDirectoryRecursive testDir
-            return True
-        _ -> return False
-
 data CmdlineOptions = CmdlineOptions
     { optTest :: TestOptions
     , optShowVersion :: Bool
diff --git a/src/Run.hs b/src/Run.hs
new file mode 100644
index 0000000..d771116
--- /dev/null
+++ b/src/Run.hs
@@ -0,0 +1,264 @@
+module Run (
+    module Run.Monad,
+    runTest,
+) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Scientific
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import System.Directory
+import System.Exit
+import System.IO.Error
+import System.Posix.Process
+import System.Posix.Signals
+import System.Process
+
+import GDB
+import Network
+import Output
+import Process
+import Run.Monad
+import Test
+
+runTest :: Output -> TestOptions -> Test -> IO Bool
+runTest out opts test = do
+    let testDir = optTestDir opts
+    when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
+        if isDoesNotExistError e then return () else ioError e
+    exists <- doesPathExist testDir
+    when exists $ ioError $ userError $ testDir ++ " exists"
+    createDirectoryIfMissing True testDir
+
+    failedVar <- newTVarIO Nothing
+    procVar <- newMVar []
+
+    mgdb <- if optGDB opts
+        then flip runReaderT out $ do
+            gdb <- gdbStart $ atomically . writeTVar failedVar . Just . ProcessCrashed
+            Just . (, gdbProcess gdb) <$> liftIO (newMVar gdb)
+        else return Nothing
+
+    let tenv = TestEnv
+            { teOutput = out
+            , teFailed = failedVar
+            , teOptions = opts
+            , teProcesses = procVar
+            , teGDB = fst <$> mgdb
+            }
+        tstate = TestState
+            { tsNetwork = error "network not initialized"
+            , tsVars = []
+            , tsNodePacketLoss = M.empty
+            }
+
+    let sigHandler SignalInfo { siginfoSpecific = chld } = do
+            processes <- readMVar procVar
+            forM_ processes $ \p -> do
+                mbpid <- getPid (procHandle p)
+                when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do
+                    let err detail = outProc OutputChildFail p detail
+                    case siginfoStatus chld of
+                        Exited ExitSuccess -> outProc OutputChildInfo p $ T.pack $ "child exited successfully"
+                        Exited (ExitFailure code) -> do
+                            err $ T.pack $ "child process exited with status " ++ show code
+                            liftIO $ atomically $ writeTVar (teFailed tenv) $ Just Failed
+                        Terminated sig _ -> do
+                            err $ T.pack $ "child terminated with signal " ++ show sig
+                            liftIO $ atomically $ writeTVar (teFailed tenv) $ Just $ ProcessCrashed p
+                        Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
+    oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
+
+    res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
+        withInternet $ \_ -> evalSteps (testSteps test)
+
+    void $ installHandler processStatusChanged oldHandler Nothing
+
+    Right () <- runExceptT $ flip runReaderT out $ do
+        maybe (return ()) (closeProcess . snd) mgdb
+    [] <- readMVar procVar
+
+    failed <- atomically $ readTVar (teFailed tenv)
+    case (res, failed) of
+        (Right (), Nothing) -> do
+            removeDirectoryRecursive testDir
+            return True
+        _ -> return False
+
+evalSteps :: [TestStep] -> TestRun ()
+evalSteps = mapM_ $ \case
+    Let (SourceLine sline) (TypedVarName name) expr inner -> do
+        cur <- asks (lookup name . tsVars . snd)
+        when (isJust cur) $ do
+            outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+            throwError Failed
+        value <- eval expr
+        withVar name value $ evalSteps inner
+
+    For (SourceLine sline) (TypedVarName name) expr inner -> do
+        cur <- asks (lookup name . tsVars . snd)
+        when (isJust cur) $ do
+            outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+            throwError Failed
+        value <- eval expr
+        forM_ value $ \i -> do
+            withVar name i $ evalSteps inner
+
+    Subnet name@(TypedVarName vname) parentExpr inner -> do
+        parent <- eval parentExpr
+        withSubnet parent (Just name) $ \net -> do
+            withVar vname net $ evalSteps inner
+
+    DeclNode name@(TypedVarName vname) net inner -> do
+        withNode net (Left name) $ \node -> do
+            withVar vname node $ evalSteps inner
+
+    Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do
+        case target of
+            Left nname -> withNode RootNetwork (Left nname) go
+            Right (Left net) -> withNode net (Right tvname) go
+            Right (Right node) -> go =<< eval node
+      where
+        go node = do
+            opts <- asks $ teOptions . fst
+            let pname = ProcName tname
+                tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
+            withProcess (Right node) pname Nothing tool $ \p -> do
+                withVar vname p (evalSteps inner)
+
+    Send pname expr -> do
+        p <- eval pname
+        line <- eval expr
+        outProc OutputChildStdin p line
+        send p line
+
+    Expect line pname expr captures inner -> do
+        p <- eval pname
+        expect line p expr captures $ evalSteps inner
+
+    Guard line expr -> do
+        testStepGuard line expr
+
+    PacketLoss loss node inner -> do
+        l <- eval loss
+        n <- eval node
+        withNodePacketLoss n l $ evalSteps inner
+
+    Wait -> do
+        void $ outPromptGetLine "Waiting..."
+
+
+withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a
+withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })
+
+withInternet :: (Network -> TestRun a) -> TestRun a
+withInternet inner = do
+    testDir <- asks $ optTestDir . teOptions . fst
+    inet <- newInternet testDir
+    res <- withNetwork (inetRoot inet) $ \net -> do
+        local (fmap $ \s -> s { tsNetwork = net }) $ inner net
+    delInternet inet
+    return res
+
+withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a
+withSubnet parent tvname inner = do
+    net <- newSubnet parent (fromTypedVarName <$> tvname)
+    withNetwork net inner
+
+withNetwork :: Network -> (Network -> TestRun a) -> TestRun a
+withNetwork net inner = do
+    tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case
+        Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)
+            (path ++ " -i br0 -w '" ++ netDir net ++ "/br0.pcap' -U -Z root") . const
+        Nothing -> id
+
+    tcpdump $ inner net
+
+withNode :: Expr Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a
+withNode netexpr tvname inner = do
+    net <- eval netexpr
+    node <- newNode net (either fromTypedVarName fromTypedVarName tvname)
+    either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node
+
+withNodePacketLoss :: Node -> Scientific -> TestRun a -> TestRun a
+withNodePacketLoss node loss inner = do
+    x <- local (fmap $ \s -> s { tsNodePacketLoss = M.insertWith (\l l' -> 1 - (1 - l) * (1 - l')) (nodeName node) loss $ tsNodePacketLoss s }) $ do
+        resetLoss
+        inner
+    resetLoss
+    return x
+  where
+    resetLoss = do
+        tl <- asks $ fromMaybe 0 . M.lookup (nodeName node) . tsNodePacketLoss . snd
+        liftIO $ callOn node $ "tc qdisc replace dev veth0 root netem loss " <> T.pack (show (tl * 100)) <> "%"
+
+
+atomicallyTest :: STM a -> TestRun a
+atomicallyTest act = do
+    failedVar <- asks $ teFailed . fst
+    res <- liftIO $ atomically $ do
+        readTVar failedVar >>= \case
+            Just e  -> return $ Left e
+            Nothing -> Right <$> act
+    case res of
+        Left e -> throwError e
+        Right x -> return x
+
+tryMatch :: Regex -> [Text] -> Maybe ((Text, [Text]), [Text])
+tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ((x, capture), xs)
+                   | otherwise = fmap (x:) <$> tryMatch re xs
+tryMatch _ [] = Nothing
+
+exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun ()
+exprFailed desc (SourceLine sline) pname expr = do
+    let prompt = maybe T.empty textProcName pname
+    exprVars <- gatherVars expr
+    outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]
+    forM_ exprVars $ \(name, value) ->
+        outLine OutputMatchFail (Just prompt) $ T.concat [T.pack "  ", textVarName name, T.pack " = ", textSomeVarValue value]
+    throwError Failed
+
+expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()
+expect (SourceLine sline) p expr tvars inner = do
+    re <- eval expr
+    timeout <- asks $ optTimeout . teOptions . fst
+    delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
+    mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
+        line <- readTVar (procOutput p)
+        case tryMatch re line of
+             Nothing -> retry
+             Just (m, out') -> do
+                 writeTVar (procOutput p) out'
+                 return $ Just m
+    case mbmatch of
+         Just (line, capture) -> do
+             let vars = map (\(TypedVarName n) -> n) tvars
+
+             when (length vars /= length capture) $ do
+                 outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline
+                 throwError Failed
+
+             forM_ vars $ \name -> do
+                 cur <- asks (lookup name . tsVars . snd)
+                 when (isJust cur) $ do
+                     outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+                     throwError Failed
+
+             outProc OutputMatch p line
+             local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner
+
+         Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr
+
+testStepGuard :: SourceLine -> Expr Bool -> TestRun ()
+testStepGuard sline expr = do
+    x <- eval expr
+    when (not x) $ exprFailed (T.pack "guard") sline Nothing expr