Avoid race condition in hDuplicateTo

In our codebase we have some code along the lines of

```
newStdout <- hDuplicate stdout
stderr `hDuplicateTo` stdout
```

to avoid stray `putStrLn`s from corrupting a protocol (LSP) that is
run over stdout.

On CI we have seen a bunch of issues where `dup2` returned `EBUSY` so
this fails with `ResourceExhausted` in Haskell.

I’ve spent some time looking at the docs for `dup2` and the code in
`base` and afaict the following race condition is being triggered
here:

1. The user calls `hDuplicateTo stderr stdout`.
2. `hDuplicateTo` calls `hClose_help stdout_`, this closes the file
handle for stdout.
3. The file handle for stdout is now free, so another thread
allocating a file might get stdout.
4. If `dup2` is called while `stdout` (now pointing to something
else) is half-open, it returns EBUSY.

I think there might actually be an even worse case where `dup2` is run
after FD 1 is fully open again. In that case, you will end up not just
redirecting the original stdout to stderr but also the whatever
resulted in that file handle being allocated.

As far as I can tell, `dup2` takes care of closing the file handle
itself so there is no reason to do this in `hDuplicateTo`. So this PR
replaces the call to `hClose_help` by the only part of `hClose_help`
that we actually care about, namely, `flushWriteBuffer`.

I tested this on our codebase fairly extensively and haven’t been able
to reproduce the issue with this patch.

1 files changed, 5 insertions, 3 deletions

diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index 720eef575b..256cf59061 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -676,21 +676,23 @@ This can be used to retarget the standard Handles, for example:
 hDuplicateTo :: Handle -> Handle -> IO ()
 hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do
  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
-   _ <- hClose_help h2_
+   try $ flushWriteBuffer h2_
    withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
      dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
 hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do
  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
-   _ <- hClose_help w2_
+   try $ flushWriteBuffer w2_
    withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
      dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
-   _ <- hClose_help r2_
+   try $ flushWriteBuffer r2_
    withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
      dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
 hDuplicateTo h1 _ =
   ioe_dupHandlesNotCompatible h1
 
+try :: IO () -> IO ()
+try io = io `catchException` (const (pure ()) :: SomeException -> IO ())
 
 ioe_dupHandlesNotCompatible :: Handle -> IO a
 ioe_dupHandlesNotCompatible h =