summaryrefslogtreecommitdiffstats
path: root/src/Process.hs
blob: 41ea1137dc8f7b046ee44970502b13ded5fb0507 (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
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)