From 6a6970bf13634fe428163af5d44fe7ceeb288521 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 4 Apr 2024 12:53:01 +0200 Subject: [PATCH] CommunicationHandle: always use mkNamedPipe on Windows --- System/Process/CommunicationHandle.hsc | 178 ++++++++++++------------- System/Process/Windows.hsc | 4 +- cbits/win32/runProcess.c | 20 +-- test/cli-child/main.hs | 12 +- 4 files changed, 99 insertions(+), 115 deletions(-) diff --git a/System/Process/CommunicationHandle.hsc b/System/Process/CommunicationHandle.hsc index 1deb197c..414c0c3f 100644 --- a/System/Process/CommunicationHandle.hsc +++ b/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 /* 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 diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index f6c97b2e..a0988358 100644 --- a/System/Process/Windows.hsc +++ b/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 () diff --git a/cbits/win32/runProcess.c b/cbits/win32/runProcess.c index c86c728d..6667fb2c 100644 --- a/cbits/win32/runProcess.c +++ b/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) { diff --git a/test/cli-child/main.hs b/test/cli-child/main.hs index 467c0d58..57439523 100644 --- a/test/cli-child/main.hs +++ b/test/cli-child/main.hs @@ -28,7 +28,7 @@ main = do childUsesWinIO <- return False #if defined(__IO_MANAGER_WINIO__) - return True + return True #endif putStr $ unlines [ "cli-child {" @@ -36,15 +36,7 @@ main = do hRead <- useCommunicationHandle $ read chRead hWrite <- useCommunicationHandle $ read chWrite input <- hGetContents hRead - let !output = force $ reverse (take 5 input) ++ "123" - -- NB: changing the above line to - -- - -- let !output = force $ reverse input ++ "123" - -- - -- should also work, but waiting until the end of the input stream - -- can cause deadlocks on Windows when using the POSIX emulation layer. - -- - -- On POSIX systems, or on Windows when using WinIO, things seem to be okay. + let !output = force $ reverse input ++ "123" hPutStr hWrite output putStrLn "cli-child }" hClose hWrite