Commit f440c7a5 authored by Valentin Reis's avatar Valentin Reis

Merge branch 'refactor-powerexpe'

parents 53721368 489a6b98
Pipeline #4993 failed with stage
in 1 minute
......@@ -12,6 +12,21 @@ 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, pretty-show
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, unliftio-core
hs-source-dirs: src
default-language: Haskell2010
ghc-options:
-Wall
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-Wmissing-export-li
-fwarn-tabs
-fwarn-unused-imports
-fwarn-missing-signatures
-fwarn-name-shadowing
-fwarn-incomplete-patternssts
-fprint-potential-instances
{-|
Module : Argo
Description : The holt core package
Copyright : (c) Valentin Reis, 2018
License : MIT
Maintainer : fre@freux.fr
-}
module Argo
( module Argo.Stack
( module Argo.Args
, module Argo.Args
, module Argo.Utils
)
where
......
......@@ -11,14 +11,12 @@ import Data.Text as T
import Turtle hiding ( option )
import Prelude hiding ( FilePath )
import System.Process hiding ( shell )
data OutputFiles = OutputFiles FilePath FilePath
data StackArgs = StackArgs
{ verbosity :: Verbosity
, app :: AppName
, args :: AppArgs
, args :: [AppArg]
, containerName :: ContainerName
, workingDirectory :: WorkingDirectory
, manifestDir :: ManifestDir
......@@ -27,11 +25,13 @@ data StackArgs = StackArgs
, cmdrun :: ProcessBehavior
, cmdlisten :: ProcessBehavior
, cmdlistenprogress :: ProcessBehavior
, cmdlistenperformance :: ProcessBehavior
, cmdlistenpower :: ProcessBehavior
}
} deriving (Show)
{-data OutputFiles = OutputFiles FilePath FilePath-}
data Verbosity = Normal | Verbose deriving (Show,Read,Eq)
newtype AppArgs = AppArgs [Text] deriving (Show, Read)
newtype AppArg = AppArg Text deriving (IsString, 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)
......@@ -56,7 +56,7 @@ instance Default StackArgs where
def = StackArgs
{ verbosity = Normal
, app = AppName "ls"
, args = AppArgs []
, args = []
, containerName = ContainerName "testContainer"
, workingDirectory = WorkingDirectory "_output"
, manifestDir = ManifestDir "manifests"
......@@ -65,83 +65,93 @@ instance Default StackArgs where
, cmdrun = DontRun
, cmdlisten = DontRun
, cmdlistenprogress = DontRun
, cmdlistenperformance = DontRun
, cmdlistenpower = DontRun
}
parseExtendStackArgs :: StackArgs -> Parser StackArgs
parseExtendStackArgs StackArgs {..} = do
parseExtendStackArgs sa = do
verbosity <- flag
Normal
Verbose
(long "verbose" <> short 'v' <> help "Enable verbose mode")
app <- strOption
( long "application"
( long "app"
<> metavar "APP"
<> help "Target application executable name. PATH is inherited."
<> showDefault
<> value app
<> value (app sa)
)
containerName <- strOption
( long "container_name"
<> metavar "ARGO_CONTAINER_UUID"
<> help "Container name"
<> showDefault
<> value containerName
<> value (containerName sa)
)
workingDirectory <- strOption
( long "output_dir"
<> metavar "DIR"
<> help "Working directory."
<> showDefault
<> value workingDirectory
<> value (workingDirectory sa)
)
manifestDir <- strOption
( long "manifest_directory"
<> metavar "DIR"
<> help "Manifest lookup directory"
<> showDefault
<> value manifestDir
<> value (manifestDir sa)
)
manifestName <- strOption
( long "manifest_name"
<> metavar "FILENAME"
<> help "Manifest file basename (relative to --manifest_directory)"
<> showDefault
<> value manifestName
<> value (manifestName sa)
)
daemon <- behaviorOption
( long "daemon"
<> metavar "BEHAVIOR"
<> help "`daemon` behavior"
<> showDefault
<> value daemon
<> value (daemon sa)
)
cmdrun <- behaviorOption
( long "cmd_run"
<> metavar "BEHAVIOR"
<> help "`cmd run` behavior"
<> showDefault
<> value cmdrun
<> value (cmdrun sa)
)
cmdlisten <- behaviorOption
( long "cmd_listen"
<> metavar "BEHAVIOR"
<> help "`cmd listen` behavior"
<> showDefault
<> value cmdlisten
<> value (cmdlisten sa)
)
cmdlistenperformance <- behaviorOption
( long "cmd_listen_performance"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter performance` behavior"
<> showDefault
<> value (cmdlistenperformance sa)
)
cmdlistenprogress <- behaviorOption
( long "cmd_listen_progress"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter progress` behavior"
<> showDefault
<> value cmdlistenprogress
<> value (cmdlistenprogress sa)
)
cmdlistenpower <- behaviorOption
( long "cmd_listen_power"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter power` behavior"
<> showDefault
<> value cmdlistenpower
<> value (cmdlistenpower sa)
)
args <- some (argument str (metavar "ARGS" <> help "Application arguments."))
<|> pure (args sa)
pure StackArgs {..}
......@@ -16,49 +16,33 @@ import Turtle
import Turtle.Shell
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
hiding ( empty )
import Data.Text.IO as Text
import Argo.Utils
import System.Process as P
hiding ( shell )
import Options.Applicative as OA
import Control.Monad.Extra as E
import Control.Monad as CM
import Control.Foldl as F
import Data.Conduit
import Data.Conduit.Process
import Data.ByteString.Char8 as C8
hiding ( empty )
import Control.Exception.Base
import Data.Maybe
import Control.Foldl as Fold
import Text.Show.Pretty
cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do
printInfo "Cleaning working(output) directory.\n"
printInfo "Cleaning working(output) directory."
cleanLog wd
printInfo "Cleaning sockets.\n"
printInfo "Cleaning sockets."
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
let x = case toText workingDirectory of
Left x -> x
Right x -> x
let findmnt = inproc "findmnt" ["-T", x, "-o", "OPTIONS"] empty
let dir = case toText workingDirectory of
Left di -> di
Right di -> di
let findmnt = inproc "findmnt" ["-T", dir, "-o", "OPTIONS"] empty
b <- liftIO $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Fold.length
when (b > 0) $ dieRed $ format
("The output directory, " % fp % ", must not mounted with \"nosuid\"")
......@@ -66,63 +50,57 @@ checkFsAttributes workingDirectory = do
prepareDaemon
:: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
prepareDaemon (StdOutLog out) (StdErrLog err) test = do
myWhich "daemon"
prepareDaemon out stdErr test = do
_ <- myWhich "daemon"
confPath <- myWhich "argo_nodeos_config"
let confPath' = "./argo_nodeos_config"
cp confPath confPath'
printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
printInfo $ format ("Copied the configurator to " % fp ) confPath'
printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config"
verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root."
ExitFailure n ->
die ("Failed to set argo_nodeos_config permissions " <> repr n)
verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
ExitSuccess -> printInfo "Set the suid bit.\n"
ExitSuccess -> printInfo "Set the suid bit."
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 (P.proc "daemon" [])
(StdOutLog out)
(StdErrLog err)
test
return $ Instrumentation (P.proc "daemon" []) out stdErr test
where
nodeOsFailure (ExitFailure n, _, _) = do
printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n")
nodeOsFailure n = do
printError ("argo_nodeos_config failed with exit code :" <> repr n )
testfile ".argo_nodeos_config_exit_message" >>= \case
True -> do
printInfo "Contents of .argo_nodeos_config_exit_message: \n"
printInfo "Contents of .argo_nodeos_config_exit_message: "
view $ input ".argo_nodeos_config_exit_message"
False -> die ("argo_nodeos_config failed with exit code " <> repr n)
cleanContainers :: FilePath -> NominalDiffTime -> Integer -> Shell ()
cleanContainers argo_nodeos_config retryTime remainingRetries = do
let
showConfig =
inshell (format (fp % " --show_config") argo_nodeos_config) empty
(isClean :: IO Bool) =
liftIO
(Turtle.Shell.fold (grep (has "CONTAINER") showConfig) Fold.length)
>>= (\x -> return $ x > 5)
verboseShell'
(format (fp % " --clean_config=kill_content:true") argo_nodeos_config)
empty
>>= \case
e@(ExitFailure n, out, err) -> do
when (remainingRetries == 0) $ nodeOsFailure e
(ExitFailure n, _, _) -> do
when (remainingRetries == 0) $ nodeOsFailure n
printWarning
( "the argo_nodeos_config call failed with exit code "
<> repr n
<> ". Retrying..\n"
<> ". Retrying.."
)
liftIO $ sleep (retryTime * 2)
cleanContainers argo_nodeos_config
(retryTime * 2)
(remainingRetries - 1)
(ExitSuccess, _, _) -> do
printInfo "Cleaned the argo config.\n"
l <- liftIO $ Turtle.Shell.fold
printInfo "Cleaned the argo config."
len <- liftIO $ Turtle.Shell.fold
(grep (has "CONTAINER") showConfig)
Fold.length
if l > 0
if len > 0
then do
printWarning
"the argo_nodeos_config call did not remove containers, \
......@@ -134,24 +112,25 @@ prepareDaemon (StdOutLog out) (StdErrLog err) test = do
else
printInfo
"argo_nodeos_config successfully cleaned the container \
\config.\n"
\config."
cmdRunI
:: AppName
-> AppArgs
-> [AppArg]
-> ContainerName
-> ManifestDir
-> ManifestName
-> ProcessBehavior
-> Maybe (StackI, Instrumentation)
cmdRunI (AppName app) (AppArgs args) (ContainerName cn) (ManifestDir md) (ManifestName mn) pb
cmdRunI (AppName app) 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
++ fmap (T.unpack . argToText) args
)
pb
where argToText (AppArg a) = a
cmdListenI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
......@@ -167,6 +146,15 @@ cmdListenProgressI (ContainerName cn) pb =
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
pb
cmdListenPerformanceI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPerformanceI (ContainerName cn) pb =
Just (Performance, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"]
)
pb
cmdListenPowerI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPowerI (ContainerName cn) pb =
......@@ -179,28 +167,36 @@ data StackOutput =
FoundMessage
| Died StackI ExitCode
data StackI = Daemon | Run | Listen | Progress | Power deriving (Show)
data StackI = Daemon | Run | Listen | Progress | Power | Performance deriving (Show)
runStack :: StackArgs -> Shell StackOutput
runStack a@StackArgs {..} = do
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in", "/tmp/nrm-upstream-event"]
runStack sa@StackArgs {..} = do
when (verbosity == Verbose) $ liftIO $ pPrint sa
CM.mapM_
cleanSocket
[ "/tmp/nrm-downstream-in"
, "/tmp/nrm-upstream-in"
, "/tmp/nrm-upstream-event"
]
let (WorkingDirectory wd) = workingDirectory
Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty
_ <- 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)
JustRun stdOut stdErr ->
(\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing
SucceedTestOnMessage t stdOut stdErr ->
(\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t)
let milist =
[ iDaemon
, cmdRunI app args containerName manifestDir manifestName cmdrun
, cmdListenI containerName cmdlisten
, cmdListenPerformanceI containerName cmdlistenperformance
, cmdListenProgressI containerName cmdlistenprogress
, cmdListenPowerI containerName cmdlistenpower
]
......@@ -208,14 +204,14 @@ runStack a@StackArgs {..} = do
if verbosity == Verbose
then do
printInfo "Starting the following processes:\n"
printInfo "Starting the following processes:"
liftIO $ pPrint ilist
else liftIO $ pPrint (fmap fst ilist)
asyncs <- liftIO $ mapM tupleToAsync ilist
liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
_ <- liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
when (verbosity == Verbose) $ printInfo "Processes started.\n"
when (verbosity == Verbose) $ printInfo "Processes started."
out <- liftIO $ waitAnyCancel asyncs
......@@ -224,14 +220,13 @@ runStack a@StackArgs {..} = do
<> repr (fst $ snd out)
<> " with exit information: "
<> repr (snd $ snd out)
<> "\n"
)
cd "../"
return $ case snd out of
(_ , Left PatternMatched) -> FoundMessage
(stacki, Right (e, _, _) ) -> Died stacki e
(stacki, Right (errmsg, _, _) ) -> Died stacki errmsg
where
tupleToAsync
:: (StackI, Instrumentation)
......
{-# LANGUAGE LambdaCase, OverloadedStrings, DataKinds,
FlexibleInstances, TypeOperators, RecordWildCards #-}
FlexibleInstances, ScopedTypeVariables, TypeOperators #-}
module Argo.Utils where
......@@ -14,15 +14,24 @@ import Data.Conduit
import Data.Conduit.Process hiding ( shell )
import Data.ByteString as B
hiding ( empty )
import System.IO ( BufferMode(NoBuffering)
, hSetBuffering
)
import Control.Monad.IO.Unlift ( MonadIO(..)
, MonadUnliftIO
, withRunInIO
)
import Data.Text.Encoding as TE
import Data.Conduit.Combinators as CC
import Control.Exception.Base
import Data.Typeable
import Data.Text as T
import qualified System.IO as IO
-- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell ()
colorShell color s = setC color *> s *> setC White
colorShell color she = setC color *> she *> setC White
where setC c = liftIO $ setSGR [SetColor Foreground Dull c]
printInfo :: Text -> Shell ()
......@@ -33,22 +42,24 @@ printSuccess :: Text -> Shell ()
printTest :: Text -> Shell ()
dieRed :: Text -> Shell ()
printInfo = printf ("Info: " % s)
printInfo = printf ("Info: " % s% "\n")
printCommand = printf ("Running: " % s % "\n")
printWarning = colorShell Yellow . printf ("Warning: " % s)
printError = colorShell Red . printf ("Error: " % s)
printSuccess = colorShell Green . printf ("Success: " % s)
printWarning = colorShell Yellow . printf ("Warning: " % s% "\n")
printError = colorShell Red . printf ("Error: " % s% "\n")
printSuccess = colorShell Green . printf ("Success: " % s% "\n")
printTest = colorShell Green . printf ("RUNNING TEST: " % s % "\n")
dieRed str =
colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1)
myWhich :: FilePath -> Shell FilePath
myWhich str = which str >>= \case
(Just p) ->
printInfo (format ("Found " % fp % " at " % fp % "\n") str p) >> return p
printInfo (format ("Found " % fp % " at " % fp) str p) >> return p
Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str
myWhichMaybe :: FilePath -> Shell (Maybe FilePath)
myWhichMaybe str = which str >>= \case
(Just p) -> printInfo (format ("Found " % fp % " at " % fp % "\n") str p)
(Just p) -> printInfo (format ("Found " % fp % " at " % fp) str p)
>> return (Just p)
Nothing -> return Nothing
......@@ -56,7 +67,7 @@ sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell ()
sudoRemoveFile printer desc filePath = do
foundSocket <- testfile filePath
when foundSocket $ go False
printInfo $ format ("OK: " % s % " " % fp % "\n") desc filePath
printInfo $ format ("OK: " % s % " " % fp) desc filePath
where
go useSudo = do
printer $ format ("found stale " % s % " at " % fp % ".. ") desc filePath
......@@ -65,7 +76,7 @@ sudoRemoveFile printer desc filePath = do
Turtle.empty
>>= \case
ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
ExitFailure n -> if useSudo
ExitFailure _ -> if useSudo
then printer $ format
("Failed to remove stale " % s % ", even with sudo.")
desc
......@@ -76,13 +87,14 @@ sudoRemoveFile printer desc filePath = do
go True
verboseShell :: Text -> Shell Line -> Shell ExitCode
verboseShell command input = printCommand command >> shell command input
verboseShell command i = printCommand command >> shell command i
verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text)
verboseShell' command input =
printCommand command >> shellStrictWithErr command input
verboseShell' command i = printCommand command >> shellStrictWithErr command i
cleanSocket :: FilePath -> Shell ()
cleanSocket = sudoRemoveFile printError "socket"
cleanLog :: FilePath -> Shell ()
cleanLog = sudoRemoveFile printWarning "log folder"
kbInstallHandler :: IO () -> IO Handler
......@@ -99,17 +111,16 @@ data Instrumentation = Instrumentation
deriving (Show)
runI :: Instrumentation -> IO (Either PatternMatched (ExitCode, (), ()))
runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try
(reroutedDaemon cp)
runI (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = try
(reroutedDaemon crProc)
where
reroutedDaemon process =
withSinkFile (T.unpack out)
$ \outSink ->
withSinkFile (T.unpack err) $ \errSink -> sourceProcessWithStreams
process
mempty
(makeMatcher t .| outSink)
(makeMatcher t .| errSink)
withSinkFileNoBuffering (T.unpack stdOut) $ \outSink ->
withSinkFile (T.unpack stdErr) $ \errSink -> sourceProcessWithStreams
process
mempty
(makeMatcher t .| outSink)
(makeMatcher t .| errSink)
makeMatcher maybeMessage = case maybeMessage of
Just (TestText msg) -> untilMatch msg
Nothing -> awaitForever yield
......@@ -124,8 +135,19 @@ runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try
untilMatch message
_ -> return ()
withSinkFileNoBuffering
:: (MonadUnliftIO m, MonadIO n)
=> IO.FilePath
-> (ConduitM ByteString o n () -> m a)
-> m a
withSinkFileNoBuffering filepath inner =
withRunInIO $ \run -> IO.withBinaryFile filepath IO.WriteMode $ \h -> do
hSetBuffering h NoBuffering
run $ inner $ sinkHandle h
processBehaviorToI :: CreateProcess -> ProcessBehavior -> Maybe Instrumentation
processBehaviorToI cp = \case
DontRun -> Nothing
JustRun out err -> Just $ Instrumentation cp out err Nothing
SucceedTestOnMessage t out err -> Just $ Instrumentation cp out err (Just t)
processBehaviorToI crProc = \case
DontRun -> Nothing
JustRun stdOut stdErr -> Just $ Instrumentation crProc stdOut stdErr Nothing
SucceedTestOnMessage t stdOut stdErr ->
Just $ Instrumentation crProc stdOut stdErr (Just t)
......@@ -19,4 +19,18 @@ executable argotk
build-depends: base, shake, argo, turtle, data-default, async, unix, text, optparse-applicative, foldl, ansi-terminal
--hs-source-dirs: src
default-language: Haskell2010
GHC-Options: -Wall
ghc-options:
-Wall
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-Wmissing-export-li
-fwarn-tabs
-fwarn-unused-imports
-fwarn-missing-signatures
-fwarn-name-shadowing
-fwarn-incomplete-patternssts
-fprint-potential-instances
#! /usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase #-}
import Argo.Stack
......@@ -17,8 +16,8 @@ opts :: StackArgs -> Parser (Shell ())
opts sa = hsubparser
( command "clean"
(info (pure $ clean sa) (progDesc "Clean sockets, logfiles."))
<> (mconcat $ fmap commandTest [(minBound :: TestType) ..])
<> commandTests [TestHello, TestListen, TestPerfwrapper]
<> mconcat (fmap commandTest [(minBound :: TestType) ..])
<> commandTests [TestHello, TestListen, TestPerfwrapper, TestSTREAM]
"tests"
"Run hardware-independent CI tests"
<> help
......@@ -42,7 +41,11 @@ data TestType =
| TestHello
| TestListen
| TestPerfwrapper
| TestPower deriving (Enum,Bounded,Show)
| TestPower
| TestAMG
| TestSTREAM
| RunAMG
| RunSTREAM deriving (Enum,Bounded,Show)
data TestSpec = TestSpec
{ stackArgsUpdate :: StackArgs -> StackArgs
......@@ -61,7 +64,7 @@ doSpec :: TestSpec -> StackArgs -> Shell ()
doSpec spec stackArgs = do
printTest $ T.pack $ description spec
fullStack (isTest spec) stackArgs
printSuccess "Test Successful."
printSuccess "Test Successful.\n"
configureTest :: TestType -> TestSpec
configureTest = \case
......@@ -71,26 +74,29 @@ configureTest = \case
, isTest = IsTest False
}
DaemonAndApp -> TestSpec
{ stackArgsUpdate = \sa -> sa
{ daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlistenprogress = JustRun (StdOutLog "progress.csv")
(StdErrLog "progress.log")
, cmdlistenpower = JustRun (StdOutLog "power.csv") (StdErrLog "power.log")
}
{ stackArgsUpdate = \sa ->
sa { daemon = daemonBehavior, cmdrun = runBehavior }
, description = "Set up and start daemon, run a command in a container."
, isTest = IsTest False
}
CsvLogs -> TestSpec
{ stackArgsUpdate = \sa ->
sa { daemon = daemonBehavior, cmdrun = runBehavior }
{ stackArgsUpdate = \sa -> sa
{ manifestName = "perfwrap.json"
, daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlistenperformance = JustRun (StdOutLog "performance.csv")
(StdErrLog "performance.log")
, cmdlistenpower = JustRun (StdOutLog "power.csv") (StdErrLog "power.log")
, cmdlistenprogress = JustRun (StdOutLog "progress.csv")
(StdErrLog "progress.log")
}
, description = "Set up and start daemon, run a command in a container."
, isTest = IsTest False
}
TestHello -> TestSpec
{ stackArgsUpdate = \sa -> sa
{ app = AppName "echo"
, args = AppArgs [msg]
, args = [AppArg msg]
, daemon = daemonBehavior
, cmdrun = SucceedTestOnMessage (TestText msg)
(StdOutLog "monitored-cmdrun-out.log")
......@@ -103,7 +109,7 @@ configureTest = \case
TestListen -> TestSpec
{ stackArgsUpdate = \sa -> sa
{ app = AppName "sleep"
, args = AppArgs ["15"]
, args = [AppArg "15"]
, daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlisten = listentestBehavior (TestText ",")
......@@ -116,10 +122,10 @@ configureTest = \case
{ stackArgsUpdate = \sa -> sa
{ manifestName = "perfwrap.json"
, app = AppName "sleep"
, args = AppArgs ["15"]
, args = [AppArg "15"]
, daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlisten = listentestBehavior (TestText "performance")
, cmdlistenperformance = listenprogresstestBehavior (TestText ",")
}
, description = "3: Setup stack and check that argo-perf-wrapper sends\
\ at least one *performance* message to cmd listen through the\
......@@ -129,7 +135,7 @@ configureTest = \case
TestPower -> TestSpec
{ stackArgsUpdate = \sa -> sa
{ app = AppName "sleep"
, args = AppArgs ["15"]
, args = [AppArg "15"]
, daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlisten = listentestBehavior (TestText "power")
......@@ -139,7 +145,78 @@ configureTest = \case
\ daemon."
, isTest = IsTest True
}
TestAMG -> TestSpec
{ stackArgsUpdate = \sa -> sa