[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