summaryrefslogtreecommitdiffstats
path: root/Process.hs
blob: 5c536814477d0f8dd11c8f44ce12d4421639d3c9 (plain)
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
{-# LANGUAGE RecordWildCards #-}
module Process
    ( spawn
    , module System.Process
    ) where

import Control.Monad (unless, when)
import System.IO
import System.Process
import Control.Concurrent

type OutputWrapper = IO () -> IO ()

data OutStreamType = Stderr | Stdout

color :: OutStreamType -> String
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 $ do
            putStrLn $
              "\x1b[35m" ++ jobName ++ "\x1b[m " ++
              "\x1b[" ++ (color streamType) ++ "m" ++ line ++ "\x1b[m"

    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
    withOutput $
        putStrLn $ "\x1b[35m" ++ jobName ++ "\x1b[m exit: " ++ 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)