diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index f4093e96..cbdc6628 100644 --- a/src/Data/Text/IO.hs +++ b/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 diff --git a/src/Data/Text/Lazy/IO.hs b/src/Data/Text/Lazy/IO.hs index 48b2bcec..6b111503 100644 --- a/src/Data/Text/Lazy/IO.hs +++ b/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 diff --git a/tests/Tests/Regressions.hs b/tests/Tests/Regressions.hs index 64a31fe6..dc8e4a67 100644 --- a/tests/Tests/Regressions.hs +++ b/tests/Tests/Regressions.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Tests.Regressions ( @@ -11,6 +12,7 @@ module Tests.Regressions ) 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,7 +31,9 @@ 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 @@ -37,8 +41,8 @@ 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"