CommunicationHandle: always use mkNamedPipe on Windows

System/Process/CommunicationHandle.hsc

@@ -21,22 +21,25 @@ import Control.Arrow ( first )
 import Foreign.C (CInt(..), throwErrnoIf_)
 import GHC.IO.Handle (Handle())
 #if defined(mingw32_HOST_OS)
+import Foreign.Marshal (alloca)
 import Foreign.Ptr (Ptr, ptrToWordPtr, wordPtrToPtr)
-import GHC.IO (onException)
-import GHC.Windows (HANDLE)
+import Foreign.Storable (Storable(peek))
+import GHC.IO.FD(mkFD)
+import GHC.IO.Handle (mkFileHandle, nativeNewlineMode)
 import GHC.IO.Handle.FD (fdToHandle)
-import GHC.IO.Device as IODevice
 import GHC.IO.Encoding (getLocaleEncoding)
-import GHC.IO.IOMode (IOMode(ReadMode, WriteMode, ReadWriteMode))
-import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle())
+import GHC.IO.IOMode (IOMode(ReadMode, WriteMode))
 ##  if defined(__IO_MANAGER_WINIO__)
-import Foreign.Marshal
 import Control.Exception (catch, throwIO)
+import GHC.IO (onException)
+import GHC.IO.Device as IODevice (close, devType)
 import GHC.IO.Exception (IOException(..), IOErrorType(InvalidArgument))
+import GHC.IO.IOMode (IOMode(ReadWriteMode))
+import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
 import GHC.IO.SubSystem ((<!>))
-import GHC.IO.Handle.Windows (handleToHANDLE, mkHandleFromHANDLE)
+import GHC.IO.Windows.Handle (Io, NativeHandle, fromHANDLE)
 import GHC.Event.Windows (associateHandle')
-import System.Process.Common (StdStream(CreatePipe), mbPipeHANDLE)
+import GHC.Windows (HANDLE)
 ##  endif
 
 #include <fcntl.h>     /* for _O_BINARY */
@@ -54,9 +57,7 @@ import GHC.IO.Handle.FD (handleToFd)
 
 import System.Process.Internals
   ( CreateProcess(..), ignoreSigPipe, withForkWait,
-##if defined(mingw32_HOST_OS)
-  createPipeFd,
-##else
+##if !defined(mingw32_HOST_OS)
   createPipe
 ##endif
   )
@@ -103,6 +104,13 @@ newtype CommunicationHandle =
 ##endif
   deriving ( Eq, Ord )
 
+#if defined(mingw32_HOST_OS)
+type Fd = CInt
+##  if !defined(__IO_MANAGER_WINIO__)
+type HANDLE = Ptr ()
+##  endif
+#endif
+
 -- @since 1.7.0.0
 instance Show CommunicationHandle where
   showsPrec p (CommunicationHandle h) =
@@ -158,7 +166,7 @@ handleAssociateHandleIOError
     -- associateHandleWithIOCP: invalid argument (The parameter is incorrect.)
     | InvalidArgument <- errTy
     , Just 22 <- mbErrNo
-    = return ()
+    = return () -- TODO: we could try to re-open the HANDLE in asynchronous mode.
     | otherwise
     = throwIO ioErr
 ##endif
@@ -177,15 +185,22 @@ closeCommunicationHandle (CommunicationHandle ch) =
 
 #if defined(mingw32_HOST_OS)
 getGhcHandle :: HANDLE -> IO Handle
-getGhcHandle = getGhcHandlePOSIX <!> getGhcHandleNative
+getGhcHandle =
+  getGhcHandlePOSIX
+##  if defined(__IO_MANAGER_WINIO__)
+    <!> getGhcHandleNative
+##  endif
 
 getGhcHandlePOSIX :: HANDLE -> IO Handle
-getGhcHandlePOSIX handle =
-  _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle
+getGhcHandlePOSIX handle = openHANDLE handle >>= fdToHandle
+
+openHANDLE :: HANDLE -> IO Fd
+openHANDLE handle = _open_osfhandle handle (#const _O_BINARY)
 
 foreign import ccall "io.h _open_osfhandle"
-  _open_osfhandle :: HANDLE -> CInt -> IO CInt
+  _open_osfhandle :: HANDLE -> CInt -> IO Fd
 
+##  if defined(__IO_MANAGER_WINIO__)
 getGhcHandleNative :: HANDLE -> IO Handle
 getGhcHandleNative hwnd =
   do mb_codec <- fmap Just getLocaleEncoding
@@ -194,6 +209,7 @@ getGhcHandleNative hwnd =
      hw_type <- IODevice.devType $ native_handle
      mkHandleFromHANDLE native_handle hw_type (show hwnd) iomode mb_codec
        `onException` IODevice.close native_handle
+##  endif
 #else
 getGhcHandle :: Fd -> IO Handle
 getGhcHandle fd = fdToHandle fd
@@ -228,94 +244,70 @@ createCommunicationPipe
   :: ( forall a. (a, a) -> (a, a) )
   -> IO (Handle, CommunicationHandle)
 createCommunicationPipe mbSwap = do
-  -- On Windows:
-  --  - without WinIO, use FDs.
-  --  - with WinIO, use pipes.
-  -- On POSIX: use pipes.
-##if defined(mingw32_HOST_OS)
-  usingFDs
-##  if defined(__IO_MANAGER_WINIO__)
-    <!> usingPipes
-##  endif
+##if !defined(mingw32_HOST_OS)
+  (ourHandle, theirHandle) <- mbSwap <$> createPipe
+  -- Don't allow the child process to inherit a parent file descriptor
+  -- (such inheritance happens by default on Unix).
+  ourFD   <- Fd . fdFD <$> handleToFd ourHandle
+  setFdOption ourFD CloseOnExec True
+  theirFD <- Fd . fdFD <$> handleToFd theirHandle
+  return (ourHandle, CommunicationHandle theirFD)
 ##else
-  usingPipes
-##endif
-  where
-##if !defined(mingw32_HOST_OS) || defined(__IO_MANAGER_WINIO__)
-    usingPipes :: IO (Handle, CommunicationHandle)
-    usingPipes = do
-      (hUs, hThem) <- createPipeEnds mbSwap
-      chThem <-
-        CommunicationHandle <$>
-##  if defined(__IO_MANAGER_WINIO__)
-          handleToHANDLE hThem
-##  else
-          (Fd . fdFD <$> handleToFd hThem)
+  trueForWinIO <-
+    return False
+##  if defined (__IO_MANAGER_WINIO__)
+      <!> return True
 ##  endif
-      associateToCurrentProcess hUs
-      return (hUs, chThem)
-##endif
-##if defined(mingw32_HOST_OS)
-    usingFDs :: IO (Handle, CommunicationHandle)
-    usingFDs = do
-      (fdRead, fdWrite) <- createPipeFd
-      let (fdUs, fdThem) = mbSwap (fdRead, fdWrite)
-      chThem <-
-        CommunicationHandle <$>
-          _get_osfhandle fdThem
-      hUs <- fdToHandle fdUs `onException` c__close fdUs
-      return (hUs, chThem)
-
-foreign import ccall unsafe "io.h _get_osfhandle"
-  _get_osfhandle :: CInt -> IO HANDLE
-
-foreign import ccall "io.h _close"
-  c__close :: CInt -> IO CInt
-##endif
-
--- | Internal: create two ends of a pipe. The first result is the parent 'Handle',
--- while the second is a 'Handle' to be inherited by a child process.
---
--- The argument can be either @id@ (ours = read, theirs = write) or @swap@
--- (ours = write, theirs = read).
-createPipeEnds :: ( forall a. (a, a) -> (a, a) )
-               -> IO (Handle, Handle)
-createPipeEnds mbSwap =
-##if !defined(__IO_MANAGER_WINIO__)
-  mbSwap <$> createPipe
-##else
+  -- On Windows, use mkNamedPipe to create the two pipe ends.
   alloca $ \ pfdStdInput  ->
     alloca $ \ pfdStdOutput -> do
       let (inheritRead, inheritWrite) = mbSwap (False, True)
+          -- If we're using WinIO, make the parent pipe end overlapped,
+          -- otherwise make both pipe ends synchronous.
+          overlappedRead  = if inheritRead  then False else trueForWinIO
+          overlappedWrite = if inheritWrite then False else trueForWinIO
       throwErrnoIf_ (==False) "c_mkNamedPipe" $
         -- Create one end to be un-inheritable and the other
-        -- to be inheritable, which ensures the un-inheritable part
-        -- can be properly associated with the parent process.
-        c_mkNamedPipe pfdStdInput inheritRead pfdStdOutput inheritWrite
-      Just hndStdInput  <- mbPipeHANDLE CreatePipe pfdStdInput ReadMode
-      Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput WriteMode
-      return $ mbSwap (hndStdInput, hndStdOutput)
+        -- to be inheritable, which ensures the parent end can be properly
+        -- associated with the parent process.
+        c_mkNamedPipe
+          pfdStdInput  inheritRead  overlappedRead
+          pfdStdOutput inheritWrite overlappedWrite
+      let ((ourPfd, ourMode), (theirPfd, _theirMode)) =
+            mbSwap ((pfdStdInput, ReadMode), (pfdStdOutput, WriteMode))
+      ourHANDLE   <- peek ourPfd
+      theirHANDLE <- peek theirPfd
+      -- With WinIO, we need to associate any handles we are going to use in
+      -- the current process before being able to use them.
+      return ()
+##  if defined (__IO_MANAGER_WINIO__)
+        <!> associateHandle' ourHANDLE
+##  endif
+      ourHandle <- createNonDuplexPipeHandle ourMode ourHANDLE
+      return $ (ourHandle, CommunicationHandle theirHANDLE)
 
 foreign import ccall "mkNamedPipe" c_mkNamedPipe ::
-    Ptr HANDLE -> Bool -> Ptr HANDLE -> Bool -> IO Bool
-##endif
+    Ptr HANDLE -> Bool -> Bool -> Ptr HANDLE -> Bool -> Bool -> IO Bool
 
--- | Internal: associate the 'Handle' to the current process. This operation
--- ensures the handle can be properly read from/written to,
--- within the current process.
-associateToCurrentProcess :: Handle -> IO ()
-associateToCurrentProcess _h = do
-##if !defined(mingw32_HOST_OS)
-  fd <- Fd . fdFD <$> handleToFd _h
-  -- Don't allow the child process to inherit a parent file descriptor
-  -- (such inheritance happens by default on Unix).
-  setFdOption fd CloseOnExec True
-##else
-  return ()
+createNonDuplexPipeHandle :: IOMode -> HANDLE -> IO Handle
+createNonDuplexPipeHandle iomode raw_handle = do
+  createNonDuplexPipeHandleFD
+##  if defined (__IO_MANAGER_WINIO__)
+    <!> createNonDuplexPipeHandleNative
+##  endif
+  where
+    ident = "hwnd:" ++ show raw_handle
+    createNonDuplexPipeHandleFD = do
+      enc <- getLocaleEncoding
+      fd <- openHANDLE raw_handle
+      (dev, _) <- mkFD fd iomode Nothing False False
+      mkFileHandle dev ident iomode (Just enc) nativeNewlineMode
 ##  if defined (__IO_MANAGER_WINIO__)
-  -- With WinIO, we need to associate any handles we are going to use in
-  -- the current process before being able to use them.
-    <!> (associateHandle' =<< handleToHANDLE _h)
+    createNonDuplexPipeHandleNative = do
+      enc <- getLocaleEncoding
+      let dev :: Io NativeHandle
+          dev = fromHANDLE raw_handle
+      mkFileHandle dev ident iomode (Just enc) nativeNewlineMode
 ##  endif
 ##endif
 

System/Process/Windows.hsc

@@ -515,14 +515,14 @@ createPipeInternalHANDLE =
   alloca $ \ pfdStdInput  ->
    alloca $ \ pfdStdOutput -> do
      throwErrnoIf_  (==False) "c_mkNamedPipe" $
-       c_mkNamedPipe pfdStdInput True pfdStdOutput True
+       c_mkNamedPipe pfdStdInput True False pfdStdOutput True False
      Just hndStdInput  <- mbPipeHANDLE CreatePipe pfdStdInput ReadMode
      Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput WriteMode
      return (hndStdInput, hndStdOutput)
 
 
 foreign import ccall "mkNamedPipe" c_mkNamedPipe ::
-    Ptr HANDLE -> Bool -> Ptr HANDLE -> Bool -> IO Bool
+    Ptr HANDLE -> Bool -> Bool -> Ptr HANDLE -> Bool -> Bool -> IO Bool
 ##endif
 
 close' :: CInt -> IO ()

cbits/win32/runProcess.c

@@ -88,8 +88,8 @@ mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn,
  *           asynchronously while anonymous pipes require blocking calls.
  */
 BOOL
-mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn,
-             HANDLE* pHandleOut, BOOL isInheritableOut)
+mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn, BOOL isOverlappedIn,
+             HANDLE* pHandleOut, BOOL isInheritableOut, BOOL isOverlappedOut)
 {
     HANDLE hTemporaryIn  = INVALID_HANDLE_VALUE;
     HANDLE hTemporaryOut = INVALID_HANDLE_VALUE;
@@ -142,7 +142,7 @@ mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn,
        bytes and the error ERROR_NO_DATA."[0]
 
        [0] https://devblogs.microsoft.com/oldnewthing/20110114-00/?p=11753  */
-    DWORD inAttr = isInheritableIn ? 0 : FILE_FLAG_OVERLAPPED;
+    DWORD inAttr = isOverlappedIn ? FILE_FLAG_OVERLAPPED : 0;
     hTemporaryIn
       = CreateNamedPipeW (pipeName,
                           PIPE_ACCESS_INBOUND | inAttr | FILE_FLAG_FIRST_PIPE_INSTANCE,
@@ -162,9 +162,9 @@ mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn,
                      FILE_SHARE_WRITE,
                      &secAttr,
                      OPEN_EXISTING,
-                     isInheritableOut
-                       ? FILE_ATTRIBUTE_NORMAL
-                       : FILE_FLAG_OVERLAPPED,
+                     isOverlappedOut
+                       ? FILE_FLAG_OVERLAPPED
+                       : FILE_ATTRIBUTE_NORMAL,
                      NULL);
 
     if (hTemporaryOut == INVALID_HANDLE_VALUE)
@@ -244,21 +244,21 @@ createJob ()
 static inline bool
 setStdHandleInfo (LPHANDLE destination, HANDLE _stdhandle,
                   LPHANDLE hStdRead, LPHANDLE hStdWrite, HANDLE defaultStd,
-                  BOOL isInhertibleIn, BOOL isInhertibleOut, BOOL asynchronous)
+                  BOOL isInheritableIn, BOOL isInheritableOut, BOOL asynchronous)
 {
     BOOL status;
     assert (destination);
     assert (hStdRead);
     assert (hStdWrite);
 
-    LPHANDLE tmpHandle = isInhertibleOut ? hStdWrite : hStdRead;
+    LPHANDLE tmpHandle = isInheritableOut ? hStdWrite : hStdRead;
 
     if (_stdhandle == (HANDLE)-1) {
         if (!asynchronous
-            && !mkAnonPipe(hStdRead, isInhertibleIn, hStdWrite, isInhertibleOut))
+            && !mkAnonPipe(hStdRead, isInheritableIn, hStdWrite, isInheritableOut))
             return false;
         if (asynchronous
-            && !mkNamedPipe(hStdRead, isInhertibleIn, hStdWrite, isInhertibleOut))
+            && !mkNamedPipe(hStdRead, isInheritableIn, !isInheritableIn, hStdWrite, isInheritableOut, !isInheritableOut))
             return false;
         *destination = *tmpHandle;
     } else if (_stdhandle == (HANDLE)-2) {