summaryrefslogtreecommitdiff
path: root/src/Run.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Run.hs')
-rw-r--r--src/Run.hs264
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-19 22:20:32 +0000