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.hs51
1 files changed, 33 insertions, 18 deletions
diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs
index 6d73e70..c23b4f0 100644
--- a/src/Reaktor/Plugins/System.hs
+++ b/src/Reaktor/Plugins/System.hs
@@ -23,6 +23,7 @@ import System.FilePath.Posix (takeBaseName)
import System.IO (BufferMode(LineBuffering),hSetBuffering)
import System.IO (Handle,hClose,hPutStr,hIsEOF)
import System.Process
+import System.Timeout
import qualified Text.Regex.PCRE.Heavy as RE
import qualified Text.Regex.PCRE.Light as RE
@@ -158,8 +159,7 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
cwd = commandWorkDir <|> hWorkDir <|> cWorkDir
- fork commandPath args cwd (Just env) "" onOutLine onErrLine onExit
- `catch` onExcept
+ fork commandPath args cwd (Just env) "" hTimeout Callbacks{..}
Nothing -> do
let s = name <> ": command not found"
@@ -167,28 +167,25 @@ 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 ()
+ }
+
fork :: FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> String
- -> (Text -> IO ())
- -> (Text -> IO ())
- -> (ExitCode -> IO ())
+ -> Maybe Int
+ -> Callbacks
-> IO ()
-fork path args cwd env input onOutLine onErrLine onExit = do
- let
- p = (proc path args)
- { cwd = cwd
- , env = env
- , std_in = CreatePipe
- , std_out = CreatePipe
- , std_err = CreatePipe
- , close_fds = True
- , create_group = True
- , new_session = True
- }
- withCreateProcess p $ \(Just inh) (Just outh) (Just errh) ph -> do
+fork path args cwd env input hTimeout Callbacks{..} =
+ forkIO (withTimeout f `catch` onExcept) >> return ()
+ where
+ f = withCreateProcess p $ \(Just inh) (Just outh) (Just errh) ph -> do
mapM_ forkIO [
hPutStr inh input `finally` hClose inh,
hWithLines outh onOutLine,
@@ -196,6 +193,24 @@ fork path args cwd env input onOutLine onErrLine onExit = do
]
waitForProcess ph >>= onExit
+ p = (proc path args)
+ { cwd = cwd
+ , env = env
+ , std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ , close_fds = True
+ , create_group = True
+ , new_session = True
+ }
+
+ timeoutError = errorWithoutStackTrace "timeout"
+
+ withTimeout =
+ case hTimeout of
+ Just time -> (maybe timeoutError return =<<) . timeout time
+ Nothing -> id
+
hWithLines :: Handle -> (Text -> IO ()) -> IO ()
hWithLines h f = do