From 83ada18319e1be5648370e79cb1a829d4cb3ce93 Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Mon, 4 Mar 2019 16:51:19 -0600 Subject: [PATCH] Refactor -> prepare for adding --powercap option --- src/Argo/Args.hs | 27 +++++++++++++++++++++++++-- src/Argo/Stack.hs | 23 +++++++++++++---------- src/Argo/Utils.hs | 42 ++++++++++++++++++++++++------------------ 3 files changed, 62 insertions(+), 30 deletions(-) diff --git a/src/Argo/Args.hs b/src/Argo/Args.hs index 155fbe5..3527a14 100644 --- a/src/Argo/Args.hs +++ b/src/Argo/Args.hs @@ -1,6 +1,29 @@ -{-# LANGUAGE OverloadedStrings, ApplicativeDo, GeneralizedNewtypeDeriving, RecordWildCards #-} +{-# language OverloadedStrings #-} +{-# language ApplicativeDo #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language RecordWildCards #-} -module Argo.Args where +module Argo.Args + ( StdOutLog(..) + , StdErrLog(..) + , TestText(..) + , ProcessBehavior(..) + , TextBehavior(..) + , TextBehaviorStdout(..) + , TextBehaviorStderr(..) + , WorkingDirectory(..) + , Verbosity(..) + , AppName(..) + , AppArg(..) + , ContainerName(..) + , ShareDir(..) + , ManifestName(..) + , StackArgs(..) + , PreludeCommand(..) + , HwThreadCount(..) + , parseExtendStackArgs + ) +where import Options.Applicative as OA import Options.Applicative.Types diff --git a/src/Argo/Stack.hs b/src/Argo/Stack.hs index f024c62..3cd0609 100644 --- a/src/Argo/Stack.hs +++ b/src/Argo/Stack.hs @@ -1,5 +1,4 @@ {-# language TupleSections #-} -{-# language ViewPatterns #-} {-# language LambdaCase #-} {-# language RecordWildCards #-} {-# language OverloadedStrings #-} @@ -12,7 +11,13 @@ License : MIT Maintainer : fre@freux.fr -} -module Argo.Stack where +module Argo.Stack + ( StackOutput(..) + , cleanLeftovers + , runStack + ) +where + import Argo.Args import Data.Coerce ( coerce ) @@ -59,11 +64,8 @@ prepareDaemon out stdErr test v = do cleanContainers confPath' 1 2 export "ARGO_NODEOS_CONFIG" (format fp confPath') return $ Instrumentation - (P.proc - "daemon" - ( ["--nrm_log", "./nrm_log"] - ++ (if (v == Verbose) then ["--verbose"] else []) - ) + (P.proc "daemon" + (["--nrm_log", "./nrm_log"] ++ [ "--verbose" | v == Verbose ]) ) out stdErr @@ -187,16 +189,16 @@ instance Show StackI where Performance -> "cmd listen -f performance" runStack :: StackArgs -> Shell StackOutput -runStack sa@StackArgs { verbosity = (==Verbose) -> verbose, ..} = do +runStack sa@StackArgs {..} = do when verbose $ liftIO $ pPrint sa cleanLeftovers workingDirectory - CM.mapM_ ($ (coerce workingDirectory)) [mktree, cd] + CM.mapM_ ($ coerce workingDirectory) [mktree, cd] iDaemon <- case daemon of DontRun -> return Nothing JustRun stdOut stdErr -> - (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing (verbosity sa) + (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing verbosity Test t stdOut stdErr -> (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t) Verbose @@ -250,6 +252,7 @@ runStack sa@StackArgs { verbosity = (==Verbose) -> verbose, ..} = do cd "../" return r where + verbose = verbosity == Verbose procsWithTracebacks :: [(StackI, Instrumentation)] -> Shell [(StackI, Text, Text)] procsWithTracebacks ilist = fmap showOutputs <$> filterM (checkI . snd) ilist diff --git a/src/Argo/Utils.hs b/src/Argo/Utils.hs index acae79d..954c20c 100644 --- a/src/Argo/Utils.hs +++ b/src/Argo/Utils.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE LambdaCase, OverloadedStrings, DataKinds, - FlexibleInstances, ScopedTypeVariables, TypeOperators #-} +{-# language LambdaCase #-} +{-# language OverloadedStrings #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language ScopedTypeVariables #-} +{-# language TypeOperators #-} {-| Module : Argo.Utils @@ -9,7 +13,23 @@ License : MIT Maintainer : fre@freux.fr -} -module Argo.Utils where +module Argo.Utils + ( printInfo + , printWarning + , printSuccess + , printError + , printTest + , verboseShell' + , MonitoringResult(..) + , Instrumentation(..) + , TracebackScan(..) + , processBehaviorToI + , kbInstallHandler + , runI + , cleanSocket + , myWhich + ) +where import Argo.Args import Turtle @@ -47,7 +67,6 @@ printError :: Text -> Shell () printWarning :: Text -> Shell () printSuccess :: Text -> Shell () printTest :: Text -> Shell () -dieRed :: Text -> Shell () printInfo = printf ("Info: " % s % "\n") printCommand = printf ("Running: " % s % "\n") @@ -55,8 +74,6 @@ printWarning = colorShell Yellow . printf ("Warning: " % s % "\n") printError = colorShell Red . printf ("Error: " % s % "\n") printSuccess = colorShell Green . printf ("Success: " % s % "\n") printTest = colorShell Green . printf ("RUNNING TEST: " % s % "\n") -dieRed str = - colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1) myWhich :: FilePath -> Shell FilePath myWhich str = which str >>= \case @@ -64,12 +81,6 @@ myWhich str = which str >>= \case printInfo (format ("Found " % fp % " at " % fp) str p) >> return p Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str -myWhichMaybe :: FilePath -> Shell (Maybe FilePath) -myWhichMaybe str = which str >>= \case - (Just p) -> - printInfo (format ("Found " % fp % " at " % fp) str p) >> return (Just p) - Nothing -> return Nothing - sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell () sudoRemoveFile printer desc filePath = do foundSocket <- testfile filePath @@ -93,16 +104,11 @@ sudoRemoveFile printer desc filePath = do desc go True -verboseShell :: Text -> Shell Line -> Shell ExitCode -verboseShell command i = printCommand command >> shell command i - verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text) verboseShell' command i = printCommand command >> shellStrictWithErr command i cleanSocket :: FilePath -> Shell () cleanSocket = sudoRemoveFile printWarning "socket" -cleanLog :: FilePath -> Shell () -cleanLog = sudoRemoveFile printWarning "log folder" kbInstallHandler :: IO () -> IO Handler kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing @@ -142,7 +148,7 @@ runI (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = try warnOnTraceback :: Bool -> ConduitT ByteString ByteString IO TracebackScan warnOnTraceback sawTraceback = await >>= \case Just b | B.isInfixOf "Traceback" b -> yield b >> warnOnTraceback True - | otherwise -> yield b >> warnOnTraceback sawTraceback + | otherwise -> yield b >> warnOnTraceback sawTraceback Nothing -> if sawTraceback then return WarningTraceback else return Clean untilMatch :: Text -> Bool -> ConduitT ByteString ByteString IO TracebackScan -- 2.26.2