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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Process
( spawn
, module System.Process
) where
import Control.Concurrent
import Control.Monad (unless, when)
import Data.Monoid
import System.Exit
import System.IO
import System.Process
import Blessings
import Blessings.String ()
type OutputWrapper = IO () -> IO ()
data OutStreamType = Stderr | Stdout
color :: OutStreamType -> Ps
color Stderr = 31
color Stdout = 32
data ReaperConfig = ReaperConfig
{ withOutput :: OutputWrapper
, jobName :: String
, openFdsRef :: MVar Int
, processHandle :: ProcessHandle
, streamHandle :: Handle
, streamType :: OutStreamType
}
spawn :: Int -> OutputWrapper -> String -> IO ()
spawn jobId _withOutput cmdline = do
-- TODO stdin
(Nothing, Just hOut, Just hErr, ph) <-
createProcess (shell cmdline)
{ std_in = Inherit -- TODO close
, std_out = CreatePipe
, std_err = CreatePipe
}
_openFdsRef <- newMVar 2
let rcOut = ReaperConfig
{ streamType = Stdout
, streamHandle = hOut
, withOutput = _withOutput
, jobName = '&' : show jobId
, openFdsRef = _openFdsRef
, processHandle = ph
}
rcErr = rcOut
{ streamType = Stderr
, streamHandle = hErr
}
forkIO $ reap rcOut
reap rcErr
reap :: ReaperConfig -> IO ()
reap rc@ReaperConfig{..} = do
forLines_ streamHandle $ \line ->
withOutput $ putStrLn $ pp $
SGR [35] (Plain jobName) <>
Plain " " <>
SGR [color streamType] (Plain line)
i <- decMVar openFdsRef
--withOutput $
-- putStrLn $ "\x1b[35m" ++ name ++ "\x1b[m eof"
when (i == 0) $ finish rc
hClose streamHandle
myThreadId >>= killThread
finish :: ReaperConfig -> IO ()
finish ReaperConfig{..} = do
exitCode <- waitForProcess processHandle
when (exitCode /= ExitSuccess) $
withOutput $ putStrLn $ pp $
SGR [35] (Plain jobName) <>
Plain " " <>
SGR [31] (Plain $ show exitCode)
decMVar :: MVar Int -> IO Int
decMVar =
flip modifyMVar dec
where
dec i = let i' = i - 1 in return (i', i')
-- TODO move utilities somewhere else
forLines_ :: Handle -> (String -> IO ()) -> IO ()
forLines_ h f = rec
where
rec = hIsEOF h >>= flip unless (hGetLine h >>= f >> rec)
|
