Commits

Bryan O'Sullivan committed a19de8a

Fix a crash reported by Michael Snoyman.

Comments (0)

Files changed (3)

Data/Text/Lazy/Encoding/Fusion.hs

 unstreamChunks :: Int -> Stream Word8 -> ByteString
 unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
   where chunk s1 len1 = unsafePerformIO $ do
-          let len = min len1 chunkSize
+          let len = max 4 (min len1 chunkSize)
           mallocByteString len >>= loop len 0 s1
           where
             loop !n !off !s fp = case next s of
                 Done | off == 0 -> return Empty
-                     | otherwise -> do
-                      bs <- trimUp fp off
-                      return $! Chunk bs Empty
+                     | otherwise -> return $! Chunk (trimUp fp off) Empty
                 Skip s' -> loop n off s' fp
                 Yield x s'
                     | off == chunkSize -> do
-                      bs <- trimUp fp off
-                      return (Chunk bs (chunk s (n - B.length bs)))
+                      let !newLen = n - off
+                      return $! Chunk (trimUp fp off) (chunk s newLen)
                     | off == n -> realloc fp n off s' x
                     | otherwise -> do
                       withForeignPtr fp $ \p -> pokeByteOff p off x
               fp' <- copy0 fp n n'
               withForeignPtr fp' $ \p -> pokeByteOff p off x
               loop n' (off+1) s fp'
-            {-# NOINLINE trimUp #-}
-            trimUp fp off = return $! B.PS fp 0 off
+            trimUp fp off = B.PS fp 0 off
             copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)
             copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do
                 dest <- mallocByteString destLen
 	-package bytestring -ignore-package text \
 	-fno-ignore-asserts
 ghc-test-flags := -package QuickCheck -package test-framework \
-	-package test-framework-quickcheck
+	-package test-framework-quickcheck -package test-framework-hunit \
+	-package HUnit
 ghc-base-flags += -Wall -fno-warn-orphans -fno-warn-missing-signatures
 ghc-flags := $(ghc-base-flags) -i../dist/build -package-name text-$(version)
 ghc-hpc-flags := $(ghc-base-flags) -fhpc -fno-ignore-asserts -odir hpcdir \
 
 cabal := $(shell which cabal 2>/dev/null)
 
-all: bm qc coverage
+all: bm qc coverage regressions
 
 lib: $(lib)
 
 	$(ghc) $(ghc-hpc-flags) $(ghc-opt-flags) -ihpcdir \
 	  --make -threaded -o $@ $<
 
+regressions: Regressions.o
+	$(ghc) $(ghc-test-flags) -o $@ $^ $(lib)
+
 coverage: qc-hpc-html/hpc_index.html
 
 qc-hpc-html/hpc_index.html: qc-hpc

tests/Regressions.hs

+-- Regression tests for specific bugs.
+
+import Control.Exception (bracket)
+import System.Directory (removeFile)
+import System.IO (hClose, openTempFile)
+import Test.HUnit (Assertion)
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LE
+import qualified Test.Framework as F
+import qualified Test.Framework.Providers.HUnit as F
+
+-- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring
+-- caused either a segfault or attempt to allocate a negative number
+-- of bytes.
+lazy_encode_crash =
+  bracket (openTempFile "." "crashy.txt")
+          (\(path,h) -> hClose h >> removeFile path) $
+  \(_,h) -> LB.hPut h . LE.encodeUtf8 . LT.pack . replicate 100000 $ 'a'
+
+tests :: F.Test
+tests = F.testGroup "crashers" [
+          F.testCase "lazy_encode_crash" lazy_encode_crash
+        ]
+
+main = F.defaultMain [tests]