diff --git a/src/Argo/Args.hs b/src/Argo/Args.hs index 616f29e1d74a4978fc3704fdd521dc17643627c8..ae0c74ee63cc188a023217259b0aa35fc7a702d6 100644 --- a/src/Argo/Args.hs +++ b/src/Argo/Args.hs @@ -13,11 +13,16 @@ module Argo.Args ) where -import Argo.Types +import Argo.Types ( ProcessBehavior + , Verbosity(..) + , StackArgs(..) + ) import Options.Applicative as OA -import Options.Applicative.Types import Options.Applicative.Builder ( option ) -import Turtle hiding ( option ) +import Options.Applicative.Types ( Parser + , ReadM + , readerAsk + ) import Prelude hiding ( FilePath ) behavior :: ReadM ProcessBehavior diff --git a/src/Argo/Stack.hs b/src/Argo/Stack.hs index f067e265f4302d53b037193b07d07a482d818e9a..e81265ada4c59a24b272b0b8ccc4ea61457aae27 100644 --- a/src/Argo/Stack.hs +++ b/src/Argo/Stack.hs @@ -30,9 +30,9 @@ module Argo.Stack ) where -import Protolude -import qualified Prelude ( show ) import Argo.Types +import qualified Prelude ( show ) +import Protolude import Data.Coerce ( coerce ) @@ -41,9 +41,7 @@ import Data.Foldable ( for_ ) import Data.Text as T hiding ( empty ) import Data.Traversable ( for ) -{-import System.Process as P-} - {-hiding ( shell )-} -import Text.Show.Pretty +import System.Directory import System.Process.Typed ( readProcessStdout_ , runProcess_ , runProcess @@ -51,7 +49,7 @@ import System.Process.Typed ( readProcessStdout_ , shell , setEnv ) -import System.Directory +import Text.Show.Pretty cleanLeftovers :: WorkingDirectory -> IO () cleanLeftovers (WorkingDirectory wd) = do @@ -73,12 +71,13 @@ prepareDaemon -> Maybe TestText -> Verbosity -> PowerCap + -> [(EnvVar, Text)] -> IO Instrumentation -prepareDaemon out stdErr test v powercap = do +prepareDaemon out stdErr test v powercap vars = do let confPath' = "/tmp/argo_nodeos_config" cleanContainers confPath' return $ Instrumentation - ( setEnv [("ARGO_NODEOS_CONFIG", toS confPath')] + ( setEnv ((castArg <$> vars) ++ [("ARGO_NODEOS_CONFIG", toS confPath')]) $ proc "daemon" $ toS <$> ["--nrm_log", "./nrm_log"] @@ -89,6 +88,7 @@ prepareDaemon out stdErr test v powercap = do stdErr test where + castArg (EnvVar varname, y) = (toS varname, toS y) nodeOsFailure n = do printError $ "argo_nodeos_config failed with exit code :" <> show n doesFileExist ".argo_nodeos_config_exit_message" >>= \case @@ -121,7 +121,7 @@ cmdRunI (AppName app) args (ContainerName cn) (ShareDir md) (ManifestName mn) va pp = proc "cmd" $ toS - <$> ["run", "-u", cn, md <> "manifests" <> "/" <> mn, app] + <$> ["run", "-u", cn, md <> "/manifests/" <> mn, app] ++ fmap argToText args cmdListenI @@ -180,13 +180,12 @@ runStack sa@StackArgs {..} = do when (powercap /= None) $ do user <- readProcessStdout_ (proc "whoami" []) - for_ ([0, 1]::[Int]) $ \x -> + for_ ([0, 1] :: [Int]) $ \x -> chownPowercapFiles (toS user) $ "/sys/devices/virtual/powercap/intel-rapl/intel-rapl:" <> show x cleanLeftovers workingDirectory - runProcess (proc "mkdir" ["-p", toS wd]) >>= \case ExitFailure _ -> die $ "couldn't create " <> wd ExitSuccess -> return () @@ -195,10 +194,10 @@ runStack sa@StackArgs {..} = do DontRun -> return Nothing JustRun stdOut stdErr -> (\i -> Just (Daemon, i)) - <$> prepareDaemon stdOut stdErr Nothing verbosity powercap + <$> prepareDaemon stdOut stdErr Nothing verbosity powercap vars Test t stdOut stdErr -> (\i -> Just (Daemon, i)) - <$> prepareDaemon stdOut stdErr (Just t) Verbose powercap + <$> prepareDaemon stdOut stdErr (Just t) Verbose powercap vars let milist :: [Maybe (StackI, Instrumentation)] milist = diff --git a/src/Argo/Utils.hs b/src/Argo/Utils.hs index d47bfbd852a19591491f3368e9cf22606138f5a2..db9de32ce4550393f419d09d91bf822595126a21 100644 --- a/src/Argo/Utils.hs +++ b/src/Argo/Utils.hs @@ -181,13 +181,17 @@ untilMatch msg sawTraceback = await >>= \case Nothing -> return Clean configureConduits - :: WorkingDirectory -> ProcessConfig () () () + :: WorkingDirectory + -> ProcessConfig () () () -> ProcessConfig () (ConduitM () ByteString IO ()) (ConduitM () ByteString IO ()) configureConduits (WorkingDirectory wd) p = - setStdout createSource $ setStderr createSource $ setStdin closed $ setWorkingDir (toS wd) p + setStdout createSource + $ setStderr createSource + $ setStdin closed + $ setWorkingDir (toS wd) p withConduitSinks :: Text @@ -206,19 +210,27 @@ withSinkFileNoBuffering filepath inner = run $ inner $ sinkHandle h runI - :: WorkingDirectory -> Instrumentation + :: WorkingDirectory + -> Instrumentation -> IO (Either MonitoringResult (ExitCode, TracebackScan, TracebackScan)) -runI workDir (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = - try $ withConduitSinks stdOut stdErr $ \outSink errSink -> - withProcess (configureConduits workDir crProc) $ \p -> - withAsyncConduitsOnProcess p outSink outTest errSink errTest waitEither - >>= \case - Left Clean -> (, Clean, Clean) <$> waitExitCode p - Right Clean -> (, Clean, Clean) <$> waitExitCode p - Right WarningTraceback -> - (, Clean, WarningTraceback) <$> waitExitCode p - Left WarningTraceback -> - (, WarningTraceback, Clean) <$> waitExitCode p +runI workDir@(WorkingDirectory wd) (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) + = try + $ withConduitSinks (wd <> "/" <> stdOut) (wd <> "/" <> stdErr) + $ \outSink errSink -> + withProcess (configureConduits workDir crProc) $ \p -> + withAsyncConduitsOnProcess p + outSink + outTest + errSink + errTest + waitEither + >>= \case + Left Clean -> (, Clean, Clean) <$> waitExitCode p + Right Clean -> (, Clean, Clean) <$> waitExitCode p + Right WarningTraceback -> + (, Clean, WarningTraceback) <$> waitExitCode p + Left WarningTraceback -> + (, WarningTraceback, Clean) <$> waitExitCode p where outTest :: Maybe TextBehavior errTest :: Maybe TextBehavior @@ -227,7 +239,6 @@ runI workDir (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = (Just tOut, Just tErr) Nothing -> (Nothing, Nothing) - processBehaviorToI :: ProcessConfig () () () -> ProcessBehavior -> Maybe Instrumentation processBehaviorToI crProc = \case