Fix hGetContents to close handle on exception

src/Data/Text/IO.hs

@@ -57,6 +57,7 @@ import GHC.IO.Handle.Internals (augmentIOError, hClose_help, wantReadableHandle)
 import GHC.IO.Handle.Types (BufferMode(..), Handle__(..), HandleType(..))
 import System.IO (hGetBuffering, hFileSize, hSetBuffering, hTell)
 import System.IO.Error (isEOFError)
+import Control.Exception (SomeException)
 
 -- | The 'readFile' function reads a file and returns the contents of
 -- the file as a string.  The entire file is read strictly, as with
@@ -151,7 +152,16 @@ hGetChunk h = wantReadableHandle "hGetChunk" h readSingleChunk
 hGetContents :: Handle -> IO Text
 hGetContents h = do
   chooseGoodBuffering h
-  wantReadableHandle "hGetContents" h readAll
+  r <- wantReadableHandle "hGetContents" h readAll
+  case r of
+    Left e | Just ioe <- E.fromException e -> E.throwIO (augmentIOError ioe "hGetContents" h)
+    Left e -> E.throwIO
+#if __GLASGOW_HASKELL__ >= 912
+      (E.NoBacktrace e)
+#else
+      e
+#endif
+    Right ts -> return $! T.concat ts
  where
   readAll hh@Handle__{..} = do
     let readChunks = do
@@ -161,9 +171,13 @@ hGetContents h = do
           if eof
             then return [t]
             else (t:) `fmap` readChunks
-    ts <- readChunks
-    (hh', _) <- hClose_help hh
-    return (hh'{haType=ClosedHandle}, T.concat ts)
+    r <- E.try readChunks :: IO (Either SomeException [Text])
+    (hh', me) <- hClose_help hh
+    let rr = case (r, me) of
+               (Left e, _) -> Left e
+               (Right _, Just e) -> Left e
+               (Right chunks, Nothing) -> Right chunks
+    return (hh'{haType=ClosedHandle}, rr)
 
 -- | Use a more efficient buffer size if we're reading in
 -- block-buffered mode with the default buffer size.  When we can

src/Data/Text/Lazy/IO.hs

@@ -116,12 +116,11 @@ lazyReadBuffered h hh@Handle__{..} = do
    (do t <- readChunk hh buf
        ts <- lazyRead h
        return (hh, chunk t ts)) `E.catch` \e -> do
-         (hh', _) <- hClose_help hh
-         if isEOFError e
-           then return $ if isEmptyBuffer buf
-                         then (hh', empty)
-                         else (hh', L.singleton '\r')
-           else E.throwIO (augmentIOError e "hGetContents" h)
+          (hh', _) <- hClose_help hh
+          let r | not (isEOFError e) = E.throw (augmentIOError e "hGetContents" h)
+                | isEmptyBuffer buf = empty
+                | otherwise = L.singleton '\r'
+          return (hh', r)
 
 -- | Read a single line from a handle.
 hGetLine :: Handle -> IO Text

tests/Tests/Regressions.hs

@@ -4,13 +4,15 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Tests.Regressions
     (
       tests
     ) where
 
 import Control.Exception (ErrorCall, SomeException, handle, evaluate, displayException, try)
+import Control.Monad ((>=>))
 import Data.Char (isLetter, chr)
 import GHC.Exts (Int(..), sizeofByteArray#)
 import Control.Exception (IOException)
@@ -29,16 +31,18 @@ import qualified Data.Text.Internal as T
 import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E
 import qualified Data.Text.Internal.Lazy.Fusion as LF
 import qualified Data.Text.IO as T
+import qualified Data.Text.IO.Utf8 as UT
 import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.IO as LT
 import qualified Data.Text.Lazy.Builder as TB
 import qualified Data.Text.Lazy.Encoding as LE
 import qualified Data.Text.Unsafe as T
 import qualified Test.Tasty as F
 import qualified Test.Tasty.HUnit as F
 import Tests.Utils (withTempFile)
 import System.IO.Error (isFullError)
-import Control.Monad (when)
-import Data.Either (isRight)
+import Data.Either (isLeft)
+import GHC.Stack (HasCallStack)
 
 -- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring
 -- caused either a segfault or attempt to allocate a negative number
@@ -217,15 +221,33 @@ t648 = withTempFile $ \_ h -> do
   T.append line "\r" @?= line'
 
 t714 :: IO ()
-t714 = withTempFile $ \name h -> do
-  hSetBinaryMode h True
-  hPutChar h '\xFF'
-  hClose h
-  e :: Either IOException T.Text <- try (T.readFile name)
-  when (isRight e) (assertFailure "should fail")
-  -- readFile must close the handle even in the case of an exception,
-  -- in which case the next line should succeed.
-  openFile name WriteMode >>= hClose
+t714 = withTempFile $ \name h0 -> do
+  hSetBinaryMode h0 True
+  hPutChar h0 '\xFF'
+  hClose h0
+
+  -- readFile must close the handle on exception
+  let checkReadFile :: HasCallStack => (String -> IO (Either e a)) -> IO ()
+      checkReadFile rf = do
+        rf name >>= assertBool "should fail" . isLeft
+        -- readFile must close the handle even in the case of an exception,
+        -- in which case the next line should succeed.
+        -- Use AppendMode to not truncate the file.
+        openFile name AppendMode >>= hClose
+  checkReadFile (try @IOException . T.readFile)
+  checkReadFile (LT.readFile >=> \t -> try @IOException (LT.length t `seq` pure ()))
+  checkReadFile (try @E.UnicodeException . UT.readFile)
+
+  -- hGetContents must close the handle
+  let checkGetContents :: HasCallStack => (Handle -> IO (Either e a)) -> IO ()
+      checkGetContents gc = do
+        h <- openFile name ReadMode
+        gc h >>= assertBool "should fail" . isLeft
+        closed <- hIsClosed h
+        assertBool "should be closed" closed
+  checkGetContents (try @IOException . T.hGetContents)
+  checkGetContents (LT.hGetContents >=> \t -> try @IOException (LT.length t `seq` pure ()))
+  checkGetContents (try @E.UnicodeException . UT.hGetContents)
 
 tests :: F.TestTree
 tests = F.testGroup "Regressions"