summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs249
-rw-r--r--src/Run.hs264
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