Main: src/ -> app/

1 files changed, 108 insertions, 0 deletions

diff --git a/app/Process.hs b/app/Process.hs
new file mode 100644
index 0000000..41ea113
--- /dev/null
+++ b/app/Process.hs
@@ -0,0 +1,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)