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
|
{- Interface for running a shell command as a coprocess,
- sending it queries and getting back results.
-
- Copyright 2012-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
module Utility.CoProcess (
CoProcessHandle,
start,
stop,
query,
) where
import Common
import Control.Concurrent.MVar
type CoProcessHandle = MVar CoProcessState
data CoProcessState = CoProcessState
{ coProcessPid :: ProcessHandle
, coProcessTo :: Handle
, coProcessFrom :: Handle
, coProcessSpec :: CoProcessSpec
}
data CoProcessSpec = CoProcessSpec
{ coProcessNumRestarts :: Int
, coProcessCmd :: FilePath
, coProcessParams :: [String]
, coProcessEnv :: Maybe [(String, String)]
}
start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
start numrestarts cmd params environ = do
s <- start' $ CoProcessSpec numrestarts cmd params environ
newMVar s
start' :: CoProcessSpec -> IO CoProcessState
start' s = do
(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)
rawMode from
rawMode to
return $ CoProcessState pid to from s
where
#ifdef mingw32_HOST_OS
rawMode h = hSetNewlineMode h noNewlineTranslation
#else
rawMode _ = return ()
#endif
stop :: CoProcessHandle -> IO ()
stop ch = do
s <- readMVar ch
hClose $ coProcessTo s
hClose $ coProcessFrom s
let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)
forceSuccessProcess p (coProcessPid s)
{- To handle a restartable process, any IO exception thrown by the send and
- receive actions are assumed to mean communication with the process
- failed, and the failed action is re-run with a new process. -}
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
query ch send receive = do
s <- readMVar ch
restartable s (send $ coProcessTo s) $ const $
restartable s (hFlush $ coProcessTo s) $ const $
restartable s (receive $ coProcessFrom s)
return
where
restartable s a cont
| coProcessNumRestarts (coProcessSpec s) > 0 =
maybe restart cont =<< catchMaybeIO a
| otherwise = cont =<< a
restart = do
s <- takeMVar ch
void $ catchMaybeIO $ do
hClose $ coProcessTo s
hClose $ coProcessFrom s
void $ waitForProcess $ coProcessPid s
s' <- start' $ (coProcessSpec s)
{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }
putMVar ch s'
query ch send receive
|
