summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2019-01-26 16:04:29 +0100
committertv <tv@krebsco.de>2019-01-26 16:04:29 +0100
commit3e8aabc3993e4ad1d34c25c1caeb75ff6faa97ff (patch)
treef6cb1332f225e50a03acbed1a9cefb7041266dfb /src
parentf8c5b4cfe57cb50503b8333d5d06bd0f99fdecc6 (diff)
Reaktor.Plugins.System: add optional timeout
Diffstat (limited to 'src')
-rw-r--r--src/Reaktor/Plugins/System.hs51
-rw-r--r--src/Reaktor/Plugins/System/Internal.hs2
2 files changed, 35 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
diff --git a/src/Reaktor/Plugins/System/Internal.hs b/src/Reaktor/Plugins/System/Internal.hs
index 9b1b8de..45b7329 100644
--- a/src/Reaktor/Plugins/System/Internal.hs
+++ b/src/Reaktor/Plugins/System/Internal.hs
@@ -51,6 +51,7 @@ data Hook = Hook
, hArguments :: [CaptureOr Text]
, hWorkDir :: Maybe FilePath
, hCommands :: HashMap Text Command
+ , hTimeout :: Maybe Int
}
deriving Show
@@ -64,6 +65,7 @@ instance FromJSON Hook where
<*> v .:? "arguments" .!= []
<*> v .:? "workdir"
<*> v .:? "commands" .!= mempty
+ <*> (fmap (*1000000) <$> v .:? "timeoutSec" .!= Just 10)
_ -> undefined