{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module System.Process.Common
    ( CreateProcess (..)
    , CmdSpec (..)
    , StdStream (..)
    , ProcessHandle(..)
    , ProcessHandle__(..)
    , ProcRetHandles (..)
    , withFilePathException
    , PHANDLE
    , GroupID
    , UserID
    , modifyProcessHandle
    , withProcessHandle
    , fd_stdin
    , fd_stdout
    , fd_stderr
    , mbFd
    , mbPipe
    , pfdToHandle
#ifdef WINDOWS
    , CGid (..)
#else
    , CGid
#endif
#if defined(__IO_MANAGER_WINIO__)
    , HANDLE
    , mbHANDLE
    , mbPipeHANDLE
#endif
    ) where
import Control.Concurrent
import Control.Exception
import Data.String
import Foreign.Ptr
import Foreign.Storable
import System.Posix.Internals
import GHC.IO.Exception
import GHC.IO.Encoding
import qualified GHC.IO.FD as FD
import GHC.IO.Device
#if defined(__IO_MANAGER_WINIO__)
import GHC.IO.Handle.Windows
import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle())
#endif
import GHC.IO.Handle.FD
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types hiding (ClosedHandle)
import System.IO.Error
import Data.Typeable
import System.IO (IOMode)
#if defined(javascript_HOST_ARCH)
import GHC.JS.Prim (JSVal)
#endif
#ifdef WINDOWS
import Data.Word (Word32)
import System.Win32.DebugApi (PHANDLE)
#if defined(__IO_MANAGER_WINIO__)
import System.Win32.Types (HANDLE)
#endif
#else
import System.Posix.Types
#endif
#if defined(javascript_HOST_ARCH)
type PHANDLE = JSVal
#elif defined(WINDOWS)
newtype CGid = CGid Word32
  deriving (Show, Eq)
type GroupID = CGid
type UserID = CGid
#else
type PHANDLE = CPid
#endif
data CreateProcess = CreateProcess{
  CreateProcess -> CmdSpec
cmdspec      :: CmdSpec,                 
  CreateProcess -> Maybe FilePath
cwd          :: Maybe FilePath,          
  CreateProcess -> Maybe [(FilePath, FilePath)]
env          :: Maybe [(String,String)], 
  CreateProcess -> StdStream
std_in       :: StdStream,               
  CreateProcess -> StdStream
std_out      :: StdStream,               
  CreateProcess -> StdStream
std_err      :: StdStream,               
  CreateProcess -> Bool
close_fds    :: Bool,                    
  CreateProcess -> Bool
create_group :: Bool,                    
  CreateProcess -> Bool
delegate_ctlc:: Bool,                    
                                           
                                           
  CreateProcess -> Bool
detach_console :: Bool,                  
                                           
                                           
  CreateProcess -> Bool
create_new_console :: Bool,              
                                           
                                           
                                           
                                           
  CreateProcess -> Bool
new_session :: Bool,                     
                                           
                                           
  CreateProcess -> Maybe GroupID
child_group :: Maybe GroupID,            
                                           
                                           
                                           
                                           
  CreateProcess -> Maybe UserID
child_user :: Maybe UserID,              
                                           
                                           
                                           
                                           
  CreateProcess -> Bool
use_process_jobs :: Bool                 
                                           
                                           
                                           
                                           
                                           
 } deriving (Int -> CreateProcess -> ShowS
[CreateProcess] -> ShowS
CreateProcess -> FilePath
(Int -> CreateProcess -> ShowS)
-> (CreateProcess -> FilePath)
-> ([CreateProcess] -> ShowS)
-> Show CreateProcess
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CreateProcess -> ShowS
showsPrec :: Int -> CreateProcess -> ShowS
$cshow :: CreateProcess -> FilePath
show :: CreateProcess -> FilePath
$cshowList :: [CreateProcess] -> ShowS
showList :: [CreateProcess] -> ShowS
Show, CreateProcess -> CreateProcess -> Bool
(CreateProcess -> CreateProcess -> Bool)
-> (CreateProcess -> CreateProcess -> Bool) -> Eq CreateProcess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CreateProcess -> CreateProcess -> Bool
== :: CreateProcess -> CreateProcess -> Bool
$c/= :: CreateProcess -> CreateProcess -> Bool
/= :: CreateProcess -> CreateProcess -> Bool
Eq)
data ProcRetHandles
  = ProcRetHandles { ProcRetHandles -> Maybe Handle
hStdInput      :: Maybe Handle
                   , ProcRetHandles -> Maybe Handle
hStdOutput     :: Maybe Handle
                   , ProcRetHandles -> Maybe Handle
hStdError      :: Maybe Handle
                   , ProcRetHandles -> ProcessHandle
procHandle     :: ProcessHandle
                   }
data CmdSpec
  = ShellCommand String
      
  | RawCommand FilePath [String]
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
  deriving (Int -> CmdSpec -> ShowS
[CmdSpec] -> ShowS
CmdSpec -> FilePath
(Int -> CmdSpec -> ShowS)
-> (CmdSpec -> FilePath) -> ([CmdSpec] -> ShowS) -> Show CmdSpec
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CmdSpec -> ShowS
showsPrec :: Int -> CmdSpec -> ShowS
$cshow :: CmdSpec -> FilePath
show :: CmdSpec -> FilePath
$cshowList :: [CmdSpec] -> ShowS
showList :: [CmdSpec] -> ShowS
Show, CmdSpec -> CmdSpec -> Bool
(CmdSpec -> CmdSpec -> Bool)
-> (CmdSpec -> CmdSpec -> Bool) -> Eq CmdSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CmdSpec -> CmdSpec -> Bool
== :: CmdSpec -> CmdSpec -> Bool
$c/= :: CmdSpec -> CmdSpec -> Bool
/= :: CmdSpec -> CmdSpec -> Bool
Eq)
instance IsString CmdSpec where
  fromString :: FilePath -> CmdSpec
fromString = FilePath -> CmdSpec
ShellCommand
data StdStream
  = Inherit                  
  | UseHandle Handle         
  | CreatePipe               
                             
                             
                             
  | NoStream                 
                             
                             
                             
                             
                             
                             
                             
                             
                             
                             
  deriving (StdStream -> StdStream -> Bool
(StdStream -> StdStream -> Bool)
-> (StdStream -> StdStream -> Bool) -> Eq StdStream
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StdStream -> StdStream -> Bool
== :: StdStream -> StdStream -> Bool
$c/= :: StdStream -> StdStream -> Bool
/= :: StdStream -> StdStream -> Bool
Eq, Int -> StdStream -> ShowS
[StdStream] -> ShowS
StdStream -> FilePath
(Int -> StdStream -> ShowS)
-> (StdStream -> FilePath)
-> ([StdStream] -> ShowS)
-> Show StdStream
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StdStream -> ShowS
showsPrec :: Int -> StdStream -> ShowS
$cshow :: StdStream -> FilePath
show :: StdStream -> FilePath
$cshowList :: [StdStream] -> ShowS
showList :: [StdStream] -> ShowS
Show)
data ProcessHandle__ = OpenHandle { ProcessHandle__ -> PHANDLE
phdlProcessHandle :: PHANDLE }
                     
                     
                     
                     | OpenExtHandle { phdlProcessHandle :: PHANDLE
                                     
                                     , ProcessHandle__ -> PHANDLE
phdlJobHandle     :: PHANDLE
                                     
                                     
                                     }
                     | ClosedHandle ExitCode
data ProcessHandle
  = ProcessHandle { ProcessHandle -> MVar ProcessHandle__
phandle          :: !(MVar ProcessHandle__)
                  , ProcessHandle -> Bool
mb_delegate_ctlc :: !Bool
                  , ProcessHandle -> MVar ()
waitpidLock      :: !(MVar ())
                  }
withFilePathException :: FilePath -> IO a -> IO a
withFilePathException :: forall a. FilePath -> IO a -> IO a
withFilePathException FilePath
fpath IO a
act = (IOError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO a
forall {a}. IOError -> IO a
mapEx IO a
act
  where
    mapEx :: IOError -> IO a
mapEx IOError
ex = IOError -> IO a
forall {a}. IOError -> IO a
ioError (IOError -> FilePath -> IOError
ioeSetFileName IOError
ex FilePath
fpath)
modifyProcessHandle
        :: ProcessHandle
        -> (ProcessHandle__ -> IO (ProcessHandle__, a))
        -> IO a
modifyProcessHandle :: forall a.
ProcessHandle
-> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a
modifyProcessHandle (ProcessHandle MVar ProcessHandle__
m Bool
_ MVar ()
_) ProcessHandle__ -> IO (ProcessHandle__, a)
io = MVar ProcessHandle__
-> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ProcessHandle__
m ProcessHandle__ -> IO (ProcessHandle__, a)
io
withProcessHandle
        :: ProcessHandle
        -> (ProcessHandle__ -> IO a)
        -> IO a
withProcessHandle :: forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle (ProcessHandle MVar ProcessHandle__
m Bool
_ MVar ()
_) ProcessHandle__ -> IO a
io = MVar ProcessHandle__ -> (ProcessHandle__ -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ProcessHandle__
m ProcessHandle__ -> IO a
io
fd_stdin, fd_stdout, fd_stderr :: FD
fd_stdin :: FD
fd_stdin  = FD
0
fd_stdout :: FD
fd_stdout = FD
1
fd_stderr :: FD
fd_stderr = FD
2
mbFd :: String -> FD -> StdStream -> IO FD
mbFd :: FilePath -> FD -> StdStream -> IO FD
mbFd FilePath
_   FD
_std StdStream
CreatePipe      = FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (-FD
1)
mbFd FilePath
_fun FD
std StdStream
Inherit         = FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
std
mbFd FilePath
_fn FD
_std StdStream
NoStream        = FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (-FD
2)
mbFd FilePath
fun FD
_std (UseHandle Handle
hdl) =
  FilePath -> Handle -> (Handle__ -> IO (Handle__, FD)) -> IO FD
forall a.
FilePath -> Handle -> (Handle__ -> IO (Handle__, a)) -> IO a
withHandle FilePath
fun Handle
hdl ((Handle__ -> IO (Handle__, FD)) -> IO FD)
-> (Handle__ -> IO (Handle__, FD)) -> IO FD
forall a b. (a -> b) -> a -> b
$ \Handle__{haDevice :: ()
haDevice=dev
dev,Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer Char)
IORef (Buffer Word8)
IORef (BufferList Char)
Newline
BufferMode
HandleType
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer Char)
haBuffers :: IORef (BufferList Char)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
haType :: Handle__ -> HandleType
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haBufferMode :: Handle__ -> BufferMode
haLastDecode :: ()
haCharBuffer :: Handle__ -> IORef (Buffer Char)
haBuffers :: Handle__ -> IORef (BufferList Char)
haEncoder :: ()
haDecoder :: ()
haCodec :: Handle__ -> Maybe TextEncoding
haInputNL :: Handle__ -> Newline
haOutputNL :: Handle__ -> Newline
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
..} -> do
    case dev -> Maybe FD
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev of
      Just FD
fd -> do
#if !defined(javascript_HOST_ARCH)
         
         
         FD
fd' <- FD -> Bool -> IO FD
FD.setNonBlockingMode FD
fd Bool
False
#else
         
         fd' <- pure fd
#endif
         (Handle__, FD) -> IO (Handle__, FD)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle__{haDevice :: FD
haDevice=FD
fd',Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer Char)
IORef (Buffer Word8)
IORef (BufferList Char)
Newline
BufferMode
HandleType
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer Char)
haBuffers :: IORef (BufferList Char)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer Char)
haBuffers :: IORef (BufferList Char)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
..}, FD -> FD
FD.fdFD FD
fd')
      Maybe FD
Nothing ->
          IOError -> IO (Handle__, FD)
forall {a}. IOError -> IO a
ioError (IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
mkIOError IOErrorType
illegalOperationErrorType
                      FilePath
"createProcess" (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
hdl) Maybe FilePath
forall a. Maybe a
Nothing
                   IOError -> FilePath -> IOError
`ioeSetErrorString` FilePath
"handle is not a file descriptor")
mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe StdStream
CreatePipe Ptr FD
pfd  IOMode
mode = (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Ptr FD -> IOMode -> IO Handle
pfdToHandle Ptr FD
pfd IOMode
mode)
mbPipe StdStream
_std      Ptr FD
_pfd IOMode
_mode = Maybe Handle -> IO (Maybe Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
pfdToHandle :: Ptr FD -> IOMode -> IO Handle
pfdToHandle :: Ptr FD -> IOMode -> IO Handle
pfdToHandle Ptr FD
pfd IOMode
mode = do
  FD
fd <- Ptr FD -> IO FD
forall a. Storable a => Ptr a -> IO a
peek Ptr FD
pfd
  let filepath :: FilePath
filepath = FilePath
"fd:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FD -> FilePath
forall a. Show a => a -> FilePath
show FD
fd
  (FD
fD,IODeviceType
fd_type) <- FD
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD (FD -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
fd) IOMode
mode
                       ((IODeviceType, CDev, CIno) -> Maybe (IODeviceType, CDev, CIno)
forall a. a -> Maybe a
Just (IODeviceType
Stream,CDev
0,CIno
0)) 
                       Bool
False 
                       Bool
False 
  FD
fD' <- FD -> Bool -> IO FD
FD.setNonBlockingMode FD
fD Bool
True 
#if __GLASGOW_HASKELL__ >= 704
  TextEncoding
enc <- IO TextEncoding
getLocaleEncoding
#else
  let enc = localeEncoding
#endif
  FD
-> IODeviceType
-> FilePath
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
mkHandleFromFD FD
fD' IODeviceType
fd_type FilePath
filepath IOMode
mode Bool
False  (TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just TextEncoding
enc)
#if defined(__IO_MANAGER_WINIO__)
mbHANDLE :: HANDLE -> StdStream -> IO HANDLE
mbHANDLE _std CreatePipe      = return $ intPtrToPtr (-1)
mbHANDLE  std Inherit         = return std
mbHANDLE _std NoStream        = return $ intPtrToPtr (-2)
mbHANDLE _std (UseHandle hdl) = handleToHANDLE hdl
mbPipeHANDLE :: StdStream -> Ptr HANDLE -> IOMode -> IO (Maybe Handle)
mbPipeHANDLE CreatePipe pfd  mode =
  do raw_handle <- peek pfd
     let hwnd  = fromHANDLE raw_handle :: Io NativeHandle
         ident = "hwnd:" ++ show raw_handle
     enc <- fmap Just getLocaleEncoding
     Just <$> mkHandleFromHANDLE hwnd Stream ident mode enc
mbPipeHANDLE _std      _pfd _mode = return Nothing
#endif