Commit 2a4f8320 authored by Valentin Reis's avatar Valentin Reis
Browse files

refactoring to protolude.

parent 73c9d00c
Pipeline #6105 failed with stages
in 1 minute and 34 seconds
...@@ -18,7 +18,10 @@ executable argotk ...@@ -18,7 +18,10 @@ executable argotk
-- other-extensions: -- other-extensions:
build-depends: build-depends:
base, base,
protolude,
shake, shake,
directory,
typed-process,
turtle, turtle,
data-default, data-default,
async, async,
......
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
"name": "argo/container", "name": "argo/container",
"value": { "value": {
"cpus": "48", "cpus": "48",
"mems": "1" "mems": "2"
} }
}, },
{ {
......
{-# language TupleSections #-} {-# language TupleSections #-}
{-# language FlexibleContexts #-}
{-# language LambdaCase #-} {-# language LambdaCase #-}
{-# language RecordWildCards #-} {-# language RecordWildCards #-}
{-# language NoImplicitPrelude #-}
{-# language OverloadedStrings #-} {-# language OverloadedStrings #-}
{-| {-|
...@@ -28,12 +30,11 @@ module Argo.Stack ...@@ -28,12 +30,11 @@ module Argo.Stack
) )
where where
import Protolude
import qualified Prelude ( show )
import Argo.Types import Argo.Types
import Data.Coerce ( coerce ) import Data.Coerce ( coerce )
import Prelude hiding ( FilePath )
import Turtle
import Turtle.Shell
import Filesystem.Path ( (</>) ) import Filesystem.Path ( (</>) )
...@@ -50,16 +51,24 @@ import Data.Maybe ...@@ -50,16 +51,24 @@ import Data.Maybe
import Data.Text as T import Data.Text as T
hiding ( empty ) hiding ( empty )
import Data.Traversable ( for ) import Data.Traversable ( for )
import System.Process as P {-import System.Process as P-}
hiding ( shell ) {-hiding ( shell )-}
import Text.Show.Pretty import Text.Show.Pretty
import System.Process.Typed ( readProcessStdout_
, runProcess_
, runProcess
, proc
, shell
, setEnv
)
import System.Directory
cleanLeftovers :: WorkingDirectory -> Shell () --TODO cleanLeftovers :: WorkingDirectory -> IO ()
cleanLeftovers (WorkingDirectory wd) = do cleanLeftovers (WorkingDirectory wd) = do
printInfo "Cleaning sockets." putText "Cleaning sockets."
for_ socklist cleanSocket for_ socklist cleanSocket
printInfo "Cleaning output directory." putText "Cleaning output directory."
void $ shell (format ("rm -rf " % fp) wd) Turtle.empty runProcess_ (shell $ toS $ "rm -rf " <> wd)
where where
socklist = socklist =
[ "/tmp/nrm-downstream-in" [ "/tmp/nrm-downstream-in"
...@@ -74,36 +83,36 @@ prepareDaemon ...@@ -74,36 +83,36 @@ prepareDaemon
-> Maybe TestText -> Maybe TestText
-> Verbosity -> Verbosity
-> PowerCap -> PowerCap
-> Shell Instrumentation -> IO Instrumentation
prepareDaemon out stdErr test v powercap = do prepareDaemon out stdErr test v powercap = do
let confPath' = "/tmp/argo_nodeos_config" let confPath' = "/tmp/argo_nodeos_config"
cleanContainers confPath' cleanContainers confPath'
export "ARGO_NODEOS_CONFIG" (format fp confPath')
return $ Instrumentation return $ Instrumentation
(P.proc "daemon" ( setEnv [("ARGO_NODEOS_CONFIG", toS confPath')]
(["--nrm_log", "./nrm_log"] ++ toOption v ++ toOption powercap) $ proc "daemon"
$ toS
<$> ["--nrm_log", "./nrm_log"]
++ toOption v
++ toOption powercap
) )
out out
stdErr stdErr
test test
where where
nodeOsFailure n = do nodeOsFailure n = do
printError ("argo_nodeos_config failed with exit code :" <> repr n) printError $ "argo_nodeos_config failed with exit code :" <> show n
testfile ".argo_nodeos_config_exit_message" >>= \case doesFileExist ".argo_nodeos_config_exit_message" >>= \case
True -> do True ->
printInfo "Contents of .argo_nodeos_config_exit_message: " putText "Contents of .argo_nodeos_config_exit_message: "
view $ input ".argo_nodeos_config_exit_message" *> (readFile ".argo_nodeos_config_exit_message" >>= print)
False -> die ("argo_nodeos_config failed with exit code " <> repr n) False -> die ("argo_nodeos_config failed with exit code " <> show n)
cleanContainers :: FilePath -> Shell () cleanContainers :: FilePath -> IO ()
cleanContainers argo_nodeos_config = cleanContainers argo_nodeos_config =
verboseShell' runProcess
(format ("sudo " % fp % " --clean_config=kill_content:true") (proc "sudo" [argo_nodeos_config, "--clean_config=kill_content:true"])
argo_nodeos_config
)
empty
>>= \case >>= \case
(ExitFailure n, _, _) -> nodeOsFailure n ExitFailure n -> nodeOsFailure n
(ExitSuccess , _, _) -> return () ExitSuccess -> return ()
cmdRunI cmdRunI
:: AppName :: AppName
...@@ -115,33 +124,28 @@ cmdRunI ...@@ -115,33 +124,28 @@ cmdRunI
-> ProcessBehavior -> ProcessBehavior
-> Maybe (StackI, Instrumentation) -> Maybe (StackI, Instrumentation)
cmdRunI (AppName app) args (ContainerName cn) (ShareDir md) (ManifestName mn) vars pb cmdRunI (AppName app) args (ContainerName cn) (ShareDir md) (ManifestName mn) vars pb
= Just (Run, ) <*> processBehaviorToI (pp { P.env = Just $ cast <$> vars }) pb = Just (Run, ) <*> processBehaviorToI (setEnv (cast <$> vars) pp) pb
where where
argToText (AppArg a) = a argToText (AppArg a) = a
cast :: (EnvVar, Text) -> (String, String) cast (EnvVar v, y) = (toS v, toS y)
cast (EnvVar v, y) = (T.unpack v, T.unpack y)
pp = pp =
P.proc "cmd" proc "cmd"
$ [ "run" $ toS
, "-u" <$> ["run", "-u", cn, md <> "manifests" <> "/" <> mn, app]
, T.unpack cn ++ fmap argToText args
, encodeString $ md <> "manifests" </> mn
, T.unpack app
]
++ fmap (T.unpack . argToText) args
cmdListenI cmdListenI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation) :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenI (ContainerName cn) pb = cmdListenI (ContainerName cn) pb =
Just (Listen, ) Just (Listen, )
<*> processBehaviorToI (P.proc "cmd" ["listen", "-u", T.unpack cn]) pb <*> processBehaviorToI (proc "cmd" ["listen", "-u", T.unpack cn]) pb
cmdListenProgressI cmdListenProgressI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation) :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenProgressI (ContainerName cn) pb = cmdListenProgressI (ContainerName cn) pb =
Just (Progress, ) Just (Progress, )
<*> processBehaviorToI <*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"]) (proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
pb pb
cmdListenPerformanceI cmdListenPerformanceI
...@@ -149,8 +153,7 @@ cmdListenPerformanceI ...@@ -149,8 +153,7 @@ cmdListenPerformanceI
cmdListenPerformanceI (ContainerName cn) pb = cmdListenPerformanceI (ContainerName cn) pb =
Just (Performance, ) Just (Performance, )
<*> processBehaviorToI <*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"] (proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"])
)
pb pb
cmdListenPowerI cmdListenPowerI
...@@ -158,7 +161,7 @@ cmdListenPowerI ...@@ -158,7 +161,7 @@ cmdListenPowerI
cmdListenPowerI (ContainerName cn) pb = cmdListenPowerI (ContainerName cn) pb =
Just (Power, ) Just (Power, )
<*> processBehaviorToI <*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"]) (proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
pb pb
data StackOutput = data StackOutput =
...@@ -179,19 +182,25 @@ instance Show StackI where ...@@ -179,19 +182,25 @@ instance Show StackI where
Power -> "cmd listen -f power" Power -> "cmd listen -f power"
Performance -> "cmd listen -f performance" Performance -> "cmd listen -f performance"
runStack :: StackArgs -> Shell StackOutput runStack :: StackArgs -> IO StackOutput
runStack sa@StackArgs {..} = do runStack sa@StackArgs {..} = do
let (WorkingDirectory wd) = workingDirectory
when verbose $ liftIO $ pPrint sa when verbose $ liftIO $ pPrint sa
when (powercap /= None) $ do when (powercap /= None) $ do
user <- lineToText <$> single (inproc "whoami" [] empty) user <- readProcessStdout_ (proc "whoami" [])
chownPowercapFiles user for_
"/sys/devices/virtual/powercap/intel-rapl/intel-rapl:0" [0, 1]
chownPowercapFiles user ( chownPowercapFiles (toS user)
"/sys/devices/virtual/powercap/intel-rapl/intel-rapl:1" . ("/sys/devices/virtual/powercap/intel-rapl/intel-rapl:" <>)
)
cleanLeftovers workingDirectory cleanLeftovers workingDirectory
mapM_ ($ coerce workingDirectory) [mktree, cd]
runProcess (proc "mkdir" ["-p", toS wd]) >>= \case
ExitFailure n -> die $ "couldn't create " <> wd
ExitSuccess -> return ()
iDaemon <- case daemon of iDaemon <- case daemon of
DontRun -> return Nothing DontRun -> return Nothing
...@@ -202,7 +211,8 @@ runStack sa@StackArgs {..} = do ...@@ -202,7 +211,8 @@ runStack sa@StackArgs {..} = do
(\i -> Just (Daemon, i)) (\i -> Just (Daemon, i))
<$> prepareDaemon stdOut stdErr (Just t) Verbose powercap <$> prepareDaemon stdOut stdErr (Just t) Verbose powercap
let milist = let milist :: [Maybe (StackI, Instrumentation)]
milist =
[ iDaemon [ iDaemon
, cmdRunI app args containerName shareDir manifestName vars cmdrun , cmdRunI app args containerName shareDir manifestName vars cmdrun
, cmdListenI containerName cmdlisten , cmdListenI containerName cmdlisten
...@@ -213,23 +223,23 @@ runStack sa@StackArgs {..} = do ...@@ -213,23 +223,23 @@ runStack sa@StackArgs {..} = do
ilist = catMaybes milist ilist = catMaybes milist
_ <- shell (coerce preludeCommand :: Text) empty >>= \case _ <- shell (coerce preludeCommand :: Text) empty >>= \case
ExitSuccess -> when verbose ExitSuccess ->
$ printInfo ("Executed preludeCommand." <> repr preludeCommand) when verbose $ putText ("Executed preludeCommand." <> repr preludeCommand)
ExitFailure _ -> ExitFailure _ ->
die ("failed to execute preludeCommand." <> repr preludeCommand) die ("failed to execute preludeCommand." <> repr preludeCommand)
when verbose $ do when verbose $ do
printInfo "Starting the following processes:" putText "Starting the following processes:"
liftIO $ pPrint ilist liftIO $ pPrint ilist
asyncs <- liftIO $ for ilist tupleToAsync asyncs <- liftIO $ for ilist tupleToAsync
_ <- liftIO $ kbInstallHandler $ for_ asyncs cancel _ <- liftIO $ kbInstallHandler $ for_ asyncs cancel
when verbose $ printInfo "Processes started." when verbose $ putText "Processes started."
out <- liftIO $ waitAnyCancel asyncs out <- liftIO $ waitAnyCancel asyncs
printInfo putText
( "Processes cancelled due to termination of: " ( "Processes cancelled due to termination of: "
<> repr (fst $ snd out) <> repr (fst $ snd out)
<> " with exit information: " <> " with exit information: "
...@@ -258,28 +268,24 @@ runStack sa@StackArgs {..} = do ...@@ -258,28 +268,24 @@ runStack sa@StackArgs {..} = do
ExitSuccess -> printWarning $ "changed ownership on " <> fn ExitSuccess -> printWarning $ "changed ownership on " <> fn
ExitFailure _ -> die $ "Couldn't change ownership on " <> fn ExitFailure _ -> die $ "Couldn't change ownership on " <> fn
chownPowercapFiles :: Text -> Text -> IO ()
chownPowercapFiles user p = chownPowercapFiles user p =
chownPowercap user (p <> "/constraint_1_power_limit_uw") chownPowercap user (p <> "/constraint_1_power_limit_uw")
<> chownPowercap user (p <> "/constraint_0_power_limit_uw") <> chownPowercap user (p <> "/constraint_0_power_limit_uw")
verbose = verbosity == Verbose verbose = verbosity == Verbose
procsWithTracebacks procsWithTracebacks
:: [(StackI, Instrumentation)] -> Shell [(StackI, Text, Text)] :: [(StackI, Instrumentation)] -> IO [(StackI, Text, Text)]
procsWithTracebacks ilist = fmap showOutputs <$> filterM (checkI . snd) ilist procsWithTracebacks ilist = fmap showOutputs <$> filterM (checkI . snd) ilist
showOutputs :: (StackI, Instrumentation) -> (StackI, Text, Text) showOutputs :: (StackI, Instrumentation) -> (StackI, Text, Text)
showOutputs (si, Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) = showOutputs (si, Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) =
(si, outlog, errlog) (si, outlog, errlog)
checkI :: Instrumentation -> Shell Bool checkI :: Instrumentation -> IO Bool
checkI (Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) = do checkI (Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) =
b <- liftIO $ Turtle.Shell.fold return $ test outlog || test errlog
(grep (has "Traceback") (input $ fromText outlog)) where test = isInfixOf "Traceback"
Fold.length
c <- liftIO $ Turtle.Shell.fold
(grep (has "Traceback") (input $ fromText errlog))
Fold.length
return $ (b > 0) || (c > 0)
tupleToAsync tupleToAsync
:: (StackI, Instrumentation) :: (StackI, Instrumentation)
...@@ -291,4 +297,5 @@ runStack sa@StackArgs {..} = do ...@@ -291,4 +297,5 @@ runStack sa@StackArgs {..} = do
(ExitCode, TracebackScan, TracebackScan) (ExitCode, TracebackScan, TracebackScan)
) )
) )
tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum tupleToAsync (stacki, instrum) =
async $ (stacki, ) <$> runI workingDirectory instrum
{-# language GeneralizedNewtypeDeriving #-} {-# language GeneralizedNewtypeDeriving #-}
{-# language OverloadedStrings #-} {-# language OverloadedStrings #-}
{-# language NoImplicitPrelude #-}
{-| {-|
Module : Argo.Types Module : Argo.Types
...@@ -36,8 +37,7 @@ where ...@@ -36,8 +37,7 @@ where
import Data.Default import Data.Default
import Data.Text as T import Data.Text as T
hiding ( empty ) hiding ( empty )
import Turtle hiding ( option ) import Protolude
import Prelude hiding ( FilePath )
data StackArgs = StackArgs data StackArgs = StackArgs
{ verbosity :: Verbosity { verbosity :: Verbosity
...@@ -59,16 +59,16 @@ data StackArgs = StackArgs ...@@ -59,16 +59,16 @@ data StackArgs = StackArgs
, powercap :: PowerCap , powercap :: PowerCap
} deriving (Show) } deriving (Show)
{-data OutputFiles = OutputFiles FilePath FilePath-} {-data OutputFiles = OutputFiles Text Text-}
data Verbosity = Normal | Verbose deriving (Show, Read, Eq) data Verbosity = Normal | Verbose deriving (Show, Read, Eq)
newtype EnvVar = EnvVar Text deriving (Show, Read) newtype EnvVar = EnvVar Text deriving (Show, Read)
newtype HwThreadCount = HwThreadCount Int deriving (Show, Read, Eq) newtype HwThreadCount = HwThreadCount Int deriving (Show, Read, Eq)
newtype AppArg = AppArg Text deriving (IsString, Show, Read) newtype AppArg = AppArg Text deriving (IsString, Show, Read)
newtype WorkingDirectory = WorkingDirectory FilePath deriving (IsString, Show) newtype WorkingDirectory = WorkingDirectory Text 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)
newtype ShareDir = ShareDir FilePath deriving (IsString, Show) newtype ShareDir = ShareDir Text deriving (IsString, Show)
newtype ManifestName = ManifestName FilePath deriving (IsString, Show) newtype ManifestName = ManifestName Text deriving (IsString, Show)
newtype PreludeCommand = PreludeCommand Text deriving (IsString, Show, Read) newtype PreludeCommand = PreludeCommand Text deriving (IsString, Show, Read)
data ProcessBehavior = data ProcessBehavior =
Test TestText StdOutLog StdErrLog Test TestText StdOutLog StdErrLog
...@@ -85,7 +85,7 @@ data TextBehavior = ...@@ -85,7 +85,7 @@ data TextBehavior =
data PowerCap = Fixed Int | Adaptive | None deriving (Show, Read, Eq) data PowerCap = Fixed Int | Adaptive | None deriving (Show, Read, Eq)
class ToDaemonOption a where class ToDaemonOption a where
toOption :: a -> [String] toOption :: a -> [Text]
instance ToDaemonOption Verbosity where instance ToDaemonOption Verbosity where
toOption Verbose = ["--verbose"] toOption Verbose = ["--verbose"]
......
{-# language LambdaCase #-} {-# language LambdaCase #-}
{-# language TupleSections #-}
{-# language OverloadedStrings #-} {-# language OverloadedStrings #-}
{-# language DataKinds #-} {-# language DataKinds #-}
{-# language FlexibleInstances #-} {-# language FlexibleInstances #-}
...@@ -19,7 +20,6 @@ module Argo.Utils ...@@ -19,7 +20,6 @@ module Argo.Utils
, printSuccess , printSuccess
, printError , printError
, printTest , printTest
, verboseShell'
, MonitoringResult(..) , MonitoringResult(..)
, Instrumentation(..) , Instrumentation(..)
, TracebackScan(..) , TracebackScan(..)
...@@ -31,19 +31,21 @@ module Argo.Utils ...@@ -31,19 +31,21 @@ module Argo.Utils
) )
where where
import Protolude
import Argo.Types import Argo.Types
import System.Exit ( ExitCode(..) )
import Data.ByteString as B import Data.ByteString as B
hiding ( empty ) hiding ( empty )
import Data.Conduit import Data.Conduit
import Data.Conduit.Process hiding ( shell ) import Data.Conduit.Combinators as CC
import Prelude hiding ( FilePath ) import Prelude hiding ( Text )
import System.Console.ANSI import System.Console.ANSI
import System.Console.ANSI.Types ( Color ) import System.Console.ANSI.Types ( Color )
import System.Posix.Signals ( installHandler import System.Posix.Signals ( installHandler
, keyboardSignal , keyboardSignal
, Handler(..) , Handler(..)
) )
import Turtle import System.Directory
import Control.Exception.Base ( Exception import Control.Exception.Base ( Exception
, try , try
...@@ -52,10 +54,6 @@ import Control.Exception.Base ( Exception ...@@ -52,10 +54,6 @@ import Control.Exception.Base ( Exception
import Control.Monad.IO.Unlift ( MonadIO(..) import Control.Monad.IO.Unlift ( MonadIO(..)
, withRunInIO , withRunInIO
) )
import Data.Conduit.Combinators as CC
( sinkHandle
, withSinkFile
)
import Data.Text as T import Data.Text as T
( unpack ( unpack
, Text , Text
...@@ -69,60 +67,59 @@ import System.IO ( BufferMode(NoBuffering) ...@@ -69,60 +67,59 @@ import System.IO ( BufferMode(NoBuffering)
, hSetBuffering , hSetBuffering
) )
import qualified System.IO as IO import qualified System.IO as IO
import Data.Conduit.Process.Typed
import Data.Conduit.Binary as CB
-- | Miscellaneous printing utilities -- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell () colorShell :: Color -> IO () -> IO ()
colorShell color she = setC color *> she *> 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 -> IO ()
printCommand :: Text -> Shell () printCommand :: Text -> IO ()
printError :: Text -> Shell () printError :: Text -> IO ()
printWarning :: Text -> Shell () printWarning :: Text -> IO ()
printSuccess :: Text -> Shell () printSuccess :: Text -> IO ()
printTest :: Text -> Shell () printTest :: Text -> IO ()
printInfo = printf ("info: " % s % "\n") printInfo s = putText $ "info: " <> s <> "\n"
printCommand = printf ("running: " % s % "\n") printCommand s = putText $ "running: " <> s <> "\n"
printWarning = colorShell Yellow . printf ("warning: " % s % "\n") printWarning s = colorShell Yellow $ putText $ "warning: " <> s <> "\n"
printError = colorShell Red . printf ("error: " % s % "\n") printError s = colorShell Red $ putText $ "error: " <> s <> "\n"
printSuccess = colorShell Green . printf ("success: " % s % "\n") printSuccess s = colorShell Green $ putText $ "success: " <> s <> "\n"
printTest = colorShell Green . printf ("running stack: " % s % "\n") printTest s = colorShell Green $ putText $ "running stack: " <> s <> "\n"
myWhich :: FilePath -> Shell FilePath myWhich :: Text -> IO Text
myWhich str = which str >>= \case myWhich str =
(Just p) -> (toS <$> readProcessStdout_ (shell $ toS $ "which " <> str)) >>= \case
printInfo (format ("Found " % fp % " at " % fp) str p) >> return p "" -> die $ "Argo `" <> str <> "` not in $PATH."
Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str p -> printInfo ("Found " <> str <> " at " <> p) $> p
sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell () sudoRemoveFile :: (Text -> IO ()) -> Text -> Text -> IO ()
sudoRemoveFile printer desc filePath = do sudoRemoveFile printer desc filePath = do
foundSocket <- testfile filePath