Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Support
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
A
argotest
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Valentin Reis
argotest
Commits
746cee22
Commit
746cee22
authored
Dec 21, 2018
by
Valentin Reis
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[feature] Added the `cmd listen` Test.
parent
c9580560
Pipeline
#4784
passed with stage
in 41 seconds
Changes
5
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
205 additions
and
73 deletions
+205
-73
argo/argo.cabal
argo/argo.cabal
+1
-1
argo/src/Argo/Args.hs
argo/src/Argo/Args.hs
+67
-24
argo/src/Argo/Stack.hs
argo/src/Argo/Stack.hs
+72
-18
argo/src/Argo/Utils.hs
argo/src/Argo/Utils.hs
+4
-7
argotk/argotk.hs
argotk/argotk.hs
+61
-23
No files found.
argo/argo.cabal
View file @
746cee22
...
...
@@ -12,6 +12,6 @@ library
exposed-Modules: Argo.Stack
Argo.Utils
Argo.Args
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
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
, stm
hs-source-dirs: src
default-language: Haskell2010
argo/src/Argo/Args.hs
View file @
746cee22
...
...
@@ -14,6 +14,7 @@ import Turtle
import
Prelude
hiding
(
FilePath
)
data
OutputFiles
=
OutputFiles
FilePath
FilePath
data
StackArgs
=
StackArgs
{
app
::
Text
,
args
::
[
Text
]
...
...
@@ -21,15 +22,19 @@ data StackArgs = StackArgs
,
workingDirectory
::
FilePath
,
manifestDir
::
FilePath
,
manifestName
::
FilePath
,
cmd_out
::
FilePath
,
cmd_err
::
FilePath
,
cmd_run_out
::
FilePath
,
cmd_run_err
::
FilePath
,
cmd_listen_out
::
FilePath
,
cmd_listen_err
::
FilePath
,
daemon_out
::
FilePath
,
daemon_err
::
FilePath
,
nrm_log
::
FilePath
,
messageDaemonOut
::
Maybe
Text
,
messageDaemonErr
::
Maybe
Text
,
messageCmdOut
::
Maybe
Text
,
messageCmdErr
::
Maybe
Text
,
messageCmdRunOut
::
Maybe
Text
,
messageCmdRunErr
::
Maybe
Text
,
messageCmdListenOut
::
Maybe
Text
,
messageCmdListenErr
::
Maybe
Text
}
instance
Default
StackArgs
where
...
...
@@ -40,15 +45,19 @@ instance Default StackArgs where
,
workingDirectory
=
"_output"
,
manifestDir
=
"manifests"
,
manifestName
=
"basic.json"
,
cmd_out
=
"cmd_out.log"
,
cmd_err
=
"cmd_err.log"
,
cmd_run_out
=
"cmd_run_out.log"
,
cmd_run_err
=
"cmd_run_err.log"
,
cmd_listen_out
=
"cmd_listen_out.log"
,
cmd_listen_err
=
"cmd_listen_err.log"
,
daemon_out
=
"daemon_out.log"
,
daemon_err
=
"daemon_err.log"
,
nrm_log
=
"nrm.log"
,
messageDaemonOut
=
Nothing
,
messageDaemonErr
=
Nothing
,
messageCmdOut
=
Nothing
,
messageCmdErr
=
Nothing
,
messageCmdRunOut
=
Nothing
,
messageCmdRunErr
=
Nothing
,
messageCmdListenOut
=
Nothing
,
messageCmdListenErr
=
Nothing
}
parseExtendStackArgs
::
StackArgs
->
Parser
StackArgs
...
...
@@ -88,19 +97,33 @@ parseExtendStackArgs StackArgs {..} = do
<>
showDefault
<>
value
manifestName
)
cmd_out
<-
strOption
(
long
"cmd_out"
cmd_
run_
out
<-
strOption
(
long
"cmd_
run_
out"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir),
application
stdout"
<>
help
"Output file (relative to --output_dir),
\"
cmd run
\"
stdout"
<>
showDefault
<>
value
cmd_out
<>
value
cmd_
run_
out
)
cmd_err
<-
strOption
(
long
"cmd_err"
cmd_
run_
err
<-
strOption
(
long
"cmd_
run_
err"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir),
application
stderr"
<>
help
"Output file (relative to --output_dir),
\"
cmd run
\"
stderr"
<>
showDefault
<>
value
cmd_err
<>
value
cmd_run_err
)
cmd_listen_out
<-
strOption
(
long
"cmd_listen_out"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir),
\"
cmd listen
\"
stdout"
<>
showDefault
<>
value
cmd_listen_out
)
cmd_listen_err
<-
strOption
(
long
"cmd_listen_err"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir),
\"
cmd listen
\"
stderr"
<>
showDefault
<>
value
cmd_listen_err
)
daemon_out
<-
strOption
(
long
"daemon_out"
...
...
@@ -143,24 +166,44 @@ parseExtendStackArgs StackArgs {..} = do
<>
showDefault
<>
maybe
mempty
value
messageDaemonErr
)
messageCmdOut
<-
optional
$
strOption
(
long
"message_cmd_stdout"
messageCmd
Run
Out
<-
optional
$
strOption
(
long
"message_cmd_
run_
stdout"
<>
metavar
"STRING"
<>
help
"The appearance of this character string in the
daemo
n stdout
\
"The appearance of this character string in the
cmd ru
n stdout
\
\
will be monitored during execution. When observed, the
\
\
stack will be killed and a return code of 0 will be returned."
<>
showDefault
<>
maybe
mempty
value
messageCmdOut
<>
maybe
mempty
value
messageCmd
Run
Out
)
messageCmdErr
<-
optional
$
strOption
(
long
"message_cmd_stderr"
messageCmd
Run
Err
<-
optional
$
strOption
(
long
"message_cmd_
run_
stderr"
<>
metavar
"STRING"
<>
help
"The appearance of this character string in the daemon stdout
\
"The appearance of this character string in the cmd run stdout
\
\
will be monitored during execution. When observed, the
\
\
stack will be killed and a return code of 0 will be returned."
<>
showDefault
<>
maybe
mempty
value
messageCmdRunErr
)
messageCmdListenOut
<-
optional
$
strOption
(
long
"message_cmd_listen_stdout"
<>
metavar
"STRING"
<>
help
"The appearance of this character string in the cmd listen stdout
\
\
will be monitored during execution. When observed, the
\
\
stack will be killed and a return code of 0 will be returned."
<>
showDefault
<>
maybe
mempty
value
messageCmdListenOut
)
messageCmdListenErr
<-
optional
$
strOption
(
long
"message_cmd_listen_stderr"
<>
metavar
"STRING"
<>
help
"The appearance of this character string in the cmd listen stdout
\
\
will be monitored during execution. When observed, the
\
\
stack will be killed and a return code of 0 will be returned."
<>
showDefault
<>
maybe
mempty
value
messageCmdErr
<>
maybe
mempty
value
messageCmd
Listen
Err
)
pure
StackArgs
{
..
}
argo/src/Argo/Stack.hs
View file @
746cee22
...
...
@@ -18,7 +18,12 @@ import Prelude hiding ( FilePath )
import
System.IO
(
withFile
)
import
Debug.Trace
import
Filesystem.Path
(
(
</>
)
)
import
Control.Concurrent.Async
import
Control.Monad.STM
(
atomically
,
orElse
)
import
System.Console.ANSI
import
System.Console.ANSI.Types
(
Color
)
import
Data.Text
as
T
...
...
@@ -62,8 +67,10 @@ cleanLeftovers StackArgs {..} = do
cleanLog
[
workingDirectory
</>
daemon_out
,
workingDirectory
</>
daemon_err
,
workingDirectory
</>
cmd_out
,
workingDirectory
</>
cmd_err
,
workingDirectory
</>
cmd_run_out
,
workingDirectory
</>
cmd_run_err
,
workingDirectory
</>
cmd_listen_out
,
workingDirectory
</>
cmd_listen_err
,
workingDirectory
</>
nrm_log
,
workingDirectory
</>
".argo_nodeos_config_exit_message"
,
workingDirectory
</>
"argo_nodeos_config"
...
...
@@ -82,8 +89,7 @@ checkFsAttributes StackArgs {..} = do
(
"The output directory, "
%
fp
%
", must not mounted with
\"
nosuid
\"
"
)
workingDirectory
prepareDaemon
::
StackArgs
->
Shell
(
IO
(
Either
PatternMatched
(
ExitCode
,
()
,
()
)))
prepareDaemon
::
StackArgs
->
Shell
Instrumentation
prepareDaemon
sa
@
StackArgs
{
..
}
=
do
mktree
workingDirectory
checkFsAttributes
sa
...
...
@@ -103,7 +109,7 @@ prepareDaemon sa@StackArgs {..} = do
ExitFailure
n
->
die
(
"Setting suid bit failed with exit code "
<>
repr
n
)
cleanContainers
confPath'
1
4
export
"ARGO_NODEOS_CONFIG"
(
format
fp
confPath'
)
makeInstrumentedProcess
$
Instrumentation
return
$
Instrumentation
{
process
=
P
.
proc
"daemon"
[
"--nrm_log"
,
encodeString
nrm_log
]
,
stdOutFile
=
daemon_out
,
stdErrFile
=
daemon_err
...
...
@@ -160,9 +166,8 @@ prepareDaemon sa@StackArgs {..} = do
"argo_nodeos_config successfully cleaned the container
\
\
config."
prepareCmdRun
::
StackArgs
->
Shell
(
IO
(
Either
PatternMatched
(
ExitCode
,
()
,
()
)))
prepareCmdRun
StackArgs
{
..
}
=
makeInstrumentedProcess
$
Instrumentation
prepareCmdRun
::
StackArgs
->
Instrumentation
prepareCmdRun
StackArgs
{
..
}
=
Instrumentation
{
process
=
P
.
proc
"cmd"
$
[
"run"
,
"-u"
...
...
@@ -171,28 +176,77 @@ prepareCmdRun StackArgs {..} = makeInstrumentedProcess $ Instrumentation
,
T
.
unpack
app
]
++
fmap
T
.
unpack
args
,
stdOutFile
=
cmd_out
,
stdErrFile
=
cmd_err
,
messageOut
=
messageCmdOut
,
messageErr
=
messageCmdErr
,
stdOutFile
=
cmd_run_out
,
stdErrFile
=
cmd_run_err
,
messageOut
=
messageCmdRunOut
,
messageErr
=
messageCmdRunErr
}
prepareCmdListen
::
StackArgs
->
Instrumentation
prepareCmdListen
StackArgs
{
..
}
=
Instrumentation
{
process
=
P
.
proc
"cmd"
[
"listen"
,
"-u"
,
T
.
unpack
containerName
]
,
stdOutFile
=
cmd_listen_out
,
stdErrFile
=
cmd_listen_err
,
messageOut
=
messageCmdListenOut
,
messageErr
=
messageCmdListenErr
}
data
StackOutput
=
FoundMessage
|
DaemonDied
|
CmdDied
runSimpleStack
::
StackArgs
->
Shell
StackOutput
runSimpleStack
a
@
StackArgs
{
..
}
=
do
cleanLeftovers
a
i
nstrumented
Daemon
<-
prepareDaemon
a
instrumentedCmd
<-
prepareCmdRun
a
iDaemon
<-
prepareDaemon
a
let
iRun
=
prepareCmdRun
a
printInfo
"Running the daemon.."
liftIO
$
withAsync
instrumentedDaemon
$
\
daemon
->
do
liftIO
$
withAsync
(
runI
iDaemon
)
$
\
daemon
->
do
kbInstallHandler
$
cancel
daemon
sh
$
printInfo
"Daemon running.
\n
"
sh
$
printInfo
"Running
cmd
.."
withAsync
instrumentedCmd
$
\
cmd
->
do
sh
$
printInfo
"
cmd
running.
\n
"
sh
$
printInfo
"Running
'cmd run'
.."
withAsync
(
runI
iRun
)
$
\
cmd
->
do
sh
$
printInfo
"
'cmd run'
running.
\n
"
kbInstallHandler
$
cancel
daemon
>>
cancel
cmd
waitEitherCancel
daemon
cmd
>>=
\
case
Left
(
Left
PatternMatched
)
->
return
FoundMessage
Left
(
Right
_
)
->
return
DaemonDied
Right
(
Left
PatternMatched
)
->
return
FoundMessage
Right
(
Right
_
)
->
return
CmdDied
data
ListenAsyncConclusion
a
=
Daemon
a
|
Listen
a
|
Run
a
data
ListenStackOutput
=
LSFoundMessage
|
LSMessageNotFound
|
LSDaemonDied
ExitCode
|
LSRunDied
ExitCode
|
LSListenDied
ExitCode
runListenStack
::
StackArgs
->
Shell
ListenStackOutput
runListenStack
a
@
StackArgs
{
..
}
=
do
cleanLeftovers
a
iDaemon
<-
prepareDaemon
a
let
iRun
=
prepareCmdRun
a
let
iListen
=
prepareCmdListen
a
printInfo
"Running the daemon.."
liftIO
$
withAsync
(
runI
iDaemon
)
$
\
daemon
->
do
kbInstallHandler
$
cancel
daemon
sh
$
printInfo
"Daemon running.
\n
"
sh
$
printInfo
"Running 'cmd run'.."
withAsync
(
runI
iRun
)
$
\
run
->
do
sh
$
printInfo
"'cmd run' running.
\n
"
kbInstallHandler
$
cancel
daemon
>>
cancel
run
sh
$
printInfo
"Running 'cmd listen'.."
withAsync
(
runI
iListen
)
$
\
listen
->
do
sh
$
printInfo
"'cmd listen' running.
\n
"
kbInstallHandler
$
cancel
daemon
>>
cancel
run
>>
cancel
listen
waitStackCancel
daemon
run
listen
>>=
\
case
Daemon
(
Left
PatternMatched
)
->
return
LSFoundMessage
Daemon
(
Right
(
e
,
_
,
_
)
)
->
return
$
LSDaemonDied
e
Run
(
Left
PatternMatched
)
->
return
LSFoundMessage
Run
(
Right
(
e
,
_
,
_
)
)
->
return
$
LSRunDied
e
Listen
(
Left
PatternMatched
)
->
return
LSFoundMessage
Listen
(
Right
(
e
,
_
,
_
)
)
->
return
$
LSListenDied
e
where
waitStackCancel
daemon
run
listen
=
waitStack
daemon
run
listen
`
finally
`
(
cancel
daemon
>>
cancel
run
>>
cancel
listen
)
waitStack
daemon
run
listen
=
atomically
$
(
Daemon
<$>
waitSTM
daemon
)
`
orElse
`
(
Run
<$>
waitSTM
run
)
`
orElse
`
(
Listen
<$>
waitSTM
listen
)
argo/src/Argo/Utils.hs
View file @
746cee22
...
...
@@ -76,7 +76,8 @@ verboseShell :: Text -> Shell Line -> Shell ExitCode
verboseShell
command
input
=
printCommand
command
>>
shell
command
input
verboseShell'
::
Text
->
Shell
Line
->
Shell
(
ExitCode
,
Text
,
Text
)
verboseShell'
command
input
=
printCommand
command
>>
shellStrictWithErr
command
input
verboseShell'
command
input
=
printCommand
command
>>
shellStrictWithErr
command
input
cleanSocket
=
sudoRemoveFile
printError
"socket"
cleanLog
=
sudoRemoveFile
printWarning
"log file"
...
...
@@ -95,12 +96,8 @@ data Instrumentation = Instrumentation
,
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
)
runI
::
Instrumentation
->
IO
(
Either
PatternMatched
(
ExitCode
,
()
,
()
))
runI
Instrumentation
{
..
}
=
try
(
reroutedDaemon
process
)
where
reroutedDaemon
process
=
withSinkFile
(
encodeString
stdOutFile
)
$
\
outSink
->
...
...
argotk/argotk.hs
View file @
746cee22
...
...
@@ -21,11 +21,11 @@ import Data.Maybe
opts
::
StackArgs
->
Parser
(
IO
()
)
opts
sa
=
hsubparser
(
command
"clean"
(
info
(
pure
$
runC
lean
sa
)
(
progDesc
"Clean sockets, logfiles."
))
(
info
(
pure
$
c
lean
sa
)
(
progDesc
"Clean sockets, logfiles."
))
<>
command
"daemon-only"
(
info
(
runD
aemon
<$>
parseExtendStackArgs
sa
)
(
d
aemon
<$>
parseExtendStackArgs
sa
)
(
progDesc
"Set up and launch the daemon in synchronous mode,
\
\
with properly cleaned sockets, logfiles."
...
...
@@ -33,18 +33,18 @@ opts sa = hsubparser
)
<>
command
"full-stack"
(
info
(
run
Stack
<$>
parseExtendStackArgs
sa
)
(
info
(
simple
Stack
<$>
parseExtendStackArgs
sa
)
(
progDesc
"Setup stack and run a command in a container."
)
)
<>
command
"helloworld"
(
info
(
run
Stack
<$>
parseExtendStackArgs
(
simple
Stack
<$>
parseExtendStackArgs
(
let
msg
=
"Hello-Moto"
in
sa
{
app
=
"echo"
,
args
=
[
msg
]
,
messageCmdOut
=
Just
msg
,
messageCmdErr
=
Just
msg
in
sa
{
app
=
"echo"
,
args
=
[
msg
]
,
messageCmd
Run
Out
=
Just
msg
,
messageCmd
Run
Err
=
Just
msg
}
)
)
...
...
@@ -56,7 +56,7 @@ opts sa = hsubparser
<>
command
"perfwrapper"
(
info
(
run
Stack
<$>
parseExtendStackArgs
(
simple
Stack
<$>
parseExtendStackArgs
(
sa
{
manifestName
=
"perfwrap.json"
,
app
=
"sleep"
,
args
=
[
"15"
]
...
...
@@ -67,7 +67,25 @@ opts sa = hsubparser
)
(
progDesc
"Test 2: Setup stack and check that argo-perf-wrapper sends
\
\
at least one progress message up."
\
at least one progress message to the daemon."
)
)
<>
command
"listen"
(
info
(
listenStack
<$>
parseExtendStackArgs
(
sa
{
manifestName
=
"perfwrap.json"
,
app
=
"sleep"
,
args
=
[
"15"
]
,
messageCmdListenOut
=
Just
"progress"
,
messageCmdListenErr
=
Just
"progress"
}
)
)
(
progDesc
"Test 3: Setup stack and check that argo-perf-wrapper sends
\
\
at least one progress message to cmd listen through the
\
\
daemon."
)
)
<>
help
...
...
@@ -76,14 +94,8 @@ opts sa = hsubparser
\
values are printed when you call --help on these actions."
)
main
::
IO
()
main
=
do
manifests
<-
getEnv
"MANIFESTS"
let
a
=
def
{
manifestDir
=
decodeString
manifests
}
join
$
execParser
(
info
(
opts
a
<**>
helper
)
idm
)
runStack
::
StackArgs
->
IO
()
runStack
a
@
StackArgs
{
..
}
=
sh
$
runSimpleStack
a
>>=
\
case
simpleStack
::
StackArgs
->
IO
()
simpleStack
a
@
StackArgs
{
..
}
=
sh
$
runSimpleStack
a
>>=
\
case
FoundMessage
->
printSuccess
"Found message!
\n
"
>>
exit
ExitSuccess
DaemonDied
->
printError
"Daemon died unexpectedly.
\n
"
>>
exit
(
ExitFailure
1
)
...
...
@@ -91,13 +103,39 @@ runStack a@StackArgs {..} = sh $ runSimpleStack a >>= \case
when
(
or
$
isJust
<$>
[
messageDaemonOut
,
messageDaemonErr
,
messageCmdOut
,
messageCmdErr
]
<$>
[
messageDaemonOut
,
messageDaemonErr
,
messageCmdRunOut
,
messageCmdRunErr
]
)
$
printError
"Did not find message.
\n
"
exit
(
ExitFailure
1
)
runClean
::
StackArgs
->
IO
()
runClean
=
sh
.
cleanLeftovers
runDaemon
::
StackArgs
->
IO
()
runDaemon
a
=
sh
$
cleanLeftovers
a
>>
prepareDaemon
a
>>=
liftIO
listenStack
::
StackArgs
->
IO
()
listenStack
a
@
StackArgs
{
..
}
=
sh
$
runListenStack
a
>>=
\
case
LSFoundMessage
->
printSuccess
"Found message!
\n
"
>>
exit
ExitSuccess
LSMessageNotFound
->
printError
"Message not found.
\n
"
>>
exit
(
ExitFailure
1
)
LSDaemonDied
exitcode
->
printError
"`daemon` died unexpectedly.
\n
"
>>
exit
(
ExitFailure
1
)
LSRunDied
exitcode
->
printError
"`cmd run` unexpectedly.
\n
"
>>
exit
(
ExitFailure
1
)
LSListenDied
exitcode
->
printError
"`cmd listen` died unexpectedly.
\n
"
>>
exit
(
ExitFailure
1
)
clean
::
StackArgs
->
IO
()
clean
=
sh
.
cleanLeftovers
daemon
::
StackArgs
->
IO
()
daemon
a
=
sh
$
do
cleanLeftovers
a
iDaemon
<-
prepareDaemon
a
liftIO
$
runI
iDaemon
main
::
IO
()
main
=
do
manifests
<-
getEnv
"MANIFESTS"
let
a
=
def
{
manifestDir
=
decodeString
manifests
}
join
$
execParser
(
info
(
opts
a
<**>
helper
)
idm
)
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment