Timeout for the expect step

1 files changed, 25 insertions, 12 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 5cb64d9..fd62a3e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,6 @@
 module Main where
 
+import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Monad
@@ -65,10 +66,10 @@ initNetwork out = do
         "tcpdump -i br0 -w '" ++ testDir ++ "/br0.pcap' -U -Z root"
     return net
 
-exitNetwork :: Output -> Network -> IO ()
-exitNetwork out net = do
+exitNetwork :: Output -> Network -> Bool -> IO ()
+exitNetwork out net okTest = do
     processes <- readMVar (netProcesses net)
-    ok <- fmap and $ forM processes $ \p -> do
+    okProc <- fmap and $ forM processes $ \p -> do
         hClose (procStdin p)
         case procKillWith p of
              Nothing -> return ()
@@ -81,7 +82,7 @@ exitNetwork out net = do
                 outLine out OutputChildFail (Just $ procName p) $ T.pack $ "exit code: " ++ show code
                 return False
 
-    if ok
+    if okTest && okProc
        then do removeDirectoryRecursive $ netDir net
                exitSuccess
        else exitFailure
@@ -163,9 +164,10 @@ tryMatch re (x:xs) | Right (Just _) <- regexec re x = Just (x, xs)
                    | otherwise = fmap (x:) <$> tryMatch re xs
 tryMatch _ [] = Nothing
 
-expect :: Output -> Process -> Regex -> IO ()
+expect :: Output -> Process -> Regex -> IO Bool
 expect out p re = do
-    mbmatch <- atomically $ do
+    delay <- registerDelay 1000000
+    mbmatch <- atomically $ (Nothing <$ (check =<< readTVar delay)) <|> do
         line <- readTVar (procOutput p)
         case tryMatch re line of
              Nothing -> retry
@@ -173,13 +175,22 @@ expect out p re = do
                  writeTVar (procOutput p) out'
                  return $ Just m
     case mbmatch of
-         Just line -> outLine out OutputMatch (Just $ procName p) line
-         Nothing -> outLine out OutputMatchFail (Just $ procName p) $ T.pack "expect failed"
-
-send :: Process -> Text -> IO ()
+         Just line -> do
+             outLine out OutputMatch (Just $ procName p) line
+             return True
+         Nothing -> do
+             outLine out OutputMatchFail (Just $ procName p) $ T.pack "expect failed"
+             return False
+
+send :: Process -> Text -> IO Bool
 send p line = do
     T.hPutStrLn (procStdin p) line
     hFlush (procStdin p)
+    return True
+
+allM :: Monad m => [a] -> (a -> m Bool) -> m Bool
+allM (x:xs) p = p x >>= \case True -> allM xs p; False -> return False
+allM [] _ = return True
 
 runTest :: Output -> String -> Test -> IO ()
 runTest out tool test = do
@@ -198,10 +209,11 @@ runTest out tool test = do
                          Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
     oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
 
-    forM_ (testSteps test) $ \case
+    ok <- allM (testSteps test) $ \case
         Spawn pname nname -> do
             node <- getNode net nname
             void $ spawnOn out (Right node) pname Nothing tool
+            return True
 
         Send pname line -> do
             p <- getProcess net pname
@@ -215,9 +227,10 @@ runTest out tool test = do
             outPrompt out $ T.pack "Waiting..."
             void $ getLine
             outClearPrompt out
+            return True
 
     _ <- installHandler processStatusChanged oldHandler Nothing
-    exitNetwork out net
+    exitNetwork out net ok
 
 main :: IO ()
 main = do