summaryrefslogtreecommitdiffstats
path: root/Process.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Process.hs')
-rw-r--r--Process.hs98
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)