1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
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
|
