diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Reaktor/Plugins/System.hs | 61 |
1 files changed, 31 insertions, 30 deletions
diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs index 573d11d..2f7a2b2 100644 --- a/src/Reaktor/Plugins/System.hs +++ b/src/Reaktor/Plugins/System.hs @@ -128,26 +128,24 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do baseEnv <- getEnvironment let - onExit code = do - let s = T.show code - (sig, col) = - if code == ExitSuccess - then (SGR [38,5,235] "* ", SGR [38,5,107]) - else (SGR [38,5,235] "! ", SGR [31,1]) - aLog $ sig <> col (Plain $ name <> ": " <> s) - - onExcept :: SomeException -> IO () - onExcept e = do - let s0 = T.show e - aLog $ SGR [38,5,235] "! " - <> SGR [31,1] (Plain $ name <> ": " <> s0) - - onErrLine :: Text -> IO () - onErrLine s0 = do - aLog $ SGR [38,5,235] "2 " - <> SGR [31,1] (Plain $ name <> ": " <> s0) - - onOutLine s = aSend (privmsg audience [s]) + logStr pid s = do + let p = name <> "[" <> T.show pid <> "] " + aLog $ SGR [38,5,247] (Plain p <> s) + + red :: Text -> Blessings Text + red = SGR [31] . Plain + + onStart pid = logStr pid "started" + onErrLine pid s = logStr pid $ "stderr: " <> red s + onOutLine _ s = aSend (privmsg audience [s]) + onError pid e = logStr pid $ "failed: " <> red (T.show e) + + onExit pid = \case + ExitSuccess -> + logStr pid "stopped" + ExitFailure i -> + logStr pid $ "stopped with exit code " <> + red (T.show $ if i <= 127 then i else -256 + i) extraEnv = [ ("_prefix", T.unpack prefix) @@ -172,10 +170,11 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do Nothing -> return () data Callbacks = Callbacks - { onOutLine :: Text -> IO () - , onErrLine :: Text -> IO () - , onExit :: ExitCode -> IO () - , onExcept :: SomeException -> IO () + { onOutLine :: Pid -> Text -> IO () + , onErrLine :: Pid -> Text -> IO () + , onError :: Pid -> SomeException -> IO () + , onExit :: Pid -> ExitCode -> IO () + , onStart :: Pid -> IO () } fork :: FilePath @@ -187,25 +186,27 @@ fork :: FilePath -> Callbacks -> IO () fork path args cwd env input hTimeout Callbacks{..} = - forkIO (f `catch` onExcept) >> return () + forkIO (f `catch` onError (-1)) >> return () where f = withCreateProcess p $ \(Just inh) (Just outh) (Just errh) ph -> do Just pid <- getPid ph pgid <- getProcessGroupIDOf pid + onStart pid + mapM_ forkIO [ hPutStr inh input `finally` hClose inh, - hWithLines outh onOutLine, - hWithLines errh onErrLine + hWithLines outh (onOutLine pid), + hWithLines errh (onErrLine pid) ] case hTimeout of Just time -> race (threadDelay time) (waitForProcess ph) >>= \case - Left () -> onExcept (SomeException (ErrorCall "timeout")) - Right code -> onExit code + Left () -> onError pid (SomeException (ErrorCall "timeout")) + Right code -> onExit pid code Nothing -> - waitForProcess ph >>= onExit + waitForProcess ph >>= onExit pid killProcessGroup pgid |