Commit 0bc48edd authored by Valentin Reis's avatar Valentin Reis

[refactor] power experiment refactor.

parent 78474c1a
Pipeline #4918 failed with stage
in 4 seconds
...@@ -15,3 +15,18 @@ library ...@@ -15,3 +15,18 @@ library
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 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 hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options:
-Wall
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-Wmissing-export-li
-fwarn-tabs
-fwarn-unused-imports
-fwarn-missing-signatures
-fwarn-name-shadowing
-fwarn-incomplete-patternssts
-fprint-potential-instances
{-|
Module : Argo
Description : The holt core package
Copyright : (c) Valentin Reis, 2018
License : MIT
Maintainer : fre@freux.fr
-}
module Argo module Argo
( module Argo.Stack ( module Argo.Stack
( module Argo.Args , module Argo.Args
, module Argo.Utils , module Argo.Utils
) )
where where
......
...@@ -11,14 +11,12 @@ import Data.Text as T ...@@ -11,14 +11,12 @@ import Data.Text as T
import Turtle hiding ( option ) import Turtle hiding ( option )
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
import System.Process hiding ( shell )
data OutputFiles = OutputFiles FilePath FilePath
data StackArgs = StackArgs data StackArgs = StackArgs
{ verbosity :: Verbosity { verbosity :: Verbosity
, app :: AppName , app :: AppName
, args :: AppArgs , args :: [AppArg]
, containerName :: ContainerName , containerName :: ContainerName
, workingDirectory :: WorkingDirectory , workingDirectory :: WorkingDirectory
, manifestDir :: ManifestDir , manifestDir :: ManifestDir
...@@ -27,11 +25,13 @@ data StackArgs = StackArgs ...@@ -27,11 +25,13 @@ data StackArgs = StackArgs
, cmdrun :: ProcessBehavior , cmdrun :: ProcessBehavior
, cmdlisten :: ProcessBehavior , cmdlisten :: ProcessBehavior
, cmdlistenprogress :: ProcessBehavior , cmdlistenprogress :: ProcessBehavior
, cmdlistenperformance :: ProcessBehavior
, cmdlistenpower :: ProcessBehavior , cmdlistenpower :: ProcessBehavior
} }
{-data OutputFiles = OutputFiles FilePath FilePath-}
data Verbosity = Normal | Verbose deriving (Show,Read,Eq) data Verbosity = Normal | Verbose deriving (Show,Read,Eq)
newtype AppArgs = AppArgs [Text] deriving (Show, Read) newtype AppArg = AppArg Text deriving (IsString, Show, Read)
newtype WorkingDirectory = WorkingDirectory FilePath deriving (IsString, Show) newtype WorkingDirectory = WorkingDirectory FilePath deriving (IsString, Show)
newtype AppName = AppName Text deriving (IsString, Show, Read) newtype AppName = AppName Text deriving (IsString, Show, Read)
newtype ContainerName = ContainerName Text deriving (IsString, Show, Read) newtype ContainerName = ContainerName Text deriving (IsString, Show, Read)
...@@ -56,7 +56,7 @@ instance Default StackArgs where ...@@ -56,7 +56,7 @@ instance Default StackArgs where
def = StackArgs def = StackArgs
{ verbosity = Normal { verbosity = Normal
, app = AppName "ls" , app = AppName "ls"
, args = AppArgs [] , args = []
, containerName = ContainerName "testContainer" , containerName = ContainerName "testContainer"
, workingDirectory = WorkingDirectory "_output" , workingDirectory = WorkingDirectory "_output"
, manifestDir = ManifestDir "manifests" , manifestDir = ManifestDir "manifests"
...@@ -65,83 +65,95 @@ instance Default StackArgs where ...@@ -65,83 +65,95 @@ instance Default StackArgs where
, cmdrun = DontRun , cmdrun = DontRun
, cmdlisten = DontRun , cmdlisten = DontRun
, cmdlistenprogress = DontRun , cmdlistenprogress = DontRun
, cmdlistenperformance = DontRun
, cmdlistenpower = DontRun , cmdlistenpower = DontRun
} }
parseExtendStackArgs :: StackArgs -> Parser StackArgs parseExtendStackArgs :: StackArgs -> Parser StackArgs
parseExtendStackArgs StackArgs {..} = do parseExtendStackArgs sa = do
verbosity <- flag verbosity <- flag
Normal Normal
Verbose Verbose
(long "verbose" <> short 'v' <> help "Enable verbose mode") (long "verbose" <> short 'v' <> help "Enable verbose mode")
app <- strOption app <- strOption
( long "application" ( long "app"
<> metavar "APP" <> metavar "APP"
<> help "Target application executable name. PATH is inherited." <> help "Target application executable name. PATH is inherited."
<> showDefault <> showDefault
<> value app <> value (app sa)
) )
args <- many ( argument auto
( metavar "ARGS"
<> help "Application arguments."
))
containerName <- strOption containerName <- strOption
( long "container_name" ( long "container_name"
<> metavar "ARGO_CONTAINER_UUID" <> metavar "ARGO_CONTAINER_UUID"
<> help "Container name" <> help "Container name"
<> showDefault <> showDefault
<> value containerName <> value (containerName sa)
) )
workingDirectory <- strOption workingDirectory <- strOption
( long "output_dir" ( long "output_dir"
<> metavar "DIR" <> metavar "DIR"
<> help "Working directory." <> help "Working directory."
<> showDefault <> showDefault
<> value workingDirectory <> value (workingDirectory sa)
) )
manifestDir <- strOption manifestDir <- strOption
( long "manifest_directory" ( long "manifest_directory"
<> metavar "DIR" <> metavar "DIR"
<> help "Manifest lookup directory" <> help "Manifest lookup directory"
<> showDefault <> showDefault
<> value manifestDir <> value (manifestDir sa)
) )
manifestName <- strOption manifestName <- strOption
( long "manifest_name" ( long "manifest_name"
<> metavar "FILENAME" <> metavar "FILENAME"
<> help "Manifest file basename (relative to --manifest_directory)" <> help "Manifest file basename (relative to --manifest_directory)"
<> showDefault <> showDefault
<> value manifestName <> value (manifestName sa)
) )
daemon <- behaviorOption daemon <- behaviorOption
( long "daemon" ( long "daemon"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`daemon` behavior" <> help "`daemon` behavior"
<> showDefault <> showDefault
<> value daemon <> value (daemon sa)
) )
cmdrun <- behaviorOption cmdrun <- behaviorOption
( long "cmd_run" ( long "cmd_run"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd run` behavior" <> help "`cmd run` behavior"
<> showDefault <> showDefault
<> value cmdrun <> value (cmdrun sa)
) )
cmdlisten <- behaviorOption cmdlisten <- behaviorOption
( long "cmd_listen" ( long "cmd_listen"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd listen` behavior" <> help "`cmd listen` behavior"
<> showDefault <> showDefault
<> value cmdlisten <> value (cmdlisten sa)
)
cmdlistenperformance <- behaviorOption
( long "cmd_listen_performance"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter performance` behavior"
<> showDefault
<> value (cmdlistenperformance sa)
) )
cmdlistenprogress <- behaviorOption cmdlistenprogress <- behaviorOption
( long "cmd_listen_progress" ( long "cmd_listen_progress"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd listen --filter progress` behavior" <> help "`cmd listen --filter progress` behavior"
<> showDefault <> showDefault
<> value cmdlistenprogress <> value (cmdlistenprogress sa)
) )
cmdlistenpower <- behaviorOption cmdlistenpower <- behaviorOption
( long "cmd_listen_power" ( long "cmd_listen_power"
<> metavar "BEHAVIOR" <> metavar "BEHAVIOR"
<> help "`cmd listen --filter power` behavior" <> help "`cmd listen --filter power` behavior"
<> showDefault <> showDefault
<> value cmdlistenpower <> value (cmdlistenpower sa)
) )
pure StackArgs {..} pure StackArgs {..}
...@@ -16,32 +16,16 @@ import Turtle ...@@ -16,32 +16,16 @@ import Turtle
import Turtle.Shell import Turtle.Shell
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
import System.IO ( withFile )
import Debug.Trace
import Filesystem.Path ( (</>) ) import Filesystem.Path ( (</>) )
import Control.Concurrent.Async 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 import Data.Text as T
hiding ( empty ) hiding ( empty )
import Data.Text.IO as Text
import Argo.Utils import Argo.Utils
import System.Process as P import System.Process as P
hiding ( shell ) hiding ( shell )
import Options.Applicative as OA
import Control.Monad.Extra as E
import Control.Monad as CM import Control.Monad as CM
import Control.Foldl as F
import Data.Conduit
import Data.Conduit.Process
import Data.ByteString.Char8 as C8
hiding ( empty )
import Control.Exception.Base
import Data.Maybe import Data.Maybe
import Control.Foldl as Fold import Control.Foldl as Fold
import Text.Show.Pretty import Text.Show.Pretty
...@@ -55,10 +39,10 @@ cleanLeftovers (WorkingDirectory wd) = do ...@@ -55,10 +39,10 @@ cleanLeftovers (WorkingDirectory wd) = do
checkFsAttributes :: FilePath -> Shell () checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do checkFsAttributes workingDirectory = do
let x = case toText workingDirectory of let dir = case toText workingDirectory of
Left x -> x Left di -> di
Right x -> x Right di -> di
let findmnt = inproc "findmnt" ["-T", x, "-o", "OPTIONS"] empty let findmnt = inproc "findmnt" ["-T", dir, "-o", "OPTIONS"] empty
b <- liftIO $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Fold.length b <- liftIO $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Fold.length
when (b > 0) $ dieRed $ format when (b > 0) $ dieRed $ format
("The output directory, " % fp % ", must not mounted with \"nosuid\"") ("The output directory, " % fp % ", must not mounted with \"nosuid\"")
...@@ -66,8 +50,8 @@ checkFsAttributes workingDirectory = do ...@@ -66,8 +50,8 @@ checkFsAttributes workingDirectory = do
prepareDaemon prepareDaemon
:: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation :: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
prepareDaemon (StdOutLog out) (StdErrLog err) test = do prepareDaemon out stdErr test = do
myWhich "daemon" _ <- myWhich "daemon"
confPath <- myWhich "argo_nodeos_config" confPath <- myWhich "argo_nodeos_config"
let confPath' = "./argo_nodeos_config" let confPath' = "./argo_nodeos_config"
cp confPath confPath' cp confPath confPath'
...@@ -82,32 +66,26 @@ prepareDaemon (StdOutLog out) (StdErrLog err) test = do ...@@ -82,32 +66,26 @@ prepareDaemon (StdOutLog out) (StdErrLog err) test = 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 (P.proc "daemon" []) return $ Instrumentation (P.proc "daemon" []) out stdErr test
(StdOutLog out)
(StdErrLog err)
test
where where
nodeOsFailure (ExitFailure n, _, _) = do nodeOsFailure n = do
printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n") printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n")
testfile ".argo_nodeos_config_exit_message" >>= \case testfile ".argo_nodeos_config_exit_message" >>= \case
True -> do True -> do
printInfo "Contents of .argo_nodeos_config_exit_message: \n" printInfo "Contents of .argo_nodeos_config_exit_message: \n"
view $ input ".argo_nodeos_config_exit_message" view $ input ".argo_nodeos_config_exit_message"
False -> die ("argo_nodeos_config failed with exit code " <> repr n) False -> die ("argo_nodeos_config failed with exit code " <> repr n)
cleanContainers :: FilePath -> NominalDiffTime -> Integer -> Shell ()
cleanContainers argo_nodeos_config retryTime remainingRetries = do cleanContainers argo_nodeos_config retryTime remainingRetries = do
let let
showConfig = showConfig =
inshell (format (fp % " --show_config") argo_nodeos_config) empty inshell (format (fp % " --show_config") argo_nodeos_config) empty
(isClean :: IO Bool) =
liftIO
(Turtle.Shell.fold (grep (has "CONTAINER") showConfig) Fold.length)
>>= (\x -> return $ x > 5)
verboseShell' verboseShell'
(format (fp % " --clean_config=kill_content:true") argo_nodeos_config) (format (fp % " --clean_config=kill_content:true") argo_nodeos_config)
empty empty
>>= \case >>= \case
e@(ExitFailure n, out, err) -> do (ExitFailure n, _, _) -> do
when (remainingRetries == 0) $ nodeOsFailure e when (remainingRetries == 0) $ nodeOsFailure n
printWarning printWarning
( "the argo_nodeos_config call failed with exit code " ( "the argo_nodeos_config call failed with exit code "
<> repr n <> repr n
...@@ -119,10 +97,10 @@ prepareDaemon (StdOutLog out) (StdErrLog err) test = do ...@@ -119,10 +97,10 @@ prepareDaemon (StdOutLog out) (StdErrLog err) test = do
(remainingRetries - 1) (remainingRetries - 1)
(ExitSuccess, _, _) -> do (ExitSuccess, _, _) -> do
printInfo "Cleaned the argo config.\n" printInfo "Cleaned the argo config.\n"
l <- liftIO $ Turtle.Shell.fold len <- liftIO $ Turtle.Shell.fold
(grep (has "CONTAINER") showConfig) (grep (has "CONTAINER") showConfig)
Fold.length Fold.length
if l > 0 if len > 0
then do then do
printWarning printWarning
"the argo_nodeos_config call did not remove containers, \ "the argo_nodeos_config call did not remove containers, \
...@@ -138,20 +116,21 @@ prepareDaemon (StdOutLog out) (StdErrLog err) test = do ...@@ -138,20 +116,21 @@ prepareDaemon (StdOutLog out) (StdErrLog err) test = do
cmdRunI cmdRunI
:: AppName :: AppName
-> AppArgs -> [AppArg]
-> ContainerName -> ContainerName
-> ManifestDir -> ManifestDir
-> ManifestName -> ManifestName
-> ProcessBehavior -> ProcessBehavior
-> Maybe (StackI, Instrumentation) -> Maybe (StackI, Instrumentation)
cmdRunI (AppName app) (AppArgs args) (ContainerName cn) (ManifestDir md) (ManifestName mn) pb cmdRunI (AppName app) args (ContainerName cn) (ManifestDir md) (ManifestName mn) pb
= Just (Run, ) = Just (Run, )
<*> processBehaviorToI <*> processBehaviorToI
( P.proc "cmd" ( P.proc "cmd"
$ ["run", "-u", T.unpack cn, encodeString $ md </> mn, T.unpack app] $ ["run", "-u", T.unpack cn, encodeString $ md </> mn, T.unpack app]
++ fmap T.unpack args ++ fmap (T.unpack . argToText) args
) )
pb pb
where argToText (AppArg a) = a
cmdListenI cmdListenI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation) :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
...@@ -167,6 +146,15 @@ cmdListenProgressI (ContainerName cn) pb = ...@@ -167,6 +146,15 @@ cmdListenProgressI (ContainerName cn) pb =
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"]) (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
pb pb
cmdListenPerformanceI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPerformanceI (ContainerName cn) pb =
Just (Performance, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"]
)
pb
cmdListenPowerI cmdListenPowerI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation) :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPowerI (ContainerName cn) pb = cmdListenPowerI (ContainerName cn) pb =
...@@ -179,28 +167,34 @@ data StackOutput = ...@@ -179,28 +167,34 @@ data StackOutput =
FoundMessage FoundMessage
| Died StackI ExitCode | Died StackI ExitCode
data StackI = Daemon | Run | Listen | Progress | Power deriving (Show) data StackI = Daemon | Run | Listen | Progress | Power | Performance deriving (Show)
runStack :: StackArgs -> Shell StackOutput runStack :: StackArgs -> Shell StackOutput
runStack a@StackArgs {..} = do runStack StackArgs {..} = do
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in", "/tmp/nrm-upstream-event"] CM.mapM_
cleanSocket
[ "/tmp/nrm-downstream-in"
, "/tmp/nrm-upstream-in"
, "/tmp/nrm-upstream-event"
]
let (WorkingDirectory wd) = workingDirectory let (WorkingDirectory wd) = workingDirectory
Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty _ <- Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty
mktree wd mktree wd
checkFsAttributes wd checkFsAttributes wd
cd wd cd wd
iDaemon <- case daemon of iDaemon <- case daemon of
DontRun -> return Nothing DontRun -> return Nothing
JustRun out err -> JustRun stdOut stdErr ->
(\x -> Just (Daemon, x)) <$> prepareDaemon out err Nothing (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing
SucceedTestOnMessage t out err -> SucceedTestOnMessage t stdOut stdErr ->
(\x -> Just (Daemon, x)) <$> prepareDaemon out err (Just t) (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t)
let milist = let milist =
[ iDaemon [ iDaemon
, cmdRunI app args containerName manifestDir manifestName cmdrun , cmdRunI app args containerName manifestDir manifestName cmdrun
, cmdListenI containerName cmdlisten , cmdListenI containerName cmdlisten
, cmdListenPerformanceI containerName cmdlistenperformance
, cmdListenProgressI containerName cmdlistenprogress , cmdListenProgressI containerName cmdlistenprogress
, cmdListenPowerI containerName cmdlistenpower , cmdListenPowerI containerName cmdlistenpower
] ]
...@@ -213,7 +207,7 @@ runStack a@StackArgs {..} = do ...@@ -213,7 +207,7 @@ runStack a@StackArgs {..} = do
else liftIO $ pPrint (fmap fst ilist) else liftIO $ pPrint (fmap fst ilist)
asyncs <- liftIO $ mapM tupleToAsync ilist asyncs <- liftIO $ mapM tupleToAsync ilist
liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs _ <- liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
when (verbosity == Verbose) $ printInfo "Processes started.\n" when (verbosity == Verbose) $ printInfo "Processes started.\n"
...@@ -231,7 +225,7 @@ runStack a@StackArgs {..} = do ...@@ -231,7 +225,7 @@ runStack a@StackArgs {..} = do
return $ case snd out of return $ case snd out of
(_ , Left PatternMatched) -> FoundMessage (_ , Left PatternMatched) -> FoundMessage
(stacki, Right (e, _, _) ) -> Died stacki e (stacki, Right (errmsg, _, _) ) -> Died stacki errmsg
where where
tupleToAsync tupleToAsync
:: (StackI, Instrumentation) :: (StackI, Instrumentation)
......
{-# LANGUAGE LambdaCase, OverloadedStrings, DataKinds, {-# LANGUAGE LambdaCase, OverloadedStrings, DataKinds,
FlexibleInstances, TypeOperators, RecordWildCards #-} FlexibleInstances, TypeOperators #-}
module Argo.Utils where module Argo.Utils where
...@@ -22,7 +22,7 @@ import Data.Text as T ...@@ -22,7 +22,7 @@ import Data.Text as T
-- | Miscellaneous printing utilities -- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell () colorShell :: Color -> Shell () -> Shell ()
colorShell color s = setC color *> s *> setC White colorShell color she = setC color *> she *> setC White
where setC c = liftIO $ setSGR [SetColor Foreground Dull c] where setC c = liftIO $ setSGR [SetColor Foreground Dull c]
printInfo :: Text -> Shell () printInfo :: Text -> Shell ()
...@@ -42,11 +42,13 @@ printTest = colorShell Green . printf ("RUNNING TEST: " % s % "\n") ...@@ -42,11 +42,13 @@ 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)
myWhich :: FilePath -> Shell FilePath
myWhich str = which str >>= \case myWhich str = which str >>= \case
(Just p) -> (Just p) ->
printInfo (format ("Found " % fp % " at " % fp % "\n") str p) >> return p printInfo (format ("Found " % fp % " at " % fp % "\n") str p) >> return p
Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str
myWhichMaybe :: FilePath -> Shell (Maybe FilePath)
myWhichMaybe str = which str >>= \case myWhichMaybe str = which str >>= \case
(Just p) -> printInfo (format ("Found " % fp % " at " % fp % "\n") str p) (Just p) -> printInfo (format ("Found " % fp % " at " % fp % "\n") str p)
>> return (Just p) >> return (Just p)
...@@ -65,7 +67,7 @@ sudoRemoveFile printer desc filePath = do ...@@ -65,7 +67,7 @@ sudoRemoveFile printer desc filePath = do
Turtle.empty Turtle.empty
>>= \case >>= \case
ExitSuccess -> colorShell Green $ printf " Successfully removed.\n" ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
ExitFailure n -> if useSudo ExitFailure _ -> if useSudo
then printer $ format then printer $ format
("Failed to remove stale " % s % ", even with sudo.") ("Failed to remove stale " % s % ", even with sudo.")
desc desc
...@@ -76,13 +78,15 @@ sudoRemoveFile printer desc filePath = do ...@@ -76,13 +78,15 @@ sudoRemoveFile printer desc filePath = do
go True go True
verboseShell :: Text -> Shell Line -> Shell ExitCode verboseShell :: Text -> Shell Line -> Shell ExitCode
verboseShell command input = printCommand command >> shell command input verboseShell command i = printCommand command >> shell command i
verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text) verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text)
verboseShell' command input = verboseShell' command i =
printCommand command >> shellStrictWithErr command input printCommand command >> shellStrictWithErr command i
cleanSocket :: FilePath -> Shell ()
cleanSocket = sudoRemoveFile printError "socket" cleanSocket = sudoRemoveFile printError "socket"
cleanLog :: FilePath -> Shell ()
cleanLog = sudoRemoveFile printWarning "log folder" cleanLog = sudoRemoveFile printWarning "log folder"
kbInstallHandler :: IO () -> IO Handler kbInstallHandler :: IO () -> IO Handler
...@@ -99,13 +103,13 @@ data Instrumentation = Instrumentation ...@@ -99,13 +103,13 @@ data Instrumentation = Instrumentation
deriving (Show) deriving (Show)
runI :: Instrumentation -> IO (Either PatternMatched (ExitCode, (), ())) runI :: Instrumentation -> IO (Either PatternMatched (ExitCode, (), ()))
runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try runI (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = try
(reroutedDaemon cp) (reroutedDaemon crProc)
where where
reroutedDaemon process = reroutedDaemon process =
withSinkFile (T.unpack out) withSinkFile (T.unpack stdOut)
$ \outSink -> $ \outSink ->
withSinkFile (T.unpack err) $ \errSink -> sourceProcessWithStreams withSinkFile (T.unpack stdErr) $ \errSink -> sourceProcessWithStreams
process process
mempty mempty
(makeMatcher t .| outSink) (makeMatcher t .| outSink)
...@@ -125,7 +129,7 @@ runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try ...@@ -125,7 +129,7 @@ runI (Instrumentation cp outlog@(StdOutLog out) errlog@(StdErrLog err) t) = try
_ -> return () _ -> return ()
processBehaviorToI :: CreateProcess -> ProcessBehavior -> Maybe Instrumentation processBehaviorToI :: CreateProcess -> ProcessBehavior -> Maybe Instrumentation
processBehaviorToI cp = \case processBehaviorToI crProc = \case
DontRun -> Nothing DontRun -> Nothing
JustRun out err -> Just $ Instrumentation cp out err Nothing JustRun stdOut stdErr -> Just $ Instrumentation crProc stdOut stdErr Nothing
SucceedTestOnMessage t out err -> Just $ Instrumentation cp out err (Just t) SucceedTestOnMessage t stdOut stdErr -> Just $ Instrumentation crProc stdOut stdErr (Just t)
...@@ -19,4 +19,18 @@ executable argotk ...@@ -19,4 +19,18 @@ executable argotk
build-depends: base, shake, argo, turtle, data-default, async, unix, text, optparse-applicative, foldl, ansi-terminal 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
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-Wmissing-export-li
-fwarn-tabs
-fwarn-unused-imports
-fwarn-missing-signatures
-fwarn-name-shadowing
-fwarn-incomplete-patternssts
-fprint-potential-instances
...@@ -71,26 +71,27 @@ configureTest = \case ...@@ -71,26 +71,27 @@ configureTest = \case
, isTest = IsTest False , isTest = IsTest False
} }
DaemonAndApp -> TestSpec DaemonAndApp -> TestSpec
{ stackArgsUpdate = \sa -> sa { stackArgsUpdate = \sa ->
{ daemon = daemonBehavior sa { daemon = daemonBehavior, cmdrun = runBehavior }