refactoring to protolude.

argotk.cabal

@@ -18,7 +18,10 @@ executable argotk
   -- other-extensions:
   build-depends:
     base,
+    protolude,
     shake,
+    directory,
+    typed-process,
     turtle,
     data-default,
     async,

share/manifests/parallel.json

@@ -15,7 +15,7 @@
         "name": "argo/container",
         "value": {
           "cpus": "48",
-          "mems": "1"
+          "mems": "2"
         }
       },
       {

src/Argo/Stack.hs

 {-# 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
-  printInfo "Cleaning sockets."
+  putText "Cleaning sockets."
   for_ socklist cleanSocket
-  printInfo "Cleaning output directory."
-  void $ shell (format ("rm -rf " % fp) wd) Turtle.empty
+  putText "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
-        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 -> Shell ()
+    printError $ "argo_nodeos_config failed with exit code :" <> show n
+    doesFileExist ".argo_nodeos_config_exit_message" >>= \case
+      True ->
+        putText "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
-    printInfo "Starting the following processes:"
+    putText "Starting the following processes:"
     liftIO $ pPrint ilist
 
   asyncs <- liftIO $ for ilist tupleToAsync
   _      <- liftIO $ kbInstallHandler $ for_ asyncs cancel
 
-  when verbose $ printInfo "Processes started."
+  when verbose $ putText "Processes started."
 
   out <- liftIO $ waitAnyCancel asyncs
 
-  printInfo
+  putText
     (  "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

 {-# 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

 {-# 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 = 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 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 = putText $ "info: " <> s <> "\n"
+printCommand s = putText $ "running: " <> s <> "\n"
+printWarning s = colorShell Yellow $ putText $ "warning: " <> s <> "\n"
+printError s = colorShell Red $ putText $ "error: " <> s <> "\n"
+printSuccess s = colorShell Green $ putText $ "success: " <> s <> "\n"
+printTest s = colorShell Green $ putText $ "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
-  CreateProcess
+  (ProcessConfig () () ())
   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)
-        (makeBehavior errTest `fuseUpstream` errSink)
-  makeBehavior
-    :: Maybe TextBehavior -> ConduitT ByteString ByteString IO TracebackScan