Commit dc3d0f7f authored by Valentin Reis's avatar Valentin Reis

[refactor] split out types, apply warnings. adds --powercap option.

parent 83ada183
Pipeline #5817 failed with stage
in 2 minutes and 10 seconds
...@@ -10,9 +10,11 @@ module Argo ...@@ -10,9 +10,11 @@ module Argo
( module Argo.Stack ( module Argo.Stack
, module Argo.Args , module Argo.Args
, module Argo.Utils , module Argo.Utils
, module Argo.Types
) )
where where
import Argo.Stack import Argo.Stack
import Argo.Utils import Argo.Utils
import Argo.Args import Argo.Args
import Argo.Types
{-# language OverloadedStrings #-} {-# language OverloadedStrings #-}
{-# language ApplicativeDo #-} {-# language ApplicativeDo #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language RecordWildCards #-} {-# language RecordWildCards #-}
module Argo.Args module Argo.Args
( StdOutLog(..) ( parseExtendStackArgs
, StdErrLog(..)
, TestText(..)
, ProcessBehavior(..)
, TextBehavior(..)
, TextBehaviorStdout(..)
, TextBehaviorStderr(..)
, WorkingDirectory(..)
, Verbosity(..)
, AppName(..)
, AppArg(..)
, ContainerName(..)
, ShareDir(..)
, ManifestName(..)
, StackArgs(..)
, PreludeCommand(..)
, HwThreadCount(..)
, parseExtendStackArgs
) )
where where
import Argo.Types
import Options.Applicative as OA import Options.Applicative as OA
import Options.Applicative.Types import Options.Applicative.Types
import Options.Applicative.Builder ( option ) import Options.Applicative.Builder ( option )
import Data.Default
import Data.Text as T
hiding ( empty )
import Turtle hiding ( option ) import Turtle hiding ( option )
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
{-| {-|
Module : Argo.Args Module : Argo.Args
Description : Argo stack library Description : Argo stack library
...@@ -43,72 +21,11 @@ License : MIT ...@@ -43,72 +21,11 @@ License : MIT
Maintainer : fre@freux.fr Maintainer : fre@freux.fr
-} -}
data StackArgs = StackArgs
{ verbosity :: Verbosity
, app :: AppName
, args :: [AppArg]
, containerName :: ContainerName
, workingDirectory :: WorkingDirectory
, shareDir :: ShareDir
, manifestName :: ManifestName
, preludeCommand :: PreludeCommand
, daemon
, cmdrun
, cmdlisten
, cmdlistenprogress
, cmdlistenperformance
, cmdlistenpower :: ProcessBehavior
, hwThreadCount :: HwThreadCount
} deriving (Show)
{-data OutputFiles = OutputFiles FilePath FilePath-}
data Verbosity = Normal | Verbose deriving (Show, Read, Eq)
newtype HwThreadCount = HwThreadCount Int deriving (Show, Read, Eq)
newtype AppArg = AppArg Text deriving (IsString, 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 ShareDir = ShareDir FilePath deriving (IsString, Show)
newtype ManifestName = ManifestName FilePath deriving (IsString, Show)
newtype PreludeCommand = PreludeCommand Text deriving (IsString, Show, Read)
data ProcessBehavior =
Test TestText StdOutLog StdErrLog
| JustRun StdOutLog StdErrLog
| DontRun deriving (Show,Read)
newtype StdOutLog = StdOutLog Text deriving (Show, Read)
newtype StdErrLog = StdErrLog Text deriving (Show, Read)
data TestText = TestText TextBehaviorStdout TextBehaviorStderr deriving (Show, Read)
newtype TextBehaviorStdout = TextBehaviorStdout TextBehavior deriving (Show, Read)
newtype TextBehaviorStderr = TextBehaviorStderr TextBehavior deriving (Show, Read)
data TextBehavior =
WaitFor Text
| ExpectClean deriving (Show,Read)
behavior :: ReadM ProcessBehavior behavior :: ReadM ProcessBehavior
behavior = read <$> readerAsk behavior = read <$> readerAsk
behaviorOption :: Mod OptionFields ProcessBehavior -> Parser ProcessBehavior behaviorOption :: Mod OptionFields ProcessBehavior -> Parser ProcessBehavior
behaviorOption = option behavior behaviorOption = option behavior
instance Default StackArgs where
def = StackArgs
{ verbosity = Normal
, app = AppName "ls"
, args = []
, containerName = ContainerName "testContainer"
, workingDirectory = WorkingDirectory "_output"
, shareDir = ShareDir "/tmp"
, manifestName = ManifestName "basic.json"
, preludeCommand = PreludeCommand ""
, daemon = DontRun
, cmdrun = DontRun
, cmdlisten = DontRun
, cmdlistenprogress = DontRun
, cmdlistenperformance = DontRun
, cmdlistenpower = DontRun
, hwThreadCount = HwThreadCount 1
}
parseExtendStackArgs :: StackArgs -> Parser StackArgs parseExtendStackArgs :: StackArgs -> Parser StackArgs
parseExtendStackArgs sa = do parseExtendStackArgs sa = do
verbosity <- flag verbosity <- flag
...@@ -207,6 +124,14 @@ parseExtendStackArgs sa = do ...@@ -207,6 +124,14 @@ parseExtendStackArgs sa = do
<> showDefault <> showDefault
<> value (hwThreadCount sa) <> value (hwThreadCount sa)
) )
powercap <- option
auto
( long "powercap"
<> metavar "POWERCAP"
<> help "Powercap strategy: Fixed x | None | Adaptive"
<> showDefault
<> value (powercap sa)
)
args <- some (argument str (metavar "ARGS" <> help "Application arguments.")) args <- some (argument str (metavar "ARGS" <> help "Application arguments."))
<|> pure (args sa) <|> pure (args sa)
pure StackArgs {..} pure StackArgs {..}
...@@ -18,7 +18,7 @@ module Argo.Stack ...@@ -18,7 +18,7 @@ module Argo.Stack
) )
where where
import Argo.Args import Argo.Types
import Data.Coerce ( coerce ) import Data.Coerce ( coerce )
import Turtle import Turtle
...@@ -57,15 +57,16 @@ prepareDaemon ...@@ -57,15 +57,16 @@ prepareDaemon
-> StdErrLog -> StdErrLog
-> Maybe TestText -> Maybe TestText
-> Verbosity -> Verbosity
-> PowerCap
-> Shell Instrumentation -> Shell Instrumentation
prepareDaemon out stdErr test v = do prepareDaemon out stdErr test v powercap = do
_ <- myWhich "daemon" _ <- myWhich "daemon"
let confPath' = "/tmp/argo_nodeos_config" let confPath' = "/tmp/argo_nodeos_config"
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" (P.proc "daemon"
(["--nrm_log", "./nrm_log"] ++ [ "--verbose" | v == Verbose ]) (["--nrm_log", "./nrm_log"] ++ toOption v ++ toOption powercap)
) )
out out
stdErr stdErr
...@@ -105,16 +106,16 @@ prepareDaemon out stdErr test v = do ...@@ -105,16 +106,16 @@ prepareDaemon out stdErr test v = do
if len > 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, "
\at least not fast enough. Retrying.." <> "at least not fast enough. Retrying.."
liftIO $ sleep retryTime liftIO $ sleep retryTime
cleanContainers argo_nodeos_config cleanContainers argo_nodeos_config
(retryTime * 2) (retryTime * 2)
(remainingRetries - 1) (remainingRetries - 1)
else else
printInfo printInfo
"argo_nodeos_config successfully cleaned the container \ $ "argo_nodeos_config successfully cleaned the container "
\config." <> "config."
cmdRunI cmdRunI
:: AppName :: AppName
...@@ -198,9 +199,11 @@ runStack sa@StackArgs {..} = do ...@@ -198,9 +199,11 @@ runStack sa@StackArgs {..} = do
iDaemon <- case daemon of iDaemon <- case daemon of
DontRun -> return Nothing DontRun -> return Nothing
JustRun stdOut stdErr -> JustRun stdOut stdErr ->
(\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing verbosity (\i -> Just (Daemon, i))
<$> prepareDaemon stdOut stdErr Nothing verbosity powercap
Test t stdOut stdErr -> Test t stdOut stdErr ->
(\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t) Verbose (\i -> Just (Daemon, i))
<$> prepareDaemon stdOut stdErr (Just t) Verbose powercap
let milist = let milist =
[ iDaemon [ iDaemon
......
{-# language GeneralizedNewtypeDeriving #-}
{-# language OverloadedStrings #-}
module Argo.Types
( StdOutLog(..)
, StdErrLog(..)
, TestText(..)
, ProcessBehavior(..)
, TextBehavior(..)
, TextBehaviorStdout(..)
, TextBehaviorStderr(..)
, WorkingDirectory(..)
, Verbosity(..)
, AppName(..)
, AppArg(..)
, ContainerName(..)
, ShareDir(..)
, ManifestName(..)
, StackArgs(..)
, PreludeCommand(..)
, HwThreadCount(..)
, PowerCap(..)
, toOption
)
where
import Data.Default
import Data.Text as T
hiding ( empty )
import Turtle hiding ( option )
import Prelude hiding ( FilePath )
data StackArgs = StackArgs
{ verbosity :: Verbosity
, app :: AppName
, args :: [AppArg]
, containerName :: ContainerName
, workingDirectory :: WorkingDirectory
, shareDir :: ShareDir
, manifestName :: ManifestName
, preludeCommand :: PreludeCommand
, daemon
, cmdrun
, cmdlisten
, cmdlistenprogress
, cmdlistenperformance
, cmdlistenpower :: ProcessBehavior
, hwThreadCount :: HwThreadCount
, powercap :: PowerCap
} deriving (Show)
{-data OutputFiles = OutputFiles FilePath FilePath-}
data Verbosity = Normal | Verbose deriving (Show, Read, Eq)
newtype HwThreadCount = HwThreadCount Int deriving (Show, Read, Eq)
newtype AppArg = AppArg Text deriving (IsString, 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 ShareDir = ShareDir FilePath deriving (IsString, Show)
newtype ManifestName = ManifestName FilePath deriving (IsString, Show)
newtype PreludeCommand = PreludeCommand Text deriving (IsString, Show, Read)
data ProcessBehavior =
Test TestText StdOutLog StdErrLog
| JustRun StdOutLog StdErrLog
| DontRun deriving (Show,Read)
newtype StdOutLog = StdOutLog Text deriving (Show, Read)
newtype StdErrLog = StdErrLog Text deriving (Show, Read)
data TestText = TestText TextBehaviorStdout TextBehaviorStderr deriving (Show, Read)
newtype TextBehaviorStdout = TextBehaviorStdout TextBehavior deriving (Show, Read)
newtype TextBehaviorStderr = TextBehaviorStderr TextBehavior deriving (Show, Read)
data TextBehavior =
WaitFor Text
| ExpectClean deriving (Show,Read)
data PowerCap = Fixed Int | Adaptive | None deriving (Show, Read)
class ToDaemonOption a where
toOption :: a -> [String]
instance ToDaemonOption Verbosity where
toOption Verbose = ["--verbose"]
toOption Normal = []
instance ToDaemonOption PowerCap where
toOption (Fixed i) = ["--powercap", show i]
toOption Adaptive = []
toOption None = []
instance Default StackArgs where
def = StackArgs
{ verbosity = Normal
, app = AppName "ls"
, args = []
, containerName = ContainerName "testContainer"
, workingDirectory = WorkingDirectory "_output"
, shareDir = ShareDir "/tmp"
, manifestName = ManifestName "basic.json"
, preludeCommand = PreludeCommand ""
, daemon = DontRun
, cmdrun = DontRun
, cmdlisten = DontRun
, cmdlistenprogress = DontRun
, cmdlistenperformance = DontRun
, cmdlistenpower = DontRun
, hwThreadCount = HwThreadCount 1
, powercap = None
}
...@@ -31,7 +31,7 @@ module Argo.Utils ...@@ -31,7 +31,7 @@ module Argo.Utils
) )
where where
import Argo.Args import Argo.Types
import Turtle import Turtle
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
import System.Console.ANSI import System.Console.ANSI
......
...@@ -12,6 +12,7 @@ Maintainer : fre@freux.fr ...@@ -12,6 +12,7 @@ Maintainer : fre@freux.fr
import Data.Coerce ( coerce ) import Data.Coerce ( coerce )
import Argo.Stack import Argo.Stack
import Argo.Utils import Argo.Utils
import Argo.Types
import Argo.Args import Argo.Args
import Turtle import Turtle
import Prelude hiding ( FilePath ) import Prelude hiding ( FilePath )
...@@ -65,10 +66,7 @@ instance Default TestSpec where ...@@ -65,10 +66,7 @@ instance Default TestSpec where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
mkRun :: (StackArgs -> StackArgs) -> Text -> TestSpec mkRun :: (StackArgs -> StackArgs) -> Text -> TestSpec
mkRun updater description = TestSpec mkRun updater description = TestSpec {stackArgsUpdate = updater . runAppSA, ..}
{ stackArgsUpdate = updater . runAppSA
, ..
}
where where
isTest = NotTest isTest = NotTest
runAppSA sa = sa { manifestName = "parallel.json" runAppSA sa = sa { manifestName = "parallel.json"
...@@ -178,8 +176,7 @@ configureTest TestPower = TestSpec ...@@ -178,8 +176,7 @@ configureTest TestPower = TestSpec
configureTest TestSTREAM = configureTest TestSTREAM =
testProgressFromRun RunSTREAM "Test STREAM progress reports." testProgressFromRun RunSTREAM "Test STREAM progress reports."
configureTest TestAMG = configureTest TestAMG = testProgressFromRun RunAMG "Test AMG progress reports."
testProgressFromRun RunAMG "Test AMG progress reports."
configureTest TestQMCPack = configureTest TestQMCPack =
testProgressFromRun RunQMCPack "Test QMCPack progress reports." testProgressFromRun RunQMCPack "Test QMCPack progress reports."
configureTest TestOpenMC = configureTest TestOpenMC =
...@@ -282,18 +279,18 @@ testProgressFromRun :: TestName -> Text -> TestSpec ...@@ -282,18 +279,18 @@ testProgressFromRun :: TestName -> Text -> TestSpec
testProgressFromRun = testFromRun updater testProgressFromRun = testFromRun updater
where where
updater sa = sa updater sa = sa
{ cmdlistenprogress = Test { cmdlistenprogress = Test
(TestText (TestText
(TextBehaviorStdout (WaitFor "progress")) (TextBehaviorStdout (WaitFor "progress"))
(TextBehaviorStderr ExpectClean) (TextBehaviorStderr ExpectClean)
) )
(StdOutLog "progress_stdout.csv") (StdOutLog "progress_stdout.csv")
(StdErrLog "progress_stderr.log") (StdErrLog "progress_stderr.log")
, cmdlistenpower = DontRun , cmdlistenpower = DontRun
, cmdlisten = DontRun , cmdlisten = DontRun
, cmdlistenperformance = DontRun , cmdlistenperformance = DontRun
, manifestName = "basic.json" , manifestName = "basic.json"
, hwThreadCount = HwThreadCount 2 , hwThreadCount = HwThreadCount 2
} }
-- parsing and building the shell monad -- parsing and building the shell monad
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment