1{-# LANGUAGE CPP, ForeignFunctionInterface #-} 2{-# LANGUAGE InterruptibleFFI #-} 3module System.Process.Windows 4 ( mkProcessHandle 5 , translateInternal 6 , createProcess_Internal 7 , withCEnvironment 8 , closePHANDLE 9 , startDelegateControlC 10 , endDelegateControlC 11 , stopDelegateControlC 12 , isDefaultSignal 13 , createPipeInternal 14 , createPipeInternalFd 15 , interruptProcessGroupOfInternal 16 , terminateJob 17 , terminateJobUnsafe 18 , waitForJobCompletion 19 , timeout_Infinite 20 ) where 21 22import System.Process.Common 23import Control.Concurrent 24import Control.Exception 25import Data.Bits 26import Foreign.C 27import Foreign.Marshal 28import Foreign.Ptr 29import Foreign.Storable 30import System.IO.Unsafe 31 32import System.Posix.Internals 33import GHC.IO.Exception 34##if defined(__IO_MANAGER_WINIO__) 35import GHC.IO.SubSystem 36import Graphics.Win32.Misc 37import qualified GHC.Event.Windows as Mgr 38##endif 39import GHC.IO.Handle.FD 40import GHC.IO.Handle.Types hiding (ClosedHandle) 41import System.IO.Error 42import System.IO (IOMode(..)) 43 44import System.Directory ( doesFileExist ) 45import System.Environment ( getEnv ) 46import System.FilePath 47import System.Win32.Console (generateConsoleCtrlEvent, cTRL_BREAK_EVENT) 48import System.Win32.Process (getProcessId) 49 50-- The double hash is used so that hsc does not process this include file 51##include "processFlags.h" 52 53#include <fcntl.h> /* for _O_BINARY */ 54 55##if defined(i386_HOST_ARCH) 56## define WINDOWS_CCONV stdcall 57##elif defined(x86_64_HOST_ARCH) 58## define WINDOWS_CCONV ccall 59##else 60## error Unknown mingw32 arch 61##endif 62 63throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE 64throwErrnoIfBadPHandle = throwErrnoIfNull 65 66-- On Windows, we have to close this HANDLE when it is no longer required, 67-- hence we add a finalizer to it 68mkProcessHandle :: PHANDLE -> PHANDLE -> IO ProcessHandle 69mkProcessHandle h job = do 70 m <- if job == nullPtr 71 then newMVar (OpenHandle h) 72 else newMVar (OpenExtHandle h job) 73 _ <- mkWeakMVar m (processHandleFinaliser m) 74 l <- newMVar () 75 return (ProcessHandle m False l) 76 77processHandleFinaliser :: MVar ProcessHandle__ -> IO () 78processHandleFinaliser m = 79 modifyMVar_ m $ \p_ -> do 80 case p_ of 81 OpenHandle ph -> closePHANDLE ph 82 OpenExtHandle ph job -> closePHANDLE ph 83 >> closePHANDLE job 84 _ -> return () 85 return (error "closed process handle") 86 87closePHANDLE :: PHANDLE -> IO () 88closePHANDLE ph = c_CloseHandle ph 89 90foreign import WINDOWS_CCONV unsafe "CloseHandle" 91 c_CloseHandle 92 :: PHANDLE 93 -> IO () 94 95createProcess_Internal 96 :: String -- ^ function name (for error messages) 97 -> CreateProcess 98 -> IO ProcRetHandles 99 100##if defined(__IO_MANAGER_WINIO__) 101createProcess_Internal = createProcess_Internal_mio <!> createProcess_Internal_winio 102##else 103createProcess_Internal = createProcess_Internal_mio 104##endif 105 106createProcess_Internal_mio 107 :: String -- ^ function name (for error messages) 108 -> CreateProcess 109 -> IO ProcRetHandles 110 111createProcess_Internal_mio fun def@CreateProcess{ 112 std_in = mb_stdin, 113 std_out = mb_stdout, 114 std_err = mb_stderr, 115 close_fds = mb_close_fds, 116 create_group = mb_create_group, 117 delegate_ctlc = _ignored, 118 detach_console = mb_detach_console, 119 create_new_console = mb_create_new_console, 120 new_session = mb_new_session, 121 use_process_jobs = use_job } 122 = createProcess_Internal_wrapper fun def $ 123 \pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline -> do 124 fdin <- mbFd fun fd_stdin mb_stdin 125 fdout <- mbFd fun fd_stdout mb_stdout 126 fderr <- mbFd fun fd_stderr mb_stderr 127 128 -- #2650: we must ensure mutual exclusion of c_runInteractiveProcess, 129 -- because otherwise there is a race condition whereby one thread 130 -- has created some pipes, and another thread spawns a process which 131 -- accidentally inherits some of the pipe handles that the first 132 -- thread has created. 133 -- 134 -- An MVar in Haskell is the best way to do this, because there 135 -- is no way to do one-time thread-safe initialisation of a mutex 136 -- the C code. Also the MVar will be cheaper when not running 137 -- the threaded RTS. 138 proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> 139 throwErrnoIfBadPHandle fun $ 140 c_runInteractiveProcess pcmdline pWorkDir pEnv 141 fdin fdout fderr 142 pfdStdInput pfdStdOutput pfdStdError 143 ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) 144 .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0) 145 .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0) 146 .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0) 147 .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0)) 148 use_job 149 hJob 150 151 hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode 152 hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode 153 hndStdError <- mbPipe mb_stderr pfdStdError ReadMode 154 155 return (proc_handle, hndStdInput, hndStdOutput, hndStdError) 156 157 158createProcess_Internal_wrapper 159 :: Storable a => String -- ^ function name (for error messages) 160 -> CreateProcess 161 -> (Ptr a -> Ptr a -> Ptr a -> Ptr PHANDLE -> Ptr CWString -> CWString 162 -> CWString -> IO (PHANDLE, Maybe Handle, Maybe Handle, Maybe Handle)) 163 -> IO ProcRetHandles 164 165createProcess_Internal_wrapper _fun CreateProcess{ 166 cmdspec = cmdsp, 167 cwd = mb_cwd, 168 env = mb_env, 169 delegate_ctlc = _ignored } 170 action 171 = do 172 let lenPtr = sizeOf (undefined :: WordPtr) 173 (cmd, cmdline) <- commandToProcess cmdsp 174 withFilePathException cmd $ 175 alloca $ \ pfdStdInput -> 176 alloca $ \ pfdStdOutput -> 177 alloca $ \ pfdStdError -> 178 allocaBytes lenPtr $ \ hJob -> 179 maybeWith withCEnvironment mb_env $ \pEnv -> 180 maybeWith withCWString mb_cwd $ \pWorkDir -> do 181 withCWString cmdline $ \pcmdline -> do 182 183 (proc_handle, hndStdInput, hndStdOutput, hndStdError) 184 <- action pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline 185 186 phJob <- peek hJob 187 ph <- mkProcessHandle proc_handle phJob 188 return ProcRetHandles { hStdInput = hndStdInput 189 , hStdOutput = hndStdOutput 190 , hStdError = hndStdError 191 , procHandle = ph 192 } 193 194##if defined(__IO_MANAGER_WINIO__) 195createProcess_Internal_winio 196 :: String -- ^ function name (for error messages) 197 -> CreateProcess 198 -> IO ProcRetHandles 199 200createProcess_Internal_winio fun def@CreateProcess{ 201 std_in = mb_stdin, 202 std_out = mb_stdout, 203 std_err = mb_stderr, 204 close_fds = mb_close_fds, 205 create_group = mb_create_group, 206 delegate_ctlc = _ignored, 207 detach_console = mb_detach_console, 208 create_new_console = mb_create_new_console, 209 new_session = mb_new_session, 210 use_process_jobs = use_job } 211 = createProcess_Internal_wrapper fun def $ 212 \pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline -> do 213 214 _stdin <- getStdHandle sTD_INPUT_HANDLE 215 _stdout <- getStdHandle sTD_OUTPUT_HANDLE 216 _stderr <- getStdHandle sTD_ERROR_HANDLE 217 hwnd_in <- mbHANDLE _stdin mb_stdin 218 hwnd_out <- mbHANDLE _stdout mb_stdout 219 hwnd_err <- mbHANDLE _stderr mb_stderr 220 221 -- #2650: we must ensure mutual exclusion of c_runInteractiveProcess, 222 -- because otherwise there is a race condition whereby one thread 223 -- has created some pipes, and another thread spawns a process which 224 -- accidentally inherits some of the pipe handles that the first 225 -- thread has created. 226 -- 227 -- An MVar in Haskell is the best way to do this, because there 228 -- is no way to do one-time thread-safe initialisation of a mutex 229 -- the C code. Also the MVar will be cheaper when not running 230 -- the threaded RTS. 231 proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> 232 throwErrnoIfBadPHandle fun $ 233 c_runInteractiveProcessHANDLE pcmdline pWorkDir pEnv 234 hwnd_in hwnd_out hwnd_err 235 pfdStdInput pfdStdOutput pfdStdError 236 ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) 237 .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0) 238 .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0) 239 .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0) 240 .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0)) 241 use_job 242 hJob 243 244 -- Attach the handle to the I/O manager's CompletionPort. This allows the 245 -- I/O manager to service requests for this Handle. 246 Mgr.associateHandle' =<< peek pfdStdInput 247 Mgr.associateHandle' =<< peek pfdStdOutput 248 Mgr.associateHandle' =<< peek pfdStdError 249 250 -- Create the haskell mode handles as files. 251 hndStdInput <- mbPipeHANDLE mb_stdin pfdStdInput WriteMode 252 hndStdOutput <- mbPipeHANDLE mb_stdout pfdStdOutput ReadMode 253 hndStdError <- mbPipeHANDLE mb_stderr pfdStdError ReadMode 254 255 return (proc_handle, hndStdInput, hndStdOutput, hndStdError) 256 257##endif 258 259{-# NOINLINE runInteractiveProcess_lock #-} 260runInteractiveProcess_lock :: MVar () 261runInteractiveProcess_lock = unsafePerformIO $ newMVar () 262 263-- The following functions are always present in the export list. For 264-- compatibility with the non-Windows code, we provide the same functions with 265-- matching type signatures, but implemented as no-ops. For details, see: 266-- <https://github.com/haskell/process/pull/21> 267startDelegateControlC :: IO () 268startDelegateControlC = return () 269 270endDelegateControlC :: ExitCode -> IO () 271endDelegateControlC _ = return () 272 273stopDelegateControlC :: IO () 274stopDelegateControlC = return () 275 276-- End no-op functions 277 278 279-- ---------------------------------------------------------------------------- 280-- Interface to C I/O CP bits 281 282-- | Variant of terminateJob that is not thread-safe 283terminateJobUnsafe :: ProcessHandle__ -> CUInt -> IO Bool 284terminateJobUnsafe p_ ecode = do 285 case p_ of 286 ClosedHandle _ -> return False 287 OpenHandle _ -> return False 288 OpenExtHandle _ job -> c_terminateJobObject job ecode 289 290terminateJob :: ProcessHandle -> CUInt -> IO Bool 291terminateJob jh ecode = 292 withProcessHandle jh $ \p_ -> terminateJobUnsafe p_ ecode 293 294timeout_Infinite :: CUInt 295timeout_Infinite = 0xFFFFFFFF 296 297waitForJobCompletion :: PHANDLE -- ^ job handle 298 -> IO () 299waitForJobCompletion job = 300 throwErrnoIf_ not "waitForJobCompletion" $ c_waitForJobCompletion job 301 302-- ---------------------------------------------------------------------------- 303-- Interface to C bits 304 305foreign import WINDOWS_CCONV unsafe "TerminateJobObject" 306 c_terminateJobObject 307 :: PHANDLE 308 -> CUInt 309 -> IO Bool 310 311foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block 312 c_waitForJobCompletion 313 :: PHANDLE 314 -> IO Bool 315 316foreign import ccall unsafe "runInteractiveProcess" 317 c_runInteractiveProcess 318 :: CWString 319 -> CWString 320 -> Ptr CWString 321 -> FD 322 -> FD 323 -> FD 324 -> Ptr FD 325 -> Ptr FD 326 -> Ptr FD 327 -> CInt -- flags 328 -> Bool -- useJobObject 329 -> Ptr PHANDLE -- Handle to Job 330 -> IO PHANDLE 331 332##if defined(__IO_MANAGER_WINIO__) 333foreign import ccall unsafe "runInteractiveProcessHANDLE" 334 c_runInteractiveProcessHANDLE 335 :: CWString 336 -> CWString 337 -> Ptr CWString 338 -> HANDLE 339 -> HANDLE 340 -> HANDLE 341 -> Ptr HANDLE 342 -> Ptr HANDLE 343 -> Ptr HANDLE 344 -> CInt -- flags 345 -> Bool -- useJobObject 346 -> Ptr PHANDLE -- Handle to Job 347 -> IO PHANDLE 348##endif 349 350commandToProcess 351 :: CmdSpec 352 -> IO (FilePath, String) 353commandToProcess (ShellCommand string) = do 354 cmd <- findCommandInterpreter 355 return (cmd, translateInternal cmd ++ " /c " ++ string) 356 -- We don't want to put the cmd into a single 357 -- argument, because cmd.exe will not try to split it up. Instead, 358 -- we just tack the command on the end of the cmd.exe command line, 359 -- which partly works. There seem to be some quoting issues, but 360 -- I don't have the energy to find+fix them right now (ToDo). --SDM 361 -- (later) Now I don't know what the above comment means. sigh. 362commandToProcess (RawCommand cmd args) = do 363 return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateInternal) args) 364 365-- Find CMD.EXE (or COMMAND.COM on Win98). We use the same algorithm as 366-- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation). 367findCommandInterpreter :: IO FilePath 368findCommandInterpreter = do 369 -- try COMSPEC first 370 catchJust (\e -> if isDoesNotExistError e then Just e else Nothing) 371 (getEnv "COMSPEC") $ \_ -> do 372 373 -- try to find CMD.EXE or COMMAND.COM 374 {- 375 XXX We used to look at _osver (using cbits) and pick which shell to 376 use with 377 let filename | osver .&. 0x8000 /= 0 = "command.com" 378 | otherwise = "cmd.exe" 379 We ought to use GetVersionEx instead, but for now we just look for 380 either filename 381 -} 382 path <- getEnv "PATH" 383 let 384 -- use our own version of System.Directory.findExecutable, because 385 -- that assumes the .exe suffix. 386 search :: [FilePath] -> IO (Maybe FilePath) 387 search [] = return Nothing 388 search (d:ds) = do 389 let path1 = d </> "cmd.exe" 390 path2 = d </> "command.com" 391 b1 <- doesFileExist path1 392 b2 <- doesFileExist path2 393 if b1 then return (Just path1) 394 else if b2 then return (Just path2) 395 else search ds 396 -- 397 mb_path <- search (splitSearchPath path) 398 399 case mb_path of 400 Nothing -> ioError (mkIOError doesNotExistErrorType 401 "findCommandInterpreter" Nothing Nothing) 402 Just cmd -> return cmd 403 404translateInternal :: String -> String 405translateInternal xs = '"' : snd (foldr escape (True,"\"") xs) 406 where escape '"' (_, str) = (True, '\\' : '"' : str) 407 escape '\\' (True, str) = (True, '\\' : '\\' : str) 408 escape '\\' (False, str) = (False, '\\' : str) 409 escape c (_, str) = (False, c : str) 410 -- See long comment above for what this function is trying to do. 411 -- 412 -- The Bool passed back along the string is True iff the 413 -- rest of the string is a sequence of backslashes followed by 414 -- a double quote. 415 416withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a 417withCEnvironment envir act = 418 let env' = foldr (\(name, val) env0 -> name ++ ('=':val)++'\0':env0) "\0" envir 419 in withCWString env' (act . castPtr) 420 421isDefaultSignal :: CLong -> Bool 422isDefaultSignal = const False 423 424createPipeInternal :: IO (Handle, Handle) 425##if defined(__IO_MANAGER_WINIO__) 426createPipeInternal = createPipeInternalPosix <!> createPipeInternalHANDLE 427##else 428createPipeInternal = createPipeInternalPosix 429##endif 430 431createPipeInternalPosix :: IO (Handle, Handle) 432createPipeInternalPosix = do 433 (readfd, writefd) <- createPipeInternalFd 434 (do readh <- fdToHandle readfd 435 writeh <- fdToHandle writefd 436 return (readh, writeh)) `onException` (close' readfd >> close' writefd) 437 438createPipeInternalFd :: IO (FD, FD) 439createPipeInternalFd = do 440 allocaArray 2 $ \ pfds -> do 441 throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 8192 (#const _O_BINARY) 442 readfd <- peek pfds 443 writefd <- peekElemOff pfds 1 444 return (readfd, writefd) 445 446##if defined(__IO_MANAGER_WINIO__) 447createPipeInternalHANDLE :: IO (Handle, Handle) 448createPipeInternalHANDLE = 449 alloca $ \ pfdStdInput -> 450 alloca $ \ pfdStdOutput -> do 451 throwErrnoIf_ (==False) "c_mkNamedPipe" $ 452 c_mkNamedPipe pfdStdInput True pfdStdOutput True 453 Just hndStdInput <- mbPipeHANDLE CreatePipe pfdStdInput WriteMode 454 Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput ReadMode 455 return (hndStdInput, hndStdOutput) 456 457 458foreign import ccall "mkNamedPipe" c_mkNamedPipe :: 459 Ptr HANDLE -> Bool -> Ptr HANDLE -> Bool -> IO Bool 460##endif 461 462close' :: CInt -> IO () 463close' = throwErrnoIfMinus1_ "_close" . c__close 464 465foreign import ccall "io.h _pipe" c__pipe :: 466 Ptr CInt -> CUInt -> CInt -> IO CInt 467 468foreign import ccall "io.h _close" c__close :: 469 CInt -> IO CInt 470 471interruptProcessGroupOfInternal 472 :: ProcessHandle -- ^ A process in the process group 473 -> IO () 474interruptProcessGroupOfInternal ph = do 475 withProcessHandle ph $ \p_ -> do 476 case p_ of 477 ClosedHandle _ -> return () 478 _ -> do let h = phdlProcessHandle p_ 479#if mingw32_HOST_OS 480 pid <- getProcessId h 481 generateConsoleCtrlEvent cTRL_BREAK_EVENT pid 482-- We can't use an #elif here, because MIN_VERSION_unix isn't defined 483-- on Windows, so on Windows cpp fails: 484-- error: missing binary operator before token "(" 485#else 486 pgid <- getProcessGroupIDOf h 487 signalProcessGroup sigINT pgid 488#endif 489 return () 490