Merge branch 'experiment-commands' into 'master'

Experiment commands

See merge request argo/argotest!14

.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/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, stm
+  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
   hs-source-dirs:      src
   default-language:    Haskell2010

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
+  { verbosity              :: Verbosity
+  , app                    :: AppName
+  , args                   :: AppArgs
+  , containerName          :: ContainerName
+  , workingDirectory       :: WorkingDirectory
+  , manifestDir            :: ManifestDir
+  , manifestName           :: ManifestName
+  , daemon                 :: ProcessBehavior
+  , cmdrun                 :: ProcessBehavior
+  , cmdlisten              :: ProcessBehavior
+  , cmdlistenprogress      :: ProcessBehavior
+  , cmdlistenpower         :: ProcessBehavior
   }
 
+data Verbosity = Normal | Verbose deriving (Show,Read,Eq)
+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
+    { verbosity = Verbose
+    , app = AppName "ls"
+    , args = AppArgs []
+    , 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
 parseExtendStackArgs StackArgs {..} = do
+  verbosity <- flag
+    Normal
+    Verbose
+    (long "verbose" <> short 'v' <> help "Enable verbose mode")
   app <- strOption
     (  long "application"
     <> metavar "APP"
@@ -97,113 +109,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/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"
@@ -82,36 +83,36 @@ verboseShell' command input =
   printCommand command >> shellStrictWithErr command input
 
 cleanSocket = sudoRemoveFile printError "socket"
-cleanLog = sudoRemoveFile printWarning "log file"
+cleanLog = sudoRemoveFile printWarning "log folder"
 
 kbInstallHandler :: IO () -> IO Handler
 kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing
 
-
 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 +123,9 @@ 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

default.nix

@@ -18,6 +18,7 @@ let
   hpkgs = pkgs.haskellPackages.override {
         overrides = self: super: rec {
         argo = self.callCabal2nix "argo" (filterHdevTools ./argo) {};
+        argotk = self.callCabal2nix "argotk" (filterHdevTools ./argotk) {};
     };
   };
 
@@ -49,17 +50,23 @@ in rec
 
   amg = pkgs.applications.nrm.amg;
 
-  inherit(hpkgs) argo;
+  inherit(hpkgs) argo argotk;
 
-  dev-lib = hpkgs.shellFor {
+  hack-argo = hpkgs.shellFor {
     packages = p: with p; [ argo ];
     withHoogle = true;
     buildInputs = devInputs ++ devHPackages;
   };
 
+  hack-argotk = hpkgs.shellFor {
+    packages = p: with p; [ argotk ];
+    withHoogle = true;
+    buildInputs = devInputs ++ devHPackages;
+  };
+
   manifests = ./manifests;
 
-  argotk = pkgs.stdenv.mkDerivation rec {
+  argotkp = pkgs.stdenv.mkDerivation rec {
     name = "env";
     env = pkgs.buildEnv { name = name; paths = buildInputs ++ propagatedBuildInputs; };
     src = filterHdevTools ./argotk;
@@ -84,7 +91,7 @@ in rec
     name = "env";
     env = pkgs.buildEnv { name = name; paths = buildInputs; };
     buildInputs =  [
-      argotk
+      argotkp
       pkgs.coreutils
       pkgs.utillinux
       containers