Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
argo
argotk
Commits
2a4f8320
Commit
2a4f8320
authored
Mar 21, 2019
by
Valentin Reis
Browse files
refactoring to protolude.
parent
73c9d00c
Pipeline
#6105
failed with stages
in 1 minute and 34 seconds
Changes
6
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
argotk.cabal
View file @
2a4f8320
...
...
@@ -18,7 +18,10 @@ executable argotk
-- other-extensions:
build-depends:
base,
protolude,
shake,
directory,
typed-process,
turtle,
data-default,
async,
...
...
share/manifests/parallel.json
View file @
2a4f8320
...
...
@@ -15,7 +15,7 @@
"name"
:
"argo/container"
,
"value"
:
{
"cpus"
:
"48"
,
"mems"
:
"
1
"
"mems"
:
"
2
"
}
},
{
...
...
src/Argo/Stack.hs
View file @
2a4f8320
{-# 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
p
rintInfo
"Cleaning sockets."
p
utText
"Cleaning sockets."
for_
socklist
cleanSocket
p
rintInfo
"Cleaning output directory."
void
$
shell
(
format
(
"rm -rf "
%
fp
)
wd
)
Turtle
.
empty
p
utText
"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
p
rintInfo
"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
->
p
utText
"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
p
rintInfo
"Starting the following processes:"
p
utText
"Starting the following processes:"
liftIO
$
pPrint
ilist
asyncs
<-
liftIO
$
for
ilist
tupleToAsync
_
<-
liftIO
$
kbInstallHandler
$
for_
asyncs
cancel
when
verbose
$
p
rintInfo
"Processes started."
when
verbose
$
p
utText
"Processes started."
out
<-
liftIO
$
waitAnyCancel
asyncs
p
rintInfo
p
utText
(
"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
src/Argo/Types.hs
View file @
2a4f8320
{-# 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"
]
...
...
src/Argo/Utils.hs
View file @
2a4f8320
{-# 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
=
p
rintf
(
"info: "
%
s
%
"
\n
"
)
printCommand
=
p
rintf
(
"running: "
%
s
%
"
\n
"
)
printWarning
=
colorShell
Yellow
.
p
rintf
(
"warning: "
%
s
%
"
\n
"
)
printError
=
colorShell
Red
.
p
rintf
(
"error: "
%
s
%
"
\n
"
)
printSuccess
=
colorShell
Green
.
p
rintf
(
"success: "
%
s
%
"
\n
"
)
printTest
=
colorShell
Green
.
p
rintf
(
"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
=
p
utText
$
"info: "
<>
s
<>
"
\n
"
printCommand
s
=
p
utText
$
"running: "
<>
s
<>
"
\n
"
printWarning
s
=
colorShell
Yellow
$
p
utText
$
"warning: "
<>
s
<>
"
\n
"
printError
s
=
colorShell
Red
$
p
utText
$
"error: "
<>
s
<>
"
\n
"
printSuccess
s
=
colorShell
Green
$
p
utText
$
"success: "
<>
s
<>
"
\n
"
printTest
s
=
colorShell
Green
$
p
utText
$
"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
Create
Process
(
Process
Config
()
()
()
)
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
)