From 746cee220608db0fdc7b8252c8547c1d2df90392 Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Fri, 21 Dec 2018 16:52:38 -0600 Subject: [PATCH] [feature] Added the `cmd listen` Test. --- argo/argo.cabal | 2 +- argo/src/Argo/Args.hs | 91 +++++++++++++++++++++++++++++++----------- argo/src/Argo/Stack.hs | 90 ++++++++++++++++++++++++++++++++--------- argo/src/Argo/Utils.hs | 11 ++--- argotk/argotk.hs | 84 +++++++++++++++++++++++++++----------- 5 files changed, 205 insertions(+), 73 deletions(-) diff --git a/argo/argo.cabal b/argo/argo.cabal index 3b1c37b..aaf1522 100644 --- a/argo/argo.cabal +++ b/argo/argo.cabal @@ -12,6 +12,6 @@ library exposed-Modules: Argo.Stack Argo.Utils Argo.Args - build-depends: base >=4 && <=8, turtle, data-default, managed, ansi-terminal, unix, system-filepath, async, process, text, optparse-applicative, extra, foldl, conduit,conduit-extra, bytestring + build-depends: base >=4 && <=8, turtle, data-default, managed, ansi-terminal, unix, system-filepath, async, process, text, optparse-applicative, extra, foldl, conduit,conduit-extra, bytestring, stm hs-source-dirs: src default-language: Haskell2010 diff --git a/argo/src/Argo/Args.hs b/argo/src/Argo/Args.hs index 5b76f24..a8b55d5 100644 --- a/argo/src/Argo/Args.hs +++ b/argo/src/Argo/Args.hs @@ -14,6 +14,7 @@ import Turtle import Prelude hiding ( FilePath ) +data OutputFiles = OutputFiles FilePath FilePath data StackArgs = StackArgs { app :: Text , args :: [Text] @@ -21,15 +22,19 @@ data StackArgs = StackArgs , workingDirectory :: FilePath , manifestDir :: FilePath , manifestName :: FilePath - , cmd_out :: FilePath - , cmd_err :: FilePath + , cmd_run_out :: FilePath + , cmd_run_err :: FilePath + , cmd_listen_out :: FilePath + , cmd_listen_err :: FilePath , daemon_out :: FilePath , daemon_err :: FilePath , nrm_log :: FilePath , messageDaemonOut :: Maybe Text , messageDaemonErr :: Maybe Text - , messageCmdOut :: Maybe Text - , messageCmdErr :: Maybe Text + , messageCmdRunOut :: Maybe Text + , messageCmdRunErr :: Maybe Text + , messageCmdListenOut :: Maybe Text + , messageCmdListenErr :: Maybe Text } instance Default StackArgs where @@ -40,15 +45,19 @@ instance Default StackArgs where , workingDirectory = "_output" , manifestDir = "manifests" , manifestName = "basic.json" - , cmd_out = "cmd_out.log" - , cmd_err = "cmd_err.log" + , cmd_run_out = "cmd_run_out.log" + , cmd_run_err = "cmd_run_err.log" + , cmd_listen_out = "cmd_listen_out.log" + , cmd_listen_err = "cmd_listen_err.log" , daemon_out = "daemon_out.log" , daemon_err = "daemon_err.log" , nrm_log = "nrm.log" , messageDaemonOut = Nothing , messageDaemonErr = Nothing - , messageCmdOut = Nothing - , messageCmdErr = Nothing + , messageCmdRunOut = Nothing + , messageCmdRunErr = Nothing + , messageCmdListenOut = Nothing + , messageCmdListenErr = Nothing } parseExtendStackArgs :: StackArgs -> Parser StackArgs @@ -88,19 +97,33 @@ parseExtendStackArgs StackArgs {..} = do <> showDefault <> value manifestName ) - cmd_out <- strOption - ( long "cmd_out" + cmd_run_out <- strOption + ( long "cmd_run_out" <> metavar "FILENAME" - <> help "Output file (relative to --output_dir), application stdout" + <> help "Output file (relative to --output_dir), \"cmd run\" stdout" <> showDefault - <> value cmd_out + <> value cmd_run_out ) - cmd_err <- strOption - ( long "cmd_err" + cmd_run_err <- strOption + ( long "cmd_run_err" <> metavar "FILENAME" - <> help "Output file (relative to --output_dir), application stderr" + <> help "Output file (relative to --output_dir), \"cmd run\" stderr" <> showDefault - <> value cmd_err + <> value cmd_run_err + ) + cmd_listen_out <- strOption + ( long "cmd_listen_out" + <> metavar "FILENAME" + <> help "Output file (relative to --output_dir), \"cmd listen\" stdout" + <> showDefault + <> value cmd_listen_out + ) + cmd_listen_err <- strOption + ( long "cmd_listen_err" + <> metavar "FILENAME" + <> help "Output file (relative to --output_dir), \"cmd listen\" stderr" + <> showDefault + <> value cmd_listen_err ) daemon_out <- strOption ( long "daemon_out" @@ -143,24 +166,44 @@ parseExtendStackArgs StackArgs {..} = do <> showDefault <> maybe mempty value messageDaemonErr ) - messageCmdOut <- optional $ strOption - ( long "message_cmd_stdout" + messageCmdRunOut <- optional $ strOption + ( long "message_cmd_run_stdout" <> metavar "STRING" <> help - "The appearance of this character string in the daemon stdout \ + "The appearance of this character string in the cmd run stdout \ \ will be monitored during execution. When observed, the \ \ stack will be killed and a return code of 0 will be returned." <> showDefault - <> maybe mempty value messageCmdOut + <> maybe mempty value messageCmdRunOut ) - messageCmdErr <- optional $ strOption - ( long "message_cmd_stderr" + messageCmdRunErr <- optional $ strOption + ( long "message_cmd_run_stderr" <> metavar "STRING" <> help - "The appearance of this character string in the daemon stdout \ + "The appearance of this character string in the cmd run stdout \ + \ will be monitored during execution. When observed, the \ + \ stack will be killed and a return code of 0 will be returned." + <> showDefault + <> maybe mempty value messageCmdRunErr + ) + messageCmdListenOut <- optional $ strOption + ( long "message_cmd_listen_stdout" + <> metavar "STRING" + <> help + "The appearance of this character string in the cmd listen stdout \ + \ will be monitored during execution. When observed, the \ + \ stack will be killed and a return code of 0 will be returned." + <> showDefault + <> maybe mempty value messageCmdListenOut + ) + messageCmdListenErr <- optional $ strOption + ( long "message_cmd_listen_stderr" + <> metavar "STRING" + <> help + "The appearance of this character string in the cmd listen stdout \ \ will be monitored during execution. When observed, the \ \ stack will be killed and a return code of 0 will be returned." <> showDefault - <> maybe mempty value messageCmdErr + <> maybe mempty value messageCmdListenErr ) pure StackArgs {..} diff --git a/argo/src/Argo/Stack.hs b/argo/src/Argo/Stack.hs index 304b6cb..4990e4c 100644 --- a/argo/src/Argo/Stack.hs +++ b/argo/src/Argo/Stack.hs @@ -18,7 +18,12 @@ import Prelude hiding ( FilePath ) import System.IO ( withFile ) import Debug.Trace import Filesystem.Path ( () ) + import Control.Concurrent.Async +import Control.Monad.STM ( atomically + , orElse + ) + import System.Console.ANSI import System.Console.ANSI.Types ( Color ) import Data.Text as T @@ -62,8 +67,10 @@ cleanLeftovers StackArgs {..} = do cleanLog [ workingDirectory daemon_out , workingDirectory daemon_err - , workingDirectory cmd_out - , workingDirectory cmd_err + , workingDirectory cmd_run_out + , workingDirectory cmd_run_err + , workingDirectory cmd_listen_out + , workingDirectory cmd_listen_err , workingDirectory nrm_log , workingDirectory ".argo_nodeos_config_exit_message" , workingDirectory "argo_nodeos_config" @@ -82,8 +89,7 @@ checkFsAttributes StackArgs {..} = do ("The output directory, " % fp % ", must not mounted with \"nosuid\"") workingDirectory -prepareDaemon - :: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ()))) +prepareDaemon :: StackArgs -> Shell Instrumentation prepareDaemon sa@StackArgs {..} = do mktree workingDirectory checkFsAttributes sa @@ -103,7 +109,7 @@ prepareDaemon sa@StackArgs {..} = do ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n) cleanContainers confPath' 1 4 export "ARGO_NODEOS_CONFIG" (format fp confPath') - makeInstrumentedProcess $ Instrumentation + return $ Instrumentation { process = P.proc "daemon" ["--nrm_log", encodeString nrm_log] , stdOutFile = daemon_out , stdErrFile = daemon_err @@ -160,9 +166,8 @@ prepareDaemon sa@StackArgs {..} = do "argo_nodeos_config successfully cleaned the container \ \config." -prepareCmdRun - :: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ()))) -prepareCmdRun StackArgs {..} = makeInstrumentedProcess $ Instrumentation +prepareCmdRun :: StackArgs -> Instrumentation +prepareCmdRun StackArgs {..} = Instrumentation { process = P.proc "cmd" $ [ "run" , "-u" @@ -171,28 +176,77 @@ prepareCmdRun StackArgs {..} = makeInstrumentedProcess $ Instrumentation , T.unpack app ] ++ fmap T.unpack args - , stdOutFile = cmd_out - , stdErrFile = cmd_err - , messageOut = messageCmdOut - , messageErr = messageCmdErr + , stdOutFile = cmd_run_out + , stdErrFile = cmd_run_err + , messageOut = messageCmdRunOut + , messageErr = messageCmdRunErr + } + +prepareCmdListen :: StackArgs -> Instrumentation +prepareCmdListen StackArgs {..} = Instrumentation + { process = P.proc "cmd" ["listen", "-u", T.unpack containerName] + , stdOutFile = cmd_listen_out + , stdErrFile = cmd_listen_err + , messageOut = messageCmdListenOut + , messageErr = messageCmdListenErr } data StackOutput = FoundMessage | DaemonDied | CmdDied + runSimpleStack :: StackArgs -> Shell StackOutput runSimpleStack a@StackArgs {..} = do cleanLeftovers a - instrumentedDaemon <- prepareDaemon a - instrumentedCmd <- prepareCmdRun a + iDaemon <- prepareDaemon a + let iRun = prepareCmdRun a printInfo "Running the daemon.." - liftIO $ withAsync instrumentedDaemon $ \daemon -> do + liftIO $ withAsync (runI iDaemon) $ \daemon -> do kbInstallHandler $ cancel daemon sh $ printInfo "Daemon running.\n" - sh $ printInfo "Running cmd.." - withAsync instrumentedCmd $ \cmd -> do - sh $ printInfo "cmd running.\n" + sh $ printInfo "Running 'cmd run'.." + withAsync (runI iRun) $ \cmd -> do + sh $ printInfo "'cmd run' running.\n" kbInstallHandler $ cancel daemon >> cancel cmd waitEitherCancel daemon cmd >>= \case Left (Left PatternMatched) -> return FoundMessage Left (Right _ ) -> return DaemonDied Right (Left PatternMatched) -> return FoundMessage Right (Right _ ) -> return CmdDied + + +data ListenAsyncConclusion a = Daemon a | Listen a | Run a +data ListenStackOutput = LSFoundMessage | LSMessageNotFound | LSDaemonDied ExitCode | LSRunDied ExitCode | LSListenDied ExitCode + +runListenStack :: StackArgs -> Shell ListenStackOutput +runListenStack a@StackArgs {..} = do + cleanLeftovers a + iDaemon <- prepareDaemon a + let iRun = prepareCmdRun a + let iListen = prepareCmdListen a + printInfo "Running the daemon.." + liftIO $ withAsync (runI iDaemon) $ \daemon -> do + kbInstallHandler $ cancel daemon + sh $ printInfo "Daemon running.\n" + sh $ printInfo "Running 'cmd run'.." + withAsync (runI iRun) $ \run -> do + sh $ printInfo "'cmd run' running.\n" + kbInstallHandler $ cancel daemon >> cancel run + sh $ printInfo "Running 'cmd listen'.." + withAsync (runI iListen) $ \listen -> do + sh $ printInfo "'cmd listen' running.\n" + kbInstallHandler $ cancel daemon >> cancel run >> cancel listen + waitStackCancel daemon run listen >>= \case + Daemon (Left PatternMatched) -> return LSFoundMessage + Daemon (Right (e, _, _) ) -> return $ LSDaemonDied e + Run (Left PatternMatched) -> return LSFoundMessage + Run (Right (e, _, _) ) -> return $ LSRunDied e + Listen (Left PatternMatched) -> return LSFoundMessage + Listen (Right (e, _, _) ) -> return $ LSListenDied e + where + waitStackCancel daemon run listen = + waitStack daemon run listen + `finally` (cancel daemon >> cancel run >> cancel listen) + waitStack daemon run listen = + atomically + $ (Daemon <$> waitSTM daemon) + `orElse` (Run <$> waitSTM run) + `orElse` (Listen <$> waitSTM listen) diff --git a/argo/src/Argo/Utils.hs b/argo/src/Argo/Utils.hs index f260710..9cadc58 100644 --- a/argo/src/Argo/Utils.hs +++ b/argo/src/Argo/Utils.hs @@ -76,7 +76,8 @@ verboseShell :: Text -> Shell Line -> Shell ExitCode verboseShell command input = printCommand command >> shell command input verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text) -verboseShell' command input = printCommand command >> shellStrictWithErr command input +verboseShell' command input = + printCommand command >> shellStrictWithErr command input cleanSocket = sudoRemoveFile printError "socket" cleanLog = sudoRemoveFile printWarning "log file" @@ -95,12 +96,8 @@ data Instrumentation = Instrumentation , messageOut :: Maybe Text , messageErr :: Maybe Text } deriving (Show) -makeInstrumentedProcess - :: Instrumentation -> Shell (IO (Either PatternMatched (ExitCode, (), ()))) -makeInstrumentedProcess instrumentation@Instrumentation {..} = do - printInfo "Prepared a process with full configuration: \n" - liftIO $ Prelude.print instrumentation - return $ try (reroutedDaemon process) +runI :: Instrumentation -> IO (Either PatternMatched (ExitCode, (), ())) +runI Instrumentation {..} = try (reroutedDaemon process) where reroutedDaemon process = withSinkFile (encodeString stdOutFile) $ \outSink -> diff --git a/argotk/argotk.hs b/argotk/argotk.hs index 67e4efa..fc12a31 100755 --- a/argotk/argotk.hs +++ b/argotk/argotk.hs @@ -21,11 +21,11 @@ import Data.Maybe opts :: StackArgs -> Parser (IO ()) opts sa = hsubparser ( command "clean" - (info (pure $ runClean sa) (progDesc "Clean sockets, logfiles.")) + (info (pure $ clean sa) (progDesc "Clean sockets, logfiles.")) <> command "daemon-only" (info - (runDaemon <$> parseExtendStackArgs sa) + (daemon <$> parseExtendStackArgs sa) (progDesc "Set up and launch the daemon in synchronous mode, \ \with properly cleaned sockets, logfiles." @@ -33,18 +33,18 @@ opts sa = hsubparser ) <> command "full-stack" - (info (runStack <$> parseExtendStackArgs sa) + (info (simpleStack <$> parseExtendStackArgs sa) (progDesc "Setup stack and run a command in a container.") ) <> command "helloworld" (info - (runStack <$> parseExtendStackArgs + (simpleStack <$> parseExtendStackArgs (let msg = "Hello-Moto" - in sa { app = "echo" - , args = [msg] - , messageCmdOut = Just msg - , messageCmdErr = Just msg + in sa { app = "echo" + , args = [msg] + , messageCmdRunOut = Just msg + , messageCmdRunErr = Just msg } ) ) @@ -56,7 +56,7 @@ opts sa = hsubparser <> command "perfwrapper" (info - (runStack <$> parseExtendStackArgs + (simpleStack <$> parseExtendStackArgs (sa { manifestName = "perfwrap.json" , app = "sleep" , args = ["15"] @@ -67,7 +67,25 @@ opts sa = hsubparser ) (progDesc "Test 2: Setup stack and check that argo-perf-wrapper sends \ - \ at least one progress message up." + \ at least one progress message to the daemon." + ) + ) + <> command + "listen" + (info + (listenStack <$> parseExtendStackArgs + (sa { manifestName = "perfwrap.json" + , app = "sleep" + , args = ["15"] + , messageCmdListenOut = Just "progress" + , messageCmdListenErr = Just "progress" + } + ) + ) + (progDesc + "Test 3: Setup stack and check that argo-perf-wrapper sends \ + \ at least one progress message to cmd listen through the \ + \ daemon." ) ) <> help @@ -76,14 +94,8 @@ opts sa = hsubparser \ values are printed when you call --help on these actions." ) -main :: IO () -main = do - manifests <- getEnv "MANIFESTS" - let a = def { manifestDir = decodeString manifests } - join $ execParser (info (opts a <**> helper) idm) - -runStack :: StackArgs -> IO () -runStack a@StackArgs {..} = sh $ runSimpleStack a >>= \case +simpleStack :: StackArgs -> IO () +simpleStack a@StackArgs {..} = sh $ runSimpleStack a >>= \case FoundMessage -> printSuccess "Found message!\n" >> exit ExitSuccess DaemonDied -> printError "Daemon died unexpectedly.\n" >> exit (ExitFailure 1) @@ -91,13 +103,39 @@ runStack a@StackArgs {..} = sh $ runSimpleStack a >>= \case when ( or $ isJust - <$> [messageDaemonOut, messageDaemonErr, messageCmdOut, messageCmdErr] + <$> [ messageDaemonOut + , messageDaemonErr + , messageCmdRunOut + , messageCmdRunErr + ] ) $ printError "Did not find message.\n" exit (ExitFailure 1) -runClean :: StackArgs -> IO () -runClean = sh . cleanLeftovers -runDaemon :: StackArgs -> IO () -runDaemon a = sh $ cleanLeftovers a >> prepareDaemon a >>= liftIO +listenStack :: StackArgs -> IO () +listenStack a@StackArgs {..} = sh $ runListenStack a >>= \case + LSFoundMessage -> printSuccess "Found message!\n" >> exit ExitSuccess + LSMessageNotFound -> + printError "Message not found.\n" >> exit (ExitFailure 1) + LSDaemonDied exitcode -> + printError "`daemon` died unexpectedly.\n" >> exit (ExitFailure 1) + LSRunDied exitcode -> + printError "`cmd run` unexpectedly.\n" >> exit (ExitFailure 1) + LSListenDied exitcode -> + printError "`cmd listen` died unexpectedly.\n" >> exit (ExitFailure 1) + +clean :: StackArgs -> IO () +clean = sh . cleanLeftovers + +daemon :: StackArgs -> IO () +daemon a = sh $ do + cleanLeftovers a + iDaemon <- prepareDaemon a + liftIO $ runI iDaemon + +main :: IO () +main = do + manifests <- getEnv "MANIFESTS" + let a = def { manifestDir = decodeString manifests } + join $ execParser (info (opts a <**> helper) idm) -- 2.26.2