Move test-executing functions to separate module

1 files changed, 264 insertions, 0 deletions

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