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
be0e5b41
Commit
be0e5b41
authored
Jan 08, 2019
by
Valentin Reis
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Refactor compiles.
parent
a2b60e73
Changes
8
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
289 additions
and
426 deletions
+289
-426
.README.md
.README.md
+0
-28
.gitignore
.gitignore
+7
-0
argo/src/Argo/Args.hs
argo/src/Argo/Args.hs
+73
-142
argo/src/Argo/Stack.hs
argo/src/Argo/Stack.hs
+98
-134
argo/src/Argo/Utils.hs
argo/src/Argo/Utils.hs
+24
-15
argotk/argotk.cabal
argotk/argotk.cabal
+1
-1
argotk/argotk.hs
argotk/argotk.hs
+75
-102
default.nix
default.nix
+11
-4
No files found.
.README.md
View file @
be0e5b41
...
...
@@ -112,34 +112,6 @@ There are a few things one has to be aware of using this workflow:
minutes by default. Use a local checkout if you need to modify some of these
sources on the fly.
### Example CI setup
```
{.yml}
integration.test:
stage: test
script:
- nix-shell -E '{ argotest ? (builtins.fetchGit {
url = https://xgitlab.cels.anl.gov/argo/argotest.git;
ref="master";})
}:
(import argotest { containers-src = ./. ; }).test' \
--run 'argotk.hs TestHello'
artifacts:
paths:
- argotest/_output/cmd_err.log
- argotest/_output/cmd_out.log
- argotest/_output/daemon_out.log
- argotest/_output/daemon_out.log
- argotest/_output/nrm.log
- argotest/_output/time.log
expire_in: 1 week
except:
- /^wip\/.*/
- /^WIP\/.*/
tags:
- integration
```
### Hacking
-
edit
`.README.md`
in place of README.md.
...
...
.gitignore
View file @
be0e5b41
...
...
@@ -3,3 +3,10 @@ _output
result
.shake
*.log
*/build
*/new-build
*/dist
*/new-dist
*/result
_output
*/_output
argo/src/Argo/Args.hs
View file @
be0e5b41
{-# LANGUAGE
OverloadedStrings,
ApplicativeDo,
RecordWildCards #-}
{-# LANGUAGE OverloadedStrings, ApplicativeDo, GeneralizedNewtypeDeriving, RecordWildCards #-}
module
Argo.Args
where
import
Options.Applicative
as
OA
import
Options.Applicative.Types
import
Options.Applicative.Builder
(
option
)
import
Data.Default
import
Data.Text
as
T
hiding
(
empty
)
import
Turtle
import
Turtle
hiding
(
option
)
import
Prelude
hiding
(
FilePath
)
import
System.Process
hiding
(
shell
)
data
OutputFiles
=
OutputFiles
FilePath
FilePath
data
StackArgs
=
StackArgs
{
app
::
Text
,
args
::
[
Text
]
,
containerName
::
Text
,
workingDirectory
::
FilePath
,
manifestDir
::
FilePath
,
manifestName
::
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
,
messageCmdRunOut
::
Maybe
Text
,
messageCmdRunErr
::
Maybe
Text
,
messageCmdListenOut
::
Maybe
Text
,
messageCmdListenErr
::
Maybe
Text
{
app
::
AppName
,
args
::
AppArgs
,
containerName
::
ContainerName
,
workingDirectory
::
WorkingDirectory
,
manifestDir
::
ManifestDir
,
manifestName
::
ManifestName
,
daemon
::
ProcessBehavior
,
cmdrun
::
ProcessBehavior
,
cmdlisten
::
ProcessBehavior
,
cmdlistenprogress
::
ProcessBehavior
,
cmdlistenpower
::
ProcessBehavior
}
newtype
AppArgs
=
AppArgs
[
Text
]
deriving
(
Show
,
Read
)
newtype
WorkingDirectory
=
WorkingDirectory
FilePath
deriving
(
IsString
,
Show
)
newtype
AppName
=
AppName
Text
deriving
(
IsString
,
Show
,
Read
)
newtype
ContainerName
=
ContainerName
Text
deriving
(
IsString
,
Show
,
Read
)
newtype
ManifestDir
=
ManifestDir
FilePath
deriving
(
IsString
,
Show
)
newtype
ManifestName
=
ManifestName
FilePath
deriving
(
IsString
,
Show
)
newtype
StdOutLog
=
StdOutLog
Text
deriving
(
Show
,
Read
)
newtype
StdErrLog
=
StdErrLog
Text
deriving
(
Show
,
Read
)
newtype
TestText
=
TestText
Text
deriving
(
Show
,
Read
)
data
ProcessBehavior
=
SucceedTestOnMessage
TestText
StdOutLog
StdErrLog
|
JustRun
StdOutLog
StdErrLog
|
DontRun
deriving
(
Show
,
Read
)
behavior
::
ReadM
ProcessBehavior
behavior
=
read
<$>
readerAsk
behaviorOption
::
Mod
OptionFields
ProcessBehavior
->
Parser
ProcessBehavior
behaviorOption
=
option
behavior
instance
Default
StackArgs
where
def
=
StackArgs
{
app
=
"echo"
,
args
=
[
"foobar"
]
,
containerName
=
"testContainer"
,
workingDirectory
=
"_output"
,
manifestDir
=
"manifests"
,
manifestName
=
"basic.json"
,
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
,
messageCmdRunOut
=
Nothing
,
messageCmdRunErr
=
Nothing
,
messageCmdListenOut
=
Nothing
,
messageCmdListenErr
=
Nothing
{
app
=
AppName
"echo"
,
args
=
AppArgs
[
"foobar"
]
,
containerName
=
ContainerName
"testContainer"
,
workingDirectory
=
WorkingDirectory
"_output"
,
manifestDir
=
ManifestDir
"manifests"
,
manifestName
=
ManifestName
"basic.json"
,
daemon
=
DontRun
,
cmdrun
=
DontRun
,
cmdlisten
=
DontRun
,
cmdlistenprogress
=
DontRun
,
cmdlistenpower
=
DontRun
}
parseExtendStackArgs
::
StackArgs
->
Parser
StackArgs
...
...
@@ -97,113 +102,39 @@ parseExtendStackArgs StackArgs {..} = do
<>
showDefault
<>
value
manifestName
)
cmd_run_out
<-
strOption
(
long
"cmd_run_out"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir),
\"
cmd run
\"
stdout"
<>
showDefault
<>
value
cmd_run_out
)
cmd_run_err
<-
strOption
(
long
"cmd_run_err"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir),
\"
cmd run
\"
stderr"
<>
showDefault
<>
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"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir), daemon stdout"
<>
showDefault
<>
value
daemon_out
)
daemon_err
<-
strOption
(
long
"daemon_err"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir), daemon stderr"
<>
showDefault
<>
value
daemon_err
)
nrm_log
<-
strOption
(
long
"nrm_log"
<>
metavar
"FILENAME"
<>
help
"Output file (relative to --output_dir), daemon log"
<>
showDefault
<>
value
nrm_log
)
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. When observed, the
\
\
stack will be killed and a return code of 0 will be returned."
<>
showDefault
<>
maybe
mempty
value
messageDaemonOut
)
messageDaemonErr
<-
optional
$
strOption
(
long
"message_daemon_stderr"
<>
metavar
"STRING"
<>
help
"The appearance of this character string in the daemon stdout
\
\
will be monitored during execution. When observed, the
\
\
stack will be killed and a return code of 0 will be returned."
daemon
<-
behaviorOption
(
long
"daemon"
<>
metavar
"BEHAVIOR"
<>
help
"`daemon` behavior"
<>
showDefault
<>
maybe
mempty
value
messageDaemonErr
<>
value
daemon
)
messageCmdRunOut
<-
optional
$
strOption
(
long
"message_cmd_run_stdout"
<>
metavar
"STRING"
<>
help
"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."
cmdrun
<-
behaviorOption
(
long
"cmd_run"
<>
metavar
"BEHAVIOR"
<>
help
"`cmd run` behavior"
<>
showDefault
<>
maybe
mempty
value
messageCmdRunOut
<>
value
cmdrun
)
messageCmdRunErr
<-
optional
$
strOption
(
long
"message_cmd_run_stderr"
<>
metavar
"STRING"
<>
help
"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."
cmdlisten
<-
behaviorOption
(
long
"cmd_listen"
<>
metavar
"BEHAVIOR"
<>
help
"`cmd listen` behavior"
<>
showDefault
<>
maybe
mempty
value
messageCmdRunErr
<>
value
cmdlisten
)
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."
cmdlistenprogress
<-
behaviorOption
(
long
"cmd_listen_progress"
<>
metavar
"BEHAVIOR"
<>
help
"`cmd listen --filter progress` behavior"
<>
showDefault
<>
maybe
mempty
value
messageCmdListenOut
<>
value
cmdlistenprogress
)
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."
cmdlistenpower
<-
behaviorOption
(
long
"cmd_listen_power"
<>
metavar
"BEHAVIOR"
<>
help
"`cmd listen --filter power` behavior"
<>
showDefault
<>
maybe
mempty
value
messageCmdListenEr
r
<>
value
cmdlistenpowe
r
)
pure
StackArgs
{
..
}
argo/src/Argo/Stack.hs
View file @
be0e5b41
{-# LANGUAGE
TupleSections,
ScopedTypeVariables,
LambdaCase,
RecordWildCards,
...
...
@@ -44,42 +45,15 @@ import Control.Exception.Base
import
Data.Maybe
import
Control.Foldl
as
Fold
{-cleanLeftoverProcesses :: Shell ()-}
{-cleanLeftoverProcesses = do-}
{-printInfo "Cleaning leftover processes.\n"-}
{-daemon <- myWhich "daemon"-}
{-verboseShell (format ("pkill " % fp) daemon) empty-}
{-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)-}
{-cmd_wrapped <- myWhichMaybe ".cmd-wrapped"-}
{-void $ E.whenJust cmd_wrapped-}
{-(\x -> void $ verboseShell "pkill .cmd-wrapped" empty)-}
cleanLeftovers
::
StackArgs
->
Shell
()
cleanLeftovers
StackArgs
{
..
}
=
do
{-cleanLeftoverProcesses-}
cleanLeftovers
::
WorkingDirectory
->
Shell
()
cleanLeftovers
(
WorkingDirectory
wd
)
=
do
printInfo
"Cleaning leftover files.
\n
"
CM
.
mapM_
cleanLog
[
workingDirectory
</>
daemon_out
,
workingDirectory
</>
daemon_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"
]
cleanLog
wd
printInfo
"Cleaning leftover sockets.
\n
"
CM
.
mapM_
cleanSocket
[
"/tmp/nrm-downstream-in"
,
"/tmp/nrm-upstream-in"
]
checkFsAttributes
::
StackArgs
->
Shell
()
checkFsAttributes
StackArgs
{
..
}
=
do
checkFsAttributes
::
FilePath
->
Shell
()
checkFsAttributes
workingDirectory
=
do
let
x
=
case
toText
workingDirectory
of
Left
x
->
x
Right
x
->
x
...
...
@@ -89,11 +63,16 @@ checkFsAttributes StackArgs {..} = do
(
"The output directory, "
%
fp
%
", must not mounted with
\"
nosuid
\"
"
)
workingDirectory
prepareDaemon
::
StackArgs
->
Shell
Instrumentation
prepareDaemon
sa
@
StackArgs
{
..
}
=
do
mktree
workingDirectory
checkFsAttributes
sa
cd
workingDirectory
prepareDaemon
::
StdOutLog
->
StdErrLog
->
Maybe
TestText
->
WorkingDirectory
->
Shell
Instrumentation
prepareDaemon
(
StdOutLog
out
)
(
StdErrLog
err
)
test
(
WorkingDirectory
wd
)
=
do
mktree
wd
checkFsAttributes
wd
cd
wd
myWhich
"daemon"
confPath
<-
myWhich
"argo_nodeos_config"
let
confPath'
=
"./argo_nodeos_config"
...
...
@@ -109,13 +88,10 @@ prepareDaemon sa@StackArgs {..} = do
ExitFailure
n
->
die
(
"Setting suid bit failed with exit code "
<>
repr
n
)
cleanContainers
confPath'
1
2
export
"ARGO_NODEOS_CONFIG"
(
format
fp
confPath'
)
return
$
Instrumentation
{
process
=
P
.
proc
"daemon"
[
"--nrm_log"
,
encodeString
nrm_log
]
,
stdOutFile
=
daemon_out
,
stdErrFile
=
daemon_err
,
messageOut
=
messageDaemonOut
,
messageErr
=
messageDaemonErr
}
return
$
Instrumentation
(
P
.
proc
"daemon"
[]
)
(
StdOutLog
out
)
(
StdErrLog
err
)
test
where
nodeOsFailure
(
ExitFailure
n
,
_
,
_
)
=
do
printError
(
"argo_nodeos_config failed with exit code :"
<>
repr
n
<>
"
\n
"
)
...
...
@@ -166,95 +142,83 @@ prepareDaemon sa@StackArgs {..} = do
"argo_nodeos_config successfully cleaned the container
\
\
config."
prepareCmdRun
::
StackArgs
->
Instrumentation
prepareCmdRun
StackArgs
{
..
}
=
Instrumentation
{
process
=
P
.
proc
"cmd"
$
[
"run"
,
"-u"
,
T
.
unpack
containerName
,
encodeString
$
manifestDir
</>
manifestName
,
T
.
unpack
app
]
++
fmap
T
.
unpack
args
,
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
iDaemon
<-
prepareDaemon
a
let
iRun
=
prepareCmdRun
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
)
$
\
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
cmdRunI
::
AppName
->
AppArgs
->
ContainerName
->
ManifestDir
->
ManifestName
->
ProcessBehavior
->
Maybe
(
StackI
,
Instrumentation
)
cmdRunI
(
AppName
app
)
(
AppArgs
args
)
(
ContainerName
cn
)
(
ManifestDir
md
)
(
ManifestName
mn
)
pb
=
Just
(
Run
,
)
<*>
processBehaviorToI
(
P
.
proc
"cmd"
$
[
"run"
,
"-u"
,
T
.
unpack
cn
,
encodeString
$
md
</>
mn
,
T
.
unpack
app
]
++
fmap
T
.
unpack
args
)
pb
cmdListenI
::
ContainerName
->
ProcessBehavior
->
Maybe
(
StackI
,
Instrumentation
)
cmdListenI
(
ContainerName
cn
)
pb
=
Just
(
Listen
,
)
<*>
processBehaviorToI
(
P
.
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"
])
pb
cmdListenPowerI
::
ContainerName
->
ProcessBehavior
->
Maybe
(
StackI
,
Instrumentation
)
cmdListenPowerI
(
ContainerName
cn
)
pb
=
Just
(
Power
,
)
<*>
processBehaviorToI
(
P
.
proc
"cmd"
[
"listen"
,
"-u"
,
T
.
unpack
cn
,
"--filter"
,
"power"
])
pb
data
StackOutput
=
FoundMessage
|
MessageNotFound
|
Died
StackI
ExitCode
data
StackI
=
Daemon
|
Run
|
Listen
|
Progress
|
Power
deriving
(
Show
)
runListenStack
::
StackArgs
->
Shell
StackOutput
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
cleanLeftovers
workingDirectory
iDaemon
<-
case
daemon
of
DontRun
->
return
Nothing
JustRun
out
err
->
(
\
x
->
Just
(
Daemon
,
x
))
<$>
prepareDaemon
out
err
Nothing
workingDirectory
SucceedTestOnMessage
t
out
err
->
(
\
x
->
Just
(
Daemon
,
x
))
<$>
prepareDaemon
out
err
(
Just
t
)
workingDirectory
let
milist
=
[
iDaemon
,
cmdRunI
app
args
containerName
manifestDir
manifestName
cmdrun
,
cmdListenI
containerName
cmdlisten
,
cmdListenProgressI
containerName
cmdlistenprogress
,
cmdListenPowerI
containerName
cmdlistenpower
]
ilist
=
catMaybes
milist
asyncs
<-
liftIO
$
mapM
tupleToAsync
ilist
liftIO
$
kbInstallHandler
$
CM
.
mapM_
cancel
asyncs
out
<-
liftIO
$
waitAnyCancel
asyncs
return
$
case
snd
out
of
(
_
,
Left
PatternMatched
)
->
FoundMessage
(
Run
,
Right
(
ExitSuccess
,
_
,
_
))
->
MessageNotFound
(
stacki
,
Right
(
e
,
_
,
_
)
)
->
Died
stacki
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
)
tupleToAsync
::
(
StackI
,
Instrumentation
)
->
IO
(
Async
(
StackI
,
Either
PatternMatched
(
ExitCode
,
()
,
()
)))
tupleToAsync
(
stacki
,
instrum
)
=
async
$
(
stacki
,)
<$>
runI
instrum
argo/src/Argo/Utils.hs
View file @
be0e5b41
...
...
@@ -3,6 +3,7 @@
module
Argo.Utils
where
import
Argo.Args
import
Turtle
import
Prelude
hiding
(
FilePath
)
import
System.Console.ANSI
...
...
@@ -37,7 +38,7 @@ printCommand = printf ("Running: " % s % "\n")
printWarning
=
colorShell
Yellow
.
printf
(
"Warning: "
%
s
)
printError
=
colorShell
Red
.
printf
(
"Error: "
%
s
)
printSuccess
=
colorShell
Green
.
printf
(
"Success: "
%
s
)
printTest
=
colorShell
Green
.
printf
(
"RUNNING TEST: "
%
s
%
"
\n
"
)
printTest
=
colorShell
Green
.
printf
(
"RUNNING TEST: "
%
s
%
"
\n
"
)
dieRed
str
=
colorShell
Red
(
printf
(
"Failure: "
%
s
)
str
)
>>
exit
(
ExitFailure
1
)
...
...
@@ -60,7 +61,7 @@ sudoRemoveFile printer desc filePath = do
go
useSudo
=
do
printer
$
format
(
"found stale "
%
s
%
" at "
%
fp
%
".. "
)
desc
filePath
shell
(
format
((
if
useSudo
then
"sudo "
else
""
)
%
"rm -f "
%
fp
)
filePath
)
(
format
((
if
useSudo
then
"sudo "
else
""
)
%
"rm -
r
f "
%
fp
)
filePath
)
Turtle
.
empty
>>=
\
case
ExitSuccess
->
colorShell
Green
$
printf
" Successfully removed.
\n
"
...
...
@@ -92,26 +93,27 @@ 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
)
CreateProcess
StdOutLog
StdErrLog
(
Maybe
TestText
)
deriving
(
Show
)
runI
::
Instrumentation
->
IO
(
Either
PatternMatched
(
ExitCode
,
()
,
()
))
runI
Instrumentation
{
..
}
=
try
(
reroutedDaemon
process
)
runI
(
Instrumentation
cp
outlog
@
(
StdOutLog
out
)
errlog
@
(
StdErrLog
err
)
t
)
=
try
(
reroutedDaemon
cp
)
where
reroutedDaemon
process
=
withSinkFile
(
encodeString
stdOutFile
)
$
\
outSink
->
withSinkFile
(
encodeString
stdErrFile
)
$
\
errSink
->
sourceProcessWithStreams
withSinkFile
(
T
.
unpack
out
)
$
\
outSink
->
withSinkFile
(
T
.
unpack
err
)
$
\
errSink
->
sourceProcessWithStreams
process
mempty
(
makeMatcher
messageOu
t
.|
outSink
)
(
makeMatcher
messageErr
.|
errSink
)
(
makeMatcher
t
.|
outSink
)
(
makeMatcher
t
.|
errSink
)
makeMatcher
maybeMessage
=
case
maybeMessage
of
Just
msg
->
untilMatch
msg
Nothing
->
awaitForever
yield
Just
(
TestText
msg
)
->
untilMatch
msg
Nothing
->
awaitForever
yield
untilMatch
::
Text
->
ConduitT
ByteString
ByteString
IO
()
untilMatch
message
=
do
inb
<-
await
...
...
@@ -122,3 +124,10 @@ runI Instrumentation {..} = try (reroutedDaemon process)
yield
b
untilMatch
message
_
->
return
()
processBehaviorToI
::
CreateProcess
->
ProcessBehavior
->
Maybe
Instrumentation
processBehaviorToI
cp
=
\
case
DontRun
->
Nothing
JustRun
out
err
->
Just
$
Instrumentation
cp
out
err
Nothing
SucceedTestOnMessage
t
out
err
->
Just
$
Instrumentation
cp
out
err
(
Just
t
)
argotk/argotk.cabal
View file @
be0e5b41
...
...
@@ -16,7 +16,7 @@ executable argotk
main-is: argotk.hs
-- other-modules:
-- other-extensions:
build-depends: base, shake
build-depends: base, shake
, argo, turtle, data-default, async, unix, text, optparse-applicative, foldl, ansi-terminal
--hs-source-dirs: src
default-language: Haskell2010
GHC-Options: -Wall
argotk/argotk.hs
View file @
be0e5b41
...
...
@@ -8,16 +8,8 @@ import Argo.Args
import
Turtle
import
Prelude
hiding
(
FilePath
)
import
Data.Default
import
Control.Concurrent.Async
import
System.Environment
import
System.Console.ANSI
import
System.Console.ANSI.Types
(
Color
)
import
Options.Applicative
import
System.Posix.Signals
import
Control.Monad
import
Data.Either
import
Data.Maybe
import
qualified
Control.Foldl
as
Fold
import
Options.Applicative
hiding
(
action
)
import
Data.Text
as
T
(
pack
)
...
...
@@ -25,20 +17,12 @@ opts :: StackArgs -> Parser (Shell ())
opts
sa
=
hsubparser
(
command
"clean"
(
info
(
pure
$
clean
sa
)
(
progDesc
"Clean sockets, logfiles."
))
<>
command
"daemon-only"
(
info
(
daemon
<$>
parseExtendStackArgs
sa
)
(
progDesc
"Set up and launch the daemon in synchronous mode,
\
\
with properly cleaned sockets, logfiles."
)
)
<>
command
"full-stack"
(
info
(
simpleStack
False
<$>
parseExtendStackArgs
sa
)
(
info
(
fullStack
<$>
parseExtendStackArgs
sa
)
(
progDesc
"Setup stack and run a command in a container."
)
)
<>
commandTest
DaemonOnly
<>
commandTest
TestHello
<>
commandTest
TestListen
<>
commandTest
TestPerfwrapper
...
...
@@ -55,126 +39,115 @@ opts sa = hsubparser
action
ttype
=
doOverridenTest
ttype
<$>
parseExtendStackArgs
((
stackArgsUpdate
$
configureTest
ttype
)
sa
)
descTest
ttype
=
"test"
++
description
(
configureTest
ttype
)
commandTest
ttype
=
command
(
show
ttype
)
$
info
(
action
ttype
)
(
progDesc
$
descTest
ttype
)
commandTests
ttypes
cmdStr
descStr
=
command
cmdStr
$
info
(
pure
$
mapM_
(
doTest
sa
)
ttypes
)
(
progDesc
descStr
)
commandTest
ttype
=
command
(
show
ttype
)
$
info
(
action
ttype
)
(
progDesc
$
descTest
ttype
)
commandTests
ttypes
cmdStr
descStr
=
command
cmdStr
$
info
(
pure
$
mapM_
(
doTest
sa
)
ttypes
)
(
progDesc
descStr
)
data
TestType
=
TestHello
|
TestListen
|
TestPerfwrapper
|
TestPower
deriving
Show
data
TestSpec
=
TestSpec
{
stackAction
::
StackArgs
->
Shell
()
,
stackArgsUpdate
::
StackArgs
->
StackArgs
,
description
::
String
}
data
TestType
=
DaemonOnly
|
DaemonApp
|
TestHello
|
TestListen
|
TestPerfwrapper
|
TestPower
deriving
Show
doTest
::
StackArgs
->
TestType
->
Shell
()
doTest
stackArgs
ttype
=
doSpec
spec
$
(
stackArgsUpdate
$
configureTest
ttype
)
stackArgs
data
TestSpec
=
TestSpec
{
stackArgsUpdate
::
StackArgs
->
StackArgs
,
description
::
String
}
doTest
::
StackArgs
->
TestType
->
Shell
()
doTest
stackArgs
ttype
=
doSpec
spec