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
90
91
92
93
|
{- Interface for running a shell command as a coprocess,
- sending it queries and getting back results.
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Utility.CoProcess (
CoProcessHandle,
start,
stop,
query,
rawMode
) 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
{ coProcessRestartable :: Bool
, coProcessCmd :: FilePath
, coProcessParams :: [String]
, coProcessEnv :: Maybe [(String, String)]
}
start :: Bool -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
start restartable cmd params env = do
s <- start' $ CoProcessSpec restartable cmd params env
newMVar s
start' :: CoProcessSpec -> IO CoProcessState
start' s = do
(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)
return $ CoProcessState pid to from s
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
| coProcessRestartable (coProcessSpec s) =
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)
putMVar ch s'
query ch send receive
rawMode :: CoProcessHandle -> IO CoProcessHandle
rawMode ch = do
s <- readMVar ch
raw $ coProcessFrom s
raw $ coProcessTo s
return ch
where
raw h = do
fileEncoding h
#ifdef mingw32_HOST_OS
hSetNewlineMode h noNewlineTranslation
#endif
|
