diff options
| -rw-r--r-- | reaktor2.cabal | 1 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/System.hs | 37 |
2 files changed, 29 insertions, 9 deletions
diff --git a/reaktor2.cabal b/reaktor2.cabal index 4932137..f0cff6f 100644 --- a/reaktor2.cabal +++ b/reaktor2.cabal @@ -9,6 +9,7 @@ cabal-version: >=1.10 executable reaktor build-depends: aeson, + async, attoparsec, base, blessings, diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs index c23b4f0..573d11d 100644 --- a/src/Reaktor/Plugins/System.hs +++ b/src/Reaktor/Plugins/System.hs @@ -7,7 +7,8 @@ module Reaktor.Plugins.System (new) where import Blessings import Control.Applicative -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO,threadDelay) +import Control.Concurrent.Async (race) import Control.Exception import qualified Data.HashMap.Lazy as M import qualified Data.List as L @@ -22,8 +23,11 @@ import System.Exit import System.FilePath.Posix (takeBaseName) import System.IO (BufferMode(LineBuffering),hSetBuffering) import System.IO (Handle,hClose,hPutStr,hIsEOF) +import System.IO.Error (catchIOError,isDoesNotExistError) import System.Process -import System.Timeout +import System.Posix.Process (getProcessGroupIDOf) +import System.Posix.Signals (Signal,signalProcessGroup,killProcess) +import System.Posix.Types (ProcessGroupID) import qualified Text.Regex.PCRE.Heavy as RE import qualified Text.Regex.PCRE.Light as RE @@ -183,15 +187,27 @@ fork :: FilePath -> Callbacks -> IO () fork path args cwd env input hTimeout Callbacks{..} = - forkIO (withTimeout f `catch` onExcept) >> return () + forkIO (f `catch` onExcept) >> return () where f = withCreateProcess p $ \(Just inh) (Just outh) (Just errh) ph -> do + Just pid <- getPid ph + pgid <- getProcessGroupIDOf pid + mapM_ forkIO [ hPutStr inh input `finally` hClose inh, hWithLines outh onOutLine, hWithLines errh onErrLine ] - waitForProcess ph >>= onExit + + case hTimeout of + Just time -> + race (threadDelay time) (waitForProcess ph) >>= \case + Left () -> onExcept (SomeException (ErrorCall "timeout")) + Right code -> onExit code + Nothing -> + waitForProcess ph >>= onExit + + killProcessGroup pgid p = (proc path args) { cwd = cwd @@ -204,12 +220,15 @@ fork path args cwd env input hTimeout Callbacks{..} = , new_session = True } - timeoutError = errorWithoutStackTrace "timeout" - withTimeout = - case hTimeout of - Just time -> (maybe timeoutError return =<<) . timeout time - Nothing -> id +killProcessGroup :: ProcessGroupID -> IO () +killProcessGroup = signalProcessGroup' killProcess + +signalProcessGroup' :: Signal -> ProcessGroupID -> IO () +signalProcessGroup' sig pgid = + catchIOError + (signalProcessGroup sig pgid) + (\e -> if isDoesNotExistError e then return () else ioError e) hWithLines :: Handle -> (Text -> IO ()) -> IO () |