{-# 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

-- | A 'Job' is a list of shell commands to run, along with the 'FileEvent' that
-- triggered the job.
data Job = Job
  { Job -> FileEvent
jobEvent    :: FileEvent             -- ^ Event that triggered this job.
  , Job -> NonEmpty String
jobCommands :: NonEmpty ShellCommand -- ^ The list of shell commands to run.
  }

-- | Non-stanard Eq instance: Job equality compares only the shell commands it's
-- associated with.
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

-- | Run a Job's list of shell commands sequentially. If a command returns
-- ExitFailure, or an exception is thrown, propagate the exception.
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
  -- Create a process (inheriting all file descriptors) in a new process group
  -- and give it terminal access.
  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"

  -- Terminate a process and take back control of the terminal.
  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