From 359607468fac0ed11bfc1a3579c69fe4310419cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 4 May 2022 20:50:06 +0200 Subject: Test run monad --- erebos-tester.cabal | 2 + src/GDB.hs | 10 ++- src/Main.hs | 244 ++++++++++++++++++++++++++++++++-------------------- src/Output.hs | 27 ++++-- src/Process.hs | 5 +- 5 files changed, 181 insertions(+), 107 deletions(-) diff --git a/erebos-tester.cabal b/erebos-tester.cabal index 4964b6f..90c768d 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -43,8 +43,10 @@ executable erebos-tester-core ExistentialQuantification FlexibleContexts FlexibleInstances + GeneralizedNewtypeDeriving ImportQualifiedPost LambdaCase + MultiParamTypeClasses RankNTypes TypeFamilies TypeOperators diff --git a/src/GDB.hs b/src/GDB.hs index 40a4e8f..76c33c1 100644 --- a/src/GDB.hs +++ b/src/GDB.hs @@ -4,6 +4,8 @@ module GDB ( gdbSession, ) where +import Control.Monad.IO.Class + import Data.Text qualified as T import Data.Text.IO qualified as T @@ -15,20 +17,20 @@ import Process gdbCmd :: String gdbCmd = "gdb --quiet --interpreter=mi3" -gdbInit :: Process -> IO () +gdbInit :: MonadIO m => Process -> m () gdbInit gdb = do send gdb $ T.pack "-gdb-set schedule-multiple on" send gdb $ T.pack "-gdb-set mi-async on" send gdb $ T.pack "-gdb-set print symbol-loading off" -addInferior :: Process -> Int -> Pid -> IO () +addInferior :: MonadIO m => Process -> Int -> Pid -> m () addInferior gdb i pid = do send gdb $ T.pack $ "-add-inferior" send gdb $ T.pack $ "-target-attach --thread-group i" ++ show i ++ " " ++ show pid send gdb $ T.pack $ "-exec-continue --thread-group i" ++ show i -gdbSession :: Process -> IO () -gdbSession gdb = do +gdbSession :: MonadIO m => Process -> m () +gdbSession gdb = liftIO $ do catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) >>= \case Just line -> do send gdb (T.pack "-interpreter-exec console \"" `T.append` line `T.append` T.pack "\"") diff --git a/src/Main.hs b/src/Main.hs index 20e01e6..6cf5405 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,6 +4,8 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader import Data.List import Data.Maybe @@ -63,30 +65,78 @@ defaultOptions = Options testDir :: FilePath testDir = "./.test" -initNetwork :: Output -> Bool -> IO Network -initNetwork out useGDB = do - exists <- doesPathExist testDir - when exists $ ioError $ userError $ testDir ++ " exists" - createDirectoryIfMissing True testDir - callCommand "ip link add name br0 type bridge" - callCommand "ip addr add 192.168.0.1/24 broadcast 192.168.0.255 dev br0" - callCommand "ip link set dev br0 up" - callCommand "ip link set dev lo up" - net <- Network <$> newMVar [] <*> newMVar [] <*> pure testDir +data TestEnv = TestEnv + { teOutput :: Output + , teFailed :: TVar Bool + , teOptions :: Options + } - void $ spawnOn out (Left net) (ProcNameTcpdump) (Just softwareTermination) $ +newtype TestRun a = TestRun { fromTestRun :: ReaderT TestEnv (ExceptT () IO) a } + deriving (Functor, Applicative, Monad, MonadReader TestEnv, MonadIO) + +instance MonadFail TestRun where + fail str = do + outLine OutputError Nothing $ T.pack str + throwError () + +instance MonadError () TestRun where + throwError () = do + failedVar <- asks teFailed + liftIO $ atomically $ writeTVar failedVar True + TestRun $ throwError () + + catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler + + +instance MonadOutput TestRun where + getOutput = asks teOutput + +forkTest :: TestRun () -> TestRun () +forkTest act = do + tenv <- ask + void $ liftIO $ forkIO $ do + runExceptT (runReaderT (fromTestRun act) tenv) >>= \case + Left () -> atomically $ writeTVar (teFailed tenv) True + Right () -> return () + +atomicallyTest :: STM a -> TestRun a +atomicallyTest act = do + failedVar <- asks teFailed + res <- liftIO $ atomically $ do + failed <- readTVar failedVar + if failed then return $ Left () + else Right <$> act + case res of + Left e -> throwError e + Right x -> return x + +initNetwork :: TestRun Network +initNetwork = do + net <- liftIO $ do + exists <- doesPathExist testDir + when exists $ ioError $ userError $ testDir ++ " exists" + createDirectoryIfMissing True testDir + + callCommand "ip link add name br0 type bridge" + callCommand "ip addr add 192.168.0.1/24 broadcast 192.168.0.255 dev br0" + callCommand "ip link set dev br0 up" + callCommand "ip link set dev lo up" + Network <$> newMVar [] <*> newMVar [] <*> pure testDir + + void $ spawnOn (Left net) (ProcNameTcpdump) (Just softwareTermination) $ "tcpdump -i br0 -w '" ++ testDir ++ "/br0.pcap' -U -Z root" + useGDB <- asks $ optGDB . teOptions when useGDB $ do - gdbInit =<< spawnOn out (Left net) ProcNameGDB Nothing gdbCmd + gdbInit =<< spawnOn (Left net) ProcNameGDB Nothing gdbCmd return net -exitNetwork :: Output -> Network -> Bool -> IO () -exitNetwork out net okTest = do - processes <- readMVar (netProcesses net) - forM_ processes $ \p -> do +exitNetwork :: Network -> TestRun () +exitNetwork net = do + processes <- liftIO $ readMVar (netProcesses net) + liftIO $ forM_ processes $ \p -> do when (procName p /= ProcNameGDB) $ do hClose (procStdin p) case procKillWith p of @@ -97,27 +147,27 @@ exitNetwork out net okTest = do forM_ processes $ \p -> do when (procName p == ProcNameGDB) $ do - outPrompt out $ T.pack "gdb> " + outPrompt $ T.pack "gdb> " gdbSession p - outClearPrompt out - hClose (procStdin p) + outClearPrompt + liftIO $ hClose (procStdin p) - okProc <- fmap and $ forM processes $ \p -> do - waitForProcess (procHandle p) >>= \case - ExitSuccess -> return True + forM_ processes $ \p -> do + liftIO (waitForProcess (procHandle p)) >>= \case + ExitSuccess -> return () ExitFailure code -> do - outLine out OutputChildFail (Just $ procName p) $ T.pack $ "exit code: " ++ show code - return False + outLine OutputChildFail (Just $ procName p) $ T.pack $ "exit code: " ++ show code + liftIO . atomically . flip writeTVar False =<< asks teFailed - if okTest && okProc - then do removeDirectoryRecursive $ netDir net - exitSuccess - else exitFailure + failed <- liftIO . atomically . readTVar =<< asks teFailed + liftIO $ if failed then exitFailure + else do removeDirectoryRecursive $ netDir net + exitSuccess -getNode :: Network -> NodeName -> IO Node -getNode net nname@(NodeName tnname) = (find ((nname==).nodeName) <$> readMVar (netNodes net)) >>= \case +getNode :: Network -> NodeName -> TestRun Node +getNode net nname@(NodeName tnname) = (find ((nname==).nodeName) <$> liftIO (readMVar (netNodes net))) >>= \case Just node -> return node - _ -> do + _ -> liftIO $ do let name = T.unpack tnname dir = netDir net ("erebos_" ++ name) node = Node { nodeName = nname @@ -142,32 +192,32 @@ getNode net nname@(NodeName tnname) = (find ((nname==).nodeName) <$> readMVar (n callOn :: Node -> String -> IO () callOn node cmd = callCommand $ "ip netns exec \"" ++ unpackNodeName (nodeName node) ++ "\" " ++ cmd -spawnOn :: Output -> Either Network Node -> ProcName -> Maybe Signal -> String -> IO Process -spawnOn out target pname killWith cmd = do +spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process +spawnOn target pname killWith cmd = do let prefix = either (const "") (\node -> "ip netns exec \"" ++ unpackNodeName (nodeName node) ++ "\" ") target - (Just hin, Just hout, Just herr, handle) <- createProcess (shell $ prefix ++ cmd) + (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe , env = Just [("EREBOS_DIR", either netDir nodeDir target)] } - pout <- newTVarIO [] + pout <- liftIO $ newTVarIO [] - let readingLoop :: Handle -> (Text -> IO ()) -> IO () + let readingLoop :: Handle -> (Text -> TestRun ()) -> TestRun () readingLoop h act = - tryIOError (T.hGetLine h) >>= \case + liftIO (tryIOError (T.hGetLine h)) >>= \case Left err | isEOFError err -> return () - | otherwise -> outLine out OutputChildFail (Just pname) $ T.pack $ "IO error: " ++ show err + | otherwise -> outLine OutputChildFail (Just pname) $ T.pack $ "IO error: " ++ show err Right line -> do act line readingLoop h act - void $ forkIO $ readingLoop hout $ \line -> do - outLine out OutputChildStdout (Just pname) line - atomically $ modifyTVar pout (++[line]) - void $ forkIO $ readingLoop herr $ \line -> do + forkTest $ readingLoop hout $ \line -> do + outLine OutputChildStdout (Just pname) line + liftIO $ atomically $ modifyTVar pout (++[line]) + forkTest $ readingLoop herr $ \line -> do case pname of ProcNameTcpdump -> return () - _ -> outLine out OutputChildStderr (Just pname) line + _ -> outLine OutputChildStderr (Just pname) line let process = Process { procName = pname @@ -178,7 +228,7 @@ spawnOn out target pname killWith cmd = do } let net = either id nodeNetwork target - when (pname /= ProcNameGDB) $ do + when (pname /= ProcNameGDB) $ liftIO $ do getPid handle >>= \case Just pid -> void $ do ps <- readMVar (netProcesses net) @@ -187,11 +237,11 @@ spawnOn out target pname killWith cmd = do addInferior gdb (length ps) pid Nothing -> return () - modifyMVar_ (netProcesses net) $ return . (process:) + liftIO $ modifyMVar_ (netProcesses net) $ return . (process:) return process -getProcess :: Network -> ProcName -> IO Process -getProcess net pname = do +getProcess :: Network -> ProcName -> TestRun Process +getProcess net pname = liftIO $ do Just p <- find ((pname==).procName) <$> readMVar (netProcesses net) return p @@ -200,10 +250,11 @@ tryMatch re (x:xs) | Right (Just _) <- regexec re x = Just (x, xs) | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -expect :: Output -> Options -> Process -> Regex -> Text -> IO Bool -expect out opts p re pat = do - delay <- registerDelay $ ceiling $ 1000000 * optTimeout opts - mbmatch <- atomically $ (Nothing <$ (check =<< readTVar delay)) <|> do +expect :: Process -> Regex -> Text -> TestRun () +expect p re pat = do + timeout <- asks $ optTimeout . teOptions + delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout + mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) case tryMatch re line of Nothing -> retry @@ -212,57 +263,60 @@ expect out opts p re pat = do return $ Just m case mbmatch of Just line -> do - outLine out OutputMatch (Just $ procName p) line - return True + outLine OutputMatch (Just $ procName p) line Nothing -> do - outLine out OutputMatchFail (Just $ procName p) $ T.pack "expect failed /" `T.append` pat `T.append` T.pack "/" - return False + outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed /" `T.append` pat `T.append` T.pack "/" + throwError () 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 -> Options -> Test -> IO () +runTest :: Output -> Options -> Test -> IO Bool runTest out opts test = do - net <- initNetwork out $ optGDB opts - - let sigHandler SignalInfo { siginfoSpecific = chld } = do - processes <- readMVar (netProcesses net) - forM_ processes $ \p -> do - mbpid <- getPid (procHandle p) - when (mbpid == Just (siginfoPid chld)) $ do - let err detail = outLine out OutputChildFail (Just $ procName p) detail - case siginfoStatus chld of - Exited ExitSuccess -> outLine out OutputChildInfo (Just $ procName p) $ T.pack $ "child exited successfully" - Exited (ExitFailure code) -> err $ T.pack $ "child process exited with status " ++ show code - Terminated sig _ -> err $ T.pack $ "child terminated with signal " ++ show sig - Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig - oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing - - ok <- allM (testSteps test) $ \case - Spawn pname nname -> do - node <- getNode net nname - void $ spawnOn out (Right node) pname Nothing $ - fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - return True - - Send pname line -> do - p <- getProcess net pname - send p line - return True - - Expect pname regex pat -> do - p <- getProcess net pname - expect out opts p regex pat - - Wait -> do - outPrompt out $ T.pack "Waiting..." - void $ getLine - outClearPrompt out - return True - - _ <- installHandler processStatusChanged oldHandler Nothing - exitNetwork out net ok + tenv <- TestEnv + <$> pure out + <*> newTVarIO False + <*> pure opts + (fmap $ either (const False) id) $ runExceptT $ flip runReaderT tenv $ fromTestRun $ do + net <- initNetwork + + let sigHandler SignalInfo { siginfoSpecific = chld } = do + processes <- readMVar (netProcesses net) + forM_ processes $ \p -> do + mbpid <- getPid (procHandle p) + when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do + let err detail = outLine OutputChildFail (Just $ procName p) detail + case siginfoStatus chld of + Exited ExitSuccess -> outLine OutputChildInfo (Just $ procName p) $ T.pack $ "child exited successfully" + Exited (ExitFailure code) -> err $ T.pack $ "child process exited with status " ++ show code + Terminated sig _ -> err $ T.pack $ "child terminated with signal " ++ show sig + Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig + oldHandler <- liftIO $ installHandler processStatusChanged (CatchInfo sigHandler) Nothing + + flip catchError (const $ return ()) $ forM_ (testSteps test) $ \case + Spawn pname nname -> do + node <- getNode net nname + void $ spawnOn (Right node) pname Nothing $ + fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) + + Send pname line -> do + p <- getProcess net pname + send p line + + Expect pname regex pat -> do + p <- getProcess net pname + expect p regex pat + + Wait -> do + outPrompt $ T.pack "Waiting..." + void $ liftIO $ getLine + outClearPrompt + + _ <- liftIO $ installHandler processStatusChanged oldHandler Nothing + exitNetwork net + + atomicallyTest $ return True options :: [OptDescr (Options -> Options)] diff --git a/src/Output.hs b/src/Output.hs index d701176..2c34a7d 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -1,11 +1,14 @@ module Output ( Output, OutputType(..), + MonadOutput(..), startOutput, outLine, outPrompt, outClearPrompt, ) where import Control.Concurrent.MVar +import Control.Monad.IO.Class +import Control.Monad.Reader import Data.Text (Text) import Data.Text qualified as T @@ -29,6 +32,13 @@ data OutputType = OutputChildStdout | OutputChildFail | OutputMatch | OutputMatchFail + | OutputError + +class MonadIO m => MonadOutput m where + getOutput :: m Output + +instance MonadIO m => MonadOutput (ReaderT Output m) where + getOutput = ask startOutput :: IO Output startOutput = Output <$> newMVar OutputState { outCurPrompt = Nothing } @@ -40,6 +50,7 @@ outColor OutputChildInfo = T.pack "0" outColor OutputChildFail = T.pack "31" outColor OutputMatch = T.pack "32" outColor OutputMatchFail = T.pack "31" +outColor OutputError = T.pack "31" outSign :: OutputType -> Text outSign OutputChildStdout = T.empty @@ -48,6 +59,7 @@ outSign OutputChildInfo = T.pack "." outSign OutputChildFail = T.pack "!!" outSign OutputMatch = T.pack "+" outSign OutputMatchFail = T.pack "/" +outSign OutputError = T.pack "!!" clearPrompt :: OutputState -> IO () clearPrompt OutputState { outCurPrompt = Just _ } = T.putStr $ T.pack "\ESC[2K\r" @@ -57,8 +69,11 @@ showPrompt :: OutputState -> IO () showPrompt OutputState { outCurPrompt = Just p } = T.putStr p >> hFlush stdout showPrompt _ = return () -outLine :: Output -> OutputType -> Maybe ProcName -> Text -> IO () -outLine out otype mbproc line = withMVar (outState out) $ \st -> do +ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a +ioWithOutput act = liftIO . act =<< getOutput + +outLine :: MonadOutput m => OutputType -> Maybe ProcName -> Text -> m () +outLine otype mbproc line = ioWithOutput $ \out -> withMVar (outState out) $ \st -> do clearPrompt st TL.putStrLn $ TL.fromChunks [ T.pack "\ESC[", outColor otype, T.pack "m" @@ -70,14 +85,14 @@ outLine out otype mbproc line = withMVar (outState out) $ \st -> do ] showPrompt st -outPrompt :: Output -> Text -> IO () -outPrompt out p = modifyMVar_ (outState out) $ \st -> do +outPrompt :: MonadOutput m => Text -> m () +outPrompt p = ioWithOutput $ \out -> modifyMVar_ (outState out) $ \st -> do clearPrompt st let st' = st { outCurPrompt = Just p } showPrompt st' return st' -outClearPrompt :: Output -> IO () -outClearPrompt out = modifyMVar_ (outState out) $ \st -> do +outClearPrompt :: MonadOutput m => m () +outClearPrompt = ioWithOutput $ \out -> modifyMVar_ (outState out) $ \st -> do clearPrompt st return st { outCurPrompt = Nothing } diff --git a/src/Process.hs b/src/Process.hs index 9943d30..958910d 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -6,6 +6,7 @@ module Process ( ) where import Control.Concurrent.STM +import Control.Monad.IO.Class import Data.Text (Text) import qualified Data.Text as T @@ -36,7 +37,7 @@ textProcName ProcNameGDB = T.pack "gdb" unpackProcName :: ProcName -> String unpackProcName = T.unpack . textProcName -send :: Process -> Text -> IO () -send p line = do +send :: MonadIO m => Process -> Text -> m () +send p line = liftIO $ do T.hPutStrLn (procStdin p) line hFlush (procStdin p) -- cgit v1.2.3