summaryrefslogtreecommitdiffstats
path: root/src/Flameshot/Internal
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2019-02-07 18:42:36 +0100
committertv <tv@krebsco.de>2019-02-07 18:54:59 +0100
commitfb5636483871fbafe9b286b377c339c8ddf8b4f8 (patch)
tree5016d6b38bff4b13856828ee385aaf7498d8e344 /src/Flameshot/Internal
initial commitv1.0.0-rc1
Diffstat (limited to 'src/Flameshot/Internal')
-rw-r--r--src/Flameshot/Internal/Process.hs89
1 files changed, 89 insertions, 0 deletions
diff --git a/src/Flameshot/Internal/Process.hs b/src/Flameshot/Internal/Process.hs
new file mode 100644
index 0000000..c435d48
--- /dev/null
+++ b/src/Flameshot/Internal/Process.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Flameshot.Internal.Process (run,Callbacks(..)) where
+
+import Control.Concurrent (forkIO,threadDelay)
+import Control.Concurrent.Async (race)
+import Control.Exception
+import Control.Monad.Extended (untilM_,unless)
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+import System.Exit
+import System.IO (BufferMode(LineBuffering),hSetBuffering)
+import System.IO (Handle,hClose,hPutStr,hIsEOF)
+import System.IO.Error (catchIOError,isDoesNotExistError)
+import System.Process
+import System.Posix.Process (getProcessGroupIDOf)
+import System.Posix.Signals (Signal,signalProcessGroup,killProcess)
+import System.Posix.Types (ProcessGroupID)
+
+data Callbacks = Callbacks
+ { onOutLine :: Pid -> Text -> IO ()
+ , onErrLine :: Pid -> Text -> IO ()
+ , onError :: Pid -> SomeException -> IO ()
+ , onExit :: Pid -> ExitCode -> IO ()
+ , onStart :: Pid -> IO ()
+ }
+
+run :: FilePath
+ -> [String]
+ -> Maybe FilePath
+ -> Maybe [(String, String)]
+ -> String
+ -> Maybe Int
+ -> Callbacks
+ -> IO ()
+run path args cwd env input hTimeout Callbacks{..} =
+ f `catch` onError (-1)
+ 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 pid),
+ hWithLines errh (onErrLine pid)
+ ]
+
+ case hTimeout of
+ Just time ->
+ race (threadDelay time) (waitForProcess ph) >>= \case
+ Left () -> onError pid (SomeException (ErrorCall "timeout"))
+ Right code -> onExit pid code
+ Nothing ->
+ waitForProcess ph >>= onExit pid
+
+ killProcessGroup pgid
+
+ 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
+ }
+
+
+
+killProcessGroup :: ProcessGroupID -> IO ()
+killProcessGroup = signalProcessGroup' killProcess
+
+signalProcessGroup' :: Signal -> ProcessGroupID -> IO ()
+signalProcessGroup' sig pgid =
+ catchIOError
+ (signalProcessGroup sig pgid)
+ (\e -> unless (isDoesNotExistError e) $ ioError e)
+
+hWithLines :: Handle -> (Text -> IO ()) -> IO ()
+hWithLines h f = do
+ hSetBuffering h LineBuffering
+ untilM_ (hIsEOF h) (T.hGetLine h >>= f) `finally` hClose h