Flameshot.Internall.Process: add runAway

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