Commit f308fbaf authored by Valentin Reis's avatar Valentin Reis

Refactor argotk - moved out of this repository.

parent f6ab009f
Pipeline #5040 failed with stage
in 2 minutes and 38 seconds
......@@ -15,7 +15,7 @@ nix-shell -E '
#nrm-src = /path/to/nrm
#libnrm-src = /path/to/nrm
#containers-src = /path/to/nrm
}).test' --run "argotk.hs TestHello"
}).test' --run "argotk TestHello"
```
### Usage (in three parts)
......@@ -63,30 +63,30 @@ nix-shell -E '{ argotest ? (builtins.fetchGit {
ref="fancy-branch-name";
rev="commit-revisions-string";
};
}).test' --run 'argotk.hs TestHello'
}).test' --run 'argotk TestHello'
```
- [**3**] The `test`environment contains the `argotk.hs` tool, which runs various
- [**3**] The `test`environment contains the `argotk` tool, which runs various
operations on the argo stack:
Commands list:
```{.bash}
argotk.hs --help
argotk --help
```
Output:
```{.txt pipe="sh"}
root/argotk/argotk.hs --help
argotk --help
```
Detailed help:
```{.bash}
argotk.hs TestHello --help
argotk TestHello --help
```
Output:
```{.txt pipe="sh"}
root/argotk/argotk.hs TestHello --help
argotk TestHello --help
```
#### Misc
......@@ -98,7 +98,7 @@ nix-shell -E '
(import( builtins.fetchGit {
url = https://xgitlab.cels.anl.gov/argo/argotest.git;
ref="master";
}) {}).test' --run "argotk.hs TestHello"
}) {}).test' --run "argotk TestHello"
```
#### WARNINGS
......@@ -107,11 +107,6 @@ There are a few things one has to be aware of using this workflow:
- Builds may fail if the local source repositories are dirty with old build files.
- Without using the `rev` argument, the `builtins.fetchGit` nix command
prefetches and buffers its output, with an expiration time that ranges ten
minutes by default. Use a local checkout if you need to modify some of these
sources on the fly.
### Hacking
- edit `.README.md` in place of README.md.
......
# Revision history for argo
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
Copyright (c) 2018 Valentin Reis
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
import Distribution.Simple
main = defaultMain
name: argo
version: 0.1.0.0
license: MIT
license-file: LICENSE
author: Valentin Reis
maintainer: fre@freux.fr
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
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, stm, pretty-show, unliftio-core
hs-source-dirs: src
default-language: Haskell2010
ghc-options:
-Wall
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-fwarn-tabs
-fwarn-unused-imports
-fwarn-missing-signatures
-fwarn-name-shadowing
-fprint-potential-instances
-Wmissing-export-list
-fwarn-incomplete-patterns
{-|
Module : Argo
Description : The holt core package
Copyright : (c) Valentin Reis, 2018
License : MIT
Maintainer : fre@freux.fr
-}
module Argo
( module Argo.Stack
, module Argo.Args
, module Argo.Utils
)
where
import Argo.Stack
import Argo.Utils
import Argo.Args
{-# 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 hiding ( option )
import Prelude hiding ( FilePath )
data StackArgs = StackArgs
{ verbosity :: Verbosity
, app :: AppName
, args :: [AppArg]
, containerName :: ContainerName
, workingDirectory :: WorkingDirectory
, manifestDir :: ManifestDir
, manifestName :: ManifestName
, daemon :: ProcessBehavior
, cmdrun :: ProcessBehavior
, cmdlisten :: ProcessBehavior
, cmdlistenprogress :: ProcessBehavior
, cmdlistenperformance :: ProcessBehavior
, cmdlistenpower :: ProcessBehavior
} deriving (Show)
{-data OutputFiles = OutputFiles FilePath FilePath-}
data Verbosity = Normal | Verbose deriving (Show,Read,Eq)
newtype AppArg = AppArg Text deriving (IsString, 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)
data ProcessBehavior =
Test TestText StdOutLog StdErrLog
| JustRun StdOutLog StdErrLog
| DontRun deriving (Show,Read)
newtype StdOutLog = StdOutLog Text deriving (Show, Read)
newtype StdErrLog = StdErrLog Text deriving (Show, Read)
data TestText = TestText TextBehaviorStdout TextBehaviorStderr deriving (Show, Read)
newtype TextBehaviorStdout = TextBehaviorStdout TextBehavior deriving (Show, Read)
newtype TextBehaviorStderr = TextBehaviorStderr TextBehavior deriving (Show, Read)
data TextBehavior =
WaitFor Text
| ExpectClean deriving (Show,Read)
behavior :: ReadM ProcessBehavior
behavior = read <$> readerAsk
behaviorOption :: Mod OptionFields ProcessBehavior -> Parser ProcessBehavior
behaviorOption = option behavior
instance Default StackArgs where
def = StackArgs
{ verbosity = Normal
, app = AppName "ls"
, args = []
, containerName = ContainerName "testContainer"
, workingDirectory = WorkingDirectory "_output"
, manifestDir = ManifestDir "manifests"
, manifestName = ManifestName "basic.json"
, daemon = DontRun
, cmdrun = DontRun
, cmdlisten = DontRun
, cmdlistenprogress = DontRun
, cmdlistenperformance = DontRun
, cmdlistenpower = DontRun
}
parseExtendStackArgs :: StackArgs -> Parser StackArgs
parseExtendStackArgs sa = do
verbosity <- flag
Normal
Verbose
(long "verbose" <> short 'v' <> help "Enable verbose mode")
app <- strOption
( long "app"
<> metavar "APP"
<> help "Target application executable name. PATH is inherited."
<> showDefault
<> value (app sa)
)
containerName <- strOption
( long "container_name"
<> metavar "ARGO_CONTAINER_UUID"
<> help "Container name"
<> showDefault
<> value (containerName sa)
)
workingDirectory <- strOption
( long "output_dir"
<> metavar "DIR"
<> help "Working directory."
<> showDefault
<> value (workingDirectory sa)
)
manifestDir <- strOption
( long "manifest_directory"
<> metavar "DIR"
<> help "Manifest lookup directory"
<> showDefault
<> value (manifestDir sa)
)
manifestName <- strOption
( long "manifest_name"
<> metavar "FILENAME"
<> help "Manifest file basename (relative to --manifest_directory)"
<> showDefault
<> value (manifestName sa)
)
daemon <- behaviorOption
( long "daemon"
<> metavar "BEHAVIOR"
<> help "`daemon` behavior"
<> showDefault
<> value (daemon sa)
)
cmdrun <- behaviorOption
( long "cmd_run"
<> metavar "BEHAVIOR"
<> help "`cmd run` behavior"
<> showDefault
<> value (cmdrun sa)
)
cmdlisten <- behaviorOption
( long "cmd_listen"
<> metavar "BEHAVIOR"
<> help "`cmd listen` behavior"
<> showDefault
<> value (cmdlisten sa)
)
cmdlistenperformance <- behaviorOption
( long "cmd_listen_performance"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter performance` behavior"
<> showDefault
<> value (cmdlistenperformance sa)
)
cmdlistenprogress <- behaviorOption
( long "cmd_listen_progress"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter progress` behavior"
<> showDefault
<> value (cmdlistenprogress sa)
)
cmdlistenpower <- behaviorOption
( long "cmd_listen_power"
<> metavar "BEHAVIOR"
<> help "`cmd listen --filter power` behavior"
<> showDefault
<> value (cmdlistenpower sa)
)
args <- some (argument str (metavar "ARGS" <> help "Application arguments."))
<|> pure (args sa)
pure StackArgs {..}
{-# LANGUAGE
TupleSections,
LambdaCase,
RecordWildCards,
OverloadedStrings #-}
module Argo.Stack where
import Argo.Args
import Turtle
import Turtle.Shell
import Prelude hiding ( FilePath )
import Filesystem.Path ( (</>) )
import Control.Concurrent.Async
import Data.Text as T
hiding ( empty )
import Argo.Utils
import System.Process as P
hiding ( shell )
import Control.Monad as CM
import Data.Maybe
import Control.Foldl as Fold
import Text.Show.Pretty
cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do
printInfo "Cleaning working(output) directory."
cleanLog wd
printInfo "Cleaning sockets."
CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
let dir = case toText workingDirectory of
Left di -> di
Right di -> di
let findmnt = inproc "findmnt" ["-T", dir, "-o", "OPTIONS"] empty
b <- liftIO $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Fold.length
when (b > 0) $ dieRed $ format
("The output directory, " % fp % ", must not mounted with \"nosuid\"")
workingDirectory
prepareDaemon
:: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
prepareDaemon out stdErr test = do
_ <- myWhich "daemon"
confPath <- myWhich "argo_nodeos_config"
let confPath' = "./argo_nodeos_config"
cp confPath confPath'
printInfo $ format ("Copied the configurator to " % fp) confPath'
printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config"
verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root."
ExitFailure n ->
die ("Failed to set argo_nodeos_config permissions " <> repr n)
verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
ExitSuccess -> printInfo "Set the suid bit."
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 (P.proc "daemon" []) 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
printInfo "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 -> NominalDiffTime -> Integer -> Shell ()
cleanContainers argo_nodeos_config retryTime remainingRetries = do
let showConfig =
inshell (format (fp % " --show_config") argo_nodeos_config) empty
verboseShell'
(format (fp % " --clean_config=kill_content:true") argo_nodeos_config)
empty
>>= \case
(ExitFailure n, _, _) -> do
when (remainingRetries == 0) $ nodeOsFailure n
printWarning
( "the argo_nodeos_config call failed with exit code "
<> repr n
<> ". Retrying.."
)
liftIO $ sleep (retryTime * 2)
cleanContainers argo_nodeos_config
(retryTime * 2)
(remainingRetries - 1)
(ExitSuccess, _, _) -> do
printInfo "Cleaned the argo config."
len <- liftIO $ Turtle.Shell.fold
(grep (has "CONTAINER") showConfig)
Fold.length
if len > 0
then do
printWarning
"the argo_nodeos_config call did not remove containers, \
\at least not fast enough. Retrying.."
liftIO $ sleep retryTime
cleanContainers argo_nodeos_config
(retryTime * 2)
(remainingRetries - 1)
else
printInfo
"argo_nodeos_config successfully cleaned the container \
\config."
cmdRunI
:: AppName
-> [AppArg]
-> ContainerName
-> ManifestDir
-> ManifestName
-> ProcessBehavior
-> Maybe (StackI, Instrumentation)
cmdRunI (AppName app) 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 . argToText) args
)
pb
where argToText (AppArg a) = a
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
cmdListenPerformanceI
:: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPerformanceI (ContainerName cn) pb =
Just (Performance, )
<*> processBehaviorToI
(P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"]
)
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 Text
| FoundTracebacks Tracebacks
| Died StackI ExitCode TracebackScanOut TracebackScanErr Tracebacks deriving (Show)
type Tracebacks = [(StackI, Text, Text)]
newtype TracebackScanOut = TracebackScanOut TracebackScan deriving (Show)
newtype TracebackScanErr = TracebackScanErr TracebackScan deriving (Show)
data StackI = Daemon | Run | Listen | Progress | Power | Performance deriving (Eq)
instance Show StackI where
show = \case
Daemon -> "daemon"
Run -> "cmd run"
Listen -> "cmd listen -v"
Progress -> "cmd listen -f progress"
Power -> "cmd listen -f power"
Performance -> "cmd listen -f performance"
runStack :: StackArgs -> Shell StackOutput
runStack sa@StackArgs {..} = do
when (verbosity == Verbose) $ liftIO $ pPrint sa
CM.mapM_
cleanSocket
[ "/tmp/nrm-downstream-in"
, "/tmp/nrm-upstream-in"
, "/tmp/nrm-upstream-event"
]
let (WorkingDirectory wd) = workingDirectory
_ <- Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty
mktree wd
checkFsAttributes wd
cd wd
iDaemon <- case daemon of
DontRun -> return Nothing
JustRun stdOut stdErr ->
(\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing
Test t stdOut stdErr ->
(\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t)
let milist =
[ iDaemon
, cmdRunI app args containerName manifestDir manifestName cmdrun
, cmdListenI containerName cmdlisten
, cmdListenPerformanceI containerName cmdlistenperformance
, cmdListenProgressI containerName cmdlistenprogress
, cmdListenPowerI containerName cmdlistenpower
]
ilist = catMaybes milist
if verbosity == Verbose
then do
printInfo "Starting the following processes:"
liftIO $ pPrint ilist
else liftIO $ pPrint (fmap fst ilist)
asyncs <- liftIO $ mapM tupleToAsync ilist
_ <- liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
when (verbosity == Verbose) $ printInfo "Processes started."
out <- liftIO $ waitAnyCancel asyncs
printInfo
( "Processes cancelled due to termination of: "
<> repr (fst $ snd out)
<> " with exit information: "
<> repr (snd $ snd out)
)
tracebackList <- procsWithTracebacks ilist
r <- case snd out of
(_, Left (PatternMatched line)) -> case tracebackList of
[] -> return $ FoundMessage line
t -> return $ FoundTracebacks t
(stacki, Right (errmsg, tracebackOut, tracebackErr)) -> return $ Died
stacki
errmsg
(TracebackScanOut tracebackOut)
(TracebackScanErr tracebackErr)
tracebackList
cd "../"
return r
where
procsWithTracebacks
:: [(StackI, Instrumentation)] -> Shell [(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)
tupleToAsync
:: (StackI, Instrumentation)
-> IO
( Async
( StackI
, Either
MonitoringResult
(ExitCode, TracebackScan, TracebackScan)
)
)
tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum
{-# LANGUAGE LambdaCase, OverloadedStrings, DataKinds,
FlexibleInstances, ScopedTypeVariables, TypeOperators #-}
module Argo.Utils where
import Argo.Args
import Turtle
import Prelude hiding ( FilePath )
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 System.IO ( BufferMode(NoBuffering)
, hSetBuffering
)
import Control.Monad.IO.Unlift ( MonadIO(..)
, withRunInIO
)
import Data.Text.Encoding as TE
import Data.Conduit.Combinators as CC
import Control.Exception.Base
import Data.Typeable
import Data.Text as T
import qualified System.IO as IO
-- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell ()
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 ()
dieRed :: Text -> Shell ()
printInfo = printf ("Info: " % s % "\n")
printCommand = printf ("Running: " % s % "\n")
printWarning = colorShell Yellow . printf ("Warning: " % s % "\n")
printError = colorShell Red . printf ("Error: " % s % "\n")
printSuccess = colorShell Green . printf ("Success: " % s % "\n")
printTest = colorShell Green . printf ("RUNNING TEST: " % s % "\n")
dieRed str =
colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1)
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
myWhichMaybe :: FilePath -> Shell (Maybe FilePath)
myWhichMaybe str = which str >>= \case
(Just p) ->
printInfo (format ("Found " % fp % " at " % fp) str p) >> return (Just p)
Nothing -> return Nothing
sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell ()
sudoRemoveFile printer desc filePath = do
foundSocket <- testfile filePath
when foundSocket $ go False
printInfo $ format ("OK: " % s % " " % fp) 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
>>= \case
ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
ExitFailure _ -> if useSudo
then printer $ format
("Failed to remove stale " % s % ", even with sudo.")
desc
else do
printer $ format
("Failed to remove stale " % s % ". Trying sudo..\n")
desc
go True
verboseShell :: Text -> Shell Line -> Shell ExitCode
verboseShell command i = printCommand command >> shell command i
verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text)
verboseShell' command i = printCommand command >> shellStrictWithErr command i
cleanSocket :: FilePath -> Shell ()
cleanSocket = sudoRemoveFile printError "socket"
cleanLog :: FilePath -> Shell ()
cleanLog = sudoRemoveFile printWarning "log folder"
kbInstallHandler :: IO () -> IO Handler
kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing
newtype MonitoringResult = PatternMatched Text deriving (Show, Typeable)
instance Exception MonitoringResult
data Instrumentation = Instrumentation
CreateProcess
StdOutLog
StdErrLog
(Maybe TestText)
deriving (Show)
data TracebackScan = WarningTraceback | Clean deriving (Show)
runI
:: Instrumentation
-> IO (Either MonitoringResult (ExitCode, TracebackScan, TracebackScan))
runI (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = try
(reroutedDaemon crProc)
where
{-reroutedDaemon :: CreateProcess -> IO (ExitCode, (), ())-}
reroutedDaemon process =
withSinkFileNoBuffering (T.unpack stdOut) $ \outSink ->
withSinkFile (T.unpack stdErr) $ \errSink -> sourceProcessWithStreams
process
mempty
(makeBehavior outTest `fuseUpstream` outSink)
(makeBehavior errTest `fuseUpstream` errSink)
makeBehavior
:: Maybe TextBehavior -> ConduitT ByteString ByteString IO TracebackScan
makeBehavior = \case
Just ExpectClean -> warnOnTraceback False
Just (WaitFor message) -> untilMatch message False
Nothing -> awaitForever yield >> return 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