Commit 50ffa445 authored by Valentin Reis's avatar Valentin Reis
Browse files

Making the refactor work.

parent be0e5b41
Pipeline #4861 passed with stage
in 42 seconds
...@@ -47,9 +47,9 @@ import Control.Foldl as Fold ...@@ -47,9 +47,9 @@ import Control.Foldl as Fold
cleanLeftovers :: WorkingDirectory -> Shell () cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do cleanLeftovers (WorkingDirectory wd) = do
printInfo "Cleaning leftover files.\n" printInfo "Cleaning working(output) directory.\n"
cleanLog wd cleanLog wd
printInfo "Cleaning leftover sockets.\n" printInfo "Cleaning sockets.\n"
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"] CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
checkFsAttributes :: FilePath -> Shell () checkFsAttributes :: FilePath -> Shell ()
...@@ -64,15 +64,8 @@ checkFsAttributes workingDirectory = do ...@@ -64,15 +64,8 @@ checkFsAttributes workingDirectory = do
workingDirectory workingDirectory
prepareDaemon prepareDaemon
:: StdOutLog :: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
-> StdErrLog prepareDaemon (StdOutLog out) (StdErrLog err) test = do
-> Maybe TestText
-> WorkingDirectory
-> Shell Instrumentation
prepareDaemon (StdOutLog out) (StdErrLog err) test (WorkingDirectory wd) = do
mktree wd
checkFsAttributes wd
cd wd
myWhich "daemon" myWhich "daemon"
confPath <- myWhich "argo_nodeos_config" confPath <- myWhich "argo_nodeos_config"
let confPath' = "./argo_nodeos_config" let confPath' = "./argo_nodeos_config"
...@@ -188,18 +181,21 @@ data StackOutput = ...@@ -188,18 +181,21 @@ data StackOutput =
data StackI = Daemon | Run | Listen | Progress | Power deriving (Show) data StackI = Daemon | Run | Listen | Progress | Power deriving (Show)
runListenStack :: StackArgs -> Shell StackOutput runStack :: StackArgs -> Shell StackOutput
runListenStack a@StackArgs {..} = do runStack a@StackArgs {..} = do
cleanLeftovers workingDirectory 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 iDaemon <- case daemon of
DontRun -> return Nothing DontRun -> return Nothing
JustRun out err -> JustRun out err ->
(\x -> Just (Daemon, x)) (\x -> Just (Daemon, x)) <$> prepareDaemon out err Nothing
<$> prepareDaemon out err Nothing workingDirectory
SucceedTestOnMessage t out err -> SucceedTestOnMessage t out err ->
(\x -> Just (Daemon, x)) (\x -> Just (Daemon, x)) <$> prepareDaemon out err (Just t)
<$> prepareDaemon out err (Just t) workingDirectory
let milist = let milist =
[ iDaemon [ iDaemon
...@@ -221,4 +217,4 @@ runListenStack a@StackArgs {..} = do ...@@ -221,4 +217,4 @@ runListenStack a@StackArgs {..} = do
tupleToAsync tupleToAsync
:: (StackI, Instrumentation) :: (StackI, Instrumentation)
-> IO (Async (StackI, Either PatternMatched (ExitCode, (), ()))) -> IO (Async (StackI, Either PatternMatched (ExitCode, (), ())))
tupleToAsync (stacki, instrum) = async $ (stacki,) <$> runI instrum tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum
...@@ -83,12 +83,11 @@ verboseShell' command input = ...@@ -83,12 +83,11 @@ verboseShell' command input =
printCommand command >> shellStrictWithErr command input printCommand command >> shellStrictWithErr command input
cleanSocket = sudoRemoveFile printError "socket" cleanSocket = sudoRemoveFile printError "socket"
cleanLog = sudoRemoveFile printWarning "log file" cleanLog = sudoRemoveFile printWarning "log folder"
kbInstallHandler :: IO () -> IO Handler kbInstallHandler :: IO () -> IO Handler
kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing
data PatternMatched = PatternMatched deriving (Show, Typeable) data PatternMatched = PatternMatched deriving (Show, Typeable)
instance Exception PatternMatched instance Exception PatternMatched
...@@ -125,7 +124,6 @@ runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try ...@@ -125,7 +124,6 @@ runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try
untilMatch message untilMatch message
_ -> return () _ -> return ()
processBehaviorToI :: CreateProcess -> ProcessBehavior -> Maybe Instrumentation processBehaviorToI :: CreateProcess -> ProcessBehavior -> Maybe Instrumentation
processBehaviorToI cp = \case processBehaviorToI cp = \case
DontRun -> Nothing DontRun -> Nothing
......
...@@ -17,12 +17,8 @@ opts :: StackArgs -> Parser (Shell ()) ...@@ -17,12 +17,8 @@ opts :: StackArgs -> Parser (Shell ())
opts sa = hsubparser opts sa = hsubparser
( command "clean" ( command "clean"
(info (pure $ clean sa) (progDesc "Clean sockets, logfiles.")) (info (pure $ clean sa) (progDesc "Clean sockets, logfiles."))
<> command
"full-stack"
(info (fullStack <$> parseExtendStackArgs sa)
(progDesc "Setup stack and run a command in a container.")
)
<> commandTest DaemonOnly <> commandTest DaemonOnly
<> commandTest DaemonAndApp
<> commandTest TestHello <> commandTest TestHello
<> commandTest TestListen <> commandTest TestListen
<> commandTest TestPerfwrapper <> commandTest TestPerfwrapper
...@@ -39,12 +35,12 @@ opts sa = hsubparser ...@@ -39,12 +35,12 @@ opts sa = hsubparser
action ttype = doOverridenTest ttype action ttype = doOverridenTest ttype
<$> parseExtendStackArgs ((stackArgsUpdate $ configureTest ttype) sa) <$> parseExtendStackArgs ((stackArgsUpdate $ configureTest ttype) sa)
descTest ttype = "test" ++ description (configureTest ttype) descTest ttype = "test" ++ description (configureTest ttype)
commandTest ttype = command (show ttype) commandTest ttype =
$ info (action ttype) (progDesc $ descTest ttype) command (show ttype) $ info (action ttype) (progDesc $ descTest ttype)
commandTests ttypes cmdStr descStr = commandTests ttypes cmdStr descStr =
command cmdStr $ info (pure $ mapM_ (doTest sa) ttypes) (progDesc descStr) command cmdStr $ info (pure $ mapM_ (doTest sa) ttypes) (progDesc descStr)
data TestType = DaemonOnly | DaemonApp | TestHello | TestListen | TestPerfwrapper | TestPower deriving Show data TestType = DaemonOnly | DaemonAndApp | TestHello | TestListen | TestPerfwrapper | TestPower deriving Show
data TestSpec = TestSpec data TestSpec = TestSpec
{ stackArgsUpdate :: StackArgs -> StackArgs { stackArgsUpdate :: StackArgs -> StackArgs
...@@ -64,14 +60,13 @@ doSpec spec stackArgs = do ...@@ -64,14 +60,13 @@ doSpec spec stackArgs = do
fullStack stackArgs fullStack stackArgs
printSuccess "Test Successful." printSuccess "Test Successful."
configureTest :: TestType -> TestSpec configureTest :: TestType -> TestSpec
configureTest = \case configureTest = \case
DaemonOnly -> TestSpec DaemonOnly -> TestSpec
{ stackArgsUpdate = \sa -> sa { daemon = daemonBehavior } { stackArgsUpdate = \sa -> sa { daemon = daemonBehavior }
, description = "Set up and launch the daemon in synchronous mode." , description = "Set up and launch the daemon in synchronous mode."
} }
DaemonApp -> TestSpec DaemonAndApp -> TestSpec
{ stackArgsUpdate = \sa -> { stackArgsUpdate = \sa ->
sa { daemon = daemonBehavior, cmdrun = runBehavior } sa { daemon = daemonBehavior, cmdrun = runBehavior }
, description = "Set up and start daemon, run a command in a container." , description = "Set up and start daemon, run a command in a container."
...@@ -80,8 +75,8 @@ configureTest = \case ...@@ -80,8 +75,8 @@ configureTest = \case
{ stackArgsUpdate = \sa -> sa { stackArgsUpdate = \sa -> sa
{ app = AppName "echo" { app = AppName "echo"
, args = AppArgs [msg] , args = AppArgs [msg]
, cmdlisten = SucceedTestOnMessage , daemon = daemonBehavior
(TestText msg) , cmdrun = SucceedTestOnMessage (TestText msg)
(StdOutLog "monitored-cmdrun-out.log") (StdOutLog "monitored-cmdrun-out.log")
(StdErrLog "monitored-cmdrun-err.log") (StdErrLog "monitored-cmdrun-err.log")
} }
...@@ -92,6 +87,8 @@ configureTest = \case ...@@ -92,6 +87,8 @@ configureTest = \case
{ stackArgsUpdate = \sa -> sa { stackArgsUpdate = \sa -> sa
{ app = AppName "sleep" { app = AppName "sleep"
, args = AppArgs ["15"] , args = AppArgs ["15"]
, daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlisten = listentestBehavior (TestText "pub message") , cmdlisten = listentestBehavior (TestText "pub message")
} }
, description = "2: Setup stack and check that argo-perf-wrapper sends\ , description = "2: Setup stack and check that argo-perf-wrapper sends\
...@@ -102,7 +99,9 @@ configureTest = \case ...@@ -102,7 +99,9 @@ configureTest = \case
{ manifestName = "perfwrap.json" { manifestName = "perfwrap.json"
, app = AppName "sleep" , app = AppName "sleep"
, args = AppArgs ["15"] , args = AppArgs ["15"]
, cmdlisten = listentestBehavior (TestText "progress") , daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlisten = listentestBehavior (TestText "performance")
} }
, description = "3: Setup stack and check that argo-perf-wrapper sends\ , description = "3: Setup stack and check that argo-perf-wrapper sends\
\ at least one *performance* message to cmd listen through the\ \ at least one *performance* message to cmd listen through the\
...@@ -112,6 +111,8 @@ configureTest = \case ...@@ -112,6 +111,8 @@ configureTest = \case
{ stackArgsUpdate = \sa -> sa { stackArgsUpdate = \sa -> sa
{ app = AppName "sleep" { app = AppName "sleep"
, args = AppArgs ["15"] , args = AppArgs ["15"]
, daemon = daemonBehavior
, cmdrun = runBehavior
, cmdlisten = listentestBehavior (TestText "power") , cmdlisten = listentestBehavior (TestText "power")
} }
, description = "4: Setup stack and check that argo-perf-wrapper sends\ , description = "4: Setup stack and check that argo-perf-wrapper sends\
...@@ -120,17 +121,15 @@ configureTest = \case ...@@ -120,17 +121,15 @@ configureTest = \case
} }
where where
msg = "someComplicatedMessage" msg = "someComplicatedMessage"
daemonBehavior = daemonBehavior = JustRun (StdOutLog "daemon_out.log") (StdErrLog "daemon_err.log")
JustRun (StdOutLog "daemon_out.log") (StdErrLog "daemon_err.log") runBehavior = JustRun (StdOutLog "cmd_run_out.log") (StdErrLog "cmd_run_err.log")
runBehavior =
JustRun (StdOutLog "cmd_run_out.log") (StdErrLog "cmd_run_err.log")
listentestBehavior t = SucceedTestOnMessage listentestBehavior t = SucceedTestOnMessage
t t
(StdOutLog "cmd_listen_out.log") (StdOutLog "cmd_listen_out.log")
(StdErrLog "cmd_listen_err.log") (StdErrLog "cmd_listen_err.log")
fullStack :: StackArgs -> Shell () fullStack :: StackArgs -> Shell ()
fullStack a@StackArgs {..} = runListenStack a >>= \case fullStack a@StackArgs {..} = runStack a >>= \case
FoundMessage -> printSuccess "Found message!\n" FoundMessage -> printSuccess "Found message!\n"
MessageNotFound -> printError "Message not found.\n" >> exit (ExitFailure 1) MessageNotFound -> printError "Message not found.\n" >> exit (ExitFailure 1)
Died stacki ExitSuccess -> Died stacki ExitSuccess ->
......
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