Windows.hsc 12.3 KB
Newer Older
Tamar Christina's avatar
Tamar Christina committed
1 2
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# LANGUAGE InterruptibleFFI #-}
3 4 5 6 7 8 9 10 11 12
module System.Process.Windows
    ( mkProcessHandle
    , translateInternal
    , createProcess_Internal
    , withCEnvironment
    , closePHANDLE
    , startDelegateControlC
    , endDelegateControlC
    , stopDelegateControlC
    , isDefaultSignal
13
    , createPipeInternal
14
    , createPipeInternalFd
15
    , interruptProcessGroupOfInternal
Tamar Christina's avatar
Tamar Christina committed
16 17
    , terminateJob
    , waitForJobCompletion
Tamar Christina's avatar
Tamar Christina committed
18
    , timeout_Infinite
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
    ) where

import System.Process.Common
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

import System.Posix.Internals
import GHC.IO.Exception
import GHC.IO.Handle.FD
import GHC.IO.Handle.Types hiding (ClosedHandle)
import System.IO.Error
36
import System.IO (IOMode(..))
37 38 39 40

import System.Directory         ( doesFileExist )
import System.Environment       ( getEnv )
import System.FilePath
41 42
import System.Win32.Console (generateConsoleCtrlEvent, cTRL_BREAK_EVENT)
import System.Win32.Process (getProcessId)
43

Michael Snoyman's avatar
Michael Snoyman committed
44 45
-- The double hash is used so that hsc does not process this include file
##include "processFlags.h"
46

Michael Snoyman's avatar
Michael Snoyman committed
47
#include <fcntl.h>     /* for _O_BINARY */
48

49 50 51 52 53 54 55 56
##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

57 58 59 60 61
throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE
throwErrnoIfBadPHandle = throwErrnoIfNull

-- On Windows, we have to close this HANDLE when it is no longer required,
-- hence we add a finalizer to it
Ben Gamari's avatar
Ben Gamari committed
62 63 64
mkProcessHandle :: PHANDLE -> PHANDLE -> IO ProcessHandle
mkProcessHandle h job = do
   m <- if job == nullPtr
65
           then newMVar (OpenHandle h)
Ben Gamari's avatar
Ben Gamari committed
66
           else newMVar (OpenExtHandle h job)
67
   _ <- mkWeakMVar m (processHandleFinaliser m)
coopercm's avatar
coopercm committed
68 69
   l <- newMVar ()
   return (ProcessHandle m False l)
70 71 72 73 74

processHandleFinaliser :: MVar ProcessHandle__ -> IO ()
processHandleFinaliser m =
   modifyMVar_ m $ \p_ -> do
        case p_ of
75
          OpenHandle ph           -> closePHANDLE ph
Ben Gamari's avatar
Ben Gamari committed
76
          OpenExtHandle ph job    -> closePHANDLE ph
77
                                  >> closePHANDLE job
78 79 80 81 82 83
          _ -> return ()
        return (error "closed process handle")

closePHANDLE :: PHANDLE -> IO ()
closePHANDLE ph = c_CloseHandle ph

Tamar Christina's avatar
Tamar Christina committed
84
foreign import WINDOWS_CCONV unsafe "CloseHandle"
85 86 87 88 89 90 91
  c_CloseHandle
        :: PHANDLE
        -> IO ()

createProcess_Internal
  :: String                     -- ^ function name (for error messages)
  -> CreateProcess
92
  -> IO ProcRetHandles
Tamar Christina's avatar
Tamar Christina committed
93

94
createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
Tamar Christina's avatar
Tamar Christina committed
95 96 97 98 99 100 101 102 103 104
                                    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,
                                    detach_console = mb_detach_console,
                                    create_new_console = mb_create_new_console,
105 106
                                    new_session = mb_new_session,
                                    use_process_jobs = use_job }
107
 = do
Tamar Christina's avatar
Tamar Christina committed
108
  let lenPtr = sizeOf (undefined :: WordPtr)
109 110
  (cmd, cmdline) <- commandToProcess cmdsp
  withFilePathException cmd $
Tamar Christina's avatar
Tamar Christina committed
111 112 113 114
   alloca $ \ pfdStdInput           ->
   alloca $ \ pfdStdOutput          ->
   alloca $ \ pfdStdError           ->
   allocaBytes lenPtr $ \ hJob      ->
115 116 117
   maybeWith withCEnvironment mb_env $ \pEnv ->
   maybeWith withCWString mb_cwd $ \pWorkDir -> do
   withCWString cmdline $ \pcmdline -> do
Tamar Christina's avatar
Tamar Christina committed
118

119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
     fdin  <- mbFd fun fd_stdin  mb_stdin
     fdout <- mbFd fun fd_stdout mb_stdout
     fderr <- mbFd fun fd_stderr mb_stderr

     -- #2650: we must ensure mutual exclusion of c_runInteractiveProcess,
     -- because otherwise there is a race condition whereby one thread
     -- has created some pipes, and another thread spawns a process which
     -- accidentally inherits some of the pipe handles that the first
     -- thread has created.
     --
     -- An MVar in Haskell is the best way to do this, because there
     -- is no way to do one-time thread-safe initialisation of a mutex
     -- the C code.  Also the MVar will be cheaper when not running
     -- the threaded RTS.
     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)
                                .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0)
                                .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)
                                .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))
143
                                use_job
Tamar Christina's avatar
Tamar Christina committed
144
                                hJob
145 146 147 148 149

     hndStdInput  <- mbPipe mb_stdin  pfdStdInput  WriteMode
     hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
     hndStdError  <- mbPipe mb_stderr pfdStdError  ReadMode

150
     phJob  <- peek hJob
Ben Gamari's avatar
Ben Gamari committed
151
     ph     <- mkProcessHandle proc_handle phJob
152 153 154 155 156
     return ProcRetHandles { hStdInput  = hndStdInput
                           , hStdOutput = hndStdOutput
                           , hStdError  = hndStdError
                           , procHandle = ph
                           }
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176

{-# NOINLINE runInteractiveProcess_lock #-}
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = unsafePerformIO $ newMVar ()

-- The following functions are always present in the export list. For
-- compatibility with the non-Windows code, we provide the same functions with
-- matching type signatures, but implemented as no-ops. For details, see:
-- <https://github.com/haskell/process/pull/21>
startDelegateControlC :: IO ()
startDelegateControlC = return ()

endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC _ = return ()

stopDelegateControlC :: IO ()
stopDelegateControlC = return ()

-- End no-op functions

Tamar Christina's avatar
Tamar Christina committed
177 178 179 180 181 182 183 184

-- ----------------------------------------------------------------------------
-- Interface to C I/O CP bits

terminateJob :: ProcessHandle -> CUInt -> IO Bool
terminateJob jh ecode =
    withProcessHandle jh $ \p_ -> do
        case p_ of
Ben Gamari's avatar
Ben Gamari committed
185 186 187
            ClosedHandle      _ -> return False
            OpenHandle        _ -> return False
            OpenExtHandle _ job -> c_terminateJobObject job ecode
Tamar Christina's avatar
Tamar Christina committed
188

Tamar Christina's avatar
Tamar Christina committed
189 190 191
timeout_Infinite :: CUInt
timeout_Infinite = 0xFFFFFFFF

Ben Gamari's avatar
Ben Gamari committed
192 193 194 195
waitForJobCompletion :: PHANDLE -- ^ job handle
                     -> IO ()
waitForJobCompletion job =
    throwErrnoIf_ not "waitForJobCompletion" $ c_waitForJobCompletion job
Tamar Christina's avatar
Tamar Christina committed
196

Tamar Christina's avatar
Tamar Christina committed
197 198 199
-- ----------------------------------------------------------------------------
-- Interface to C bits

Tamar Christina's avatar
Tamar Christina committed
200 201
foreign import WINDOWS_CCONV unsafe "TerminateJobObject"
  c_terminateJobObject
Tamar Christina's avatar
Tamar Christina committed
202
        :: PHANDLE
Tamar Christina's avatar
Tamar Christina committed
203 204
        -> CUInt
        -> IO Bool
Tamar Christina's avatar
Tamar Christina committed
205 206 207 208

foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block
  c_waitForJobCompletion
        :: PHANDLE
Ben Gamari's avatar
Ben Gamari committed
209
        -> IO Bool
Tamar Christina's avatar
Tamar Christina committed
210

211 212 213 214 215 216 217 218 219 220 221
foreign import ccall unsafe "runInteractiveProcess"
  c_runInteractiveProcess
        :: CWString
        -> CWString
        -> Ptr CWString
        -> FD
        -> FD
        -> FD
        -> Ptr FD
        -> Ptr FD
        -> Ptr FD
Tamar Christina's avatar
Tamar Christina committed
222 223
        -> CInt          -- flags
        -> Bool          -- useJobObject
Tamar Christina's avatar
Tamar Christina committed
224
        -> Ptr PHANDLE       -- Handle to Job
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
        -> IO PHANDLE

commandToProcess
  :: CmdSpec
  -> IO (FilePath, String)
commandToProcess (ShellCommand string) = do
  cmd <- findCommandInterpreter
  return (cmd, translateInternal cmd ++ " /c " ++ string)
        -- We don't want to put the cmd into a single
        -- argument, because cmd.exe will not try to split it up.  Instead,
        -- we just tack the command on the end of the cmd.exe command line,
        -- which partly works.  There seem to be some quoting issues, but
        -- I don't have the energy to find+fix them right now (ToDo). --SDM
        -- (later) Now I don't know what the above comment means.  sigh.
commandToProcess (RawCommand cmd args) = do
  return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateInternal) args)

-- Find CMD.EXE (or COMMAND.COM on Win98).  We use the same algorithm as
-- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation).
findCommandInterpreter :: IO FilePath
findCommandInterpreter = do
  -- try COMSPEC first
  catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)
            (getEnv "COMSPEC") $ \_ -> do

    -- try to find CMD.EXE or COMMAND.COM
    {-
    XXX We used to look at _osver (using cbits) and pick which shell to
    use with
    let filename | osver .&. 0x8000 /= 0 = "command.com"
                 | otherwise             = "cmd.exe"
    We ought to use GetVersionEx instead, but for now we just look for
    either filename
    -}
    path <- getEnv "PATH"
    let
        -- use our own version of System.Directory.findExecutable, because
        -- that assumes the .exe suffix.
        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

translateInternal :: String -> String
translateInternal 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)
        -- See long comment above for what this function is trying to do.
        --
        -- The Bool passed back along the string is True iff the
        -- rest of the string is a sequence of backslashes followed by
        -- a double quote.

withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a
withCEnvironment envir act =
Michael Snoyman's avatar
Michael Snoyman committed
295
  let env' = foldr (\(name, val) env0 -> name ++ ('=':val)++'\0':env0) "\0" envir
296 297 298 299
  in withCWString env' (act . castPtr)

isDefaultSignal :: CLong -> Bool
isDefaultSignal = const False
300 301 302

createPipeInternal :: IO (Handle, Handle)
createPipeInternal = do
303
    (readfd, writefd) <- createPipeInternalFd
304 305
    (do readh <- fdToHandle readfd
        writeh <- fdToHandle writefd
Michael Snoyman's avatar
Michael Snoyman committed
306
        return (readh, writeh)) `onException` (close' readfd >> close' writefd)
Ben Gamari's avatar
Ben Gamari committed
307

308 309 310
createPipeInternalFd :: IO (FD, FD)
createPipeInternalFd = do
    allocaArray 2 $ \ pfds -> do
311
        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)
312 313 314 315
        readfd <- peek pfds
        writefd <- peekElemOff pfds 1
        return (readfd, writefd)

316

Michael Snoyman's avatar
Michael Snoyman committed
317 318
close' :: CInt -> IO ()
close' = throwErrnoIfMinus1_ "_close" . c__close
319 320 321 322 323 324

foreign import ccall "io.h _pipe" c__pipe ::
    Ptr CInt -> CUInt -> CInt -> IO CInt

foreign import ccall "io.h _close" c__close ::
    CInt -> IO CInt
325 326 327 328 329 330 331 332

interruptProcessGroupOfInternal
    :: ProcessHandle    -- ^ A process in the process group
    -> IO ()
interruptProcessGroupOfInternal ph = do
    withProcessHandle ph $ \p_ -> do
        case p_ of
            ClosedHandle _ -> return ()
333
            _ -> do let h = phdlProcessHandle p_
334
#if mingw32_HOST_OS
335 336
                    pid <- getProcessId h
                    generateConsoleCtrlEvent cTRL_BREAK_EVENT pid
337 338 339 340
-- We can't use an #elif here, because MIN_VERSION_unix isn't defined
-- on Windows, so on Windows cpp fails:
-- error: missing binary operator before token "("
#else
341 342
                    pgid <- getProcessGroupIDOf h
                    signalProcessGroup sigINT pgid
343
#endif
344
                    return ()