Skip to content

GitLab

Commit a9dc9f92 authored by Valentin Reis's avatar Valentin Reis
Browse files

[refactor] Refactored the codebase. 

Tests are now simpler, more extensible, don't leave hanging processes,
do not wrap in cmd, and allow ad-hoc monitoring of all stdout and stderr
redirections.
parent 7891afa0
Pipeline #4723 failed with stage
in 44 seconds
Hide whitespace changes
Inline Side-by-side
Showing with 184 additions and 182 deletions
.gitignore
View file @ a9dc9f92
.argo_nodeos_config_exit_message
_output
result
.shake
*.log
argo/argo.cabal
View file @ a9dc9f92
......@@ -11,6 +11,6 @@ cabal-version: >=1.10
library
exposed-Modules: Argo.Stack
Argo.Utils
build-depends: base >=4 && <=8, turtle, data-default, managed, ansi-terminal, unix, system-filepath, async, process, text, optparse-applicative, extra
build-depends: base >=4 && <=8, turtle, data-default, managed, ansi-terminal, unix, system-filepath, async, process, text, optparse-applicative, extra, foldl, conduit,conduit-extra, bytestring
hs-source-dirs: src
default-language: Haskell2010
argo/src/Argo/Stack.hs
View file @ a9dc9f92
......@@ -11,6 +11,7 @@ module Argo.Stack where
import Data.Default
import Turtle
import Turtle.Shell
import Prelude hiding ( FilePath )
import System.IO ( withFile )
......@@ -19,7 +20,7 @@ import Filesystem.Path ( (</>) )
import Control.Concurrent.Async
import System.Console.ANSI
import System.Console.ANSI.Types ( Color )
import Data.Text as Text
import Data.Text as T
hiding ( empty )
import Data.Text.IO as Text
import Argo.Utils
......@@ -27,9 +28,18 @@ import System.Process as P
hiding ( shell )
import Options.Applicative as OA
import Control.Monad.Extra as E
import Control.Monad as CM
import Control.Foldl as F
import Data.Conduit
import Data.Conduit.Process
import Data.ByteString.Char8 as C8
hiding ( empty )
import Control.Exception.Base
import Data.Maybe
data StackArgs = StackArgs
{ app :: Text
, args :: [Text]
, containerName :: Text
, workingDirectory :: FilePath
, manifestDir :: FilePath
......@@ -39,11 +49,16 @@ data StackArgs = StackArgs
, daemon_out :: FilePath
, daemon_err :: FilePath
, nrm_log :: FilePath
, time_file :: FilePath }
, messageDaemonOut :: Maybe Text
, messageDaemonErr :: Maybe Text
, messageCmdOut :: Maybe Text
, messageCmdErr :: Maybe Text
}
instance Default StackArgs where
def = StackArgs
{ app = "echo foobar"
{ app = "echo"
, args = ["foobar"]
, containerName = "testContainer"
, workingDirectory = "_output"
, manifestDir = "manifests"
......@@ -53,7 +68,10 @@ instance Default StackArgs where
, daemon_out = "daemon_out.log"
, daemon_err = "daemon_err.log"
, nrm_log = "nrm.log"
, time_file = "time.log"
, messageDaemonOut = Nothing
, messageDaemonErr = Nothing
, messageCmdOut = Nothing
, messageCmdErr = Nothing
}
parseExtendStackArgs :: StackArgs -> Parser StackArgs
......@@ -61,7 +79,7 @@ parseExtendStackArgs StackArgs {..} = do
app <- strOption
( long "application"
<> metavar "APP"
<> help "Target application call, sh+path valid"
<> help "Target application executable name. PATH is inherited."
<> showDefault
<> value app
)
......@@ -128,12 +146,45 @@ parseExtendStackArgs StackArgs {..} = do
<> showDefault
<> value nrm_log
)
time_file <- strOption
( long "time_file"
<> metavar "FILE"
<> help "Output file, application runtime"
messageDaemonOut <- optional $ strOption
( long "message_daemon_stdout"
<> metavar "STRING"
<> help
"The appearance of this character string in the daemon stdout \
\ will be monitored during execution and the stack will be \
\ killed when observing it, returning a successful exit code."
<> showDefault
<> value time_file
<> maybe mempty value messageDaemonOut
)
messageDaemonErr <- optional $ strOption
( long "message_daemon_stdout"
<> metavar "STRING"
<> help
"The appearance of this character string in the daemon stderr \
\ will be monitored during execution and the stack will be \
\ killed when observing it, returning a successful exit code."
<> showDefault
<> maybe mempty value messageDaemonErr
)
messageCmdOut <- optional $ strOption
( long "message_daemon_stdout"
<> metavar "STRING"
<> help
"The appearance of this character string in the cmd stdout \
\ will be monitored during execution and the stack will be \
\ killed when observing it, returning a successful exit code."
<> showDefault
<> maybe mempty value messageCmdOut
)
messageCmdErr <- optional $ strOption
( long "message_daemon_stdout"
<> metavar "STRING"
<> help
"The appearance of this character string in the cmd stderr \
\ will be monitored during execution and the stack will be \
\ killed when observing it, returning a successful exit code."
<> showDefault
<> maybe mempty value messageCmdErr
)
pure StackArgs {..}
......@@ -145,36 +196,32 @@ cleanLeftoverProcesses = do
cmd <- myWhich "cmd"
void $ verboseShell (format ("pkill " % fp) cmd) empty
daemon_wrapped <- myWhichMaybe ".daemon-wrapped"
E.whenJust daemon_wrapped (\x -> void $ verboseShell "pkill .daemon-wrapped" empty)
E.whenJust daemon_wrapped
(\x -> void $ verboseShell "pkill .daemon-wrapped" empty)
cmd_wrapped <- myWhichMaybe ".cmd-wrapped"
void $ E.whenJust cmd_wrapped (\x -> void $ verboseShell "pkill .cmd-wrapped" empty)
void $ E.whenJust cmd_wrapped
(\x -> void $ verboseShell "pkill .cmd-wrapped" empty)
cleanLeftovers :: StackArgs -> Shell ()
cleanLeftovers StackArgs {..} = do
cleanLeftoverProcesses
printInfo "Cleaning leftover files.\n"
mapM_
CM.mapM_
cleanLog
[ workingDirectory </> daemon_out
, workingDirectory </> daemon_err
, workingDirectory </> cmd_out
, workingDirectory </> cmd_err
, workingDirectory </> time_file
, workingDirectory </> nrm_log
, workingDirectory </> ".argo_nodeos_config_exit_message"
, workingDirectory </> "argo_nodeos_config"
]
printInfo "Cleaning leftover sockets.\n"
mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
prepareDaemonShell :: StackArgs -> Shell (IO ())
prepareDaemonShell = prepareDaemonShellWithStoppingCriterion id
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
prepareDaemonShellWithStoppingCriterion
:: (Shell (Either Line Line) -> Shell (Either Line Line))
-> StackArgs
-> Shell (IO ())
prepareDaemonShellWithStoppingCriterion waitCondition StackArgs {..} = do
prepareDaemon
:: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
prepareDaemon StackArgs {..} = do
mktree workingDirectory
cd workingDirectory
myWhich "daemon"
......@@ -190,8 +237,6 @@ prepareDaemonShellWithStoppingCriterion waitCondition StackArgs {..} = do
verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
ExitSuccess -> printInfo "Set the suid bit.\n"
ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
--Cleaning the config, running the daemon
verboseShell (format (fp % " --clean_config=kill_content:true") confPath')
empty
>>= \case
......@@ -204,102 +249,46 @@ prepareDaemonShellWithStoppingCriterion waitCondition StackArgs {..} = do
printInfo "Contents of .argo_nodeos_config_exit_message: \n"
view $ input "./argo_nodeos_config_exit_message"
False -> die ("Clean config failed with exit code " <> repr n)
printInfo $ format
( "Running the daemon, main log at "
% fp
% ", stdout at "
% fp
% ", stderr at "
% fp
% "\n"
)
nrm_log
daemon_out
daemon_err
export "ARGO_NODEOS_CONFIG" (format fp confPath')
return $ twoWayPrint daemon_out daemon_err $ waitCondition $ inprocWithErr
"daemon"
["--nrm_log", Text.pack $ encodeString nrm_log]
empty
-- | See at the bottom of this file for discussion of this function. (1)
cmdShell :: StackArgs -> Shell ()
cmdShell StackArgs {..} =
verboseShell
(format ("cmd run -u "%s%" " % fp % " " % s % " > " % fp % " 2>" % fp)
containerName
(manifestDir </> manifestName)
app
cmd_out
cmd_err
)
empty
>>= \case
ExitSuccess -> printInfo "cmd has exited successfuly.\n"
ExitFailure n -> die
( "cmd failed with exit code "
<> repr n
<> " . The application logs are at "
<> repr cmd_out
<> " "
<> repr cmd_err
)
twoWayPrint :: FilePath -> FilePath -> Shell (Either Line Line) -> IO ()
twoWayPrint outPath errPath s = sh $ do
handleOut <- using (writeonly outPath)
handleErr <- using (writeonly errPath)
s >>= \case
Left out -> liftIO $ Text.hPutStrLn handleOut (lineToText out)
Right err -> liftIO $ Text.hPutStrLn handleErr (lineToText err)
makeInstrumentedProcess $ Instrumentation
{ process = P.proc "daemon" ["--nrm_log", encodeString nrm_log]
, stdOutFile = daemon_out
, stdErrFile = daemon_err
, messageOut = messageDaemonOut
, messageErr = messageDaemonErr
}
runSimpleStack :: StackArgs -> IO ()
runSimpleStack = runSimpleStackWithCriterion id
prepareCmdRun
:: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
prepareCmdRun StackArgs {..} = makeInstrumentedProcess $ Instrumentation
{ process = P.proc "cmd"
$ [ "run"
, "-u"
, T.unpack containerName
, encodeString $ manifestDir </> manifestName
, T.unpack app
]
++ fmap T.unpack args
, stdOutFile = cmd_out
, stdErrFile = cmd_err
, messageOut = messageCmdOut
, messageErr = messageCmdErr
}
runSimpleStackWithCriterion
:: (Shell (Either Line Line) -> Shell (Either Line Line))
-> StackArgs
-> IO ()
runSimpleStackWithCriterion stoppingCriteria a@StackArgs {..} = sh $ do
data StackOutput = FoundMessage | DaemonDied | CmdDied
runSimpleStack :: StackArgs -> Shell StackOutput
runSimpleStack a@StackArgs {..} = do
cleanLeftovers a
daemonShell <- prepareDaemonShellWithStoppingCriterion stoppingCriteria a
liftIO $ withAsync daemonShell $ \daemon -> do
instrumentedDaemon <- prepareDaemon a
instrumentedCmd <- prepareCmdRun a
printInfo "Running the daemon."
liftIO $ withAsync instrumentedDaemon $ \daemon -> do
kbInstallHandler $ cancel daemon
withAsync (time $ sh $ cmdShell a) $ \cmd -> do
sh $ printInfo "Running cmd run."
withAsync instrumentedCmd $ \cmd -> do
kbInstallHandler $ cancel daemon >> cancel cmd
waitEitherCancel daemon cmd >>= \case
Left _ -> die "Daemon died."
Right (_, t) -> writeTextFile time_file (repr t)
-- | (1)
--
-- | This version fucks up the environment variables. issue at
-- https://github.com/Gabriel439/Haskell-Turtle-Library/issues/338
{-cmdShell :: FilePath -> Text -> FilePath -> FilePath -> Shell ()-}
{-cmdShell manifest app cmd_out cmd_err = do-}
{-manifestArg <- case toText manifest of-}
{-Left m -> printWarning (format ("Manifest path malformed: " % fp) manifest)-}
{->> return m-}
{-Right m -> return m-}
{-printInfo $ format-}
{-("Running cmd. Stdout at " % fp % ", stderr at " % fp % "\n")-}
{-cmd_out-}
{-cmd_err-}
{-liftIO $ twoWayPrint cmd_out cmd_err $ inprocWithErr-}
{-"cmd"-}
{-["run", "-u", "toto", manifestArg, app]-}
{-empty-}
-- | Even this one fucks up, streamWithErr really cleans this `env` attribute.
{-manifestArg <- case toText manifest of-}
{-Left m -> printWarning (format ("Manifest path malformed: " % fp) manifest)-}
{->> return m-}
{-Right m -> return m-}
{-printInfo $ format-}
{-("Running cmd. Stdout at " % fp % ", stderr at " % fp % "\n")-}
{-cmd_out-}
{-cmd_err-}
{-theEnv' <- liftIO $ Turtle.env-}
{-let theEnv = Prelude.map (\(x,y)-> (Text.unpack x,Text.unpack y)) theEnv'-}
{-void $ liftIO $ twoWayPrint cmd_out cmd_err $ streamWithErr ((P.proc (unpack "cmd") (Prelude.map unpack ["run", "-u", "toto", manifestArg, app])) {P.env=Just theEnv}) empty-}
Left (Left PatternMatched) -> return FoundMessage
Left (Right _ ) -> return DaemonDied
Right (Left PatternMatched) -> return FoundMessage
Right (Right _ ) -> return CmdDied
argo/src/Argo/Utils.hs
View file @ a9dc9f92
{-# LANGUAGE LambdaCase, OverloadedStrings, DataKinds,
FlexibleInstances, TypeOperators #-}
FlexibleInstances, TypeOperators, RecordWildCards #-}
module Argo.Utils where
......@@ -9,6 +9,15 @@ import System.Console.ANSI
import System.Console.ANSI.Types ( Color )
import System.Posix.Signals
import System.Process hiding ( shell )
import Data.Conduit
import Data.Conduit.Process hiding ( shell )
import Data.ByteString as B
hiding ( empty )
import Data.Text.Encoding as TE
import Data.Conduit.Combinators as CC
import Control.Exception.Base
import Data.Typeable
import Data.Text as T
-- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell ()
......@@ -50,7 +59,7 @@ sudoRemoveFile printer desc filePath = do
printer $ format ("found stale " % s % " at " % fp % ".. ") desc filePath
shell
(format ((if useSudo then "sudo " else "") % "rm -f " % fp) filePath)
empty
Turtle.empty
>>= \case
ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
ExitFailure n -> if useSudo
......@@ -71,3 +80,43 @@ cleanLog = sudoRemoveFile printWarning "log file"
kbInstallHandler :: IO () -> IO Handler
kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing
data PatternMatched = PatternMatched deriving (Show, Typeable)
instance Exception PatternMatched
data Instrumentation = Instrumentation
{ process :: CreateProcess
, stdOutFile :: FilePath
, stdErrFile :: FilePath
, messageOut :: Maybe Text
, messageErr :: Maybe Text } deriving (Show)
makeInstrumentedProcess
:: Instrumentation -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
makeInstrumentedProcess instrumentation@Instrumentation {..} = do
printInfo "Prepared a process with full configuration: \n"
liftIO $ Prelude.print instrumentation
return $ try (reroutedDaemon process)
where
reroutedDaemon process =
withSinkFile (encodeString stdOutFile) $ \outSink ->
withSinkFile (encodeString stdErrFile)
$ \errSink -> sourceProcessWithStreams
process
mempty
(makeMatcher messageOut .| outSink)
(makeMatcher messageErr .| errSink)
makeMatcher maybeMessage = case maybeMessage of
Just msg -> untilMatch msg
Nothing -> awaitForever yield
untilMatch :: Text -> ConduitT ByteString ByteString IO ()
untilMatch message = do
inb <- await
case inb of
Just b -> if B.isInfixOf (TE.encodeUtf8 message) b
then throw PatternMatched
else do
yield b
untilMatch message
_ -> return ()
argotk/argotk.hs
View file @ a9dc9f92
#! /usr/bin/env runhaskell
{-# LANGUAGE
OverloadedStrings,
LambdaCase,
RecordWildCards #-}
{-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase #-}
import Argo.Stack
import Argo.Utils
......@@ -19,19 +16,12 @@ import System.Posix.Signals
import Control.Monad
import Data.Either
messageOption = strOption
( long "message"
<> metavar "MESSAGE"
<> help "String to look for in the NRM daemon standard output."
<> value "progress"
)
opts :: StackArgs -> Parser (IO ())
opts sa = hsubparser
( command "clean"
(info (pure $ runClean sa) (progDesc "Clean sockets, logfiles."))
<> command
"daemon"
"daemon-only"
(info
(runDaemon <$> parseExtendStackArgs sa)
(progDesc
......@@ -40,26 +30,21 @@ opts sa = hsubparser
)
)
<> command
"stack"
(info (runSimpleStack <$> parseExtendStackArgs sa)
"full-stack"
(info (runStack <$> parseExtendStackArgs sa)
(progDesc "Setup stack and run a command in a container.")
)
<> command
"grep"
(info
(runWaitForMessage <$> messageOption <*> parseExtendStackArgs
(sa { app = "echo foobar" })
)
(progDesc
"Setup stack and look for a message in the daemon's \
\standard output."
)
)
<> command
"helloworld"
(info
(runCheckCmdOutput "helloworld" <$> parseExtendStackArgs
(sa { app = format ("echo " % s) "helloworld" })
(runStack <$> parseExtendStackArgs
(let msg = "Hello-Moto"
in sa { app = "echo"
, args = [msg]
, messageCmdOut = Just msg
, messageCmdErr = Just msg
}
)
)
(progDesc
"Test 1: Setup stack and check that a hello world app sends \
......@@ -69,9 +54,12 @@ opts sa = hsubparser
<> command
"perfwrapper"
(info
(runWaitForMessage "progress" <$> parseExtendStackArgs
(sa { manifestName = "perfwrap.json"
, app = format ("sleep " % s) "5"
(runStack <$> parseExtendStackArgs
(sa { manifestName = "perfwrap.json"
, app = "sleep"
, args = ["5"]
, messageDaemonOut = Just "progress"
, messageDaemonErr = Just "progress"
}
)
)
......@@ -92,40 +80,15 @@ main = do
let a = def { manifestDir = decodeString manifests }
join $ execParser (info (opts a <**> helper) idm)
runCheckCmdOutput :: Text -> StackArgs -> IO ()
runCheckCmdOutput message a@StackArgs {..} = do
sh cleanLeftoverProcesses
runSimpleStack a
readTextFile cmd_err >>= \x -> case match (has (text message)) x of
[] ->
sh $ dieRed $ "Cmd did not recieve the '" <> message <> "' message.\n"
_ ->
sh
$ printSuccess
"The hello world app executed properly in a \
\ container and its message was received by `cmd`.\n"
runWaitForMessage :: Text -> StackArgs -> IO ()
runWaitForMessage message a@StackArgs {..} = do
sh $ printError "WARNING: TODO: DEBUG. THIS TEST CURRENTLY FAILS ONCE PER TWO RUNS AND REPORTS BAD EXIT CODES.\n"
runSimpleStackWithCriterion criteria a
sh $ dieRed ("Did not find string '" <> message <> "' in daemon stdout.\n")
where
criteria :: (Shell (Either Line Line) -> Shell (Either Line Line))
criteria s = s >>= \case
Left out -> case match (has (text message)) (lineToText out) of
[] -> return $ Left out
_ -> do
printSuccess
$ "Found line containing '"
<> message
<> "' in daemon stdout.\n"
cleanLeftoverProcesses
exit ExitSuccess
Right err -> return $ Right err
runStack :: StackArgs -> IO ()
runStack a@StackArgs {..} = sh $ runSimpleStack a >>= \case
FoundMessage -> printSuccess "Found message!\n" >> exit ExitSuccess
DaemonDied ->
printError "Daemon died unexpectedly.\n" >> exit (ExitFailure 1)
CmdDied -> printError "Did not find message.\n" >> exit (ExitFailure 1)
runClean :: StackArgs -> IO ()
runClean = sh . cleanLeftovers
runDaemon :: StackArgs -> IO ()
runDaemon a = sh $ prepareDaemonShell a >>= liftIO
runDaemon a = sh $ cleanLeftovers a >> prepareDaemon a >>= liftIO
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