diff --git a/Data/Text.hs b/Data/Text.hs --- a/Data/Text.hs +++ b/Data/Text.hs @@ -204,9 +204,7 @@ Read(..), (&&), (||), (+), (-), (.), ($), ($!), (>>), not, return, otherwise, quot) -#if defined(HAVE_DEEPSEQ) import Control.DeepSeq (NFData(rnf)) -#endif #if defined(ASSERTS) import Control.Exception (assert) #endif @@ -381,9 +379,7 @@ toList = unpack #endif -#if defined(HAVE_DEEPSEQ) instance NFData Text where rnf !_ = () -#endif -- | @since 1.2.1.0 instance Binary Text where diff --git a/Data/Text/Encoding.hs b/Data/Text/Encoding.hs --- a/Data/Text/Encoding.hs +++ b/Data/Text/Encoding.hs @@ -65,7 +65,7 @@ import Control.Monad.ST (unsafeIOToST, unsafeSTToIO) #endif -import Control.Exception (evaluate, try) +import Control.Exception (evaluate, try, throwIO, ErrorCall(ErrorCall)) import Control.Monad.ST (runST) import Data.Bits ((.&.)) import Data.ByteString as B @@ -131,6 +131,13 @@ return dest -- | Decode a 'ByteString' containing UTF-8 encoded text. +-- +-- __NOTE__: The replacement character returned by 'OnDecodeError' +-- MUST be within the BMP plane; surrogate code points will +-- automatically be remapped to the replacement char @U+FFFD@ +-- (/since 0.11.3.0/), whereas code points beyond the BMP will throw an +-- 'error' (/since 1.2.3.1/); For earlier versions of @text@ using +-- those unsupported code points would result in undefined behavior. decodeUtf8With :: OnDecodeError -> ByteString -> Text decodeUtf8With onErr (PS fp off len) = runText $ \done -> do let go dest = withForeignPtr fp $ \ptr -> @@ -146,16 +153,52 @@ x <- peek curPtr' case onErr desc (Just x) of Nothing -> loop $ curPtr' `plusPtr` 1 - Just c -> do - destOff <- peek destOffPtr - w <- unsafeSTToIO $ - unsafeWrite dest (fromIntegral destOff) (safe c) - poke destOffPtr (destOff + fromIntegral w) - loop $ curPtr' `plusPtr` 1 + Just c + | c > '\xFFFF' -> throwUnsupportedReplChar + | otherwise -> do + destOff <- peek destOffPtr + w <- unsafeSTToIO $ + unsafeWrite dest (fromIntegral destOff) + (safe c) + poke destOffPtr (destOff + fromIntegral w) + loop $ curPtr' `plusPtr` 1 loop (ptr `plusPtr` off) (unsafeIOToST . go) =<< A.new len where desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" + + throwUnsupportedReplChar = throwIO $ + ErrorCall "decodeUtf8With: non-BMP replacement characters not supported" + -- TODO: The code currently assumes that the transcoded UTF-16 + -- stream is at most twice as long (in bytes) as the input UTF-8 + -- stream. To justify this assumption one has to assume that the + -- error handler replacement character also satisfies this + -- invariant, by emitting at most one UTF16 code unit. + -- + -- One easy way to support the full range of code-points for + -- replacement characters in the error handler is to simply change + -- the (over-)allocation to `A.new (2*len)` and then shrink back the + -- `ByteArray#` to the real size (recent GHCs have a cheap + -- `ByteArray#` resize-primop for that which allow the GC to reclaim + -- the overallocation). However, this would require 4 times as much + -- (temporary) storage as the original UTF-8 required. + -- + -- Another strategy would be to optimistically assume that + -- replacement characters are within the BMP, and if the case of a + -- non-BMP replacement occurs reallocate the target buffer (or throw + -- an exception, and fallback to a pessimistic codepath, like e.g. + -- `decodeUtf8With onErr bs = F.unstream (E.streamUtf8 onErr bs)`) + -- + -- Alternatively, `OnDecodeError` could become a datastructure which + -- statically encodes the replacement-character range, + -- e.g. something isomorphic to + -- + -- Either (... -> Maybe Word16) (... -> Maybe Char) + -- + -- And allow to statically switch between the BMP/non-BMP + -- replacement-character codepaths. There's multiple ways to address + -- this with different tradeoffs; but ideally we should optimise for + -- the optimistic/error-free case. {- INLINE[0] decodeUtf8With #-} -- $stream diff --git a/Data/Text/IO.hs b/Data/Text/IO.hs --- a/Data/Text/IO.hs +++ b/Data/Text/IO.hs @@ -95,15 +95,23 @@ appendFile :: FilePath -> Text -> IO () appendFile p = withFile p AppendMode . flip hPutStr -catchError :: String -> Handle -> Handle__ -> IOError -> IO Text +catchError :: String -> Handle -> Handle__ -> IOError -> IO (Text, Bool) catchError caller h Handle__{..} err | isEOFError err = do buf <- readIORef haCharBuffer return $ if isEmptyBuffer buf - then T.empty - else T.singleton '\r' + then (T.empty, True) + else (T.singleton '\r', True) | otherwise = E.throwIO (augmentIOError err caller h) +-- | Wrap readChunk and return a value indicating if we're reached the EOF. +-- This is needed because unpack_nl is unable to discern the difference +-- between a buffer with just \r due to EOF or because not enough data was left +-- for decoding. e.g. the final character decoded from the byte buffer was \r. +readChunkEof :: Handle__ -> CharBuffer -> IO (Text, Bool) +readChunkEof hh buf = do t <- readChunk hh buf + return (t, False) + -- | /Experimental./ Read a single chunk of strict text from a -- 'Handle'. The size of the chunk depends on the amount of input -- currently buffered. @@ -116,7 +124,7 @@ where readSingleChunk hh@Handle__{..} = do buf <- readIORef haCharBuffer - t <- readChunk hh buf `E.catch` catchError "hGetChunk" h hh + (t, _) <- readChunkEof hh buf `E.catch` catchError "hGetChunk" h hh return (hh, t) -- | Read the remaining contents of a 'Handle' as a string. The @@ -138,8 +146,9 @@ readAll hh@Handle__{..} = do let readChunks = do buf <- readIORef haCharBuffer - t <- readChunk hh buf `E.catch` catchError "hGetContents" h hh - if T.null t + (t, eof) <- readChunkEof hh buf + `E.catch` catchError "hGetContents" h hh + if eof then return [t] else (t:) `fmap` readChunks ts <- readChunks diff --git a/Data/Text/Internal/Fusion/Common.hs b/Data/Text/Internal/Fusion/Common.hs --- a/Data/Text/Internal/Fusion/Common.hs +++ b/Data/Text/Internal/Fusion/Common.hs @@ -400,7 +400,7 @@ caseConvert :: (forall s. Char -> s -> Step (CC s) Char) -> Stream Char -> Stream Char caseConvert remap (Stream next0 s0 len) = - Stream next (CC s0 '\0' '\0') (len `unionSize` 3*len) + Stream next (CC s0 '\0' '\0') (len `unionSize` (3*len)) where next (CC s '\0' _) = case next0 s of @@ -735,8 +735,10 @@ -- length of the stream. take :: Integral a => a -> Stream Char -> Stream Char take n0 (Stream next0 s0 len) = - Stream next (n0 :*: s0) (smaller len (codePointsSize $ fromIntegral n0)) + Stream next (n0' :*: s0) (smaller len (codePointsSize $ fromIntegral n0')) where + n0' = max n0 0 + {-# INLINE next #-} next (n :*: s) | n <= 0 = Done | otherwise = case next0 s of @@ -753,8 +755,10 @@ -- is greater than the length of the stream. drop :: Integral a => a -> Stream Char -> Stream Char drop n0 (Stream next0 s0 len) = - Stream next (JS n0 s0) (len - codePointsSize (fromIntegral n0)) + Stream next (JS n0' s0) (len - codePointsSize (fromIntegral n0')) where + n0' = max n0 0 + {-# INLINE next #-} next (JS n s) | n <= 0 = Skip (NS s) diff --git a/Data/Text/Internal/Fusion/Size.hs b/Data/Text/Internal/Fusion/Size.hs --- a/Data/Text/Internal/Fusion/Size.hs +++ b/Data/Text/Internal/Fusion/Size.hs @@ -61,7 +61,11 @@ -- | The 'Size' of @n@ code points. codePointsSize :: Int -> Size -codePointsSize n = Between n (2*n) +codePointsSize n = +#if defined(ASSERTS) + assert (n >= 0) +#endif + Between n (2*n) {-# INLINE codePointsSize #-} exactSize :: Int -> Size diff --git a/Data/Text/Lazy.hs b/Data/Text/Lazy.hs --- a/Data/Text/Lazy.hs +++ b/Data/Text/Lazy.hs @@ -205,9 +205,7 @@ (&&), (||), (+), (-), (.), ($), (++), error, flip, fmap, fromIntegral, not, otherwise, quot) import qualified Prelude as P -#if defined(HAVE_DEEPSEQ) import Control.DeepSeq (NFData(..)) -#endif import Data.Int (Int64) import qualified Data.List as L import Data.Char (isSpace) @@ -375,11 +373,9 @@ toList = unpack #endif -#if defined(HAVE_DEEPSEQ) instance NFData Text where rnf Empty = () rnf (Chunk _ ts) = rnf ts -#endif -- | @since 1.2.1.0 instance Binary Text where diff --git a/Data/Text/Lazy/Builder/RealFloat.hs b/Data/Text/Lazy/Builder/RealFloat.hs --- a/Data/Text/Lazy/Builder/RealFloat.hs +++ b/Data/Text/Lazy/Builder/RealFloat.hs @@ -46,6 +46,14 @@ {-# SPECIALIZE realFloat :: Double -> Builder #-} realFloat x = formatRealFloat Generic Nothing x +-- | Encode a signed 'RealFloat' according to 'FPFormat' and optionally requested precision. +-- +-- This corresponds to the @show{E,F,G}Float@ operations provided by @base@'s "Numeric" module. +-- +-- __NOTE__: The functions in @base-4.12@ changed the serialisation in +-- case of a @Just 0@ precision; this version of @text@ still provides +-- the serialisation as implemented in @base-4.11@. The next major +-- version of @text@ will switch to the more correct @base-4.12@ serialisation. formatRealFloat :: (RealFloat a) => FPFormat -> Maybe Int -- ^ Number of decimal places to render. diff --git a/benchmarks/text-benchmarks.cabal b/benchmarks/text-benchmarks.cabal --- a/benchmarks/text-benchmarks.cabal +++ b/benchmarks/text-benchmarks.cabal @@ -28,7 +28,7 @@ ghc-options: -Wall -O2 -rtsopts if flag(llvm) ghc-options: -fllvm - cpp-options: -DHAVE_DEEPSEQ -DINTEGER_GMP + cpp-options: -DINTEGER_GMP build-depends: array, base == 4.*, binary, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,17 @@ +### 1.2.3.1 + +* Make `decodeUtf8With` fail explicitly for unsupported non-BMP + replacement characters instead silent undefined behaviour (gh-213) + +* Fix termination condition for file reads via `Data.Text.IO` + operations (gh-223) + +* A serious correctness issue affecting uses of `take` and `drop` with + negative counts has been fixed (gh-227) + +* A bug in the case-mapping functions resulting in unreasonably large + allocations with large arguments has been fixed (gh-221) + ### 1.2.3.0 * Spec compliance: `toCaseFold` now follows the Unicode 9.0 spec diff --git a/tests/.ghci b/tests/.ghci --- a/tests/.ghci +++ b/tests/.ghci @@ -1,1 +1,1 @@ -:set -DHAVE_DEEPSEQ -isrc -i../.. +:set -isrc -i../.. diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -1,5 +1,6 @@ -- | QuickCheck properties for the text library. +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-} @@ -122,23 +123,39 @@ instance Arbitrary Badness where arbitrary = elements [Solo, Leading, Trailing] -t_utf8_err :: Badness -> DecodeErr -> Property -t_utf8_err bad de = do +t_utf8_err :: Badness -> Maybe DecodeErr -> Property +t_utf8_err bad mde = do let gen = case bad of Solo -> genInvalidUTF8 Leading -> B.append <$> genInvalidUTF8 <*> genUTF8 Trailing -> B.append <$> genUTF8 <*> genInvalidUTF8 genUTF8 = E.encodeUtf8 <$> genUnicode - forAll gen $ \bs -> MkProperty $ do - onErr <- genDecodeErr de - unProperty . monadicIO $ do - l <- run $ let len = T.length (E.decodeUtf8With onErr bs) - in (len `seq` return (Right len)) `Exception.catch` - (\(e::UnicodeException) -> return (Left e)) - assert $ case l of - Left err -> length (show err) >= 0 - Right _ -> de /= Strict + forAll gen $ \bs -> MkProperty $ + case mde of + -- generate an invalid character + Nothing -> do + c <- choose ('\x10000', maxBound) + let onErr _ _ = Just c + unProperty . monadicIO $ do + l <- run $ let len = T.length (E.decodeUtf8With onErr bs) + in (len `seq` return (Right len)) `Exception.catch` + (\(e::Exception.SomeException) -> return (Left e)) + assert $ case l of + Left err -> + "non-BMP replacement characters not supported" `T.isInfixOf` T.pack (show err) + Right _ -> False + -- generate a valid onErr + Just de -> do + onErr <- genDecodeErr de + unProperty . monadicIO $ do + l <- run $ let len = T.length (E.decodeUtf8With onErr bs) + in (len `seq` return (Right len)) `Exception.catch` + (\(e::UnicodeException) -> return (Left e)) + assert $ case l of + Left err -> length (show err) >= 0 + Right _ -> de /= Strict + t_utf8_err' :: B.ByteString -> Property t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of Left err -> length (show err) >= 0 @@ -203,9 +220,10 @@ case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97, 97]) of E.Some x _ _ -> x === "xaaa" -t_infix_concat bs1 text bs2 rep = +t_infix_concat bs1 text bs2 = + forAll (genDecodeErr Replace) $ \onErr -> text `T.isInfixOf` - E.decodeUtf8With (\_ _ -> rep) (B.concat [bs1, E.encodeUtf8 text, bs2]) + E.decodeUtf8With onErr (B.concat [bs1, E.encodeUtf8 text, bs2]) s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList) where _types = s :: String @@ -853,16 +871,22 @@ tb_realfloat_double (a::Double) = tb_realfloat a showFloat :: (RealFloat a) => TB.FPFormat -> Maybe Int -> a -> ShowS -showFloat TB.Exponent = showEFloat -showFloat TB.Fixed = showFFloat -showFloat TB.Generic = showGFloat +showFloat TB.Exponent (Just 0) = showEFloat (Just 1) -- see gh-231 +showFloat TB.Exponent p = showEFloat p +showFloat TB.Fixed p = showFFloat p +showFloat TB.Generic p = showGFloat p tb_formatRealFloat :: (RealFloat a, Show a) => a -> TB.FPFormat -> Precision a -> Property -tb_formatRealFloat a fmt prec = +tb_formatRealFloat a fmt prec = cond ==> TB.formatRealFloat fmt p a === TB.fromString (showFloat fmt p a "") where p = precision a prec + cond = case (p,fmt) of +#if MIN_VERSION_base(4,12,0) + (Just 0, TB.Generic) -> False -- skipping due to gh-231 +#endif + _ -> True tb_formatRealFloat_float (a::Float) = tb_formatRealFloat a tb_formatRealFloat_double (a::Double) = tb_formatRealFloat a diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs --- a/tests/Tests/QuickCheckUtils.hs +++ b/tests/Tests/QuickCheckUtils.hs @@ -210,7 +210,10 @@ genDecodeErr Lenient = return T.lenientDecode genDecodeErr Ignore = return T.ignore genDecodeErr Strict = return T.strictDecode -genDecodeErr Replace = arbitrary +genDecodeErr Replace = (\c _ _ -> c) <$> frequency + [ (1, return Nothing) + , (50, Just <$> choose ('\x1', '\xffff')) + ] instance Arbitrary DecodeErr where arbitrary = elements [Lenient, Ignore, Strict, Replace] diff --git a/tests/Tests/Regressions.hs b/tests/Tests/Regressions.hs --- a/tests/Tests/Regressions.hs +++ b/tests/Tests/Regressions.hs @@ -7,6 +7,7 @@ ) where import Control.Exception (SomeException, handle) +import Data.Char (isLetter) import System.IO import Test.HUnit (assertBool, assertEqual, assertFailure) import qualified Data.ByteString as B @@ -82,6 +83,18 @@ cond = length fltr fltr = filter (== ',') x +t221 :: IO () +t221 = + assertEqual "toLower of large input shouldn't crash" + (T.toLower (T.replicate 200000 "0") `seq` ()) + () + +t227 :: IO () +t227 = + assertEqual "take (-3) shouldn't crash with overflow" + (T.length $ T.filter isLetter $ T.take (-3) "Hello! How are you doing today?") + 0 + tests :: F.Test tests = F.testGroup "Regressions" [ F.testCase "hGetContents_crash" hGetContents_crash @@ -90,4 +103,6 @@ , F.testCase "replicate_crash" replicate_crash , F.testCase "utf8_decode_unsafe" utf8_decode_unsafe , F.testCase "t197" t197 + , F.testCase "t221" t221 + , F.testCase "t227" t227 ] diff --git a/tests/text-tests.cabal b/tests/text-tests.cabal --- a/tests/text-tests.cabal +++ b/tests/text-tests.cabal @@ -47,7 +47,6 @@ cpp-options: -DTEST_SUITE -DASSERTS - -DHAVE_DEEPSEQ build-depends: HUnit >= 1.2, @@ -139,7 +138,6 @@ cpp-options: -DTEST_SUITE - -DHAVE_DEEPSEQ -DASSERTS -DINTEGER_GMP diff --git a/text.cabal b/text.cabal --- a/text.cabal +++ b/text.cabal @@ -1,5 +1,7 @@ +cabal-version: >= 1.8 name: text -version: 1.2.3.0 +version: 1.2.3.1 + homepage: https://github.com/haskell/text bug-reports: https://github.com/haskell/text/issues synopsis: An efficient packed Unicode text type. @@ -37,13 +39,12 @@ license: BSD2 license-file: LICENSE author: Bryan O'Sullivan -maintainer: Bryan O'Sullivan +maintainer: Bryan O'Sullivan , Herbert Valerio Riedel copyright: 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper -bug-reports: https://github.com/haskell/text/issues category: Data, Text build-type: Simple -cabal-version: >= 1.8 -tested-with: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, +tested-with: GHC==8.6.1, GHC==8.4.3, + GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 extra-source-files: -- scripts/CaseFolding.txt @@ -152,9 +153,8 @@ build-depends: bytestring >= 0.9 && < 0.10.4, bytestring-builder >= 0.10.4 else - build-depends: bytestring >= 0.10.4 + build-depends: bytestring >= 0.10.4 && < 0.11 - cpp-options: -DHAVE_DEEPSEQ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 if flag(developer) ghc-prof-options: -auto-all @@ -166,7 +166,7 @@ build-depends: integer-simple >= 0.1 && < 0.5 else cpp-options: -DINTEGER_GMP - build-depends: integer-gmp >= 0.2 + build-depends: integer-gmp >= 0.2 && < 1.1 test-suite tests type: exitcode-stdio-1.0 @@ -177,7 +177,7 @@ -Wall -threaded -rtsopts cpp-options: - -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE + -DASSERTS -DTEST_SUITE -- modules specific to test-suite hs-source-dirs: tests @@ -246,7 +246,7 @@ build-depends: HUnit >= 1.2, - QuickCheck >= 2.7 && < 2.10, + QuickCheck >= 2.7 && < 2.11, array, base, binary,