Commit a9dc9f92 authored by Valentin Reis's avatar Valentin Reis

[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
.argo_nodeos_config_exit_message
_output
result
.shake
*.log
......@@ -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
This diff is collapsed.
{-# 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 ()
#! /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