Skip to content

GitLab

Commit 746cee22 authored by Valentin Reis's avatar Valentin Reis
Browse files

[feature] Added the `cmd listen` Test.

parent c9580560
Pipeline #4784 passed with stage
in 41 seconds
Hide whitespace changes
Inline Side-by-side
Showing with 205 additions and 73 deletions
argo/argo.cabal
View file @ 746cee22
......@@ -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
argo/src/Argo/Args.hs
View file @ 746cee22
......@@ -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 {..}
argo/src/Argo/Stack.hs
View file @ 746cee22
......@@ -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)
argo/src/Argo/Utils.hs
View file @ 746cee22
......@@ -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 ->
......
argotk/argotk.hs
View file @ 746cee22
......@@ -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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment