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
-- other-extensions:
build-depends:
base,
protolude,
shake,
directory,
typed-process,
turtle,
data-default,
async,
......
......@@ -15,7 +15,7 @@
"name": "argo/container",
"value": {
"cpus": "48",
"mems": "1"
"mems": "2"
}
},
{
......
{-# language TupleSections #-}
{-# language FlexibleContexts #-}
{-# language LambdaCase #-}
{-# language RecordWildCards #-}
{-# language NoImplicitPrelude #-}
{-# language OverloadedStrings #-}
{-|
......@@ -28,12 +30,11 @@ module Argo.Stack
)
where
import Protolude
import qualified Prelude ( show )
import Argo.Types
import Data.Coerce ( coerce )
import Prelude hiding ( FilePath )
import Turtle
import Turtle.Shell
import Filesystem.Path ( (</>) )
......@@ -50,16 +51,24 @@ import Data.Maybe
import Data.Text as T
hiding ( empty )
import Data.Traversable ( for )
import System.Process as P
hiding ( shell )
{-import System.Process as P-}
{-hiding ( shell )-}
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
printInfo "Cleaning sockets."
putText "Cleaning sockets."
for_ socklist cleanSocket
printInfo "Cleaning output directory."
void $ shell (format ("rm -rf " % fp) wd) Turtle.empty
putText "Cleaning output directory."
runProcess_ (shell $ toS $ "rm -rf " <> wd)
where
socklist =
[ "/tmp/nrm-downstream-in"
......@@ -74,36 +83,36 @@ prepareDaemon
-> Maybe TestText
-> Verbosity
-> PowerCap
-> Shell Instrumentation
-> IO Instrumentation
prepareDaemon out stdErr test v powercap = do
let confPath' = "/tmp/argo_nodeos_config"
cleanContainers confPath'
export "ARGO_NODEOS_CONFIG" (format fp confPath')
return $ Instrumentation
(P.proc "daemon"
(["--nrm_log", "./nrm_log"] ++ toOption v ++ toOption powercap)
( setEnv [("ARGO_NODEOS_CONFIG", toS confPath')]
$ proc "daemon"
$ toS
<$> ["--nrm_log", "./nrm_log"]
++ toOption v
++ toOption powercap
)
out
stdErr
test
where
nodeOsFailure n = do
printError ("argo_nodeos_config failed with exit code :" <> repr n)
testfile ".argo_nodeos_config_exit_message" >>= \case
True -> do
printInfo "Contents of .argo_nodeos_config_exit_message: "
view $ input ".argo_nodeos_config_exit_message"
False -> die ("argo_nodeos_config failed with exit code " <> repr n)
cleanContainers :: FilePath -> Shell ()
printError $ "argo_nodeos_config failed with exit code :" <> show n
doesFileExist ".argo_nodeos_config_exit_message" >>= \case
True ->
putText "Contents of .argo_nodeos_config_exit_message: "
*> (readFile ".argo_nodeos_config_exit_message" >>= print)
False -> die ("argo_nodeos_config failed with exit code " <> show n)
cleanContainers :: FilePath -> IO ()
cleanContainers argo_nodeos_config =
verboseShell'
(format ("sudo " % fp % " --clean_config=kill_content:true")
argo_nodeos_config
)
empty
runProcess
(proc "sudo" [argo_nodeos_config, "--clean_config=kill_content:true"])
>>= \case
(ExitFailure n, _, _) -> nodeOsFailure n
(ExitSuccess , _, _) -> return ()
ExitFailure n -> nodeOsFailure n
ExitSuccess -> return ()
cmdRunI
:: AppName
......@@ -115,33 +124,28 @@ cmdRunI
-> ProcessBehavior
-> Maybe (StackI, Instrumentation)
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
argToText (AppArg a) = a
cast :: (EnvVar, Text) -> (String, String)
cast (EnvVar v, y) = (T.unpack v, T.unpack y)
cast (EnvVar v, y) = (toS v, toS y)
pp =
P.proc "cmd"
$ [ "run"
, "-u"
, T.unpack cn
, encodeString $ md <> "manifests" </> mn
, T.unpack app
]
++ fmap (T.unpack . argToText) args
proc "cmd"
$ toS
<$> ["run", "-u", cn, md <> "manifests" <> "/" <> mn, app]
++ fmap argToText args
cmdListenI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenI (ContainerName cn) pb =
Just (Listen, )
<*> processBehaviorToI (P.proc "cmd" ["listen", "-u", T.unpack cn]) pb
<*> processBehaviorToI (proc "cmd" ["listen", "-u", T.unpack cn]) pb
cmdListenProgressI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenProgressI (ContainerName cn) pb =
Just (Progress, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
(proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
pb
cmdListenPerformanceI
......@@ -149,8 +153,7 @@ cmdListenPerformanceI
cmdListenPerformanceI (ContainerName cn) pb =
Just (Performance, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"]
)
(proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"])
pb
cmdListenPowerI
......@@ -158,7 +161,7 @@ cmdListenPowerI
cmdListenPowerI (ContainerName cn) pb =
Just (Power, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
(proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
pb
data StackOutput =
......@@ -179,19 +182,25 @@ instance Show StackI where
Power -> "cmd listen -f power"
Performance -> "cmd listen -f performance"
runStack :: StackArgs -> Shell StackOutput
runStack :: StackArgs -> IO StackOutput
runStack sa@StackArgs {..} = do
let (WorkingDirectory wd) = workingDirectory
when verbose $ liftIO $ pPrint sa
when (powercap /= None) $ do
user <- lineToText <$> single (inproc "whoami" [] empty)
chownPowercapFiles user
"/sys/devices/virtual/powercap/intel-rapl/intel-rapl:0"
chownPowercapFiles user
"/sys/devices/virtual/powercap/intel-rapl/intel-rapl:1"
user <- readProcessStdout_ (proc "whoami" [])
for_
[0, 1]
( chownPowercapFiles (toS user)
. ("/sys/devices/virtual/powercap/intel-rapl/intel-rapl:" <>)
)
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
DontRun -> return Nothing
......@@ -202,7 +211,8 @@ runStack sa@StackArgs {..} = do
(\i -> Just (Daemon, i))
<$> prepareDaemon stdOut stdErr (Just t) Verbose powercap
let milist =
let milist :: [Maybe (StackI, Instrumentation)]
milist =
[ iDaemon
, cmdRunI app args containerName shareDir manifestName vars cmdrun
, cmdListenI containerName cmdlisten
......@@ -213,23 +223,23 @@ runStack sa@StackArgs {..} = do
ilist = catMaybes milist
_ <- shell (coerce preludeCommand :: Text) empty >>= \case
ExitSuccess -> when verbose
$ printInfo ("Executed preludeCommand." <> repr preludeCommand)
ExitSuccess ->
when verbose $ putText ("Executed preludeCommand." <> repr preludeCommand)
ExitFailure _ ->
die ("failed to execute preludeCommand." <> repr preludeCommand)
when verbose $ do
printInfo "Starting the following processes:"
putText "Starting the following processes:"
liftIO $ pPrint ilist
asyncs <- liftIO $ for ilist tupleToAsync
_ <- liftIO $ kbInstallHandler $ for_ asyncs cancel
when verbose $ printInfo "Processes started."
when verbose $ putText "Processes started."
out <- liftIO $ waitAnyCancel asyncs
printInfo
putText
( "Processes cancelled due to termination of: "
<> repr (fst $ snd out)
<> " with exit information: "
......@@ -258,28 +268,24 @@ runStack sa@StackArgs {..} = do
ExitSuccess -> printWarning $ "changed ownership on " <> fn
ExitFailure _ -> die $ "Couldn't change ownership on " <> fn
chownPowercapFiles :: Text -> Text -> IO ()
chownPowercapFiles user p =
chownPowercap user (p <> "/constraint_1_power_limit_uw")
<> chownPowercap user (p <> "/constraint_0_power_limit_uw")
verbose = verbosity == Verbose
procsWithTracebacks
:: [(StackI, Instrumentation)] -> Shell [(StackI, Text, Text)]
:: [(StackI, Instrumentation)] -> IO [(StackI, Text, Text)]
procsWithTracebacks ilist = fmap showOutputs <$> filterM (checkI . snd) ilist
showOutputs :: (StackI, Instrumentation) -> (StackI, Text, Text)
showOutputs (si, Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) =
(si, outlog, errlog)
checkI :: Instrumentation -> Shell Bool
checkI (Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) = do
b <- liftIO $ Turtle.Shell.fold
(grep (has "Traceback") (input $ fromText outlog))
Fold.length
c <- liftIO $ Turtle.Shell.fold
(grep (has "Traceback") (input $ fromText errlog))
Fold.length
return $ (b > 0) || (c > 0)
checkI :: Instrumentation -> IO Bool
checkI (Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) =
return $ test outlog || test errlog
where test = isInfixOf "Traceback"
tupleToAsync
:: (StackI, Instrumentation)
......@@ -291,4 +297,5 @@ runStack sa@StackArgs {..} = do
(ExitCode, TracebackScan, TracebackScan)
)
)
tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum
tupleToAsync (stacki, instrum) =
async $ (stacki, ) <$> runI workingDirectory instrum
{-# language GeneralizedNewtypeDeriving #-}
{-# language OverloadedStrings #-}
{-# language NoImplicitPrelude #-}
{-|
Module : Argo.Types
......@@ -36,8 +37,7 @@ where
import Data.Default
import Data.Text as T
hiding ( empty )
import Turtle hiding ( option )
import Prelude hiding ( FilePath )
import Protolude
data StackArgs = StackArgs
{ verbosity :: Verbosity
......@@ -59,16 +59,16 @@ data StackArgs = StackArgs
, powercap :: PowerCap
} deriving (Show)
{-data OutputFiles = OutputFiles FilePath FilePath-}
{-data OutputFiles = OutputFiles Text Text-}
data Verbosity = Normal | Verbose deriving (Show, Read, Eq)
newtype EnvVar = EnvVar Text deriving (Show, Read)
newtype HwThreadCount = HwThreadCount Int deriving (Show, Read, Eq)
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 ContainerName = ContainerName Text deriving (IsString, Show, Read)
newtype ShareDir = ShareDir FilePath deriving (IsString, Show)
newtype ManifestName = ManifestName FilePath deriving (IsString, Show)
newtype ShareDir = ShareDir Text deriving (IsString, Show)
newtype ManifestName = ManifestName Text deriving (IsString, Show)
newtype PreludeCommand = PreludeCommand Text deriving (IsString, Show, Read)
data ProcessBehavior =
Test TestText StdOutLog StdErrLog
......@@ -85,7 +85,7 @@ data TextBehavior =
data PowerCap = Fixed Int | Adaptive | None deriving (Show, Read, Eq)
class ToDaemonOption a where
toOption :: a -> [String]
toOption :: a -> [Text]
instance ToDaemonOption Verbosity where
toOption Verbose = ["--verbose"]
......
{-# language LambdaCase #-}
{-# language TupleSections #-}
{-# language OverloadedStrings #-}
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
......@@ -19,7 +20,6 @@ module Argo.Utils
, printSuccess
, printError
, printTest
, verboseShell'
, MonitoringResult(..)
, Instrumentation(..)
, TracebackScan(..)
......@@ -31,19 +31,21 @@ module Argo.Utils
)
where
import Protolude
import Argo.Types
import System.Exit ( ExitCode(..) )
import Data.ByteString as B
hiding ( empty )
import Data.Conduit
import Data.Conduit.Process hiding ( shell )
import Prelude hiding ( FilePath )
import Data.Conduit.Combinators as CC
import Prelude hiding ( Text )
import System.Console.ANSI
import System.Console.ANSI.Types ( Color )
import System.Posix.Signals ( installHandler
, keyboardSignal
, Handler(..)
)
import Turtle
import System.Directory
import Control.Exception.Base ( Exception
, try
......@@ -52,10 +54,6 @@ import Control.Exception.Base ( Exception
import Control.Monad.IO.Unlift ( MonadIO(..)
, withRunInIO
)
import Data.Conduit.Combinators as CC
( sinkHandle
, withSinkFile
)
import Data.Text as T
( unpack
, Text
......@@ -69,60 +67,59 @@ import System.IO ( BufferMode(NoBuffering)
, hSetBuffering
)
import qualified System.IO as IO
import Data.Conduit.Process.Typed
import Data.Conduit.Binary as CB
-- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell ()
colorShell :: Color -> IO () -> IO ()
colorShell color she = setC color *> she *> setC White
where setC c = liftIO $ setSGR [SetColor Foreground Dull c]
printInfo :: Text -> Shell ()
printCommand :: Text -> Shell ()
printError :: Text -> Shell ()
printWarning :: Text -> Shell ()
printSuccess :: Text -> Shell ()
printTest :: Text -> Shell ()
printInfo = printf ("info: " % s % "\n")
printCommand = printf ("running: " % s % "\n")
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 stack: " % s % "\n")
myWhich :: FilePath -> Shell FilePath
myWhich str = which str >>= \case
(Just p) ->
printInfo (format ("Found " % fp % " at " % fp) str p) >> return p
Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str
sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell ()
printInfo :: Text -> IO ()
printCommand :: Text -> IO ()
printError :: Text -> IO ()
printWarning :: Text -> IO ()
printSuccess :: Text -> IO ()
printTest :: Text -> IO ()
printInfo s = putText $ "info: " <> s <> "\n"
printCommand s = putText $ "running: " <> s <> "\n"
printWarning s = colorShell Yellow $ putText $ "warning: " <> s <> "\n"
printError s = colorShell Red $ putText $ "error: " <> s <> "\n"
printSuccess s = colorShell Green $ putText $ "success: " <> s <> "\n"
printTest s = colorShell Green $ putText $ "running stack: " <> s <> "\n"
myWhich :: Text -> IO Text
myWhich str =
(toS <$> readProcessStdout_ (shell $ toS $ "which " <> str)) >>= \case
"" -> die $ "Argo `" <> str <> "` not in $PATH."
p -> printInfo ("Found " <> str <> " at " <> p) $> p
sudoRemoveFile :: (Text -> IO ()) -> Text -> Text -> IO ()
sudoRemoveFile printer desc filePath = do
foundSocket <- testfile filePath
foundSocket <- doesFileExist $ toS filePath
when foundSocket $ go False
printInfo $ format ("OK: " % s % " " % fp) desc filePath
printInfo $ "OK: " <> desc <> " " <> filePath
where
go useSudo = do
printer $ format ("found stale " % s % " at " % fp % ".. ") desc filePath
shell
(format ((if useSudo then "sudo " else "") % "rm -rf " % fp) filePath)
Turtle.empty
printer $ "found stale " <> desc <> " at " <> filePath <> ".. "
runProcess
( shell
$ toS ((if useSudo then "sudo " else "") <> "rm -rf " <> filePath)
)
>>= \case
ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
ExitSuccess ->
colorShell Green $ putText " Successfully removed.\n"
ExitFailure _ -> if useSudo
then printer $ format
("Failed to remove stale " % s % ", even with sudo.")
desc
then printer
("Failed to remove stale " <> desc <> ", even with sudo.")
else do
printer $ format
("Failed to remove stale " % s % ". Trying sudo..\n")
desc
printer
("Failed to remove stale " <> desc <> ". Trying sudo..\n")
go True
verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text)
verboseShell' command i = printCommand command >> shellStrictWithErr command i
cleanSocket :: FilePath -> Shell ()
cleanSocket = sudoRemoveFile printWarning "socket"
cleanSocket :: Text -> IO ()
cleanSocket = sudoRemoveFile putText "socket"
kbInstallHandler :: IO () -> IO Handler
kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing
......@@ -131,7 +128,7 @@ newtype MonitoringResult = PatternMatched Text deriving (Show, Typeable)
instance Exception MonitoringResult
data Instrumentation = Instrumentation
CreateProcess
(ProcessConfig () () ())
StdOutLog
StdErrLog
(Maybe TestText)
......@@ -139,46 +136,93 @@ data Instrumentation = Instrumentation
data TracebackScan = WarningTraceback | Clean deriving (Show)
withAsyncConduitsOnProcess
:: Process () (ConduitT () ByteString IO ()) (ConduitT () ByteString IO ())
-> ConduitT ByteString Void IO ()
-> Maybe TextBehavior
-> ConduitT ByteString Void IO ()
-> Maybe TextBehavior
-> (Async TracebackScan -> Async TracebackScan -> IO b)
-> IO b
withAsyncConduitsOnProcess p outSink outTest errSink errTest = withAsyncs
(doFilter outTest (getStdout p) outSink)
(doFilter errTest (getStderr p) errSink)
withAsyncs :: IO a -> IO a1 -> (Async a -> Async a1 -> IO b) -> IO b
withAsyncs io1 io2 f = withAsync io1 $ \a1 -> withAsync io2 $ \a2 -> f a1 a2
doFilter
:: Maybe TextBehavior
-> ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO ()
-> IO TracebackScan
doFilter behavior source sink =
runConduit $ source .| CB.lines .| makeBehavior behavior `fuseUpstream` sink
makeBehavior
:: Maybe TextBehavior -> ConduitT ByteString ByteString IO TracebackScan
makeBehavior = \case
Just ExpectClean -> warnOnTraceback False
Just (WaitFor message) -> untilMatch message False
Nothing -> awaitForever yield $> Clean
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
Nothing -> if sawTraceback then return WarningTraceback else return Clean
untilMatch :: Text -> Bool -> ConduitT ByteString ByteString IO TracebackScan
untilMatch msg sawTraceback = await >>= \case
Just b
| B.isInfixOf "Traceback" b
-> untilMatch msg True >> yield b >> untilMatch msg True
| B.isInfixOf (TE.encodeUtf8 msg) b && not sawTraceback
-> throw (PatternMatched $ TE.decodeUtf8 b)
| otherwise
-> yield b >> untilMatch msg sawTraceback
Nothing -> return Clean
configureConduits
:: WorkingDirectory -> ProcessConfig () () ()
-> ProcessConfig
()
(ConduitM () ByteString IO ())
(ConduitM () ByteString IO ())
configureConduits (WorkingDirectory wd) p =
setStdout createSource $ setStderr createSource $ setStdin closed $ setWorkingDir (toS wd) p
withConduitSinks
:: Text
-> Text
-> (ConduitT ByteString o IO () -> ConduitT ByteString o1 IO () -> IO b)
-> IO b
withConduitSinks outName errName f =
withSinkFileNoBuffering (T.unpack outName) $ \outSink ->
withSinkFileNoBuffering (T.unpack errName) $ \errSink -> f outSink errSink
withSinkFileNoBuffering
:: FilePath -> (ConduitT ByteString o IO () -> IO b) -> IO b
withSinkFileNoBuffering filepath inner =
withRunInIO $ \run -> IO.withBinaryFile filepath IO.WriteMode $ \h -> do
hSetBuffering h NoBuffering
run $ inner $ sinkHandle h
runI
:: Instrumentation
:: WorkingDirectory -> Instrumentation
-> IO (Either MonitoringResult (ExitCode, TracebackScan, TracebackScan))
runI (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = try
(reroutedDaemon crProc)
runI workingDirectory (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) =
try $ withConduitSinks stdOut stdErr $ \outSink errSink ->
withProcess (configureConduits workingDirectory 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
{-reroutedDaemon :: CreateProcess -> IO (ExitCode, (), ())-}
reroutedDaemon process =
withSinkFileNoBuffering (T.unpack stdOut) $ \outSink ->
withSinkFile (T.unpack stdErr) $ \errSink -> sourceProcessWithStreams
process
mempty
(makeBehavior outTest `fuseUpstream` outSink)
(makeBehavior errTest `fuseUpstream` errSink)
makeBehavior
:: Maybe TextBehavior -> ConduitT ByteString ByteString IO TracebackScan