diff --git a/System/Process/CommunicationHandle.hs b/System/Process/CommunicationHandle.hs --- a/System/Process/CommunicationHandle.hs +++ b/System/Process/CommunicationHandle.hs @@ -38,6 +38,9 @@ -- | Turn the 'CommunicationHandle' into a 'Handle' that can be read from -- in the current process. -- +-- The returned 'Handle' does not have any finalizers attached to it; +-- use 'hClose' to close it. +-- -- @since 1.6.20.0 openCommunicationHandleRead :: CommunicationHandle -> IO Handle openCommunicationHandleRead = useCommunicationHandle True @@ -45,6 +48,9 @@ -- | Turn the 'CommunicationHandle' into a 'Handle' that can be written to -- in the current process. -- +-- The returned 'Handle' does not have any finalizers attached to it; +-- use 'hClose' to close it. +-- -- @since 1.6.20.0 openCommunicationHandleWrite :: CommunicationHandle -> IO Handle openCommunicationHandleWrite = useCommunicationHandle False @@ -55,6 +61,9 @@ -- | Create a pipe @(weRead,theyWrite)@ that the current process can read from, -- and whose write end can be passed to a child process in order to receive data from it. -- +-- The returned 'Handle' does not have any finalizers attached to it; +-- use 'hClose' to close it. +-- -- See 'CommunicationHandle'. -- -- @since 1.6.20.0 @@ -71,6 +80,9 @@ -- | Create a pipe @(theyRead,weWrite)@ that the current process can write to, -- and whose read end can be passed to a child process in order to send data to it. -- +-- The returned 'Handle' does not have any finalizers attached to it; +-- use 'hClose' to close it. +-- -- See 'CommunicationHandle'. -- -- @since 1.6.20.0 @@ -125,6 +137,7 @@ let cp = mkProg (chTheyRead, chTheyWrite) -- The following implementation parallels 'readCreateProcess' withCreateProcess cp $ \ _ _ _ ph -> do + -- Close the parent's references to the 'CommunicationHandle's after they -- have been inherited by the child (we don't want to keep pipe ends open). closeCommunicationHandle chTheyWrite diff --git a/System/Process/CommunicationHandle/Internal.hsc b/System/Process/CommunicationHandle/Internal.hsc --- a/System/Process/CommunicationHandle/Internal.hsc +++ b/System/Process/CommunicationHandle/Internal.hsc @@ -13,9 +13,9 @@ where import Control.Arrow ( first ) -import Foreign.C (CInt(..), throwErrnoIf_) -import GHC.IO.Handle (Handle()) +import GHC.IO.Handle (Handle, hClose) #if defined(mingw32_HOST_OS) +import Foreign.C (CInt(..), throwErrnoIf_) import Foreign.Marshal (alloca) import Foreign.Ptr (ptrToWordPtr, wordPtrToPtr) import Foreign.Storable (Storable(peek)) @@ -41,28 +41,37 @@ #include /* for _O_BINARY */ #else +import GHC.IO.FD + ( mkFD, setNonBlockingMode ) +import GHC.IO.Handle + ( noNewlineTranslation ) +#if MIN_VERSION_base(4,16,0) +import GHC.IO.Handle.Internals + ( mkFileHandleNoFinalizer ) +#else +import GHC.IO.IOMode + ( IOMode(..) ) +import GHC.IO.Handle.Types + ( HandleType(..) ) +import GHC.IO.Handle.Internals + ( mkHandle ) +#endif import System.Posix - ( Fd(..), fdToHandle + ( Fd(..) , FdOption(..), setFdOption ) -import GHC.IO.FD (FD(fdFD)) --- NB: we use GHC.IO.Handle.Fd.handleToFd rather than System.Posix.handleToFd, --- as the latter flushes and closes the `Handle`, which is not the behaviour we want. -import GHC.IO.Handle.FD (handleToFd) -#endif - -##if !defined(mingw32_HOST_OS) +import System.Posix.Internals + ( fdGetMode ) import System.Process.Internals - ( createPipe ) -##endif - -import GHC.IO.Handle (hClose) + ( createPipeFd ) +#endif -------------------------------------------------------------------------------- -- Communication handles. --- | A 'CommunicationHandle' is an operating-system specific representation --- of a 'Handle' that can be communicated through a command-line interface. +-- | A 'CommunicationHandle' is an abstraction over operating-system specific +-- internal representation of a 'Handle', which can be communicated through a +-- command-line interface. -- -- In a typical use case, the parent process creates a pipe, using e.g. -- 'createWeReadTheyWritePipe' or 'createTheyReadWeWritePipe'. @@ -120,10 +129,10 @@ -- | Internal function used to define 'openCommunicationHandleRead' and -- openCommunicationHandleWrite. useCommunicationHandle :: Bool -> CommunicationHandle -> IO Handle -useCommunicationHandle wantToRead (CommunicationHandle ch) = do +useCommunicationHandle _wantToRead (CommunicationHandle ch) = do ##if defined(__IO_MANAGER_WINIO__) return () - associateHandleWithFallback wantToRead ch + associateHandleWithFallback _wantToRead ch ##endif getGhcHandle ch @@ -199,7 +208,26 @@ ## endif #else getGhcHandle :: Fd -> IO Handle -getGhcHandle fd = fdToHandle fd +getGhcHandle (Fd fdint) = do + iomode <- fdGetMode fdint + (fd0, _) <- mkFD fdint iomode Nothing False True + -- The following copies over 'mkHandleFromFDNoFinalizer' + fd <- setNonBlockingMode fd0 True + let fd_str = "" +# if MIN_VERSION_base(4,16,0) + mkFileHandleNoFinalizer fd fd_str iomode Nothing noNewlineTranslation +# else + mkHandle fd fd_str (ioModeToHandleType iomode) True Nothing noNewlineTranslation + Nothing Nothing + +ioModeToHandleType :: IOMode -> HandleType +ioModeToHandleType mode = + case mode of + ReadMode -> ReadHandle + WriteMode -> WriteHandle + ReadWriteMode -> ReadWriteHandle + AppendMode -> AppendHandle +# endif #endif -------------------------------------------------------------------------------- @@ -207,21 +235,40 @@ -- | Internal helper function used to define 'createWeReadTheyWritePipe' -- and 'createTheyReadWeWritePipe' while reducing code duplication. +-- +-- The returned 'Handle' does not have any finalizers attached to it; +-- use 'hClose' to close it. createCommunicationPipe :: ( forall a. (a, a) -> (a, a) ) -- ^ 'id' (we read, they write) or 'swap' (they read, we write) -> Bool -- ^ whether to pass a handle supporting asynchronous I/O to the child process -- (this flag only has an effect on Windows and when using WinIO) -> IO (Handle, CommunicationHandle) -createCommunicationPipe swapIfTheyReadWeWrite passAsyncHandleToChild = do +createCommunicationPipe swapIfTheyReadWeWrite _passAsyncHandleToChild = do ##if !defined(mingw32_HOST_OS) - (ourHandle, theirHandle) <- swapIfTheyReadWeWrite <$> createPipe + -- NB: it's important to use 'createPipeFd' here. + -- + -- Were we to instead use 'createPipe', we would create a Handle for both pipe + -- ends, including the end we pass to the child. + -- Such Handle would have a finalizer which closes the underlying file descriptor. + -- However, we will already close the FD after it is inherited by the child. + -- This could lead to the following scenario: + -- + -- - the parent creates a new pipe, e.g. pipe2([7,8]), + -- - the parent spawns a child process, and lets FD 8 be inherited by the child, + -- - the parent closes FD 8, + -- - the parent opens FD 8 for some other purpose, e.g. for writing to a file, + -- - the finalizer for the Handle wrapping FD 8 runs, closing FD 8, even though + -- it is now in use for a completely different purpose. + (ourFd, theirFd) <- swapIfTheyReadWeWrite <$> createPipeFd -- 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) + setFdOption (Fd ourFd) CloseOnExec True + -- NB: we will be closing this handle manually, so don't use 'handleFromFd' + -- which attaches a finalizer that closes the FD. See the above comment + -- about 'createPipeFd'. + ourHandle <- getGhcHandle (Fd ourFd) + return (ourHandle, CommunicationHandle $ Fd theirFd) ##else trueForWinIO <- return False @@ -236,8 +283,8 @@ -- - make the parent pipe end overlapped, -- - make the child end overlapped if requested, -- Otherwise: make both pipe ends synchronous. - overlappedRead = trueForWinIO && ( passAsyncHandleToChild || not inheritRead ) - overlappedWrite = trueForWinIO && ( passAsyncHandleToChild || not inheritWrite ) + overlappedRead = trueForWinIO && ( _passAsyncHandleToChild || not inheritRead ) + overlappedWrite = trueForWinIO && ( _passAsyncHandleToChild || not inheritWrite ) throwErrnoIf_ (==False) "mkNamedPipe" $ mkNamedPipe pfdStdInput inheritRead overlappedRead diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,13 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.21.0 *July 2024* + +* No longer attach finalizers to `Handle`s created by the + `System.Process.CommunicationHandle` API. Instead, all file descriptors are + manually closed by the API. + + This fixes a bug in which a file descriptor could be closed multiple times. + ## 1.6.20.0 *April 2024* * Introduce `System.Process.CommunicationHandle`, allowing for platform-independent diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: process -version: 1.6.20.0 +version: 1.6.21.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause license-file: LICENSE @@ -82,15 +82,13 @@ build-depends: unix >= 2.5 && < 2.9 include-dirs: include - includes: - runProcess.h install-includes: runProcess.h processFlags.h ghc-options: -Wall - build-depends: base >= 4.10 && < 4.20, + build-depends: base >= 4.10 && < 4.21, directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.6, deepseq >= 1.1 && < 1.6