{-# LANGUAGE CPP #-}
module Sos.Job
( Job(..)
, ShellCommand
, runJob
) where
import Sos.FileEvent
import Sos.Utils
import Control.Concurrent.MVar (readMVar)
import Control.Exception
import Data.Function (on)
import Data.List.NonEmpty (NonEmpty)
import System.Exit
import System.IO
import System.IO.Error (tryIOError)
import System.Posix.Process (getProcessGroupID, getProcessGroupIDOf)
import System.Posix.Signals
(Handler(Ignore), Signal, installHandler, sigTERM, sigTTOU,
signalProcessGroup)
import System.Posix.Terminal (setTerminalProcessGroupID)
import System.Posix.Types (ProcessGroupID)
import System.Process
import System.Process.Internals (ProcessHandle__(OpenHandle), phandle)
import Text.Printf
import qualified Data.List.NonEmpty as NonEmpty
type ShellCommand = String
data Job = Job
{ jobEvent :: FileEvent
, jobCommands :: NonEmpty ShellCommand
}
instance Eq Job where
(==) = (==) `on` jobCommands
runJob :: Job -> IO ()
runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0
where
go :: Int -> [ShellCommand] -> IO ()
go _ [] = pure ()
go n (cmd:cmds) = do
putStrLn (magenta (printf "[%d/%d] " n (length cmds0)) <> cmd)
let flushStdin :: IO ()
flushStdin =
hReady stdin >>= \case
True -> getLine >> flushStdin
False -> pure ()
flushStdin
try (runForegroundProcess (shell cmd)) >>= \case
Left (ex :: SomeException) -> do
case fromException ex of
Just ThreadKilled -> do
putStrLn (yellow "Job interrupted ✗")
throwIO ThreadKilled
_ -> do
putStrLn (red (show ex))
throwIO ex
Right ExitSuccess -> do
putStrLn (green "Success ✓")
go (n+1) cmds
Right (ExitFailure c) ->
throwIO (ExitFailure c)
#ifdef mingw32_HOST_OS
runForegroundProcess :: CreateProcess -> IO ExitCode
runForegroundProcess c =
bracket acquire release waitForProcess
where
acquire :: IO ProcessHandle
acquire = do
(_, _, _, ph) <- createProcess c { create_group = True }
pure ph
release :: ProcessHandle -> IO ()
release ph = do
_ <- tryIOError (interruptProcessGroupOf ph)
terminateProcess ph
#else
runForegroundProcess :: CreateProcess -> IO ExitCode
runForegroundProcess c =
bracket acquire release (\(ph, _) -> waitForProcess ph)
where
acquire :: IO (ProcessHandle, ProcessGroupID)
acquire = do
(_, _, _, ph) <- createProcess (c { create_group = True })
readMVar (phandle ph) >>= \case
OpenHandle pid -> do
pgid <- getProcessGroupIDOf pid
setTerminalProcessGroupID 0 pgid
pure (ph, pgid)
_ -> error "Sos.Job.runForegroundProcess: unexpected process handle"
release :: (ProcessHandle, ProcessGroupID) -> IO ()
release (_, pgid) = do
_ <- tryIOError (signalProcessGroup sigTERM pgid)
getProcessGroupID >>= ignoring sigTTOU . setTerminalProcessGroupID 0
ignoring :: Signal -> IO a -> IO a
ignoring sig act =
bracket
(installHandler sig Ignore Nothing)
(\handler -> installHandler sig handler Nothing)
(\_ -> act)
#endif