[feature] Added the `cmd listen` Test.

argo/argo.cabal

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)