Refactor compiles.

.README.md

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

@@ -3,3 +3,10 @@ _output
 result
 .shake
 *.log
+*/build
+*/new-build
+*/dist
+*/new-dist
+*/result
+_output
+*/_output

argo/src/Argo/Args.hs

-{-# 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
+  { app                    :: AppName
+  , args                   :: AppArgs
+  , containerName          :: ContainerName
+  , workingDirectory       :: WorkingDirectory
+  , manifestDir            :: ManifestDir
+  , manifestName           :: ManifestName
+  , daemon                 :: ProcessBehavior
+  , cmdrun                 :: ProcessBehavior
+  , cmdlisten              :: ProcessBehavior
+  , cmdlistenprogress      :: ProcessBehavior
+  , cmdlistenpower         :: ProcessBehavior
   }
 
+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
+    { app = AppName "echo"
+    , args = AppArgs ["foobar"]
+    , 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
@@ -97,113 +102,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

 {-# LANGUAGE
+  TupleSections,
   ScopedTypeVariables,
   LambdaCase,
   RecordWildCards,
@@ -44,42 +45,15 @@ import           Control.Exception.Base
 import           Data.Maybe
 import           Control.Foldl                 as Fold
 
-
-{-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-}
+cleanLeftovers :: WorkingDirectory -> Shell ()
+cleanLeftovers (WorkingDirectory wd) = do
   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"
-    ]
+  cleanLog wd
   printInfo "Cleaning leftover 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 +63,16 @@ 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
+  -> WorkingDirectory
+  -> Shell Instrumentation
+prepareDaemon (StdOutLog out) (StdErrLog err) test (WorkingDirectory wd) = do
+  mktree wd
+  checkFsAttributes wd
+  cd wd
   myWhich "daemon"
   confPath <- myWhich "argo_nodeos_config"
   let confPath' = "./argo_nodeos_config"
@@ -109,13 +88,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")
@@ -166,95 +142,83 @@ prepareDaemon sa@StackArgs {..} = do
                     "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
+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
+  | MessageNotFound
+  | Died StackI ExitCode
+
+data StackI = Daemon | Run | Listen | Progress | Power deriving (Show)
+
+runListenStack :: StackArgs -> Shell StackOutput
 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
+  cleanLeftovers workingDirectory
+
+  iDaemon <- case daemon of
+    DontRun -> return Nothing
+    JustRun out err ->
+      (\x -> Just (Daemon, x))
+        <$> prepareDaemon out err Nothing workingDirectory
+    SucceedTestOnMessage t out err ->
+      (\x -> Just (Daemon, x))
+        <$> prepareDaemon out err (Just t) workingDirectory
+
+  let milist =
+        [ iDaemon
+        , cmdRunI app args containerName manifestDir manifestName cmdrun
+        , cmdListenI containerName cmdlisten
+        , cmdListenProgressI containerName cmdlistenprogress
+        , cmdListenPowerI containerName cmdlistenpower
+        ]
+      ilist = catMaybes milist
+
+  asyncs <- liftIO $ mapM tupleToAsync ilist
+  liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
+  out <- liftIO $ waitAnyCancel asyncs
+  return $ case snd out of
+    (_     , Left PatternMatched      ) -> FoundMessage
+    (Run   , Right (ExitSuccess, _, _)) -> MessageNotFound
+    (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

@@ -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 = colorShell Green . printf ("RUNNING TEST: " % s%"\n")
+printTest = colorShell Green . printf ("RUNNING TEST: " % s % "\n")
 dieRed str =
   colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1)
 
@@ -60,7 +61,7 @@ sudoRemoveFile printer desc filePath = do
   go useSudo = do
     printer $ format ("found stale " % s % " at " % fp % ".. ") desc filePath
     shell
-        (format ((if useSudo then "sudo " else "") % "rm -f " % fp) filePath)
+        (format ((if useSudo then "sudo " else "") % "rm -rf " % fp) filePath)
         Turtle.empty
       >>= \case
             ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
@@ -92,26 +93,27 @@ data PatternMatched = PatternMatched deriving (Show, Typeable)
 instance Exception PatternMatched
 
 data Instrumentation = Instrumentation
-  { process    :: CreateProcess
-  , stdOutFile :: FilePath
-  , stdErrFile :: FilePath
-  , messageOut :: Maybe Text
-  , messageErr :: Maybe Text } deriving (Show)
+  CreateProcess
+  StdOutLog
+  StdErrLog
+  (Maybe TestText)
+  deriving (Show)
 
 runI :: Instrumentation -> IO (Either PatternMatched (ExitCode, (), ()))
-runI Instrumentation {..} = try (reroutedDaemon process)
+runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try
+  (reroutedDaemon cp)
  where
   reroutedDaemon process =
-    withSinkFile (encodeString stdOutFile) $ \outSink ->
-      withSinkFile (encodeString stdErrFile)
-        $ \errSink -> sourceProcessWithStreams
+    withSinkFile (T.unpack out)
+      $ \outSink ->
+          withSinkFile (T.unpack err) $ \errSink -> sourceProcessWithStreams
             process
             mempty
-            (makeMatcher messageOut .| outSink)
-            (makeMatcher messageErr .| errSink)
+            (makeMatcher t .| outSink)
+            (makeMatcher t .| errSink)
   makeMatcher maybeMessage = case maybeMessage of
-    Just msg -> untilMatch msg
-    Nothing  -> awaitForever yield
+    Just (TestText msg) -> untilMatch msg
+    Nothing             -> awaitForever yield
   untilMatch :: Text -> ConduitT ByteString ByteString IO ()
   untilMatch message = do
     inb <- await
@@ -122,3 +124,10 @@ runI Instrumentation {..} = try (reroutedDaemon process)
           yield b
           untilMatch message
       _ -> return ()
+
+
+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)

argotk/argotk.cabal

@@ -16,7 +16,7 @@ executable argotk
   main-is:             argotk.hs
   -- other-modules:
   -- other-extensions:
-  build-depends:       base, shake
+  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

argotk/argotk.hs

@@ -8,16 +8,8 @@ import           Argo.Args
 import           Turtle
 import           Prelude                 hiding ( FilePath )
 import           Data.Default
-import           Control.Concurrent.Async
 import           System.Environment
-import           System.Console.ANSI
-import           System.Console.ANSI.Types      ( Color )
-import           Options.Applicative
-import           System.Posix.Signals
-import           Control.Monad
-import           Data.Either
-import           Data.Maybe
-import qualified Control.Foldl                 as Fold
+import           Options.Applicative     hiding ( action )
 import           Data.Text                     as T
                                                 ( pack )
 
@@ -25,20 +17,12 @@ opts :: StackArgs -> Parser (Shell ())
 opts sa = hsubparser
   (  command "clean"
              (info (pure $ clean sa) (progDesc "Clean sockets, logfiles."))
-  <> command
-       "daemon-only"
-       (info
-         (daemon <$> parseExtendStackArgs sa)
-         (progDesc
-           "Set up and launch the daemon in synchronous mode, \
-           \with properly cleaned sockets, logfiles."
-         )
-       )
   <> command
        "full-stack"
-       (info (simpleStack False <$> parseExtendStackArgs sa)
+       (info (fullStack <$> parseExtendStackArgs sa)
              (progDesc "Setup stack and run a command in a container.")
        )
+  <> commandTest DaemonOnly
   <> commandTest TestHello
   <> commandTest TestListen
   <> commandTest TestPerfwrapper
@@ -55,126 +39,115 @@ opts sa = hsubparser
   action ttype = doOverridenTest ttype
     <$> parseExtendStackArgs ((stackArgsUpdate $ configureTest ttype) sa)
   descTest ttype = "test" ++ description (configureTest ttype)
-  commandTest ttype =
-    command (show ttype) $ info (action ttype) (progDesc $ descTest ttype)
-  commandTests ttypes cmdStr descStr = command cmdStr $ info (pure $ mapM_ (doTest sa) ttypes) (progDesc descStr)
+  commandTest ttype = command (show ttype)
+    $ info (action ttype) (progDesc $ descTest ttype)
+  commandTests ttypes cmdStr descStr =
+    command cmdStr $ info (pure $ mapM_ (doTest sa) ttypes) (progDesc descStr)
 
-data TestType = TestHello | TestListen | TestPerfwrapper | TestPower deriving Show
-data TestSpec = TestSpec {
-    stackAction :: StackArgs -> Shell ()
-  , stackArgsUpdate :: StackArgs -> StackArgs
-  , description :: String
-}
+data TestType = DaemonOnly | DaemonApp | TestHello | TestListen | TestPerfwrapper | TestPower deriving Show
 
-doTest :: StackArgs -> TestType ->  Shell ()
-doTest stackArgs ttype = doSpec spec $ (stackArgsUpdate $ configureTest ttype) stackArgs
+data TestSpec = TestSpec
+  { stackArgsUpdate :: StackArgs -> StackArgs
+  , description :: String }
+
+doTest :: StackArgs -> TestType -> Shell ()
+doTest stackArgs ttype = doSpec spec
+