{-# 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
{ Job -> FileEvent
jobEvent :: FileEvent
, Job -> NonEmpty String
jobCommands :: NonEmpty ShellCommand
}
instance Eq Job where
== :: Job -> Job -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Job -> NonEmpty String
jobCommands
runJob :: Job -> IO ()
runJob :: Job -> IO ()
runJob (forall a. NonEmpty a -> [a]
NonEmpty.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Job -> NonEmpty String
jobCommands -> [String]
cmds0) = Int -> [String] -> IO ()
go Int
1 [String]
cmds0
where
go :: Int -> [ShellCommand] -> IO ()
go :: Int -> [String] -> IO ()
go Int
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
go Int
n (String
cmd:[String]
cmds) = do
String -> IO ()
putStrLn (String -> String
magenta (forall r. PrintfType r => String -> r
printf String
"[%d/%d] " Int
n (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
cmds0)) forall a. Semigroup a => a -> a -> a
<> String
cmd)
let flushStdin :: IO ()
flushStdin :: IO ()
flushStdin =
Handle -> IO Bool
hReady Handle
stdin forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> IO String
getLine forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flushStdin
Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
IO ()
flushStdin
forall e a. Exception e => IO a -> IO (Either e a)
try (CreateProcess -> IO ExitCode
runForegroundProcess (String -> CreateProcess
shell String
cmd)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SomeException
ex :: SomeException) -> do
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex of
Just AsyncException
ThreadKilled -> do
String -> IO ()
putStrLn (String -> String
yellow String
"Job interrupted ✗")
forall e a. Exception e => e -> IO a
throwIO AsyncException
ThreadKilled
Maybe AsyncException
_ -> do
String -> IO ()
putStrLn (String -> String
red (forall a. Show a => a -> String
show SomeException
ex))
forall e a. Exception e => e -> IO a
throwIO SomeException
ex
Right ExitCode
ExitSuccess -> do
String -> IO ()
putStrLn (String -> String
green String
"Success ✓")
Int -> [String] -> IO ()
go (Int
nforall a. Num a => a -> a -> a
+Int
1) [String]
cmds
Right (ExitFailure Int
c) ->
forall e a. Exception e => e -> IO a
throwIO (Int -> ExitCode
ExitFailure Int
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 :: CreateProcess -> IO ExitCode
runForegroundProcess CreateProcess
c =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (ProcessHandle, ProcessGroupID)
acquire (ProcessHandle, ProcessGroupID) -> IO ()
release (\(ProcessHandle
ph, ProcessGroupID
_) -> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph)
where
acquire :: IO (ProcessHandle, ProcessGroupID)
acquire :: IO (ProcessHandle, ProcessGroupID)
acquire = do
(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
c { create_group :: Bool
create_group = Bool
True })
forall a. MVar a -> IO a
readMVar (ProcessHandle -> MVar ProcessHandle__
phandle ProcessHandle
ph) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
OpenHandle ProcessGroupID
pid -> do
ProcessGroupID
pgid <- ProcessGroupID -> IO ProcessGroupID
getProcessGroupIDOf ProcessGroupID
pid
Fd -> ProcessGroupID -> IO ()
setTerminalProcessGroupID Fd
0 ProcessGroupID
pgid
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessHandle
ph, ProcessGroupID
pgid)
ProcessHandle__
_ -> forall a. HasCallStack => String -> a
error String
"Sos.Job.runForegroundProcess: unexpected process handle"
release :: (ProcessHandle, ProcessGroupID) -> IO ()
release :: (ProcessHandle, ProcessGroupID) -> IO ()
release (ProcessHandle
_, ProcessGroupID
pgid) = do
Either IOError ()
_ <- forall a. IO a -> IO (Either IOError a)
tryIOError (Signal -> ProcessGroupID -> IO ()
signalProcessGroup Signal
sigTERM ProcessGroupID
pgid)
IO ProcessGroupID
getProcessGroupID forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Signal -> IO a -> IO a
ignoring Signal
sigTTOU forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> ProcessGroupID -> IO ()
setTerminalProcessGroupID Fd
0
ignoring :: Signal -> IO a -> IO a
ignoring :: forall a. Signal -> IO a -> IO a
ignoring Signal
sig IO a
act =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sig Handler
Ignore forall a. Maybe a
Nothing)
(\Handler
handler -> Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sig Handler
handler forall a. Maybe a
Nothing)
(\Handler
_ -> IO a
act)
#endif