Commit be0e5b41 authored by Valentin Reis's avatar Valentin Reis

Refactor compiles.

parent a2b60e73
...@@ -112,34 +112,6 @@ There are a few things one has to be aware of using this workflow: ...@@ -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 minutes by default. Use a local checkout if you need to modify some of these
sources on the fly. 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 ### Hacking
- edit `.README.md` in place of README.md. - edit `.README.md` in place of README.md.
......
...@@ -3,3 +3,10 @@ _output ...@@ -3,3 +3,10 @@ _output
result result
.shake .shake
*.log *.log
*/build
*/new-build
*/dist
*/new-dist
*/result
_output
*/_output
{-# LANGUAGE {-# LANGUAGE OverloadedStrings, ApplicativeDo, GeneralizedNewtypeDeriving, RecordWildCards #-}
OverloadedStrings,
ApplicativeDo,
RecordWildCards #-}
module Argo.Args where module Argo.Args where
import Options.Applicative as OA import Options.Applicative as OA
import Options.Applicative.Types
import Options.Applicative.Builder ( option )
import Data.Default import Data.Default
import Data.Text as T import Data.Text as T
hiding ( empty ) hiding ( empty )
import Turtle import Turtle hiding ( option )
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
import System.Process hiding ( shell )
data OutputFiles = OutputFiles FilePath FilePath data OutputFiles = OutputFiles FilePath FilePath
data StackArgs = StackArgs data StackArgs = StackArgs
{ app :: Text { app :: AppName
, args :: [Text] , args :: AppArgs
, containerName :: Text , containerName :: ContainerName
, workingDirectory :: FilePath , workingDirectory :: WorkingDirectory
, manifestDir :: FilePath , manifestDir :: ManifestDir
, manifestName :: FilePath , manifestName :: ManifestName
, cmd_run_out :: FilePath , daemon :: ProcessBehavior
, cmd_run_err :: FilePath , cmdrun :: ProcessBehavior
, cmd_listen_out :: FilePath , cmdlisten :: ProcessBehavior
, cmd_listen_err :: FilePath , cmdlistenprogress :: ProcessBehavior
, daemon_out :: FilePath , cmdlistenpower :: ProcessBehavior
, daemon_err :: FilePath
, nrm_log :: FilePath
, messageDaemonOut :: Maybe Text
, messageDaemonErr :: Maybe Text
, messageCmdRunOut :: Maybe Text
, messageCmdRunErr :: Maybe Text
, messageCmdListenOut :: Maybe Text
, messageCmdListenErr :: Maybe Text
} }
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 instance Default StackArgs where
def = StackArgs def = StackArgs
{ app = "echo" { app = AppName "echo"
, args = ["foobar"] , args = AppArgs ["foobar"]
, containerName = "testContainer" , containerName = ContainerName "testContainer"
, workingDirectory = "_output" , workingDirectory = WorkingDirectory "_output"
, manifestDir = "manifests" , manifestDir = ManifestDir "manifests"
, manifestName = "basic.json" , manifestName = ManifestName "basic.json"
, cmd_run_out = "cmd_run_out.log" , daemon = DontRun
, cmd_run_err = "cmd_run_err.log" , cmdrun = DontRun
, cmd_listen_out = "cmd_listen_out.log" , cmdlisten = DontRun
, cmd_listen_err = "cmd_listen_err.log" , cmdlistenprogress = DontRun
, daemon_out = "daemon_out.log" , cmdlistenpower = DontRun
, daemon_err = "daemon_err.log"
, nrm_log = "nrm.log"
, messageDaemonOut = Nothing
, messageDaemonErr = Nothing
, messageCmdRunOut = Nothing
, messageCmdRunErr = Nothing
, messageCmdListenOut = Nothing
, messageCmdListenErr = Nothing
} }
parseExtendStackArgs :: StackArgs -> Parser StackArgs parseExtendStackArgs :: StackArgs -> Parser StackArgs
...@@ -97,113 +102,39 @@ parseExtendStackArgs StackArgs {..} = do ...@@ -97,113 +102,39 @@ parseExtendStackArgs StackArgs {..} = do
<> showDefault <> showDefault
<> value manifestName <> value manifestName
) )
cmd_run_out <- strOption daemon <- behaviorOption
( long "cmd_run_out" ( long "daemon"
<> metavar "FILENAME" <> metavar "BEHAVIOR"
<> help "Output file (relative to --output_dir), \"cmd run\" stdout" <> help "`daemon` behavior"
<> 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."
<> showDefault <> showDefault
<> maybe mempty value messageDaemonErr <> value daemon
) )
messageCmdRunOut <- optional $ strOption cmdrun <- behaviorOption
( long "message_cmd_run_stdout" ( long "cmd_run"
<> metavar "STRING" <> metavar "BEHAVIOR"
<> help <> help "`cmd run` behavior"
"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 <> showDefault
<> maybe mempty value messageCmdRunOut <> value cmdrun
) )
messageCmdRunErr <- optional $ strOption cmdlisten <- behaviorOption
( long "message_cmd_run_stderr" ( long "cmd_listen"
<> metavar "STRING" <> metavar "BEHAVIOR"
<> help <> help "`cmd listen` behavior"
"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 <> showDefault
<> maybe mempty value messageCmdRunErr <> value cmdlisten
) )
messageCmdListenOut <- optional $ strOption cmdlistenprogress <- behaviorOption
( long "message_cmd_listen_stdout" ( long "cmd_listen_progress"
<> metavar "STRING" <> metavar "BEHAVIOR"
<> help <> help "`cmd listen --filter progress` behavior"
"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 <> showDefault
<> maybe mempty value messageCmdListenOut <> value cmdlistenprogress
) )
messageCmdListenErr <- optional $ strOption cmdlistenpower <- behaviorOption
( long "message_cmd_listen_stderr" ( long "cmd_listen_power"
<> metavar "STRING" <> metavar "BEHAVIOR"
<> help <> help "`cmd listen --filter power` behavior"
"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 <> showDefault
<> maybe mempty value messageCmdListenErr <> value cmdlistenpower
) )
pure StackArgs {..} pure StackArgs {..}
{-# LANGUAGE {-# LANGUAGE
TupleSections,
ScopedTypeVariables, ScopedTypeVariables,
LambdaCase, LambdaCase,
RecordWildCards, RecordWildCards,
...@@ -44,42 +45,15 @@ import Control.Exception.Base ...@@ -44,42 +45,15 @@ import Control.Exception.Base
import Data.Maybe import Data.Maybe
import Control.Foldl as Fold import Control.Foldl as Fold
cleanLeftovers :: WorkingDirectory -> Shell ()
{-cleanLeftoverProcesses :: Shell ()-} cleanLeftovers (WorkingDirectory wd) = do
{-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-}
printInfo "Cleaning leftover files.\n" printInfo "Cleaning leftover files.\n"
CM.mapM_ cleanLog wd
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"
]
printInfo "Cleaning leftover sockets.\n" printInfo "Cleaning leftover 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 :: StackArgs -> Shell () checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes StackArgs {..} = do checkFsAttributes workingDirectory = do
let x = case toText workingDirectory of let x = case toText workingDirectory of
Left x -> x Left x -> x
Right x -> x Right x -> x
...@@ -89,11 +63,16 @@ checkFsAttributes StackArgs {..} = do ...@@ -89,11 +63,16 @@ checkFsAttributes StackArgs {..} = do
("The output directory, " % fp % ", must not mounted with \"nosuid\"") ("The output directory, " % fp % ", must not mounted with \"nosuid\"")
workingDirectory workingDirectory
prepareDaemon :: StackArgs -> Shell Instrumentation prepareDaemon
prepareDaemon sa@StackArgs {..} = do :: StdOutLog
mktree workingDirectory -> StdErrLog
checkFsAttributes sa -> Maybe TestText
cd workingDirectory -> 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"
...@@ -109,13 +88,10 @@ prepareDaemon sa@StackArgs {..} = do ...@@ -109,13 +88,10 @@ prepareDaemon sa@StackArgs {..} = do
ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n) ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
cleanContainers confPath' 1 2 cleanContainers confPath' 1 2
export "ARGO_NODEOS_CONFIG" (format fp confPath') export "ARGO_NODEOS_CONFIG" (format fp confPath')
return $ Instrumentation return $ Instrumentation (P.proc "daemon" [])
{ process = P.proc "daemon" ["--nrm_log", encodeString nrm_log] (StdOutLog out)
, stdOutFile = daemon_out (StdErrLog err)
, stdErrFile = daemon_err test
, messageOut = messageDaemonOut
, messageErr = messageDaemonErr
}
where where
nodeOsFailure (ExitFailure n, _, _) = do nodeOsFailure (ExitFailure n, _, _) = do
printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n") printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n")
...@@ -166,95 +142,83 @@ prepareDaemon sa@StackArgs {..} = do ...@@ -166,95 +142,83 @@ prepareDaemon sa@StackArgs {..} = do
"argo_nodeos_config successfully cleaned the container \ "argo_nodeos_config successfully cleaned the container \
\config." \config."
prepareCmdRun :: StackArgs -> Instrumentation cmdRunI
prepareCmdRun StackArgs {..} = Instrumentation :: AppName
{ process = P.proc "cmd" -> AppArgs
$ [ "run" -> ContainerName
, "-u" -> ManifestDir
, T.unpack containerName -> ManifestName
, encodeString $ manifestDir </> manifestName -> ProcessBehavior
, T.unpack app -> Maybe (StackI, Instrumentation)
] cmdRunI (AppName app) (AppArgs args) (ContainerName cn) (ManifestDir md) (ManifestName mn) pb
++ fmap T.unpack args = Just (Run, )
, stdOutFile = cmd_run_out <*> processBehaviorToI
, stdErrFile = cmd_run_err ( P.proc "cmd"
, messageOut = messageCmdRunOut $ ["run", "-u", T.unpack cn, encodeString $ md </> mn, T.unpack app]
, messageErr = messageCmdRunErr ++ fmap T.unpack args
} )
pb
prepareCmdListen :: StackArgs -> Instrumentation
prepareCmdListen StackArgs {..} = Instrumentation cmdListenI
{ process = P.proc "cmd" ["listen", "-u", T.unpack containerName] :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
, stdOutFile = cmd_listen_out cmdListenI (ContainerName cn) pb =
, stdErrFile = cmd_listen_err Just (Listen, )
, messageOut = messageCmdListenOut <*> processBehaviorToI (P.proc "cmd" ["listen", "-u", T.unpack cn]) pb
, messageErr = messageCmdListenErr
} cmdListenProgressI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
data StackOutput = FoundMessage | DaemonDied | CmdDied cmdListenProgressI (ContainerName cn) pb =
Just (Progress, )
runSimpleStack :: StackArgs -> Shell StackOutput <*> processBehaviorToI
runSimpleStack a@StackArgs {..} = do (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
cleanLeftovers a pb
iDaemon <- prepareDaemon a
let iRun = prepareCmdRun a cmdListenPowerI
printInfo "Running the daemon.." :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
liftIO $ withAsync (runI iDaemon) $ \daemon -> do cmdListenPowerI (ContainerName cn) pb =
kbInstallHandler $ cancel daemon Just (Power, )
sh $ printInfo "Daemon running.\n" <*> processBehaviorToI
sh $ printInfo "Running 'cmd run'.." (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
withAsync (runI iRun) $ \cmd -> do pb
sh $ printInfo "'cmd run' running.\n"
kbInstallHandler $ cancel daemon >> cancel cmd data StackOutput =
waitEitherCancel daemon cmd >>= \case FoundMessage
Left (Left PatternMatched) -> return FoundMessage | MessageNotFound
Left (Right _ ) -> return DaemonDied | Died StackI ExitCode
Right (Left PatternMatched) -> return FoundMessage
Right (Right _ ) -> return CmdDied data StackI = Daemon | Run | Listen | Progress | Power deriving (Show)
data ListenAsyncConclusion a = runListenStack :: StackArgs -> Shell StackOutput
Daemon a
| Listen a
| Run a
data ListenStackOutput =
LSFoundMessage
| LSMessageNotFound
| LSDaemonDied ExitCode
| LSRunDied ExitCode
| LSListenDied ExitCode
runListenStack :: StackArgs -> Shell ListenStackOutput
runListenStack a@StackArgs {..} = do runListenStack a@StackArgs {..} = do
cleanLeftovers a cleanLeftovers workingDirectory
iDaemon <- prepareDaemon a
let iRun = prepareCmdRun a iDaemon <- case daemon of
let iListen = prepareCmdListen a DontRun -> return Nothing
printInfo "Running the daemon.." JustRun out err ->
liftIO $ withAsync (runI iDaemon) $ \daemon -> do (\x -> Just (Daemon, x))
kbInstallHandler $ cancel daemon <$> prepareDaemon out err Nothing workingDirectory
sh $ printInfo "Daemon running.\n" SucceedTestOnMessage t out err ->
sh $ printInfo "Running 'cmd run'.." (\x -> Just (Daemon, x))
withAsync (runI iRun) $ \run -> do <$> prepareDaemon out err (Just t) workingDirectory
sh $ printInfo "'cmd run' running.\n"
kbInstallHandler $ cancel daemon >> cancel run let milist =
sh $ printInfo "Running 'cmd listen'.." [ iDaemon
withAsync (runI iListen) $ \listen -> do , cmdRunI app args containerName manifestDir manifestName cmdrun
sh $ printInfo "'cmd listen' running.\n" , cmdListenI containerName cmdlisten
kbInstallHandler $ cancel daemon >> cancel run >> cancel listen , cmdListenProgressI containerName cmdlistenprogress
waitStackCancel daemon run listen >>= \case , cmdListenPowerI containerName cmdlistenpower
Daemon (Left PatternMatched) -> return LSFoundMessage ]
Daemon (Right (e, _, _) ) -> return $ LSDaemonDied e ilist = catMaybes milist
Run (Left PatternMatched) -> return LSFoundMessage
Run (Right (e, _, _) ) -> return $ LSRunDied e asyncs <- liftIO $ mapM tupleToAsync ilist
Listen (Left PatternMatched) -> return LSFoundMessage liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
Listen (Right (e, _, _) ) -> return $ LSListenDied e out <- liftIO $ waitAnyCancel asyncs
return $ case snd out of
(_ , Left PatternMatched ) -> FoundMessage
(Run , Right (ExitSuccess, _, _)) -> MessageNotFound
(stacki, Right (e, _, _) ) -> Died stacki e
where where
waitStackCancel daemon run listen = tupleToAsync
waitStack daemon run listen :: (StackI, Instrumentation)
`finally` (cancel daemon >> cancel run >> cancel listen) -> IO (Async (StackI, Either PatternMatched (ExitCode, (), ())))
waitStack daemon run listen = tupleToAsync (stacki, instrum) = async $ (stacki,) <$> runI instrum
atomically
$ (Daemon <$> waitSTM daemon)
`orElse` (Run <$> waitSTM run)
`orElse` (Listen <$> waitSTM listen)
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
module Argo.Utils where module Argo.Utils where
import Argo.Args
import Turtle import Turtle
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
import System.Console.ANSI import System.Console.ANSI
...@@ -37,7 +38,7 @@ printCommand = printf ("Running: " % s % "\n") ...@@ -37,7 +38,7 @@ printCommand = printf ("Running: " % s % "\n")
printWarning = colorShell Yellow . printf ("Warning: " % s) printWarning = colorShell Yellow . printf ("Warning: " % s)
printError = colorShell Red . printf ("Error: " % s) printError = colorShell Red . printf ("Error: " % s)
printSuccess = colorShell Green . printf ("Success: " % 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 = dieRed str =
colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1) colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1)
...@@ -60,7 +61,7 @@ sudoRemoveFile printer desc filePath = do ...@@ -60,7 +61,7 @@ sudoRemoveFile printer desc filePath = do
go useSudo = do go useSudo = do
printer $ format ("found stale " % s % " at " % fp % ".. ") desc filePath printer $ format ("found stale " % s % " at " % fp % ".. ") desc filePath
shell shell
(format ((if useSudo then "sudo " else "") % "rm -f " % fp) filePath) (format ((if useSudo then "sudo " else "") % "rm -rf " % fp) filePath)
Turtle.empty Turtle.empty
>>= \case >>= \case
ExitSuccess -> colorShell Green $ printf " Successfully removed.\n" ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
...@@ -92,26 +93,27 @@ data PatternMatched = PatternMatched deriving (Show, Typeable) ...@@ -92,26 +93,27 @@ data PatternMatched = PatternMatched deriving (Show, Typeable)
instance Exception PatternMatched instance Exception PatternMatched
data Instrumentation = Instrumentation data Instrumentation = Instrumentation
{ process :: CreateProcess CreateProcess
, stdOutFile :: FilePath StdOutLog
, stdErrFile :: FilePath StdErrLog
, messageOut :: Maybe Text (Maybe TestText)
, messageErr :: Maybe Text } deriving (Show) deriving (Show)
runI :: Instrumentation -> IO (Either PatternMatched (ExitCode, (), ())) 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 where
reroutedDaemon process = reroutedDaemon process =
withSinkFile (encodeString stdOutFile) $ \outSink -> withSinkFile (T.unpack out)
withSinkFile (encodeString stdErrFile) $ \outSink ->
$ \errSink -> sourceProcessWithStreams withSinkFile (T.unpack err) $ \errSink -> sourceProcessWithStreams
process process
mempty mempty
(makeMatcher messageOut .| outSink) (makeMatcher t .| outSink)
(makeMatcher messageErr .| errSink) (makeMatcher t .| errSink)
makeMatcher maybeMessage = case maybeMessage of makeMatcher maybeMessage = case maybeMessage of
Just msg -> untilMatch msg Just (TestText msg) -> untilMatch msg
Nothing -> awaitForever yield Nothing -> awaitForever yield
untilMatch :: Text -> ConduitT ByteString ByteString IO () untilMatch :: Text -> ConduitT ByteString ByteString IO ()
untilMatch message = do untilMatch message = do
inb <- await inb <- await
...@@ -122,3 +124,10 @@ runI Instrumentation {..} = try (reroutedDaemon process) ...@@ -122,3 +124,10 @@ runI Instrumentation {..} = try (reroutedDaemon process)
yield b yield b
untilMatch message untilMatch message
_ -> return () _ -> 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)
...@@ -16,7 +16,7 @@ executable argotk ...@@ -16,7 +16,7 @@ executable argotk
main-is: argotk.hs main-is: argotk.hs
-- other-modules: -- other-modules:
-- other-extensions: -- 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 --hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
GHC-Options: -Wall GHC-Options: -Wall
...@@ -8,16 +8,8 @@ import Argo.Args ...@@ -8,16 +8,8 @@ import Argo.Args
import Turtle import Turtle
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
import Data.Default import Data.Default
import Control.Concurrent.Async
import System.Environment import System.Environment
import System.Console.ANSI import Options.Applicative hiding ( action )
import System.Console.ANSI.Types ( Color )
import Options.Applicative
import System.Posix.Signals