Cleaning perf-wrapper test, adding warning, help messages.

argo/argo.cabal

@@ -11,6 +11,6 @@ cabal-version:       >=1.10
 library
   exposed-Modules:     Argo.Stack
                        Argo.Utils
-  build-depends:       base >=4 && <=8, turtle, data-default, managed, ansi-terminal, unix, system-filepath, async, process, text, optparse-applicative
+  build-depends:       base >=4 && <=8, turtle, data-default, managed, ansi-terminal, unix, system-filepath, async, process, text, optparse-applicative, extra
   hs-source-dirs:      src
   default-language:    Haskell2010

argo/src/Argo/Stack.hs

@@ -26,9 +26,11 @@ import           Argo.Utils
 import           System.Process                as P
                                          hiding ( shell )
 import           Options.Applicative           as OA
+import           Control.Monad.Extra           as E
 
 data StackArgs = StackArgs
   { app                  :: Text
+  , containerName        :: Text
   , workingDirectory     :: FilePath
   , manifestDir          :: FilePath
   , manifestName         :: FilePath
@@ -42,6 +44,7 @@ data StackArgs = StackArgs
 instance Default StackArgs where
   def = StackArgs
     { app = "echo foobar"
+    , containerName = "testContainer"
     , workingDirectory = "_output"
     , manifestDir = "manifests"
     , manifestName = "basic.json"
@@ -57,11 +60,18 @@ parseExtendStackArgs :: StackArgs -> Parser StackArgs
 parseExtendStackArgs StackArgs {..} = do
   app <- strOption
     (  long "application"
-    <> metavar "FILE"
+    <> metavar "APP"
     <> help "Target application call, sh+path valid"
     <> showDefault
     <> value app
     )
+  containerName <- strOption
+    (  long "container_name"
+    <> metavar "ARGO_CONTAINER_UUID"
+    <> help "Container name"
+    <> showDefault
+    <> value containerName
+    )
   workingDirectory <- strOption
     (  long "output"
     <> metavar "FILE"
@@ -127,9 +137,22 @@ parseExtendStackArgs StackArgs {..} = do
     )
   pure StackArgs {..}
 
+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
-  printInfo "Cleaning leftovers..\n"
+  cleanLeftoverProcesses
+  printInfo "Cleaning leftover files.\n"
   mapM_
     cleanLog
     [ workingDirectory </> daemon_out
@@ -141,6 +164,7 @@ cleanLeftovers StackArgs {..} = do
     , workingDirectory </> ".argo_nodeos_config_exit_message"
     , workingDirectory </> "argo_nodeos_config"
     ]
+  printInfo "Cleaning leftover sockets.\n"
   mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
 
 prepareDaemonShell :: StackArgs -> Shell (IO ())
@@ -159,16 +183,17 @@ prepareDaemonShellWithStoppingCriterion waitCondition StackArgs {..} = do
   cp confPath confPath'
   printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
   printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
-  shell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
+  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
     ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
     ExitFailure n ->
       die ("Failed to set argo_nodeos_config permissions " <> repr n)
-  shell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
+  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
     ExitSuccess   -> printInfo "Set the suid bit.\n"
     ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
 
   --Cleaning the config, running the daemon
-  shell (format (fp % " --clean_config=kill_content:true") confPath') empty
+  verboseShell (format (fp % " --clean_config=kill_content:true") confPath')
+               empty
     >>= \case
           ExitSuccess   -> printInfo "Cleaned the argo config.\n"
           ExitFailure n -> do
@@ -200,8 +225,9 @@ prepareDaemonShellWithStoppingCriterion waitCondition StackArgs {..} = do
 -- | See at the bottom of this file for discussion of this function. (1)
 cmdShell :: StackArgs -> Shell ()
 cmdShell StackArgs {..} =
-  shell
-      (format ("cmd run -u toto " % fp % "  " % s % " > " % fp % " 2>" % fp)
+  verboseShell
+      (format ("cmd run -u "%s%" " % fp % "  " % s % " > " % fp % " 2>" % fp)
+              containerName
               (manifestDir </> manifestName)
               app
               cmd_out
@@ -234,9 +260,9 @@ runSimpleStackWithCriterion
   :: (Shell (Either Line Line) -> Shell (Either Line Line))
   -> StackArgs
   -> IO ()
-runSimpleStackWithCriterion stoppingCriterion a@StackArgs {..} = sh $ do
+runSimpleStackWithCriterion stoppingCriteria a@StackArgs {..} = sh $ do
   cleanLeftovers a
-  daemonShell <- prepareDaemonShellWithStoppingCriterion stoppingCriterion a
+  daemonShell <- prepareDaemonShellWithStoppingCriterion stoppingCriteria a
   liftIO $ withAsync daemonShell $ \daemon -> do
     kbInstallHandler $ cancel daemon
     withAsync (time $ sh $ cmdShell a) $ \cmd -> do

argo/src/Argo/Utils.hs

@@ -16,17 +16,30 @@ colorShell color s = setC color *> s *> setC White
   where setC c = liftIO $ setSGR [SetColor Foreground Dull c]
 
 printInfo :: Text -> Shell ()
+printCommand :: Text -> Shell ()
 printError :: Text -> Shell ()
 printWarning :: Text -> Shell ()
-printInfo = printf ("Info:" % s)
-printWarning = colorShell Yellow . printf ("Warning:" % s)
-printError = colorShell Red . printf ("Error:" % s)
+printSuccess :: Text -> Shell ()
+dieRed :: Text -> Shell ()
+
+printInfo = printf ("Info: " % s)
+printCommand = printf ("Running: " % s % "\n")
+printWarning = colorShell Yellow . printf ("Warning: " % s)
+printError = colorShell Red . printf ("Error: " % s)
+printSuccess = colorShell Green . printf ("Success: " % s)
+dieRed str =
+  colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1)
 
 myWhich str = which str >>= \case
   (Just p) ->
     printInfo (format ("Found " % fp % " at " % fp % "\n") str p) >> return p
   Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str
 
+myWhichMaybe str = which str >>= \case
+  (Just p) -> printInfo (format ("Found " % fp % " at " % fp % "\n") str p)
+    >> return (Just p)
+  Nothing -> return Nothing
+
 sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell ()
 sudoRemoveFile printer desc filePath = do
   foundSocket <- testfile filePath
@@ -50,9 +63,11 @@ sudoRemoveFile printer desc filePath = do
                   desc
                 go True
 
+verboseShell :: Text -> Shell Line -> Shell ExitCode
+verboseShell command input = printCommand command >> shell command input
+
 cleanSocket = sudoRemoveFile printError "socket"
 cleanLog = sudoRemoveFile printWarning "log file"
 
 kbInstallHandler :: IO () -> IO Handler
 kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing
-

argotk/argotk.hs

@@ -19,7 +19,12 @@ import           System.Posix.Signals
 import           Control.Monad
 import           Data.Either
 
-helloWorldText = "HelloWorldFromApp"
+messageOption = strOption
+  (  long "message"
+  <> metavar "MESSAGE"
+  <> help "String to look for in the NRM daemon standard output."
+  <> value "progress"
+  )
 
 opts :: StackArgs -> Parser (IO ())
 opts sa = hsubparser
@@ -36,9 +41,19 @@ opts sa = hsubparser
        )
   <> command
        "stack"
+       (info (runSimpleStack <$> parseExtendStackArgs sa)
+             (progDesc "Setup stack and run a command in a container.")
+       )
+  <> command
+       "grep"
        (info
-         (runSimpleStack <$> parseExtendStackArgs sa)
-         (progDesc "Setup stack and run an arbitrary command in a container.")
+         (runWaitForMessage <$> messageOption <*> parseExtendStackArgs
+           (sa { app = "echo foobar" })
+         )
+         (progDesc
+           "Setup stack and look for a message in the daemon's \
+           \standard output."
+         )
        )
   <> command
        "helloworld"
@@ -54,15 +69,15 @@ opts sa = hsubparser
   <> command
        "perfwrapper"
        (info
-         (runWaitForMessage "payload" <$> parseExtendStackArgs
+         (runWaitForMessage "progress" <$> parseExtendStackArgs
            (sa { manifestName = "perfwrap.json"
                , app          = format ("sleep " % s) "5"
                }
            )
          )
          (progDesc
-           "Test 2: Setup stack and check that a hello world app sends \
-           \message back to cmd. Uses argo-perf-wrapper."
+           "Test 2: Setup stack and check that argo-perf-wrapper sends \
+           \ at least one progress message up."
          )
        )
   <> help
@@ -79,31 +94,33 @@ main = do
 
 runCheckCmdOutput :: Text -> StackArgs -> IO ()
 runCheckCmdOutput message a@StackArgs {..} = do
+  sh cleanLeftoverProcesses
   runSimpleStack a
   readTextFile cmd_err >>= \x -> case match (has (text message)) x of
     [] ->
-      die $ "Test failure: Cmd did not recieve the '" <> message <> "' message."
+      sh $ dieRed $ "Cmd did not recieve the '" <> message <> "' message.\n"
     _ ->
       sh
-        $ printInfo
-            "Test success: The hello world app executed properly in a \
+        $ printSuccess
+            "The hello world app executed properly in a \
             \ container and its message was received by `cmd`.\n"
 
 runWaitForMessage :: Text -> StackArgs -> IO ()
 runWaitForMessage message a@StackArgs {..} = do
+  sh $ printError "WARNING: TODO: DEBUG. THIS TEST CURRENTLY FAILS ONCE PER TWO RUNS AND REPORTS BAD EXIT CODES.\n"
   runSimpleStackWithCriterion criteria a
-  die
-    ("Test failure: did not find string '" <> message <> "' in daemon stdout.")
+  sh $ dieRed ("Did not find string '" <> message <> "' in daemon stdout.\n")
  where
   criteria :: (Shell (Either Line Line) -> Shell (Either Line Line))
   criteria s = s >>= \case
-    Left out -> case match (has (text "payload")) (lineToText out) of
+    Left out -> case match (has (text message)) (lineToText out) of
       [] -> return $ Left out
       _  -> do
-        printInfo
-          $  "Test success: Found line containing '"
+        printSuccess
+          $  "Found line containing '"
           <> message
-          <> "' in daemon stdout."
+          <> "' in daemon stdout.\n"
+        cleanLeftoverProcesses
         exit ExitSuccess
     Right err -> return $ Right err