diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 249 | ||||
| -rw-r--r-- | src/Run.hs | 264 |
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 |