[Git][ghc/ghc][master] base: with{Binary}File{Blocking} only annotates own exceptions

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Mon Jan 29 07:33:03 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
82a1c656 by Sebastian Nagel at 2024-01-29T02:32:40-05:00
base: with{Binary}File{Blocking} only annotates own exceptions

Fixes #20886

This ensures that inner, unrelated exceptions are not misleadingly
annotated with the opened file.

- - - - -


15 changed files:

- libraries/base/changelog.md
- libraries/base/src/GHC/IO/Handle/FD.hs
- libraries/base/tests/IO/all.T
- + libraries/base/tests/IO/withBinaryFile001.hs
- + libraries/base/tests/IO/withBinaryFile001.stderr
- + libraries/base/tests/IO/withBinaryFile002.hs
- + libraries/base/tests/IO/withBinaryFile002.stderr
- + libraries/base/tests/IO/withFile001.hs
- + libraries/base/tests/IO/withFile001.stderr
- + libraries/base/tests/IO/withFile002.hs
- + libraries/base/tests/IO/withFile002.stderr
- + libraries/base/tests/IO/withFileBlocking001.hs
- + libraries/base/tests/IO/withFileBlocking001.stderr
- + libraries/base/tests/IO/withFileBlocking002.hs
- + libraries/base/tests/IO/withFileBlocking002.stderr


Changes:

=====================================
libraries/base/changelog.md
=====================================
@@ -8,6 +8,7 @@
   * Add laws relating between `Foldable` / `Traversable` with `Bifoldable` / `Bitraversable` ([CLC proposal #205](https://github.com/haskell/core-libraries-committee/issues/205))
   * The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187))
   * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/).
+  * Fix `withFile`, `withFileBlocking`, and `withBinaryFile` to not incorrectly annotate exceptions raised in wrapped computation. ([CLC proposal #237](https://github.com/haskell/core-libraries-committee/issues/237))
   * Fix `fdIsNonBlocking` to always be `0` for regular files and block devices on unix, regardless of `O_NONBLOCK`
   * Always use `safe` call to `read` for regular files and block devices on unix if the RTS is multi-threaded, regardless of `O_NONBLOCK`.
     ([CLC proposal #166](https://github.com/haskell/core-libraries-committee/issues/166))


=====================================
libraries/base/src/GHC/IO/Handle/FD.hs
=====================================
@@ -27,7 +27,9 @@ module GHC.IO.Handle.FD (
 
 import GHC.Base
 import GHC.Show
+import Control.Exception (try)
 import Data.Maybe
+import Data.Either (either)
 import Data.Typeable
 import Foreign.C.Types
 import GHC.MVar
@@ -162,10 +164,12 @@ openFile fp im =
 --
 -- @since 4.16.0.0
 withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-withFile fp im act =
+withFile fp im act = do
+  -- Only annotate when setup or teardown of withFile' raised the exception
   catchException
-    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True act)
+    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True (try . act))
     (\e -> ioError (addFilePathToIOError "withFile" fp e))
+    >>= either ioError pure
 
 -- | Like 'openFile', but opens the file in ordinary blocking mode.
 -- This can be useful for opening a FIFO for writing: if we open in
@@ -196,10 +200,12 @@ openFileBlocking fp im =
 --
 -- @since 4.16.0.0
 withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-withFileBlocking fp im act =
+withFileBlocking fp im act = do
+  -- Only annotate when setup or teardown of withFile' raised the exception
   catchException
-    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False act)
+    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False (try . act))
     (\e -> ioError (addFilePathToIOError "withFileBlocking" fp e))
+    >>= either ioError pure
 
 -- | Like 'openFile', but open the file in binary mode.
 -- On Windows, reading a file in text mode (which is the default)
@@ -227,9 +233,11 @@ openBinaryFile fp m =
 -- @since 4.16.0.0
 withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
 withBinaryFile fp im act =
+  -- Only annotate when setup or teardown of withFile' raised the exception
   catchException
-    (withFile' fp im True True act)
+    (withFile' fp im True True (try . act))
     (\e -> ioError (addFilePathToIOError "withBinaryFile" fp e))
+    >>= either ioError pure
 
 -- | Open a file and perform an action with it. If the action throws an
 -- exception, then the file will be closed. If the last argument is 'True',


=====================================
libraries/base/tests/IO/all.T
=====================================
@@ -68,6 +68,13 @@ test('isEOF001', [extra_run_opts('</dev/null')], compile_and_run, [''])
 test('misc001', [extra_run_opts('misc001.hs misc001.out')], compile_and_run,
      [''])
 
+test('withFile001', [exit_code(1)], compile_and_run, [''])
+test('withFile002', [exit_code(1)], compile_and_run, [''])
+test('withFileBlocking001', [exit_code(1)], compile_and_run, [''])
+test('withFileBlocking002', [exit_code(1)], compile_and_run, [''])
+test('withBinaryFile001', [exit_code(1)], compile_and_run, [''])
+test('withBinaryFile002', [exit_code(1)], compile_and_run, [''])
+
 test('openFile001',  normal, compile_and_run, [''])
 test('openFile002',  [exit_code(1), normalise_win32_io_errors], compile_and_run, [''])
 test('openFile003', normalise_win32_io_errors, compile_and_run, [''])


=====================================
libraries/base/tests/IO/withBinaryFile001.hs
=====================================
@@ -0,0 +1,8 @@
+-- | Test that withBinaryFile does report file not found exceptions.
+
+import System.IO
+
+main :: IO ()
+main =
+  withBinaryFile "test.bin" ReadMode $ \h ->
+    hGetContents' h >> pure ()


=====================================
libraries/base/tests/IO/withBinaryFile001.stderr
=====================================
@@ -0,0 +1 @@
+withBinaryFile001: test.bin: withBinaryFile: does not exist (No such file or directory)


=====================================
libraries/base/tests/IO/withBinaryFile002.hs
=====================================
@@ -0,0 +1,8 @@
+-- | Test that withBinaryFile does not annotate exceptions of inner computations.
+
+import System.IO
+
+main :: IO ()
+main =
+  withBinaryFile "test.bin" WriteMode $ \_ ->
+    fail "test"


=====================================
libraries/base/tests/IO/withBinaryFile002.stderr
=====================================
@@ -0,0 +1 @@
+withBinaryFile002: user error (test)


=====================================
libraries/base/tests/IO/withFile001.hs
=====================================
@@ -0,0 +1,8 @@
+-- | Test that withFile does report file not found exceptions.
+
+import System.IO
+
+main :: IO ()
+main =
+  withFile "test.txt" ReadMode $ \h ->
+    hGetContents' h >> pure ()


=====================================
libraries/base/tests/IO/withFile001.stderr
=====================================
@@ -0,0 +1 @@
+withFile001: test.txt: withFile: does not exist (No such file or directory)


=====================================
libraries/base/tests/IO/withFile002.hs
=====================================
@@ -0,0 +1,8 @@
+-- | Test that withFile does not annotate exceptions of inner computations.
+
+import System.IO
+
+main :: IO ()
+main =
+  withFile "test.txt" WriteMode $ \_ ->
+    fail "test"


=====================================
libraries/base/tests/IO/withFile002.stderr
=====================================
@@ -0,0 +1 @@
+withFile002: user error (test)


=====================================
libraries/base/tests/IO/withFileBlocking001.hs
=====================================
@@ -0,0 +1,10 @@
+-- | Test that withFileBlocking does report file not found exceptions.
+
+import System.IO
+import GHC.IO.Handle.FD
+
+-- | Test that withFileBlocking does report file not found exceptions.
+main :: IO ()
+main =
+  withFileBlocking "test.txt" ReadMode $ \h ->
+    hGetContents' h >> pure ()


=====================================
libraries/base/tests/IO/withFileBlocking001.stderr
=====================================
@@ -0,0 +1 @@
+withFileBlocking001: test.txt: withFileBlocking: does not exist (No such file or directory)


=====================================
libraries/base/tests/IO/withFileBlocking002.hs
=====================================
@@ -0,0 +1,9 @@
+-- | Test that withFileBlocking does not annotate exceptions of inner computations.
+
+import System.IO
+import GHC.IO.Handle.FD
+
+main :: IO ()
+main =
+  withFileBlocking "test.txt" WriteMode $ \_ ->
+    fail "test"


=====================================
libraries/base/tests/IO/withFileBlocking002.stderr
=====================================
@@ -0,0 +1 @@
+withFileBlocking002: user error (test)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82a1c65666d646e7ae1c0166ce72b2d5ad09d3c8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82a1c65666d646e7ae1c0166ce72b2d5ad09d3c8
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240129/c1ad7634/attachment-0001.html>


More information about the ghc-commits mailing list