Skip to content

Commit 7e9c394

Browse files
emilypiemilypi
authored
Merge branch 'master' into relax-base-bounds
2 parents a33a4e6 + 94c31ce commit 7e9c394

File tree

4 files changed

+123
-46
lines changed

4 files changed

+123
-46
lines changed

‎Codec/Compression/Zlib/ByteStringCompat.hs

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
-- Lifted from the text package, with light editing:
2+
-- Data.Text.Internal.ByteStringCompat
3+
4+
{-# LANGUAGE BangPatterns #-}
5+
{-# LANGUAGE CPP #-}
6+
{-# LANGUAGE MagicHash #-}
7+
module Codec.Compression.Zlib.ByteStringCompat (mkBS, withBS) where
8+
9+
import Data.ByteString.Internal (ByteString (..))
10+
import Data.Word (Word8)
11+
import Foreign.ForeignPtr (ForeignPtr)
12+
13+
#if MIN_VERSION_base(4,10,0)
14+
import GHC.ForeignPtr (plusForeignPtr)
15+
#else
16+
import GHC.ForeignPtr (ForeignPtr(ForeignPtr))
17+
import GHC.Types (Int (..))
18+
import GHC.Prim (plusAddr#)
19+
#endif
20+
21+
mkBS :: ForeignPtr Word8 -> Int -> Int -> ByteString
22+
#if MIN_VERSION_bytestring(0,11,0)
23+
mkBS dfp o n = BS (plusForeignPtr dfp o) n
24+
#else
25+
mkBS dfp o n = PS dfp o n
26+
#endif
27+
{-# INLINE mkBS #-}
28+
29+
withBS :: ByteString -> (ForeignPtr Word8 -> Int -> r) -> r
30+
#if MIN_VERSION_bytestring(0,11,0)
31+
withBS (BS !sfp !slen) kont = kont sfp slen
32+
#else
33+
withBS (PS !sfp !soff !slen) kont = kont (plusForeignPtr sfp soff) slen
34+
#endif
35+
{-# INLINE withBS #-}
36+
37+
#if !MIN_VERSION_base(4,10,0)
38+
-- |Advances the given address by the given offset in bytes.
39+
--
40+
-- The new 'ForeignPtr' shares the finalizer of the original,
41+
-- equivalent from a finalization standpoint to just creating another
42+
-- reference to the original. That is, the finalizer will not be
43+
-- called before the new 'ForeignPtr' is unreachable, nor will it be
44+
-- called an additional time due to this call, and the finalizer will
45+
-- be called with the same address that it would have had this call
46+
-- not happened, *not* the new address.
47+
plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b
48+
plusForeignPtr (ForeignPtr addr guts) (I# offset) = ForeignPtr (plusAddr# addr offset) guts
49+
{-# INLINE [0] plusForeignPtr #-}
50+
{-# RULES
51+
"ByteString plusForeignPtr/0" forall fp .
52+
plusForeignPtr fp 0 = fp
53+
#-}
54+
#endif

‎Codec/Compression/Zlib/Internal.hs

Lines changed: 43 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -92,6 +92,7 @@ import Data.Word (Word8)
9292
import GHC.IO (noDuplicate)
9393

9494
import qualified Codec.Compression.Zlib.Stream as Stream
95+
import Codec.Compression.Zlib.ByteStringCompat (mkBS, withBS)
9596
import Codec.Compression.Zlib.Stream (Stream)
9697

9798
-- | The full set of parameters for compression. The defaults are
@@ -471,13 +472,12 @@ compressStream format (CompressParams compLevel method bits memLevel
471472
\chunk -> do
472473
Stream.deflateInit format compLevel method bits memLevel strategy
473474
setDictionary mdict
474-
case chunk of
475-
_ | S.null chunk ->
476-
fillBuffers 20 --gzip header is 20 bytes, others even smaller
477-
478-
S.PS inFPtr offset length -> do
479-
Stream.pushInputBuffer inFPtr offset length
480-
fillBuffers initChunkSize
475+
withBS chunk $ \inFPtr length ->
476+
if length == 0
477+
then fillBuffers 20 --gzip header is 20 bytes, others even smaller
478+
else do
479+
Stream.pushInputBuffer inFPtr 0 length
480+
fillBuffers initChunkSize
481481

482482
where
483483
-- we flick between two states:
@@ -507,11 +507,11 @@ compressStream format (CompressParams compLevel method bits memLevel
507507
Stream.pushOutputBuffer outFPtr 0 outChunkSize
508508

509509
if inputBufferEmpty
510-
then return $ CompressInputRequired $ \chunk ->
511-
case chunk of
512-
_ | S.null chunk -> drainBuffers True
513-
S.PS inFPtr offset length -> do
514-
Stream.pushInputBuffer inFPtr offset length
510+
then return $ CompressInputRequired $ flip withBS $ \inFPtr length ->
511+
if length == 0
512+
then drainBuffers True
513+
else do
514+
Stream.pushInputBuffer inFPtr 0 length
515515
drainBuffers False
516516
else drainBuffers False
517517

@@ -534,7 +534,7 @@ compressStream format (CompressParams compLevel method bits memLevel
534534
outputBufferFull <- Stream.outputBufferFull
535535
if outputBufferFull
536536
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
537-
let chunk = S.PS outFPtr offset length
537+
let chunk = mkBS outFPtr offset length
538538
return $ CompressOutputAvailable chunk $ do
539539
fillBuffers defaultCompressBufferSize
540540
else do fillBuffers defaultCompressBufferSize
@@ -545,7 +545,7 @@ compressStream format (CompressParams compLevel method bits memLevel
545545
outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable
546546
if outputBufferBytesAvailable > 0
547547
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
548-
let chunk = S.PS outFPtr offset length
548+
let chunk = mkBS outFPtr offset length
549549
Stream.finalise
550550
return $ CompressOutputAvailable chunk (return CompressStreamEnd)
551551
else do Stream.finalise
@@ -607,25 +607,25 @@ decompressStream format (DecompressParams bits initChunkSize mdict allMembers)
607607
Stream.inflateReset
608608
else assert outputBufferFull $
609609
Stream.inflateInit format bits
610-
case chunk of
611-
_ | S.null chunk -> do
612-
-- special case to avoid demanding more input again
613-
-- always an error anyway
614-
when outputBufferFull $ do
615-
let outChunkSize = 1
616-
outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)
617-
Stream.pushOutputBuffer outFPtr 0 outChunkSize
618-
drainBuffers True
619-
620-
S.PS inFPtr offset length -> do
621-
Stream.pushInputBuffer inFPtr offset length
622-
-- Normally we start with no output buffer (so counts as full) but
623-
-- if we're resuming then we'll usually still have output buffer
624-
-- space available
625-
assert (if not resume then outputBufferFull else True) $ return ()
626-
if outputBufferFull
627-
then fillBuffers initChunkSize
628-
else drainBuffers False
610+
withBS chunk $ \inFPtr length ->
611+
if length == 0
612+
then do
613+
-- special case to avoid demanding more input again
614+
-- always an error anyway
615+
when outputBufferFull $ do
616+
let outChunkSize = 1
617+
outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)
618+
Stream.pushOutputBuffer outFPtr 0 outChunkSize
619+
drainBuffers True
620+
else do
621+
Stream.pushInputBuffer inFPtr 0 length
622+
-- Normally we start with no output buffer (so counts as full) but
623+
-- if we're resuming then we'll usually still have output buffer
624+
-- space available
625+
assert (if not resume then outputBufferFull else True) $ return ()
626+
if outputBufferFull
627+
then fillBuffers initChunkSize
628+
else drainBuffers False
629629

630630
where
631631
-- we flick between two states:
@@ -657,11 +657,12 @@ decompressStream format (DecompressParams bits initChunkSize mdict allMembers)
657657

658658
if inputBufferEmpty
659659
then return $ DecompressInputRequired $ \chunk ->
660-
case chunk of
661-
_ | S.null chunk -> drainBuffers True
662-
S.PS inFPtr offset length -> do
663-
Stream.pushInputBuffer inFPtr offset length
664-
drainBuffers False
660+
withBS chunk $ \inFPtr length ->
661+
if length == 0
662+
then drainBuffers True
663+
else do
664+
Stream.pushInputBuffer inFPtr 0 length
665+
drainBuffers False
665666
else drainBuffers False
666667

667668

@@ -682,7 +683,7 @@ decompressStream format (DecompressParams bits initChunkSize mdict allMembers)
682683
outputBufferFull <- Stream.outputBufferFull
683684
if outputBufferFull
684685
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
685-
let chunk = S.PS outFPtr offset length
686+
let chunk = mkBS outFPtr offset length
686687
return $ DecompressOutputAvailable chunk $ do
687688
fillBuffers defaultDecompressBufferSize
688689
else do fillBuffers defaultDecompressBufferSize
@@ -695,7 +696,7 @@ decompressStream format (DecompressParams bits initChunkSize mdict allMembers)
695696
if inputBufferEmpty
696697
then do finish (DecompressStreamEnd S.empty)
697698
else do (inFPtr, offset, length) <- Stream.popRemainingInputBuffer
698-
let inchunk = S.PS inFPtr offset length
699+
let inchunk = mkBS inFPtr offset length
699700
finish (DecompressStreamEnd inchunk)
700701

701702
Stream.Error code msg -> case code of
@@ -714,7 +715,7 @@ decompressStream format (DecompressParams bits initChunkSize mdict allMembers)
714715
outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable
715716
if outputBufferBytesAvailable > 0
716717
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
717-
return (DecompressOutputAvailable (S.PS outFPtr offset length) (return end))
718+
return (DecompressOutputAvailable (mkBS outFPtr offset length) (return end))
718719
else return end
719720

720721
setDictionary :: Stream.DictionaryHash -> Maybe S.ByteString
@@ -902,7 +903,7 @@ decompressStreamST format params =
902903

903904

904905
tryFollowingStream :: S.ByteString -> Stream.State s -> ST s (DecompressStream (ST s))
905-
tryFollowingStream chunk zstate =
906+
tryFollowingStream chunk zstate =
906907
case S.length chunk of
907908
0 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of
908909
0 -> finaliseStreamEnd S.empty zstate

‎test/Test.hs

Lines changed: 22 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,9 @@ import Control.Exception
2222
import qualified Data.ByteString.Char8 as BS.Char8
2323
import qualified Data.ByteString.Lazy as BL
2424
import qualified Data.ByteString as BS
25+
#if !MIN_VERSION_bytestring(0,11,0)
26+
import qualified Data.ByteString.Internal as BS
27+
#endif
2528
import System.IO
2629
#if !(MIN_VERSION_base(4,6,0))
2730
import Prelude hiding (catch)
@@ -38,7 +41,8 @@ main = defaultMain $
3841
testProperty "concatenated gzip members" prop_gzip_concat,
3942
testProperty "multiple gzip members, boundaries (all 2-chunks)" prop_multiple_members_boundary2,
4043
testProperty "multiple gzip members, boundaries (all 3-chunks)" prop_multiple_members_boundary3,
41-
testProperty "prefixes of valid stream detected as truncated" prop_truncated
44+
testProperty "prefixes of valid stream detected as truncated" prop_truncated,
45+
testProperty "compress works with BSes with non-zero offset" prop_compress_nonzero_bs_offset
4246
],
4347
testGroup "unit tests" [
4448
testCase "simple gzip case" test_simple_gzip,
@@ -136,6 +140,23 @@ prop_truncated format =
136140

137141
shortStrings = sized $ \sz -> resize (sz `div` 6) arbitrary
138142

143+
prop_compress_nonzero_bs_offset :: BS.ByteString
144+
-> Int
145+
-> Property
146+
prop_compress_nonzero_bs_offset original to_drop =
147+
to_drop > 0 &&
148+
BS.length original > to_drop ==>
149+
let input = BS.drop to_drop original
150+
#if MIN_VERSION_bytestring(0,11,0)
151+
dropped = to_drop
152+
#else
153+
(BS.PS _ptr dropped _length) = input
154+
#endif
155+
input' = BL.pack $ BS.unpack input -- BL.fromStrict is only available since bytestring-0.10.4.0
156+
compressed = compress gzipFormat defaultCompressParams input'
157+
decompressed = decompress gzipFormat defaultDecompressParams compressed
158+
in dropped == to_drop && decompressed == input'
159+
139160

140161
test_simple_gzip :: Assertion
141162
test_simple_gzip =

‎zlib.cabal

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -63,7 +63,8 @@ library
6363
Codec.Compression.Zlib,
6464
Codec.Compression.Zlib.Raw,
6565
Codec.Compression.Zlib.Internal
66-
other-modules: Codec.Compression.Zlib.Stream
66+
other-modules: Codec.Compression.Zlib.Stream,
67+
Codec.Compression.Zlib.ByteStringCompat
6768
if impl(ghc < 7)
6869
default-language: Haskell98
6970
default-extensions: PatternGuards
@@ -76,8 +77,8 @@ library
7677
if impl(ghc >= 7.6)
7778
other-extensions: CApiFFI
7879
build-depends: base >= 4 && < 4.16,
79-
bytestring >= 0.9 && < 0.11
80-
if impl(ghc >= 7.2 && < 7.6)
80+
bytestring >= 0.9 && < 0.12
81+
if impl(ghc >= 7.0 && < 8.0.3)
8182
build-depends: ghc-prim
8283
includes: zlib.h
8384
ghc-options: -Wall -fwarn-tabs

0 commit comments

Comments
 (0)