summaryrefslogtreecommitdiffstats
path: root/Process.hs
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-07-28 14:18:39 +0200
committertv <tv@shackspace.de>2014-07-28 14:18:39 +0200
commite3c8479127589b05719567f6821383ad0d9f5b27 (patch)
tree7cc95adc3953ad880a5e676057043d19b1835435 /Process.hs
parent25b8aa03070758e7f72f37e325f3e6e4b22e685c (diff)
move source to src/
Diffstat (limited to 'Process.hs')
-rw-r--r--Process.hs98
1 files changed, 0 insertions, 98 deletions
diff --git a/Process.hs b/Process.hs
deleted file mode 100644
index 5c53681..0000000
--- a/Process.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-{-# 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)