{-# LANGUAGE CPP #-}
module Distribution.Compat.Process (
    -- * Redefined functions
    createProcess,
    runInteractiveProcess,
    rawSystem,
    -- * Additions
    enableProcessJobs,
    ) where

import System.Exit (ExitCode (..))
import System.IO   (Handle)

import           System.Process (CreateProcess, ProcessHandle, waitForProcess)
import qualified System.Process as Process

#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
import           System.IO.Unsafe (unsafePerformIO)
import           System.Win32.Info.Version (dwMajorVersion, dwMinorVersion, getVersionEx)
#endif

-------------------------------------------------------------------------------
-- enableProcessJobs
-------------------------------------------------------------------------------

#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
-- This exception, needed to support Windows 7, could be removed when
-- the lowest GHC version cabal supports is a GHC that doesn’t support
-- Windows 7 any more.
{-# NOINLINE isWindows8OrLater #-}
isWindows8OrLater :: Bool
isWindows8OrLater = unsafePerformIO $ do
  v <- getVersionEx
  pure $ (dwMajorVersion v, dwMinorVersion v) >= (6, 2)
#endif

-- | Enable process jobs to ensure accurate determination of process completion
-- in the presence of @exec(3)@ on Windows.
--
-- Unfortunately the process job support is badly broken in @process@ releases
-- prior to 1.6.9, so we disable it in these versions, despite the fact that
-- this means we may see sporadic build failures without jobs.
--
-- On Windows 7 or before the jobs are disabled due to the fact that
-- processes on these systems can only have one job. This prevents
-- spawned process from assigning jobs to its own children. Suppose
-- process A spawns process B. The B process has a job assigned (call
-- it J1) and when it tries to spawn a new process C the C
-- automatically inherits the job. But at it also tries to assign a
-- new job J2 to C since it doesn’t have access J1. This fails on
-- Windows 7 or before.
enableProcessJobs :: CreateProcess -> CreateProcess
#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
enableProcessJobs cp = cp {Process.use_process_jobs = isWindows8OrLater}
#else
enableProcessJobs :: CreateProcess -> CreateProcess
enableProcessJobs CreateProcess
cp = CreateProcess
cp
#endif

-------------------------------------------------------------------------------
-- process redefinitions
-------------------------------------------------------------------------------

-- | 'System.Process.createProcess' with process jobs enabled when appropriate.
-- See 'enableProcessJobs'.
createProcess :: CreateProcess
              -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess :: CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess = CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> (CreateProcess -> CreateProcess)
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateProcess -> CreateProcess
enableProcessJobs

-- | 'System.Process.rawSystem' with process jobs enabled when appropriate.
-- See 'enableProcessJobs'.
rawSystem :: String -> [String] -> IO ExitCode
rawSystem :: String -> [String] -> IO ExitCode
rawSystem String
cmd [String]
args = do
  (Maybe Handle
_,Maybe Handle
_,Maybe Handle
_,ProcessHandle
p) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
Process.proc String
cmd [String]
args) { delegate_ctlc :: Bool
Process.delegate_ctlc = Bool
True }
  ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p

-- | 'System.Process.runInteractiveProcess' with process jobs enabled when
-- appropriate. See 'enableProcessJobs'.
runInteractiveProcess
  :: FilePath                   -- ^ Filename of the executable (see 'RawCommand' for details)
  -> [String]                   -- ^ Arguments to pass to the executable
  -> Maybe FilePath             -- ^ Optional path to the working directory
  -> Maybe [(String,String)]    -- ^ Optional environment (otherwise inherit)
  -> IO (Handle,Handle,Handle,ProcessHandle)
runInteractiveProcess :: String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
cmd [String]
args Maybe String
mb_cwd Maybe [(String, String)]
mb_env = do
  (Maybe Handle
mb_in, Maybe Handle
mb_out, Maybe Handle
mb_err, ProcessHandle
p) <-
      CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
Process.proc String
cmd [String]
args)
              { std_in :: StdStream
Process.std_in  = StdStream
Process.CreatePipe,
                std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe,
                std_err :: StdStream
Process.std_err = StdStream
Process.CreatePipe,
                env :: Maybe [(String, String)]
Process.env     = Maybe [(String, String)]
mb_env,
                cwd :: Maybe String
Process.cwd     = Maybe String
mb_cwd }
  (Handle, Handle, Handle, ProcessHandle)
-> IO (Handle, Handle, Handle, ProcessHandle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle -> Handle
forall {b}. Maybe b -> b
fromJust Maybe Handle
mb_in, Maybe Handle -> Handle
forall {b}. Maybe b -> b
fromJust Maybe Handle
mb_out, Maybe Handle -> Handle
forall {b}. Maybe b -> b
fromJust Maybe Handle
mb_err, ProcessHandle
p)
  where
    fromJust :: Maybe b -> b
fromJust = b -> (b -> b) -> Maybe b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> b
forall a. HasCallStack => String -> a
error String
"runInteractiveProcess: fromJust") b -> b
forall a. a -> a
id