Skip to content

GitLab

Commit a0c7e701 authored by Valentin Reis's avatar Valentin Reis
Browse files

Merge branch 'experiment-commands' into 'master' 

Experiment commands

See merge request argo/argotest!14
parents a2b60e73 014360e9
Pipeline #4864 passed with stage
in 11 seconds
Hide whitespace changes
Inline Side-by-side
Showing with 346 additions and 441 deletions
.README.md
View file @ a0c7e701
......@@ -112,34 +112,6 @@ There are a few things one has to be aware of using this workflow:
minutes by default. Use a local checkout if you need to modify some of these
sources on the fly.
### Example CI setup
``` {.yml}
integration.test:
stage: test
script:
- nix-shell -E '{ argotest ? (builtins.fetchGit {
url = https://xgitlab.cels.anl.gov/argo/argotest.git;
ref="master";})
}:
(import argotest { containers-src = ./. ; }).test' \
--run 'argotk.hs TestHello'
artifacts:
paths:
- argotest/_output/cmd_err.log
- argotest/_output/cmd_out.log
- argotest/_output/daemon_out.log
- argotest/_output/daemon_out.log
- argotest/_output/nrm.log
- argotest/_output/time.log
expire_in: 1 week
except:
- /^wip\/.*/
- /^WIP\/.*/
tags:
- integration
```
### Hacking
- edit `.README.md` in place of README.md.
......
.gitignore
View file @ a0c7e701
......@@ -3,3 +3,10 @@ _output
result
.shake
*.log
*/build
*/new-build
*/dist
*/new-dist
*/result
_output
*/_output
argo/argo.cabal
View file @ a0c7e701
......@@ -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, stm
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, pretty-show
hs-source-dirs: src
default-language: Haskell2010
argo/src/Argo/Args.hs
View file @ a0c7e701
{-# LANGUAGE
OverloadedStrings,
ApplicativeDo,
RecordWildCards #-}
{-# LANGUAGE OverloadedStrings, ApplicativeDo, GeneralizedNewtypeDeriving, RecordWildCards #-}
module Argo.Args where
import Options.Applicative as OA
import Options.Applicative.Types
import Options.Applicative.Builder ( option )
import Data.Default
import Data.Text as T
hiding ( empty )
import Turtle
import Turtle hiding ( option )
import Prelude hiding ( FilePath )
import System.Process hiding ( shell )
data OutputFiles = OutputFiles FilePath FilePath
data StackArgs = StackArgs
{ app :: Text
, args :: [Text]
, containerName :: Text
, workingDirectory :: FilePath
, manifestDir :: FilePath
, manifestName :: 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
, messageCmdRunOut :: Maybe Text
, messageCmdRunErr :: Maybe Text
, messageCmdListenOut :: Maybe Text
, messageCmdListenErr :: Maybe Text
{ verbosity :: Verbosity
, app :: AppName
, args :: AppArgs
, containerName :: ContainerName
, workingDirectory :: WorkingDirectory
, manifestDir :: ManifestDir
, manifestName :: ManifestName
, daemon :: ProcessBehavior
, cmdrun :: ProcessBehavior
, cmdlisten :: ProcessBehavior
, cmdlistenprogress :: ProcessBehavior
, cmdlistenpower :: ProcessBehavior
}
data Verbosity = Normal | Verbose deriving (Show,Read,Eq)
newtype AppArgs = AppArgs [Text] deriving (Show, Read)
newtype WorkingDirectory = WorkingDirectory FilePath deriving (IsString, Show)
newtype AppName = AppName Text deriving (IsString, Show, Read)
newtype ContainerName = ContainerName Text deriving (IsString, Show, Read)
newtype ManifestDir = ManifestDir FilePath deriving (IsString, Show)
newtype ManifestName = ManifestName FilePath deriving (IsString, Show)
newtype StdOutLog = StdOutLog Text deriving (Show, Read)
newtype StdErrLog = StdErrLog Text deriving (Show, Read)
newtype TestText = TestText Text deriving (Show, Read)
data ProcessBehavior =
SucceedTestOnMessage TestText StdOutLog StdErrLog
| JustRun StdOutLog StdErrLog
| DontRun deriving (Show,Read)
behavior :: ReadM ProcessBehavior
behavior = read <$> readerAsk
behaviorOption :: Mod OptionFields ProcessBehavior -> Parser ProcessBehavior
behaviorOption = option behavior
instance Default StackArgs where
def = StackArgs
{ app = "echo"
, args = ["foobar"]
, containerName = "testContainer"
, workingDirectory = "_output"
, manifestDir = "manifests"
, manifestName = "basic.json"
, 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
, messageCmdRunOut = Nothing
, messageCmdRunErr = Nothing
, messageCmdListenOut = Nothing
, messageCmdListenErr = Nothing
{ verbosity = Verbose
, app = AppName "ls"
, args = AppArgs []
, containerName = ContainerName "testContainer"
, workingDirectory = WorkingDirectory "_output"
, manifestDir = ManifestDir "manifests"
, manifestName = ManifestName "basic.json"
, daemon = DontRun
, cmdrun = DontRun
, cmdlisten = DontRun
, cmdlistenprogress = DontRun
, cmdlistenpower = DontRun
}
parseExtendStackArgs :: StackArgs -> Parser StackArgs
parseExtendStackArgs StackArgs {..} = do
verbosity <- flag
Normal
Verbose
(long "verbose" <> short 'v' <> help "Enable verbose mode")
app <- strOption
( long "application"
<> metavar "APP"
......@@ -97,113 +109,39 @@ parseExtendStackArgs StackArgs {..} = do
<> showDefault
<> value manifestName
)
cmd_run_out <- strOption
( long "cmd_run_out"
<> metavar "FILENAME"
<> help "Output file (relative to --output_dir), \"cmd run\" stdout"
<> showDefault
<> value cmd_run_out
)
cmd_run_err <- strOption
( long "cmd_run_err"
<> metavar "FILENAME"
<> help "Output file (relative to --output_dir), \"cmd run\" stderr"
<> showDefault
<> 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"
<> metavar "FILENAME"
<> help "Output file (relative to --output_dir), daemon stdout"
<> showDefault
<> value daemon_out
)
daemon_err <- strOption
( long "daemon_err"
<> metavar "FILENAME"
<> help "Output file (relative to --output_dir), daemon stderr"
<> showDefault
<> value daemon_err
)
nrm_log <- strOption
( long "nrm_log"
<> metavar "FILENAME"
<> help "Output file (relative to --output_dir), daemon log"
<> showDefault
<> value nrm_log
)
messageDaemonOut <- optional $ strOption
( long "message_daemon_stdout"
<> metavar "STRING"
<> help
"The appearance of this character string in the daemon 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 messageDaemonOut
)
messageDaemonErr <- optional $ strOption
( long "message_daemon_stderr"
<> metavar "STRING"
<> help
"The appearance of this character string in the daemon stdout \
\ will be monitored during execution. When observed, the \
\ stack will be killed and a return code of 0 will be returned."
daemon <- behaviorOption
( long "daemon"
<> metavar "BEHAVIOR"
<> help "`daemon` behavior"
<> showDefault
<> maybe mempty value messageDaemonErr
<> value daemon
)
messageCmdRunOut <- optional $ strOption
( long "message_cmd_run_stdout"
<> metavar "STRING"
<> help
"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."
cmdrun <- behaviorOption
( long "cmd_run"
<> metavar "BEHAVIOR"
<> help "`cmd run` behavior"
<> showDefault
<> maybe mempty value messageCmdRunOut
<> value cmdrun
)
messageCmdRunErr <- optional $ strOption
( long "message_cmd_run_stderr"
<> metavar "STRING"
<> help
"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."
cmdlisten <- behaviorOption
( long "cmd_listen"
<> metavar "BEHAVIOR"
<> help "`cmd listen` behavior"
<> showDefault
<> maybe mempty value messageCmdRunErr
<> value cmdlisten
)
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."
cmdlistenprogress <- behaviorOption
( long "cmd_listen_progress"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter progress` behavior"
<> showDefault
<> maybe mempty value messageCmdListenOut
<> value cmdlistenprogress
)
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."
cmdlistenpower <- behaviorOption
( long "cmd_listen_power"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter power` behavior"
<> showDefault
<> maybe mempty value messageCmdListenErr
<> value cmdlistenpower
)
pure StackArgs {..}
argo/src/Argo/Stack.hs
View file @ a0c7e701
{-# LANGUAGE
TupleSections,
ScopedTypeVariables,
LambdaCase,
RecordWildCards,
......@@ -43,43 +44,17 @@ import Data.ByteString.Char8 as C8
import Control.Exception.Base
import Data.Maybe
import Control.Foldl as Fold
import Text.Show.Pretty
{-cleanLeftoverProcesses :: Shell ()-}
{-cleanLeftoverProcesses = do-}
{-printInfo "Cleaning leftover processes.\n"-}
{-daemon <- myWhich "daemon"-}
{-verboseShell (format ("pkill " % fp) daemon) empty-}
{-cmd <- myWhich "cmd"-}
{-void $ verboseShell (format ("pkill " % fp) cmd) empty-}
{-daemon_wrapped <- myWhichMaybe ".daemon-wrapped"-}
{-E.whenJust daemon_wrapped-}
{-(\x -> void $ verboseShell "pkill .daemon-wrapped" empty)-}
{-cmd_wrapped <- myWhichMaybe ".cmd-wrapped"-}
{-void $ E.whenJust cmd_wrapped-}
{-(\x -> void $ verboseShell "pkill .cmd-wrapped" empty)-}
cleanLeftovers :: StackArgs -> Shell ()
cleanLeftovers StackArgs {..} = do
{-cleanLeftoverProcesses-}
printInfo "Cleaning leftover files.\n"
CM.mapM_
cleanLog
[ workingDirectory </> daemon_out
, workingDirectory </> daemon_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"
]
printInfo "Cleaning leftover sockets.\n"
cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do
printInfo "Cleaning working(output) directory.\n"
cleanLog wd
printInfo "Cleaning sockets.\n"
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
checkFsAttributes :: StackArgs -> Shell ()
checkFsAttributes StackArgs {..} = do
checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
let x = case toText workingDirectory of
Left x -> x
Right x -> x
......@@ -89,11 +64,9 @@ checkFsAttributes StackArgs {..} = do
("The output directory, " % fp % ", must not mounted with \"nosuid\"")
workingDirectory
prepareDaemon :: StackArgs -> Shell Instrumentation
prepareDaemon sa@StackArgs {..} = do
mktree workingDirectory
checkFsAttributes sa
cd workingDirectory
prepareDaemon
:: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
prepareDaemon (StdOutLog out) (StdErrLog err) test = do
myWhich "daemon"
confPath <- myWhich "argo_nodeos_config"
let confPath' = "./argo_nodeos_config"
......@@ -109,13 +82,10 @@ prepareDaemon sa@StackArgs {..} = do
ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
cleanContainers confPath' 1 2
export "ARGO_NODEOS_CONFIG" (format fp confPath')
return $ Instrumentation
{ process = P.proc "daemon" ["--nrm_log", encodeString nrm_log]
, stdOutFile = daemon_out
, stdErrFile = daemon_err
, messageOut = messageDaemonOut
, messageErr = messageDaemonErr
}
return $ Instrumentation (P.proc "daemon" [])
(StdOutLog out)
(StdErrLog err)
test
where
nodeOsFailure (ExitFailure n, _, _) = do
printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n")
......@@ -164,97 +134,104 @@ prepareDaemon sa@StackArgs {..} = do
else
printInfo
"argo_nodeos_config successfully cleaned the container \
\config."
prepareCmdRun :: StackArgs -> Instrumentation
prepareCmdRun StackArgs {..} = Instrumentation
{ process = P.proc "cmd"
$ [ "run"
, "-u"
, T.unpack containerName
, encodeString $ manifestDir </> manifestName
, T.unpack app
]
++ fmap T.unpack args
, 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
iDaemon <- prepareDaemon a
let iRun = prepareCmdRun 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) $ \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
\config.\n"
cmdRunI
:: AppName
-> AppArgs
-> ContainerName
-> ManifestDir
-> ManifestName
-> ProcessBehavior
-> Maybe (StackI, Instrumentation)
cmdRunI (AppName app) (AppArgs args) (ContainerName cn) (ManifestDir md) (ManifestName mn) pb
= Just (Run, )
<*> processBehaviorToI
( P.proc "cmd"
$ ["run", "-u", T.unpack cn, encodeString $ md </> mn, T.unpack app]
++ fmap T.unpack args
)
pb
cmdListenI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenI (ContainerName cn) pb =
Just (Listen, )
<*> processBehaviorToI (P.proc "cmd" ["listen", "-u", T.unpack cn]) pb
cmdListenProgressI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenProgressI (ContainerName cn) pb =
Just (Progress, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
pb
cmdListenPowerI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPowerI (ContainerName cn) pb =
Just (Power, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
pb
data StackOutput =
FoundMessage
| Died StackI ExitCode
data StackI = Daemon | Run | Listen | Progress | Power deriving (Show)
runStack :: StackArgs -> Shell StackOutput
runStack a@StackArgs {..} = do
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
let (WorkingDirectory wd) = workingDirectory
Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty
mktree wd
checkFsAttributes wd
cd wd
iDaemon <- case daemon of
DontRun -> return Nothing
JustRun out err ->
(\x -> Just (Daemon, x)) <$> prepareDaemon out err Nothing
SucceedTestOnMessage t out err ->
(\x -> Just (Daemon, x)) <$> prepareDaemon out err (Just t)
let milist =
[ iDaemon
, cmdRunI app args containerName manifestDir manifestName cmdrun
, cmdListenI containerName cmdlisten
, cmdListenProgressI containerName cmdlistenprogress
, cmdListenPowerI containerName cmdlistenpower
]
ilist = catMaybes milist
if verbosity == Verbose
then do
printInfo "Starting the following processes:\n"
liftIO $ pPrint ilist
else liftIO $ pPrint (fmap fst ilist)
asyncs <- liftIO $ mapM tupleToAsync ilist
liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
when (verbosity == Verbose) $ printInfo "Processes started.\n"
out <- liftIO $ waitAnyCancel asyncs
printInfo
( "Processes cancelled due to termination of: "
<> repr (fst $ snd out)
<> " with exit information: "
<> repr (snd $ snd out)
<> "\n"
)
return $ case snd out of
(_ , Left PatternMatched) -> FoundMessage
(stacki, Right (e, _, _) ) -> Died stacki 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)
tupleToAsync
:: (StackI, Instrumentation)
-> IO (Async (StackI, Either PatternMatched (ExitCode, (), ())))
tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum
argo/src/Argo/Utils.hs
View file @ a0c7e701
......@@ -3,6 +3,7 @@
module Argo.Utils where
import Argo.Args
import Turtle
import Prelude hiding ( FilePath )
import System.Console.ANSI
......@@ -37,7 +38,7 @@ printCommand = printf ("Running: " % s % "\n")
printWarning = colorShell Yellow . printf ("Warning: " % s)
printError = colorShell Red . printf ("Error: " % s)
printSuccess = colorShell Green . printf ("Success: " % s)
printTest =