aboutsummaryrefslogtreecommitdiffstats
path: root/src/Reaktor/Plugins/System.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Reaktor/Plugins/System.hs')
-rw-r--r--src/Reaktor/Plugins/System.hs61
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