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