#ifdef __GLASGOW_HASKELL__
#endif
module System.Process.Internals (
ProcessHandle(..), ProcessHandle__(..),
PHANDLE, closePHANDLE, mkProcessHandle,
modifyProcessHandle, withProcessHandle,
#ifdef __GLASGOW_HASKELL__
CreateProcess(..),
CmdSpec(..), StdStream(..),
createProcess_,
runGenProcess_, --deprecated
#endif
startDelegateControlC,
endDelegateControlC,
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
pPrPr_disableITimers, c_execvpe,
ignoreSignal, defaultSignal,
#endif
withFilePathException, withCEnvironment,
translate,
fdToHandle,
) where
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
import Control.Monad
import Data.Char
import System.Posix.Types
import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe )
import System.IO
#endif
import Control.Concurrent
import Control.Exception
import Data.Bits
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe
#ifdef __GLASGOW_HASKELL__
import System.Posix.Internals
import GHC.IO.Exception
import GHC.IO.Encoding
import qualified GHC.IO.FD as FD
import GHC.IO.Device
import GHC.IO.Handle.FD
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types hiding (ClosedHandle)
import System.IO.Error
import Data.Typeable
#if defined(mingw32_HOST_OS)
import GHC.IO.IOMode
import System.Win32.DebugApi (PHANDLE)
#else
import System.Posix.Signals as Sig
#endif
#endif
#if defined(mingw32_HOST_OS)
import System.Directory ( doesFileExist )
import System.Environment ( getEnv )
import System.FilePath
#endif
#include "HsProcessConfig.h"
#include "processFlags.h"
#ifdef mingw32_HOST_OS
# if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
# else
# error Unknown mingw32 arch
# endif
#endif
data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode
data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool
modifyProcessHandle
:: ProcessHandle
-> (ProcessHandle__ -> IO (ProcessHandle__, a))
-> IO a
modifyProcessHandle (ProcessHandle m _) io = modifyMVar m io
withProcessHandle
:: ProcessHandle
-> (ProcessHandle__ -> IO a)
-> IO a
withProcessHandle (ProcessHandle m _) io = withMVar m io
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
type PHANDLE = CPid
mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle
mkProcessHandle p mb_delegate_ctlc = do
m <- newMVar (OpenHandle p)
return (ProcessHandle m mb_delegate_ctlc)
closePHANDLE :: PHANDLE -> IO ()
closePHANDLE _ = return ()
#else
throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE
throwErrnoIfBadPHandle = throwErrnoIfNull
mkProcessHandle :: PHANDLE -> IO ProcessHandle
mkProcessHandle h = do
m <- newMVar (OpenHandle h)
_ <- mkWeakMVar m (processHandleFinaliser m)
return (ProcessHandle m False)
processHandleFinaliser :: MVar ProcessHandle__ -> IO ()
processHandleFinaliser m =
modifyMVar_ m $ \p_ -> do
case p_ of
OpenHandle ph -> closePHANDLE ph
_ -> return ()
return (error "closed process handle")
closePHANDLE :: PHANDLE -> IO ()
closePHANDLE ph = c_CloseHandle ph
foreign import WINDOWS_CCONV unsafe "CloseHandle"
c_CloseHandle
:: PHANDLE
-> IO ()
#endif
data CreateProcess = CreateProcess{
cmdspec :: CmdSpec,
cwd :: Maybe FilePath,
env :: Maybe [(String,String)],
std_in :: StdStream,
std_out :: StdStream,
std_err :: StdStream,
close_fds :: Bool,
create_group :: Bool,
delegate_ctlc:: Bool
}
data CmdSpec
= ShellCommand String
| RawCommand FilePath [String]
data StdStream
= Inherit
| UseHandle Handle
| CreatePipe
createProcess_
:: String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
#ifdef __GLASGOW_HASKELL__
createProcess_ fun CreateProcess{ cmdspec = cmdsp,
cwd = mb_cwd,
env = mb_env,
std_in = mb_stdin,
std_out = mb_stdout,
std_err = mb_stderr,
close_fds = mb_close_fds,
create_group = mb_create_group,
delegate_ctlc = mb_delegate_ctlc }
= do
let (cmd,args) = commandToProcess cmdsp
withFilePathException cmd $
alloca $ \ pfdStdInput ->
alloca $ \ pfdStdOutput ->
alloca $ \ pfdStdError ->
alloca $ \ pFailedDoing ->
maybeWith withCEnvironment mb_env $ \pEnv ->
maybeWith withFilePath mb_cwd $ \pWorkDir ->
withMany withFilePath (cmd:args) $ \cstrs ->
withArray0 nullPtr cstrs $ \pargs -> do
fdin <- mbFd fun fd_stdin mb_stdin
fdout <- mbFd fun fd_stdout mb_stdout
fderr <- mbFd fun fd_stderr mb_stderr
when mb_delegate_ctlc
startDelegateControlC
proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->
c_runInteractiveProcess pargs pWorkDir pEnv
fdin fdout fderr
pfdStdInput pfdStdOutput pfdStdError
(if mb_delegate_ctlc then 1 else 0)
((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
.|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0))
pFailedDoing
when (proc_handle == 1) $ do
cFailedDoing <- peek pFailedDoing
failedDoing <- peekCString cFailedDoing
throwErrno (fun ++ ": " ++ failedDoing)
hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode
hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
hndStdError <- mbPipe mb_stderr pfdStdError ReadMode
ph <- mkProcessHandle proc_handle mb_delegate_ctlc
return (hndStdInput, hndStdOutput, hndStdError, ph)
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = unsafePerformIO $ newMVar ()
runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler))
runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing
startDelegateControlC :: IO ()
startDelegateControlC =
modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do
case delegating of
Nothing -> do
old_int <- installHandler sigINT Ignore Nothing
old_quit <- installHandler sigQUIT Ignore Nothing
return (Just (1, old_int, old_quit))
Just (count, old_int, old_quit) -> do
let !count' = count + 1
return (Just (count', old_int, old_quit))
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC exitCode = do
modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do
case delegating of
Just (1, old_int, old_quit) -> do
_ <- installHandler sigINT old_int Nothing
_ <- installHandler sigQUIT old_quit Nothing
return Nothing
Just (count, old_int, old_quit) -> do
let !count' = count 1
return (Just (count', old_int, old_quit))
Nothing -> return Nothing
case exitCode of
ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt
_ -> return ()
where
isSigIntQuit n = sig == sigINT || sig == sigQUIT
where
sig = fromIntegral (n)
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
:: Ptr CString
-> CString
-> Ptr CString
-> FD
-> FD
-> FD
-> Ptr FD
-> Ptr FD
-> Ptr FD
-> CInt
-> CInt
-> Ptr CString
-> IO PHANDLE
#endif /* __GLASGOW_HASKELL__ */
ignoreSignal, defaultSignal :: CLong
ignoreSignal = CONST_SIG_IGN
defaultSignal = CONST_SIG_DFL
#else
#ifdef __GLASGOW_HASKELL__
createProcess_ fun CreateProcess{ cmdspec = cmdsp,
cwd = mb_cwd,
env = mb_env,
std_in = mb_stdin,
std_out = mb_stdout,
std_err = mb_stderr,
close_fds = mb_close_fds,
create_group = mb_create_group,
delegate_ctlc = _ignored }
= do
(cmd, cmdline) <- commandToProcess cmdsp
withFilePathException cmd $
alloca $ \ pfdStdInput ->
alloca $ \ pfdStdOutput ->
alloca $ \ pfdStdError ->
maybeWith withCEnvironment mb_env $ \pEnv ->
maybeWith withCWString mb_cwd $ \pWorkDir -> do
withCWString cmdline $ \pcmdline -> do
fdin <- mbFd fun fd_stdin mb_stdin
fdout <- mbFd fun fd_stdout mb_stdout
fderr <- mbFd fun fd_stderr mb_stderr
proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->
throwErrnoIfBadPHandle fun $
c_runInteractiveProcess pcmdline pWorkDir pEnv
fdin fdout fderr
pfdStdInput pfdStdOutput pfdStdError
((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
.|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0))
hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode
hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
hndStdError <- mbPipe mb_stderr pfdStdError ReadMode
ph <- mkProcessHandle proc_handle
return (hndStdInput, hndStdOutput, hndStdError, ph)
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = unsafePerformIO $ newMVar ()
startDelegateControlC :: IO ()
startDelegateControlC = return ()
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC _ = return ()
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
:: CWString
-> CWString
-> Ptr CWString
-> FD
-> FD
-> FD
-> Ptr FD
-> Ptr FD
-> Ptr FD
-> CInt
-> IO PHANDLE
#endif
#endif /* __GLASGOW_HASKELL__ */
fd_stdin, fd_stdout, fd_stderr :: FD
fd_stdin = 0
fd_stdout = 1
fd_stderr = 2
mbFd :: String -> FD -> StdStream -> IO FD
mbFd _ _std CreatePipe = return (1)
mbFd _fun std Inherit = return std
mbFd fun _std (UseHandle hdl) =
withHandle fun hdl $ \Handle__{haDevice=dev,..} ->
case cast dev of
Just fd -> do
fd' <- FD.setNonBlockingMode fd False
return (Handle__{haDevice=fd',..}, FD.fdFD fd')
Nothing ->
ioError (mkIOError illegalOperationErrorType
"createProcess" (Just hdl) Nothing
`ioeSetErrorString` "handle is not a file descriptor")
mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
mbPipe CreatePipe pfd mode = fmap Just (pfdToHandle pfd mode)
mbPipe _std _pfd _mode = return Nothing
pfdToHandle :: Ptr FD -> IOMode -> IO Handle
pfdToHandle pfd mode = do
fd <- peek pfd
let filepath = "fd:" ++ show fd
(fD,fd_type) <- FD.mkFD (fromIntegral fd) mode
(Just (Stream,0,0))
False
False
fD' <- FD.setNonBlockingMode fD True
#if __GLASGOW_HASKELL__ >= 704
enc <- getLocaleEncoding
#else
let enc = localeEncoding
#endif
mkHandleFromFD fD' fd_type filepath mode False (Just enc)
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
commandToProcess :: CmdSpec -> (FilePath, [String])
commandToProcess (ShellCommand string) = ("/bin/sh", ["-c", string])
commandToProcess (RawCommand cmd args) = (cmd, args)
#else
commandToProcess
:: CmdSpec
-> IO (FilePath, String)
commandToProcess (ShellCommand string) = do
cmd <- findCommandInterpreter
return (cmd, translate cmd ++ " /c " ++ string)
commandToProcess (RawCommand cmd args) = do
return (cmd, translate cmd ++ concatMap ((' ':) . translate) args)
findCommandInterpreter :: IO FilePath
findCommandInterpreter = do
catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)
(getEnv "COMSPEC") $ \_ -> do
path <- getEnv "PATH"
let
search :: [FilePath] -> IO (Maybe FilePath)
search [] = return Nothing
search (d:ds) = do
let path1 = d </> "cmd.exe"
path2 = d </> "command.com"
b1 <- doesFileExist path1
b2 <- doesFileExist path2
if b1 then return (Just path1)
else if b2 then return (Just path2)
else search ds
mb_path <- search (splitSearchPath path)
case mb_path of
Nothing -> ioError (mkIOError doesNotExistErrorType
"findCommandInterpreter" Nothing Nothing)
Just cmd -> return cmd
#endif
translate :: String -> String
#if mingw32_HOST_OS
translate xs = '"' : snd (foldr escape (True,"\"") xs)
where escape '"' (_, str) = (True, '\\' : '"' : str)
escape '\\' (True, str) = (True, '\\' : '\\' : str)
escape '\\' (False, str) = (False, '\\' : str)
escape c (_, str) = (False, c : str)
#else
translate "" = "''"
translate str
| all goodChar str = str
| otherwise = '\'' : foldr escape "'" str
where escape '\'' = showString "'\\''"
escape c = showChar c
goodChar c = isAlphaNum c || c `elem` "-_.,/"
#endif
withFilePathException :: FilePath -> IO a -> IO a
withFilePathException fpath act = handle mapEx act
where
mapEx ex = ioError (ioeSetFileName ex fpath)
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a
withCEnvironment envir act =
let env' = map (\(name, val) -> name ++ ('=':val)) envir
in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
#else
withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a
withCEnvironment envir act =
let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" envir
in withCWString env' (act . castPtr)
#endif
#ifdef __GLASGOW_HASKELL__
runGenProcess_
:: String
-> CreateProcess
-> Maybe CLong
-> Maybe CLong
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
runGenProcess_ fun c (Just sig) (Just sig') | sig == defaultSignal && sig == sig'
= createProcess_ fun c { delegate_ctlc = True }
runGenProcess_ fun c _ _ = createProcess_ fun c
#else
runGenProcess_ fun c _ _ = createProcess_ fun c
#endif
#endif