summaryrefslogtreecommitdiffstats
path: root/src/Flameshot/Internal/Process.hs
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2020-05-01 09:49:42 +0200
committertv <tv@krebsco.de>2020-05-01 09:58:04 +0200
commit48347a973b39a8fe5a6731609c27a178dea11f3c (patch)
treeeba18ed07f5d76b949fbb6a160c72888273fb82c /src/Flameshot/Internal/Process.hs
parente91de0e9ac597f3aa1bda0692b6ca5b969fdbe5d (diff)
Flameshot.Internall.Process: add runAway
Diffstat (limited to 'src/Flameshot/Internal/Process.hs')
-rw-r--r--src/Flameshot/Internal/Process.hs45
1 files changed, 44 insertions, 1 deletions
diff --git a/src/Flameshot/Internal/Process.hs b/src/Flameshot/Internal/Process.hs
index 31e2fee..a4dc963 100644
--- a/src/Flameshot/Internal/Process.hs
+++ b/src/Flameshot/Internal/Process.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-module Flameshot.Internal.Process (run,Callbacks(..),writeDaemon) where
+module Flameshot.Internal.Process (Callbacks(..),run,runAway,writeDaemon) where
import Control.Concurrent (forkIO,threadDelay)
import Control.Concurrent.Async (race)
@@ -129,6 +129,49 @@ writeDaemon path args input = do
BS.hPut hin input
hClose hin
void (getProcessStatus True False pid)
+
+runAway :: FilePath
+ -> [String]
+ -> Maybe FilePath
+ -> Maybe [(String, String)]
+ -> ByteString
+ -> Maybe Int
+ -> Callbacks
+ -> IO ()
+runAway path args cwd env input hTimeout Callbacks{..} =
+ f `catch` onError (-1)
+ where
+ f = do
+ (Just inh, Just outh, Just errh, ph) <- createProcess p
+
+ Just pid <- getPid ph
+
+ onStart pid
+
+ mapM_ forkIO [
+ BS.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
+
+ 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