From 894a1ac90fcf36ee63096f7bfce48aee7047cd2c Mon Sep 17 00:00:00 2001 From: tv Date: Mon, 9 Mar 2026 14:56:38 +0100 Subject: Main: src/ -> app/ --- src/Process.hs | 108 --------------------------------------------------------- 1 file changed, 108 deletions(-) delete mode 100644 src/Process.hs (limited to 'src/Process.hs') diff --git a/src/Process.hs b/src/Process.hs deleted file mode 100644 index 41ea113..0000000 --- a/src/Process.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# 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) -- cgit v1.2.3