1 files changed, 98 insertions, 0 deletions
diff --git a/Process.hs b/Process.hs
new file mode 100644
index 0000000..5c53681
--- /dev/null
+++ b/Process.hs
@@ -0,0 +1,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)