snappy-c (empty) → 0.1.0
raw patch · 16 files changed
+1948/−0 lines, 16 filesdep +basedep +bytestringdep +conduit
Dependencies added: base, bytestring, conduit, criterion, data-default, deepseq, digest, mtl, optparse-applicative, random, snappy-c, snappy-lazy, tasty, tasty-hunit, tasty-quickcheck, zlib
Files
- CHANGELOG.md +5/−0
- LICENSE +31/−0
- README.md +104/−0
- bench/Main.hs +102/−0
- snappy-c.cabal +151/−0
- snappy-cli/Main.hs +174/−0
- src/Codec/Compression/SnappyC/Framed.hs +253/−0
- src/Codec/Compression/SnappyC/Internal/Buffer.hs +118/−0
- src/Codec/Compression/SnappyC/Internal/C.hs +62/−0
- src/Codec/Compression/SnappyC/Internal/Checksum.hs +63/−0
- src/Codec/Compression/SnappyC/Internal/FrameFormat.hs +510/−0
- src/Codec/Compression/SnappyC/Internal/Util.hs +15/−0
- src/Codec/Compression/SnappyC/Raw.hs +100/−0
- test/Main.hs +37/−0
- test/Test/Prop/Orphans.hs +77/−0
- test/Test/Prop/RoundTrip.hs +146/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for snappy-c++## 0.1.0 -- 2024-02-09++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2024, Well-Typed LLP and Anduril Industries Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Well-Typed LLP, the name of Anduril+ Industries Inc., nor the names of other contributors may be+ used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,104 @@+# snappy-c++++Haskell bindings to the C API of [Snappy][snappy]: A fast compression library.++# Usage++> [!IMPORTANT]+> To use this package, you must have the Snappy library installed **and visible+> to `cabal`**.++If your build fails with a message like:+```+Error: cabal-3.10.1.0: Missing dependency on a foreign library:+* Missing (or bad) C library: snappy+```++You need to explicitly configure the include and library paths via cabal. One+way to do so is to add something like this to your `cabal.project`+configuration:++```cabal+package snappy-c+ extra-include-dirs:+ /path/to/snappy/include+ extra-lib-dirs:+ /path/to/snappy/lib+```++In my case, on a mac using homebrew, the following suffices:++```cabal+package snappy-c+ extra-lib-dirs:+ /opt/homebrew/lib+ extra-include-dirs:+ /opt/homebrew/include+```++We wouldn't need to do this if the Snappy library supported pkg-config+configuration, but as of writing [they do+not](https://github.com/google/snappy/pull/86#issuecomment-552237257).++## Installing Snappy++The [Snappy][snappy] library is available most package managers.++### Homebrew++```+brew install snappy+```++### APT++```+apt-get install libsnappy-dev+```+++# Performance++snappy-c stays true to the speedy spirit of Snappy compression.++The package includes a benchmark suite that compares the compression,+decompression, and roundtrip performance of this package against+- a [pre-existing (unmaintained) Snappy+ implementation](https://hackage.haskell.org/package/snappy), and+- the [zlib package's](https://hackage.haskell.org/package/zlib) zlib and gzip+ compression format implementations.++Run the benchmarks with:+```+cabal run bench-snappy-c -- --time-limit 5 -o bench.html+```++> [!IMPORTANT]+> To build the benchmarks, you will need to set `extra-include-dirs` and+> `extra-lib-dirs` for the `snappy` package as you did for `snappy-c` (see+> [Usage](#usage)).++Here's a screenshot from the generated bench.html file:++++## `snappy-cli` performance++<!-- Compressing and decompressing the the [enwik9 test+data](https://mattmahoney.net/dc/textdata.html) (~953MB) 5 times in a minimally+controlled yet consistent environment resulted in the following average times:++| Tool | Compress time (s) | Decompress time (s) |+| ------------ | ----------------- | -------------------- |+| `snappy-cli` | 2.074 | 0.61 |+| `snzip` | 2.312 | 1.07 |+| `gzip` | 26.51 | 1.38 | -->++See+[snappy-cli/README.md](https://github.com/well-typed/snappy-c/tree/main/snappy-cli)+for a demonstration of the performance of this library in a CLI tool.++<!-- Links -->+[snappy]: https://github.com/google/snappy
+ bench/Main.hs view
@@ -0,0 +1,102 @@+module Main where++import Codec.Compression.SnappyC.Framed qualified as SnappyC+import Codec.Compression.Snappy.BSL qualified as SnappyLazy++import Codec.Compression.Zlib qualified as Zlib+import Codec.Compression.GZip qualified as GZip++import Control.DeepSeq+import Control.Monad+import Criterion.Main+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.ByteString.Lazy qualified as BS.Lazy+import System.Random+import Control.Exception+import Data.Word++benchmarkMBs :: Int+benchmarkMBs = 2++main :: IO ()+main = do+ benchRandom <- benchmarkOn "random" [randomMBs benchmarkMBs ]+ benchZero <- benchmarkOn "zeros" [return $ zeroMBs benchmarkMBs ]+ benchWord <- benchmarkOn "words" [return $ wordMBs benchmarkMBs ]+ benchInterleavedWord <- benchmarkOn "interleaved_words" [interleavedWordMBs benchmarkMBs]+ benchCombined <-+ benchmarkOn "combined"+ [ randomMBs benchmarkMBs+ , return $ zeroMBs benchmarkMBs+ , return $ wordMBs benchmarkMBs+ , interleavedWordMBs benchmarkMBs+ ]+ defaultMain+ [ benchRandom+ , benchZero+ , benchWord+ , benchInterleavedWord+ , benchCombined+ ]++benchmarkOn :: String -> [IO Lazy.ByteString] -> IO Benchmark+benchmarkOn label genInputs = do+ inps <- evaluate . force =<< sequence genInputs+ compressed_snappy <- evaluate . force $ map SnappyC.compress inps+ compressed_zlib <- evaluate . force $ map Zlib.compress inps+ compressed_gzip <- evaluate . force $ map GZip.compress inps+ return $+ bgroup label+ [ bgroup "compression"+ [ bench "snappy-c" $ nf (map SnappyC.compress ) inps+ , bench "snappy-lazy" $ nf (map SnappyLazy.compress) inps+ , bench "zlib" $ nf (map Zlib.compress ) inps+ , bench "gzip" $ nf (map GZip.compress ) inps+ ]+ , bgroup "decompression"+ [ bench "snappy-c" $ nf (map SnappyC.decompress ) compressed_snappy+ , bench "snappy-lazy" $ nf (map SnappyLazy.decompress) compressed_snappy+ , bench "zlib" $ nf (map Zlib.decompress ) compressed_zlib+ , bench "gzip" $ nf (map GZip.decompress ) compressed_gzip+ ]+ , bgroup "roundtrip"+ [ bench "snappy-c" $ nf (map $ SnappyC.decompress . SnappyC.compress ) inps+ , bench "snappy-lazy" $ nf (map $ SnappyLazy.decompress . SnappyLazy.compress) inps+ , bench "zlib" $ nf (map $ Zlib.decompress . Zlib.compress ) inps+ , bench "gzip" $ nf (map $ GZip.decompress . GZip.compress ) inps+ ]+ ]++randomMBs :: Int -> IO Lazy.ByteString+randomMBs n =+ BS.Lazy.pack <$> replicateM (n * mb) randomByte+ where+ randomByte :: IO Word8+ randomByte = randomIO++zeroMBs :: Int -> Lazy.ByteString+zeroMBs n = BS.Lazy.pack $ replicate (n * mb) 0++wordMBs :: Int -> Lazy.ByteString+wordMBs n =+ BS.Lazy.pack+ . concat+ $ replicate (n * mb `div` 8) repeatedWord++interleavedWordMBs :: Int -> IO Lazy.ByteString+interleavedWordMBs n =+ BS.Lazy.pack+ . concat+ <$> replicateM (n * mb `div` (8 * 2)) ((repeatedWord ++) <$> randomBytes)+ where+ randomBytes :: IO [Word8]+ randomBytes = replicateM 8 randomIO++repeatedWord :: [Word8]+repeatedWord = [0 .. 7]++mb :: Int+mb = 1024 * kb++kb :: Int+kb = 1024
+ snappy-c.cabal view
@@ -0,0 +1,151 @@+cabal-version: 3.0+name: snappy-c+version: 0.1.0+synopsis: Bindings to Google's Snappy: A fast compression library+description: [Snappy](https://github.com/google/snappy) is a fast+ (de)compression library. It is written in C++, but a basic+ set of C bindings is also provided. Although the C bindings+ only support the "raw" Snappy format, this package provides+ support for the Snappy "frame" format on top of the raw C+ API, enabling extremely fast (de)compression of lazy+ (streamed) data.+license: BSD-3-Clause+license-file: LICENSE+author: Finley McIlwaine, Edsko de Vries+maintainer: finley@well-typed.com+category: Codec+build-type: Simple+extra-source-files: README.md+extra-doc-files: CHANGELOG.md+tested-with: GHC==9.2.8+ , GHC==9.4.8+ , GHC==9.6.4+ , GHC==9.8.1++source-repository head+ type: git+ location: https://github.com/well-typed/snappy-c++common lang+ ghc-options:+ -Wall+ -Wunused-packages+ -Wprepositive-qualified-module+ -Widentities+ build-depends:+ base >= 4.16 && < 4.20+ default-language:+ Haskell2010+ default-extensions:+ BangPatterns+ DataKinds+ DeriveAnyClass+ DeriveFunctor+ DerivingStrategies+ DerivingVia+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ NumericUnderscores+ OverloadedStrings+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeFamilies++library+ import:+ lang+ hs-source-dirs:+ src+ exposed-modules:+ Codec.Compression.SnappyC.Raw+ Codec.Compression.SnappyC.Framed+ other-modules:+ Codec.Compression.SnappyC.Internal.Buffer+ Codec.Compression.SnappyC.Internal.C+ Codec.Compression.SnappyC.Internal.Checksum+ Codec.Compression.SnappyC.Internal.FrameFormat+ Codec.Compression.SnappyC.Internal.Util+ build-depends:+ , bytestring >= 0.11 && < 0.13+ , data-default >= 0.7 && < 0.8+ , digest >= 0.0.2 && < 0.0.3+ , mtl >= 2.2.2 && < 2.4+ extra-libraries:+ , snappy++executable snappy-cli+ import:+ lang+ hs-source-dirs:+ snappy-cli+ main-is:+ Main.hs+ build-depends:+ snappy-c++ , bytestring >= 0.11 && < 0.13+ , conduit >= 1.3.5 && < 1.4+ , data-default >= 0.7 && < 0.8+ , optparse-applicative >= 0.18 && < 0.19+ ghc-options:+ -threaded+ -rtsopts++-- TODO bounds here+test-suite test-snappy-c+ import:+ lang+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test+ main-is:+ Main.hs+ other-modules:+ , Test.Prop.Orphans+ , Test.Prop.RoundTrip+ build-depends:+ -- Internal dependencies+ , snappy-c+ build-depends:+ -- External dependencies+ , bytestring >= 0.11 && < 0.13+ , tasty >= 1.5 && < 1.6+ , tasty-hunit >= 0.10 && < 0.11+ , tasty-quickcheck >= 0.10 && < 0.11+ ghc-options:+ -threaded+ -rtsopts++benchmark bench-snappy-c+ import:+ lang+ type:+ exitcode-stdio-1.0+ main-is:+ bench/Main.hs+ build-depends:+ -- internal+ , snappy-c++ -- external+ , bytestring >= 0.11 && < 0.13+ , criterion >= 1.6.3 && < 1.7+ , deepseq >= 1.4 && < 1.6+ , random >= 1.2.1 && < 1.3+ , snappy-lazy >= 0.1 && < 0.2+ , zlib >= 0.6.3 && < 0.8++ ghc-options:+ -threaded+ -rtsopts
+ snappy-cli/Main.hs view
@@ -0,0 +1,174 @@+-- | Demo CLI application that uses the snappy-c incremental API with conduits+-- to compress and decompress command line input.++module Main where++import Codec.Compression.SnappyC.Framed qualified as Framed++import Conduit+import Control.Exception+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.Default+import Options.Applicative++main :: IO ()+main =+ execParser opts >>= runSnappyCLI+ where+ opts :: ParserInfo SnappyCommand+ opts =+ info+ ( snappyCommandP <**> helper )+ ( header "snappy-cli - Snappy (de)compression on the command line"+ )++runSnappyCLI :: SnappyCommand -> IO ()+runSnappyCLI SnappyCommand{..} = do+ if useConduit then+ goConduit+ else+ go+ where+ go :: IO ()+ go = do+ inp <- BS.Lazy.readFile input+ let f = case mode of+ Compress ->+ Framed.compress+ Decompress ->+ Framed.decompressWithParams+ def { Framed.verifyChecksum = verify }+ RoundTrip ->+ Framed.decompressWithParams+ def { Framed.verifyChecksum = verify }+ . Framed.compress+ BS.Lazy.writeFile output (f inp)++ goConduit :: IO ()+ goConduit =+ runConduitRes $+ sourceFileBS input+ .| case mode of+ Compress -> compressorC+ Decompress -> decompressorC verify+ RoundTrip -> compressorC .| decompressorC verify+ .| sinkFileBS output++data SnappyCommand =+ SnappyCommand+ { mode :: Mode+ , verify :: Bool+ , input :: FilePath+ , output :: FilePath+ , useConduit :: Bool+ }++data Mode = Compress | Decompress | RoundTrip++snappyCommandP :: Parser SnappyCommand+snappyCommandP =+ SnappyCommand+ <$> modeP+ <*> switch+ ( long "verify"+ <> help "Verify chucksums during decompression"+ )+ <*> inputP+ <*> outputP+ <*> switch+ ( long "conduit"+ <> help "Use the conduit (de)compressor"+ )++modeP :: Parser Mode+modeP =+ flag Compress Decompress+ ( long "decompress"+ <> short 'd'+ <> help "Decompress the input"+ )+ <|>+ flag' RoundTrip+ ( long "roundtrip"+ <> short 'r'+ <> help "Compress then decompress the input"+ <> internal+ )++inputP :: Parser FilePath+inputP =+ option str+ ( short 'i'+ <> long "input"+ <> metavar "FILE"+ <> help "Take input from FILE"+ )++outputP :: Parser FilePath+outputP =+ option str+ ( short 'o'+ <> long "output"+ <> metavar "FILE"+ <> help "Output to FILE"+ )++-------------------------------------------------------------------------------+-- Conduits+-------------------------------------------------------------------------------++-- | Compressor conduit+compressorC :: forall m.+ Monad m+ => ConduitT+ Strict.ByteString+ Strict.ByteString+ m+ ()+compressorC =+ yield streamId >> go initialEncoder+ where+ (streamId, initialEncoder) = Framed.initializeEncoder++ go :: Framed.Encoder -> ConduitT Strict.ByteString Strict.ByteString m ()+ go encoder = do+ mChunk <- await+ case mChunk of+ Just chunk -> do+ let !(compressed, encoder') = Framed.compressStep def encoder chunk+ yieldMany compressed+ go encoder'+ Nothing ->+ yieldMany $ Framed.finalizeEncoder def encoder++-- | Decompressor conduit+decompressorC :: forall m.+ MonadIO m+ => Bool+ -> ConduitT+ Strict.ByteString+ Strict.ByteString+ m+ ()+decompressorC v =+ go initialDecoder+ where+ initialDecoder = Framed.initializeDecoder++ go :: Framed.Decoder -> ConduitT Strict.ByteString Strict.ByteString m ()+ go decoder = do+ mChunk <- await+ case mChunk of+ Just chunk -> do+ let (decompressed, decoder') =+ Framed.decompressStep+ def {Framed.verifyChecksum = v}+ decoder+ chunk+ yieldMany decompressed+ go decoder'+ Nothing ->+ case Framed.finalizeDecoder decoder of+ Right () -> return ()+ Left failure -> liftIO $ throwIO failure
+ src/Codec/Compression/SnappyC/Framed.hs view
@@ -0,0 +1,253 @@+-- |+-- Module : Codec.Compression.SnappyC.Framed+-- Copyright : (c) 2024 Finley McIlwaine+-- License : BSD-3-Clause (see LICENSE)+--+-- Maintainer : Finley McIlwaine <finley@well-typed.com>+--+-- Frame format Snappy compression/decompression.+-- See the framing format description here:+-- <https://github.com/google/snappy/blob/main/framing_format.txt>+--+-- Intended for qualified import:+--+-- > import Codec.Compression.SnappyC.Framed qualified as Snappy++module Codec.Compression.SnappyC.Framed+ ( -- * Compression+ compress++ -- ** Compression with custom parameters+ , EncodeParams(..)+ , FrameSize -- Opaque+ , Threshold(..)+ , compressWithParams+ , defaultFrameSize+ , customFrameSize+ , unFrameSize++ -- * Decompression+ , DecodeFailure(..)+ , decompress+ , decompress'++ -- ** Decompression with custom parameters+ , DecodeParams(..)+ , decompressWithParams+ , decompressWithParams'++ -- * Low-level incremental API+ -- ** Compression+ , Encoder -- Opaque+ , initializeEncoder+ , finalizeEncoder+ , compressStep++ -- ** Decompression+ , Decoder -- Opaque+ , initializeDecoder+ , finalizeDecoder+ , decompressStep+ , decompressStep'+ ) where++import Codec.Compression.SnappyC.Internal.Buffer qualified as Buffer+import Codec.Compression.SnappyC.Internal.FrameFormat+import Codec.Compression.SnappyC.Internal.Util++import Data.ByteString.Internal qualified as Strict (ByteString)+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.Default+import GHC.Stack++-------------------------------------------------------------------------------+-- Compression+-------------------------------------------------------------------------------++-- | Compress the input using [Snappy](https://github.com/google/snappy/).+--+-- The output stream is in Snappy frame format.+compress :: BS.Lazy.ByteString -> BS.Lazy.ByteString+compress = compressWithParams def++-- | Compress the input using [Snappy](https://github.com/google/snappy/) with+-- the given 'EncodeParams'.+--+-- The output stream is in Snappy frame format.+compressWithParams :: EncodeParams -> Lazy.ByteString -> Lazy.ByteString+compressWithParams ps =+ BS.Lazy.fromChunks+ . (streamId :)+ . go initialEncoder+ . BS.Lazy.toChunks+ where+ streamId :: Strict.ByteString+ initialEncoder :: Encoder+ (streamId, initialEncoder) = initializeEncoder++ -- Loop invariant: The 'Encoder' has strictly less than 'chunkSize' in it.+ go ::+ Encoder+ -> [Strict.ByteString]+ -> [Strict.ByteString]+ go encoder =+ \case+ [] ->+ finalizeEncoder ps encoder+ (c:cs) ->+ -- The encoded chunks are available to the caller before we process+ -- the rest of the chunks.+ case compressStep ps encoder c of+ (encodedChunks, encoder') ->+ encodedChunks ++ go encoder' cs++-- | Append the data to the 'Encoder' buffer and do as much compression as+-- possible.+--+-- __Postconditions:__+--+-- * The resulting 'Encoder' will not have more data in its buffer than the+-- 'chunkSize' in the 'EncodeParams'.+-- * Each encoded frame will hold /exactly/ one `chunkSize` worth of+-- uncompressed data.+compressStep ::+ EncodeParams+ -> Encoder+ -> Strict.ByteString+ -> ([Strict.ByteString], Encoder)+compressStep ps (Encoder b) bs =+ let+ EncodeResult{..} = encodeBuffered ps (Encoder $ b `Buffer.append` bs)+ in+ (encodeResultEncoded, encodeResultEncoder)+++-------------------------------------------------------------------------------+-- Decompression+-------------------------------------------------------------------------------++-- | Decompress the input using [Snappy](https://github.com/google/snappy/).+--+-- The input stream is expected to be in the official Snappy frame format.+--+-- __Note:__ The extra laziness of this function (compared to `decompress'`)+-- comes at the cost of potential exceptions during decompression.+decompress :: HasCallStack => Lazy.ByteString -> Lazy.ByteString+decompress = decompressWithParams def++-- | Decompress the input using [Snappy](https://github.com/google/snappy/) with+-- the given 'DecodeParams'.+--+-- The input stream is expected to be in the official Snappy frame format.+--+-- __Note:__ The extra laziness of this function (compared to+-- `decompressWithParams'`) comes at the cost of potential exceptions during+-- decompression.+decompressWithParams ::+ HasCallStack+ => DecodeParams+ -> Lazy.ByteString+ -> Lazy.ByteString+decompressWithParams dps =+ BS.Lazy.fromChunks+ . go initializeDecoder+ . BS.Lazy.toChunks+ where+ go ::+ Decoder+ -> [Strict.ByteString]+ -> [Strict.ByteString]+ go decoder =+ \case+ [] ->+ throwLeft (finalizeDecoder decoder) `seq` []+ (c:cs) ->+ let+ (decompressed, decoder') = decompressStep dps decoder c+ in+ decompressed ++ go decoder' cs++-- | Append the data to the 'Decoder' buffer and do as much decompression as+-- possible.+--+-- Throws an exception if any 'DecodeFailure' occurs.+decompressStep ::+ HasCallStack+ => DecodeParams+ -> Decoder+ -> Strict.ByteString+ -> ([Strict.ByteString], Decoder)+decompressStep dps d@Decoder{..} bs =+ let+ DecodeResult{..} =+ throwLeft $+ decodeBuffered+ dps+ d { decoderBuffer = decoderBuffer `Buffer.append` bs }+ in+ ( decodeResultDecoded+ , decodeResultDecoder+ )++-- | Decompress the input using [Snappy](https://github.com/google/snappy/).+--+-- The input stream is expected to be in the official Snappy frame format.+-- Evaluates to a 'DecodeFailure' if the input stream is ill-formed.+--+-- __WARNING:__ This function is not as lazy as you might hope. To determine+-- whether the result is a 'DecodeFailure', it must load the entire source+-- 'Lazy.ByteString' into memory during decompression. Use either+-- 'decompressWithParams' or the incremental `decompressStep'` instead. If you+-- are truly okay with the extra memory overhead, you may ignore this warning.+{-# DEPRECATED decompress' "Consider using decompress or decompressStep' instead" #-}+decompress' :: Lazy.ByteString -> Either DecodeFailure Lazy.ByteString+decompress' = decompressWithParams' def++-- | Decompress the input using [Snappy](https://github.com/google/snappy/) with+-- the given 'DecodeParams'.+--+-- The input stream is expected to be in the official Snappy frame format.+-- Evaluates to a 'DecodeFailure' if the input stream is ill-formed.+--+-- __WARNING:__ This function is not as lazy as you might hope. To determine+-- whether the result is a 'DecodeFailure', it must load the entire source+-- 'Lazy.ByteString' into memory during decompression. Use either+-- 'decompressWithParams' or the incremental `decompressStep'` instead. If you+-- are truly okay with the extra memory overhead, you may ignore this warning.+{-# DEPRECATED decompressWithParams' "Consider using decompressWithParams or decompressStep' instead" #-}+decompressWithParams' ::+ DecodeParams+ -> Lazy.ByteString+ -> Either DecodeFailure Lazy.ByteString+decompressWithParams' dps compressed = do+ decompressedChunks <- go initializeDecoder $ BS.Lazy.toChunks compressed+ return $ BS.Lazy.fromChunks decompressedChunks+ where+ go ::+ Decoder+ -> [Strict.ByteString]+ -> Either DecodeFailure [Strict.ByteString]+ go decoder =+ \case+ [] -> do+ finalizeDecoder decoder+ return []+ (c:cs) -> do+ (decompressed, decompressor') <- decompressStep' dps decoder c+ (decompressed ++) <$> go decompressor' cs++-- | Append the data to the 'Decoder' buffer and do as much decompression as+-- possible.+--+-- __Note:__ This function is not as lazy as 'decompressStep', since it must+-- completely decode the given chunk before providing a result.+decompressStep' ::+ DecodeParams+ -> Decoder+ -> Strict.ByteString+ -> Either DecodeFailure ([Strict.ByteString], Decoder)+decompressStep' dps d@Decoder{..} bs = do+ DecodeResult{..} <-+ decodeBuffered dps d { decoderBuffer = decoderBuffer `Buffer.append` bs }+ return (decodeResultDecoded, decodeResultDecoder)
+ src/Codec/Compression/SnappyC/Internal/Buffer.hs view
@@ -0,0 +1,118 @@+-- | Intended for qualified import:+--+-- > import Codec.Compression.SnappyC.Internal.Buffer (Buffer)+-- > import Codec.Compression.SnappyC.Internal.Buffer qualified as Buffer++module Codec.Compression.SnappyC.Internal.Buffer+ ( -- * 'Buffer' type+ Buffer -- Opaque++ -- ** Introduction+ , empty+ , append++ -- ** Elimination+ , toStrict++ -- ** Length etc.+ , length+ , null++ -- ** Splitting+ , splitExactly+ ) where++import Prelude hiding (length, null)++import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString qualified as BS.Strict+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.ByteString.Lazy qualified as BS.Lazy++-- | Intended for efficiency in the case of a bunch of appends followed by a+-- bunch of splits.+data Buffer =+ Forward+ Lazy.ByteString+ !Int+ | Backward+ [Strict.ByteString]+ !Int+ deriving Show++-- | Empty buffer+empty :: Buffer+empty = Backward [] 0++-- | Is the 'Buffer' empty?+--+-- /O(1)/+null :: Buffer -> Bool+null = (== 0) . length++-- | Length+--+-- /O(1)/+length :: Buffer -> Int+length (Forward _ l) = l+length (Backward _ l) = l++-- | Append data to the end of the 'Buffer'.+--+-- /O(n)/ if the given buffer is forwards, /O(1)/ otherwise.+append :: Buffer -> Strict.ByteString -> Buffer+append b bs =+ let+ !(chunks, l) = backwards b+ in+ Backward (bs : chunks) (l + BS.Strict.length bs)++-- | Get the buffered chunks in backwards order+--+-- /O(n)/ if the given buffer is forwards, /O(1)/ otherwise.+backwards :: Buffer -> ([Strict.ByteString], Int)+backwards (Forward bs l) = (reverse $ BS.Lazy.toChunks bs, l)+backwards (Backward bs l) = (bs, l)++-- | Get the buffer data as a 'Lazy.ByteString' paired with its length.+--+-- /O(n)/ if the buffer is backward, /O(1)/ otherwise.+toLazy :: Buffer -> (Lazy.ByteString, Int)+toLazy (Forward bs l) = (bs, l)+toLazy (Backward bs l) = (BS.Lazy.fromChunks $ reverse bs, l)++-- | Create a 'Buffer' from a 'Lazy.ByteString' paired with its length.+--+-- /O(1)/+fromLazy :: (Lazy.ByteString, Int) -> Buffer+fromLazy (bs, l) = Forward bs l++-- | Split off a chunk of exactly @n@ bytes.+--+-- If there aren't enough bytes, return how many bytes we need.+--+-- /O(1)/ if the length is insufficient, /O(n)/ otherwise.+splitExactly :: Int -> Buffer -> Either Int (Strict.ByteString, Buffer)+splitExactly n b+ | length b < n+ = Left (n - length b)+ | otherwise+ = let+ !(bs, bsLength) = toLazy b+ !(tookBs, rest) = BS.Lazy.splitAt (fromIntegral n) bs+ in+ Right+ ( BS.Lazy.toStrict tookBs+ , fromLazy (rest, bsLength - n)+ )++-- | Get the buffer data as a 'Strict.ByteString'. __Only__ call this function if+-- you are __sure__ the data in the buffer is small.+--+-- /O(n)/+--+-- TODO: We are losing size information here that we could use to our advantage+-- in the conversion, but it's a minor inefficiency.+toStrict :: Buffer -> Strict.ByteString+toStrict (Forward bs _) = BS.Lazy.toStrict bs+toStrict (Backward bs _) = BS.Strict.concat $ reverse bs
+ src/Codec/Compression/SnappyC/Internal/C.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Intended for qualified import:+--+-- > import Codec.Compression.SnappyC.Internal.C qualified as C++module Codec.Compression.SnappyC.Internal.C+ ( -- * Compression+ snappy_compress+ , snappy_max_compressed_length++ -- * Decompression+ , snappy_uncompress+ , snappy_uncompressed_length+ ) where++import Foreign+import Foreign.C++foreign import ccall unsafe "snappy-c.h snappy_compress"+ snappy_compress+ :: CString+ -- ^ Source buffer+ -> CSize+ -- ^ Source buffer size+ -> CString+ -- ^ Target buffer+ -> Ptr CSize+ -- ^ Target buffer size+ -> CInt+ -- ^ Status indicator (0 => Ok, 1 => Invalid input, 2 => Target buffer too small)++foreign import ccall unsafe "snappy-c.h snappy_max_compressed_length"+ snappy_max_compressed_length+ :: CSize+ -- ^ Source buffer size+ -> CSize+ -- ^ Max size after compression++foreign import ccall unsafe "snappy-c.h snappy_uncompress"+ snappy_uncompress+ :: CString+ -- ^ Compressed+ -> CSize+ -- ^ Compressed length+ -> CString+ -- ^ Uncompressed (target) buffer+ -> Ptr CSize+ -- ^ Uncompressed length+ -> CInt+ -- ^ Status indicator (0 => Ok, 1 => Invalid input, 2 => Target buffer too small)++foreign import ccall unsafe "snappy-c.h snappy_uncompressed_length"+ snappy_uncompressed_length+ :: CString+ -- ^ Compressed buffer+ -> CSize+ -- ^ Compressed length+ -> Ptr CSize+ -- ^ Result+ -> CInt+ -- ^ Status indicator (0 => Ok, 1 => Invalid input)
+ src/Codec/Compression/SnappyC/Internal/Checksum.hs view
@@ -0,0 +1,63 @@+-- | Intended for qualified import:+--+-- > import Codec.Compression.SnappyC.Internal.Checksum (Checksum)+-- > import Codec.Compression.SnappyC.Internal.Checksum qualified as Checksum++module Codec.Compression.SnappyC.Internal.Checksum+ ( -- * Type+ Checksum -- Opaque++ -- ** Calculating checksums+ , calculate++ -- ** Encoding and decoding checksums+ , encode+ , decode+ ) where++import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString qualified as BS.Strict++import Data.Bits+import Data.Digest.CRC32C+import Data.Word++-- | Masked CRC32C checksum+newtype Checksum = Checksum { getChecksum :: Word32 }+ deriving newtype (Show, Eq)++-- | Calculate+calculate :: Strict.ByteString -> Checksum+calculate =+ Checksum . maskChecksum . crc32c+ where+ maskChecksum :: Word32 -> Word32+ maskChecksum = (+ 0xa282ead8) . (`rotateR` 15)++-- | Encode+encode :: Checksum -> Strict.ByteString+encode =+ BS.Strict.pack . toLittleEndian . getChecksum+ where+ toLittleEndian :: Word32 -> [Word8]+ toLittleEndian s =+ [ fromIntegral (s .&. 0x000000ff)+ , fromIntegral $ shiftR (s .&. 0x0000ff00) 8+ , fromIntegral $ shiftR (s .&. 0x00ff0000) 16+ , fromIntegral $ shiftR (s .&. 0xff000000) 24+ ]++-- | Decode+--+-- __Precondition:__ Input must be exactly 4 bytes.+decode :: Strict.ByteString -> Checksum+decode =+ Checksum . fromLittleEndian . BS.Strict.unpack+ where+ fromLittleEndian :: [Word8] -> Word32+ fromLittleEndian [b1, b2, b3, b4] =+ fromIntegral b1+ .|. fromIntegral b2 `shiftL` 8+ .|. fromIntegral b3 `shiftL` 16+ .|. fromIntegral b4 `shiftL` 24+ fromLittleEndian _ = error "Checksum.decode: precondition violated"
+ src/Codec/Compression/SnappyC/Internal/FrameFormat.hs view
@@ -0,0 +1,510 @@+-- | Intended for unqualified import:+--+-- > import module Codec.Compression.SnappyC.Internal.FrameFormat++module Codec.Compression.SnappyC.Internal.FrameFormat+ ( -- * The 'Frame' type+ Frame(..)+ , FrameIdentifier(..)++ -- ** Encoding+ , Encoder(..)+ , EncodeParams(..)+ , FrameSize -- Opaque+ , Threshold(..)+ , EncodeState(..)+ , EncodeResult(..)+ , initializeEncoder+ , defaultEncodeParams+ , finalizeEncoder+ , encodeBuffered+ , customFrameSize+ , unFrameSize+ , defaultFrameSize++ -- ** Decoding+ , Decoder(..)+ , DecodeParams(..)+ , DecodeState(..)+ , DecodeResult(..)+ , DecodeFailure(..)+ , initializeDecoder+ , defaultDecodeParams+ , finalizeDecoder+ , decodeBuffered+ ) where++import Codec.Compression.SnappyC.Internal.Buffer (Buffer)+import Codec.Compression.SnappyC.Internal.Buffer qualified as Buffer+import Codec.Compression.SnappyC.Internal.Checksum (Checksum)+import Codec.Compression.SnappyC.Internal.Checksum qualified as Checksum+import Codec.Compression.SnappyC.Raw qualified as Raw++import Control.Exception+import Control.Monad.Error.Class+import Data.Bits+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString qualified as BS.Strict+import Data.Default+import Data.Word+import Text.Printf+import Control.Monad++-- | Snappy frames consist of a header and a payload.+data Frame =+ Frame+ { frameHeader :: !FrameHeader+ , framePayload :: !Strict.ByteString+ }+ deriving Show++-- | A frame's header contains an identifier corresponding to the frame type and+-- the size of the payload.+data FrameHeader =+ FrameHeader+ { frameHeaderIdentifier :: !FrameIdentifier+ , frameHeaderPayloadSize :: !Int+ }+ deriving (Show, Eq)++-- | Snappy frame identifiers.+data FrameIdentifier =+ StreamId+ | Compressed+ | Uncompressed+ | Padding+ | ReservedUnskippable Word8+ | ReservedSkippable Word8+ deriving (Show, Eq)++-- | The one byte value corresponding to an identifier.+encodeFrameIdentifier :: FrameIdentifier -> Word8+encodeFrameIdentifier StreamId = 0xff+encodeFrameIdentifier Compressed = 0x00+encodeFrameIdentifier Uncompressed = 0x01+encodeFrameIdentifier Padding = 0xfd+encodeFrameIdentifier (ReservedUnskippable fid) = fid+encodeFrameIdentifier (ReservedSkippable fid) = fid++-- | Encode an 'Int' as a three byte little-endian value.+encodeFrameHeader :: FrameHeader -> Strict.ByteString+encodeFrameHeader (FrameHeader ident size)=+ BS.Strict.pack+ [ encodeFrameIdentifier ident+ , fromIntegral (w32Size .&. 0x000000ff)+ , fromIntegral $ (w32Size .&. 0x0000ff00) `shiftR` 8+ , fromIntegral $ (w32Size .&. 0x00ff0000) `shiftR` 16+ ]+ where+ w32Size :: Word32+ w32Size = fromIntegral size++-------------------------------------------------------------------------------+-- Encoding Snappy frames+-------------------------------------------------------------------------------++-- | Buffers uncompressed data for compression.+newtype Encoder = Encoder { encoderBuffer :: Buffer }+ deriving Show++-- | Determines how much data is put in each Snappy frame and whether it is+-- compressed.+data EncodeParams =+ EncodeParams+ { -- | Exact amount of uncompressed data included in a single frame.+ frameSize :: !FrameSize++ -- | Compression threshold.+ , threshold :: !Threshold+ }+ deriving (Show, Eq)++instance Default EncodeParams where+ def :: EncodeParams+ def = defaultEncodeParams++defaultEncodeParams :: EncodeParams+defaultEncodeParams = EncodeParams def def++-- | Number of bytes of uncompressed data.+newtype FrameSize = FrameSize Int+ deriving (Show, Eq)++instance Default FrameSize where+ def :: FrameSize+ def = defaultFrameSize++-- | The default frame size is 65536 bytes, which is the maximum allowed by the+-- [Snappy framing format+-- description](https://github.com/google/snappy/blob/main/framing_format.txt).+defaultFrameSize :: FrameSize+defaultFrameSize = FrameSize snappySpecMaxChunkBytes++-- | See section 4.2 of the [Snappy framing format+-- description](https://github.com/google/snappy/blob/main/framing_format.txt).+snappySpecMaxChunkBytes :: Int+snappySpecMaxChunkBytes = 65536++-- | Create a 'FrameSize'.+--+-- Must be within the inclusive range [ 1 .. 65536 ].+customFrameSize :: Int -> FrameSize+customFrameSize n+ | n >= 1 && n <= snappySpecMaxChunkBytes+ = FrameSize n+ | otherwise+ = error "customFrameSize: invalid frame size"++-- | Unwrap a 'FrameSize'+unFrameSize :: FrameSize -> Int+unFrameSize (FrameSize n) = n++-- | Compression threshold, with explicit 'AlwaysCompress' and 'NeverCompress'+-- settings.+data Threshold =+ -- | Compress everything+ AlwaysCompress++ -- | Compress nothing+ | NeverCompress++ -- | Uncompressed size divided by compressed size.+ --+ -- Only produce compressed frames if the compression ratio for the data is+ -- equal to or above this threshold.+ --+ -- A higher threshold may result in less frames holding compressed data,+ -- and thus faster decompression/decoding.+ --+ -- [According to+ -- Google](https://github.com/google/snappy?tab=readme-ov-file#performance),+ -- the typical highest compression ratio that Snappy achieves is about 4,+ -- so a 'Ratio' of > 4.0 should be similar to 'NeverCompress', while a+ -- 'Ratio' of < 7/8 should be similar to 'AlwaysCompress'.+ | Ratio !Double+ deriving (Show, Eq)++instance Default Threshold where+ def :: Threshold+ def = defaultThreshold++-- | The default threshold is a ratio of 8:7, which was taken from the+-- [golang/snappy+-- implementation](https://github.com/golang/snappy/blob/43d5d4cd4e0e3390b0b645d5c3ef1187642403d8/encode.go#L231).+defaultThreshold :: Threshold+defaultThreshold = Ratio (1 / 0.875)++-- | Determines how much uncompressed data is stored in each resulting frame.+newtype EncodeState =+ EncodeState { encodeStateMaxChunkBytes :: Int }+ deriving Show++-- | A pair of frame-encoded chunks and an updated 'Encoder'.+data EncodeResult =+ EncodeResult+ { encodeResultEncoded :: [Strict.ByteString]+ , encodeResultEncoder :: !Encoder+ }+ deriving Show++-- | Initialize an 'Encoder' with the given maximum number of bytes of+-- uncompressed data to include in frames resulting from the 'Encoder'. If the+-- given number of bytes is not in the inclusive range [1 .. 65536], 65536 is+-- used.+--+-- The 'Strict.ByteString' holds the Snappy stream identifier frame that must be+-- included at the start of every Snappy frame encoded stream.+initializeEncoder :: (Strict.ByteString, Encoder)+initializeEncoder =+ ( "\xff\x06\x00\00sNaPpY"+ , Encoder+ { encoderBuffer = Buffer.empty+ }+ )++-- | Call to indicate no more input and flush the remaining data in the+-- 'Encoder' into a new frame.+--+-- If there is no more data in the 'Encoder', an empty list is returned.+--+-- * __Precondition:__ The buffer does not hold more data than the 'frameSize'+-- in the 'EncodeParams'. Use the postcondition of 'encodeBuffered' to ensure+-- this.+finalizeEncoder :: EncodeParams -> Encoder -> [Strict.ByteString]+finalizeEncoder ep (Encoder b)+ | Buffer.null b+ = []+ | otherwise+ = encodeChunk ep (Buffer.toStrict b)++-- | Fill and compress/encode as many frames as possible with the data in the+-- 'Encoder'.+--+-- /O(1)/ if there are not enough bytes in the buffer to fill a frame.+--+-- * __Postcondition:__ The resulting buffer never holds more than the+-- 'frameSize' given in the 'EncodeParams'.+encodeBuffered :: EncodeParams -> Encoder -> EncodeResult+encodeBuffered ep@EncodeParams{..} = \(Encoder b) ->+ go [] b+ where+ go :: [Strict.ByteString] -> Buffer -> EncodeResult+ go acc b =+ case Buffer.splitExactly (unFrameSize frameSize) b of+ Right (chunk, b') ->+ go (reverse (encodeChunk ep chunk) ++ acc) b'+ Left _ ->+ EncodeResult+ (reverse acc)+ (Encoder b)++-- | Encode the input as a potentially compressed Snappy frame.+--+-- This function takes a 'Strict.ByteString' because it must pass all of the+-- data to a C function which expects the data to sit in a single buffer.+encodeChunk ::+ EncodeParams+ -> Strict.ByteString+ -> [Strict.ByteString]+encodeChunk EncodeParams{..} uncompressed =+ [ encodeFrameHeader+ (FrameHeader frameId (BS.Strict.length payloadData + 4))+ , Checksum.encode maskedChecksum+ , payloadData+ ]+ where+ maskedChecksum :: Checksum+ maskedChecksum = Checksum.calculate uncompressed++ compressed :: Strict.ByteString+ compressed = Raw.compress uncompressed++ compressionRatio :: Double+ compressionRatio =+ (/) @Double+ (fromIntegral $ BS.Strict.length uncompressed)+ (fromIntegral $ BS.Strict.length compressed)++ (frameId, payloadData) =+ if doCompress then+ (Compressed, compressed)+ else+ (Uncompressed, uncompressed)++ doCompress =+ case threshold of+ AlwaysCompress -> True+ NeverCompress -> False+ Ratio ratio -> compressionRatio >= ratio++-------------------------------------------------------------------------------+-- Decoding Snappy frames+-------------------------------------------------------------------------------++-- | Buffers compressed data for decompression and holds some useful+-- decompression state.+data Decoder =+ Decoder+ { -- | Accumulated Snappy framed data.+ --+ -- * __Invariant:__ This buffer never holds a fully decodable Snappy+ -- frame.+ decoderBuffer :: !Buffer++ -- | Tracks partial information about the buffer, e.g. whether we have+ -- decoded a header and how many bytes we need to fully decode a frame.+ , decoderState :: !DecodeState+ }+ deriving Show++-- | Have we decoded a header for the current frame yet?+--+-- If so, what was that header?+data DecodeState =+ Initial+ | KnownHeader !FrameHeader+ deriving (Show, Eq)++-- | Pair of decompressed data chunks and an updated 'Decoder'.+data DecodeResult =+ DecodeResult+ { decodeResultDecoded :: [Strict.ByteString]+ , decodeResultDecoder :: !Decoder+ }+ deriving Show+++-- | Decode parameters+data DecodeParams =+ DecodeParams+ { -- | Verify the uncompressed data checksums during decompression+ --+ -- Defaults to 'False'. Even if we don't verify the CRC, if the data+ -- is not Snappy compressed then decompression will likely still fail+ -- due to failing to decode the frame headers.+ --+ -- To enable this, use the incremental API+ -- ('Codec.Compression.SnappyC.Framed.decompressStep'). Note that+ -- checksum verification adds a significant overhead to decompression.+ verifyChecksum :: !Bool+ }+ deriving (Show, Eq)++instance Default DecodeParams where+ def :: DecodeParams+ def = defaultDecodeParams++-- | Default decode parameters+defaultDecodeParams :: DecodeParams+defaultDecodeParams = DecodeParams False++-- | Possible failure modes for decompression.+data DecodeFailure =+ DecompressionError Strict.ByteString+ | ReservedUnskippableFrameId Word8+ | BadStreamId Strict.ByteString+ | BadChecksum+ Strict.ByteString -- ^ Data+ Checksum -- ^ Received+ Checksum -- ^ Computed+ | NotDone+ deriving Show+ deriving anyclass Exception++-- | The empty 'Decoder', in an initial state.+initializeDecoder :: Decoder+initializeDecoder =+ Decoder+ { decoderBuffer = Buffer.empty+ , decoderState = Initial+ }++-- | Verify that the 'Decoder' is complete.+--+-- If the 'Decoder'\'s buffer still has data in it, 'NotDone' is returned.+finalizeDecoder :: Decoder -> Either DecodeFailure ()+finalizeDecoder Decoder{..}+ | decoderState /= Initial || not (Buffer.null decoderBuffer)+ = throwError NotDone+ | otherwise+ = return ()++-- | Decompress/decode as many frames as possible with the data in the+-- 'Decoder'.+--+-- This is not as lazy as it could be. If we had a version of 'decodeFrame' that+-- threw exceptions on failure, we could be a bit more lazy. It's not clear to+-- me if this would actually be good for performance.+--+-- /O(1)/ if there are insufficient bytes in the buffer.+decodeBuffered :: DecodeParams -> Decoder -> Either DecodeFailure DecodeResult+decodeBuffered dps =+ go []+ where+ go :: [Strict.ByteString] -> Decoder -> Either DecodeFailure DecodeResult+ go acc (Decoder b state@Initial) =+ case Buffer.splitExactly 4 b of+ Right (headerBs, rest) -> do+ header <- decodeHeader headerBs+ go acc (Decoder rest (KnownHeader header))+ Left _ ->+ return $ DecodeResult (reverse acc) $ Decoder b state+ go acc (Decoder b state@(KnownHeader header)) =+ case Buffer.splitExactly (frameHeaderPayloadSize header) b of+ Right (payloadBs, rest) -> do+ uncompressed <- decodeFrame dps header payloadBs+ go (maybe acc (: acc) uncompressed) (Decoder rest Initial)+ Left _ ->+ return $ DecodeResult (reverse acc) $ Decoder b state+++-- | Decode header+--+-- __Precondition:__ The given 'Strict.ByteString' must be exactly 4 bytes+-- long.+decodeHeader :: Strict.ByteString -> Either DecodeFailure FrameHeader+decodeHeader bs =+ case BS.Strict.unpack bs of+ [bid, b1, b2, b3] ->+ let+ payloadLen = lEWord24BytesToInt (b1, b2, b3)+ in+ case bid of+ 0xff -> return $ FrameHeader StreamId payloadLen+ 0xfd -> return $ FrameHeader Padding payloadLen+ 0x00 -> return $ FrameHeader Compressed payloadLen+ 0x01 -> return $ FrameHeader Uncompressed payloadLen+ fid+ | fid `elem` [ 0x02 .. 0x7f ] ->+ return $ FrameHeader (ReservedUnskippable fid) payloadLen+ | fid `elem` [ 0x80 .. 0xfd ] ->+ return $ FrameHeader (ReservedSkippable fid) payloadLen+ | otherwise ->+ error $+ printf+ ( "FrameFormat.decodeHeader: " +++ "impossible frame identifier 0x%x"+ )+ fid+ _ ->+ error "FrameFormat.decodeHeader: precondition violated"+ where+ lEWord24BytesToInt :: (Word8, Word8, Word8) -> Int+ lEWord24BytesToInt (lsb, mid, msb) =+ fromIntegral msb `shiftL` 16+ .|. fromIntegral mid `shiftL` 8+ .|. fromIntegral lsb++-- | Decode a frame+--+-- __Precondition:__ The given 'Strict.ByteString' is the payload associated+-- with the given 'FrameHeader'.+decodeFrame ::+ DecodeParams+ -> FrameHeader+ -> Strict.ByteString+ -> Either DecodeFailure (Maybe Strict.ByteString)+decodeFrame dps header bs =+ case frameHeaderIdentifier header of+ StreamId ->+ if bs == "sNaPpY" then+ return Nothing+ else+ throwError $ BadStreamId bs+ Compressed -> do+ let !(checksumBs, rest) = BS.Strict.splitAt 4 bs+ uncompressed <-+ case Raw.decompress rest of+ Nothing -> throwError $ DecompressionError rest+ Just decompressed -> return decompressed+ Just <$> verifyPayload dps checksumBs uncompressed+ Uncompressed -> do+ let !(checksumBs, uncompressed) = BS.Strict.splitAt 4 bs+ Just <$> verifyPayload dps checksumBs uncompressed+ Padding ->+ return Nothing+ ReservedUnskippable fid ->+ -- An unskippable reserved frame is one that has an important payload,+ -- but we don't know what it is so we can't decode it.+ throwError $ ReservedUnskippableFrameId fid+ ReservedSkippable _ ->+ return Nothing++-- | If checksum verification is enabled, compute the checksum and compare+-- against the decoded checksum.+verifyPayload ::+ DecodeParams+ -> Strict.ByteString+ -- ^ Encoded little-endian checksum+ -> Strict.ByteString+ -- ^ Uncompressed payload+ -> Either DecodeFailure Strict.ByteString+verifyPayload dps checksumBs uncompressed = do+ when (verifyChecksum dps) $ do+ let+ decodedChecksum = Checksum.decode checksumBs+ computedChecksum = Checksum.calculate uncompressed+ when (computedChecksum /= decodedChecksum) $+ throwError $+ BadChecksum uncompressed decodedChecksum computedChecksum+ return uncompressed
+ src/Codec/Compression/SnappyC/Internal/Util.hs view
@@ -0,0 +1,15 @@+-- | Intended for unqualified import:+--+-- > import Codec.Compression.SnappyC.Internal.Util++module Codec.Compression.SnappyC.Internal.Util+ ( -- * Exceptions+ throwLeft+ ) where++import Control.Exception++-- | If a 'Left' is given, throw the contained value as an exception.+throwLeft :: Exception e => Either e a -> a+throwLeft (Left err) = throw err+throwLeft (Right x) = x
+ src/Codec/Compression/SnappyC/Raw.hs view
@@ -0,0 +1,100 @@+-- |+-- Module : Codec.Compression.SnappyC.Raw+-- Copyright : (c) 2024 Finley McIlwaine+-- License : BSD-3-Clause (see LICENSE)+--+-- Maintainer : Finley McIlwaine <finley@well-typed.com>+--+-- Raw format Snappy compression/decompression.+--+-- > import Codec.Compression.SnappyC.Raw qualified as Snappy++module Codec.Compression.SnappyC.Raw+ ( -- * Compression+ compress+ -- * Decompression+ , decompress+ ) where++import Codec.Compression.SnappyC.Internal.C qualified as C++import Data.ByteString.Internal (ByteString(..))+import Foreign+import System.IO.Unsafe++-- | Compress the input using [Snappy](https://github.com/google/snappy/).+--+-- The result is in Snappy raw format, /not/ the framing format.+compress :: ByteString -> ByteString+compress (BS sfp slen) =+ unsafePerformIO $ do+ let dlen = C.snappy_max_compressed_length (fromIntegral slen)+ dfp <- mallocForeignPtrBytes (fromIntegral dlen)+ withForeignPtr sfp $ \sptr ->+ withForeignPtr dfp $ \dptr ->+ with dlen $ \dlen_ptr ->+ case+ C.snappy_compress+ (castPtr sptr)+ (fromIntegral slen)+ (castPtr dptr)+ dlen_ptr+ of+ 0 ->+ BS dfp . fromIntegral <$> peek dlen_ptr+ 1 ->+ error "impossible: there is no invalid input for compression"+ 2 ->+ error "impossible: the buffer size is always set correctly"+ status ->+ error $+ "impossible: unexpected status from snappy_compress: " +++ show status++-- | Decompress the input using [Snappy](https://github.com/google/snappy/).+--+-- Returns 'Nothing' if the input is not in Snappy raw format or+-- otherwise ill-formed.+decompress :: ByteString -> Maybe ByteString+decompress (BS sfp slen) =+ unsafePerformIO $ do+ withForeignPtr sfp $+ \sptr ->+ alloca $+ \dlen_ptr ->+ case+ C.snappy_uncompressed_length+ (castPtr sptr)+ (fromIntegral slen)+ dlen_ptr+ of+ 0 -> do+ dlen <- fromIntegral <$> peek dlen_ptr+ dfp <- mallocForeignPtrBytes dlen+ withForeignPtr dfp $+ \dptr ->+ case+ C.snappy_uncompress+ (castPtr sptr)+ (fromIntegral slen)+ (castPtr dptr)+ dlen_ptr+ of+ 0 ->+ Just . BS dfp . fromIntegral <$> peek dlen_ptr+ 1 ->+ -- Invalid input. Successful result from+ -- snappy_uncompressed_length does *not* mean the+ -- input is completely valid+ return Nothing+ status ->+ error $+ "impossible: decompression failed with status " +++ show status+ 1 ->+ return Nothing+ status ->+ error $+ "impossible: snappy_uncompressed_length failed with " +++ "status" ++ show status+
+ test/Main.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}++module Main where++import Test.Prop.RoundTrip qualified as RoundTrip++import Codec.Compression.SnappyC.Raw qualified as Raw+import Codec.Compression.SnappyC.Framed qualified as Framed++import Data.ByteString.Lazy qualified as BS.Lazy+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main =+ defaultMain $+ testGroup "Test.SnappyC"+ [ -- Round trip property tests+ RoundTrip.tests++ -- Sanity checks++ -- Ensure size of frame compressed output for empty input is exactly+ -- 10 bytes+ , testCase "emptyCompressedSize" $+ 10 @?= BS.Lazy.length (Framed.compress "")++ -- Ensure invalid raw decompression is 'Nothing'+ , testCase "invalidRawDecompress" $+ Nothing @?= Raw.decompress "not a valid compressed string"++ -- Ensure invalid framed decompression throws an exception+ , testCase "invalidFramedDecompress" $+ case Framed.decompress' "not a valid compressed string" of+ Right _ -> assertFailure "invalid decompression succeeded"+ Left _ -> return ()+ ]
+ test/Test/Prop/Orphans.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -Wno-orphans #-}++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use ++" #-}++module Test.Prop.Orphans where++import Codec.Compression.SnappyC.Framed++import Control.Monad+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString qualified as BS.Strict++import Test.Tasty.QuickCheck++instance Arbitrary Strict.ByteString where+ arbitrary = do+ n <-+ frequency+ [ (9, choose (0 , 1000))+ , (1, choose (1000, 1_000_000))+ ]+ BS.Strict.pack <$> replicateM n arbitrary+ shrink bs =+ BS.Strict.pack <$> shrink (BS.Strict.unpack bs)++instance Arbitrary EncodeParams where+ arbitrary =+ EncodeParams+ <$> arbitrary+ <*> arbitrary++ shrink (EncodeParams fs r) =+ concat+ [ [ EncodeParams fs' r+ | fs' <- shrink fs+ ]+ , [ EncodeParams fs r'+ | r' <- shrink r+ ]+ ]++instance Arbitrary FrameSize where+ arbitrary = do+ n <-+ oneof+ [ pure 1+ , pure 2+ , pure 65535+ , pure 65536+ , choose (1, 65536) -- The range of valid chunk sizes+ ]+ return $ customFrameSize n++ shrink n = [ customFrameSize m | m <- shrink (unFrameSize n), m >= 1 ]++instance Arbitrary Threshold where+ arbitrary = do+ oneof+ [ pure AlwaysCompress+ , pure NeverCompress++ -- According to Google, max Snappy compression ratio is about 4+ -- https://github.com/google/snappy?tab=readme-ov-file#performance+ , Ratio . (/ 8.0) <$> elements+ [ 7.0 -- Similar (equivalent?) to AlwaysCompress+ , 8.0+ ..+ 32.0 -- Similar to NeverCompress+ ]+ ]++ shrink NeverCompress = []+ shrink AlwaysCompress = [NeverCompress]+ shrink (Ratio r)+ | r < 7.0 / 8.0 = [ AlwaysCompress ]+ | otherwise = [ Ratio $ r - 1/8 ]
+ test/Test/Prop/RoundTrip.hs view
@@ -0,0 +1,146 @@+module Test.Prop.RoundTrip+ ( tests+ ) where++import Test.Prop.Orphans ()++import Codec.Compression.SnappyC.Raw qualified as Raw+import Codec.Compression.SnappyC.Framed++import Control.Monad+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString qualified as BS.Strict+import Data.ByteString.Lazy qualified as BS.Lazy+import Test.Tasty+import Test.Tasty.QuickCheck++tests :: TestTree+tests =+ localOption (QuickCheckTests 1000) $+ testGroup "Test.Prop.RoundTrip"+ [ testProperty "rawRoundTripId" $+ sizeTable prop_rawRoundTripId+ , testProperty "framedRoundTripId" $+ sizeTable prop_framedRoundTripId+ , testProperty "framedChunkSizeRoundTripId" $+ chunkSizeTable prop_framedChunkSizeRoundTripId+ , testProperty "framedSlicedRoundTripId" $+ prop_framedSlicedRoundTripId+ ]++-- | Roundtripping raw compression and decompression is identity+prop_rawRoundTripId :: Strict.ByteString -> Bool+prop_rawRoundTripId src =+ (Just src ==) $ Raw.decompress (Raw.compress src)++-- | Roundtripping framed compression and decompression is identity+prop_framedRoundTripId :: Strict.ByteString -> Bool+prop_framedRoundTripId src =+ src == roundTripped+ where+ roundTripped =+ BS.Lazy.toStrict+ . decompress+ . compress+ $ BS.Lazy.fromStrict src++-- | The @decompress . compress@ identity holds for arbitrary compression chunk+-- sizes.+prop_framedChunkSizeRoundTripId :: EncodeParams -> Strict.ByteString -> Bool+prop_framedChunkSizeRoundTripId eps src =+ let+ (compressedChunks, e') = compressStep eps initialEncoder src+ compressedChunksRest = finalizeEncoder eps e'++ roundTripped =+ BS.Lazy.toStrict+ . decompress+ . BS.Lazy.fromChunks+ $ streamId : compressedChunks <> compressedChunksRest+ in+ src == roundTripped+ where+ (streamId, initialEncoder) = initializeEncoder++-- | The @decompress . compress@ identity holds for arbitrary slicing of+-- compression and decompression input.+prop_framedSlicedRoundTripId ::+ EncodeParams+ -> Slices+ -- ^ Compression input slices+ -> Slices+ -- ^ Decompression input slices+ -> Strict.ByteString+ -> Bool+prop_framedSlicedRoundTripId eps compressSlices decompressSlices src =+ let+ compressed =+ BS.Lazy.toStrict+ . compressWithParams eps+ . BS.Lazy.fromChunks+ $ slice compressSlices src++ roundTripped =+ BS.Lazy.toStrict+ . decompress+ . BS.Lazy.fromChunks+ $ slice decompressSlices compressed+ in+ src == roundTripped+++-------------------------------------------------------------------------------+-- Auxiliary+-------------------------------------------------------------------------------++data Slices = Slices [Int]+ deriving Show++-- | Slices the input into chunks the size of each of the given 'Slices'+slice :: Slices -> Strict.ByteString -> [Strict.ByteString]+slice (Slices []) bs = [bs]+slice _ "" = []+slice (Slices (s:ss)) bs =+ let (sliced, rest) = BS.Strict.splitAt s bs+ in sliced : slice (Slices ss) rest++instance Arbitrary Slices where+ arbitrary = do+ slices <- replicateM 100+ $ frequency+ [ (9, choose (0 , 1000))+ , (1, choose (1000, 1_000_000))+ ]+ return $ Slices slices++ shrink (Slices slices) = [ Slices slices' | slices' <- shrink slices ]++sizeTable ::+ Testable prop+ => (Strict.ByteString -> prop)+ -> Strict.ByteString+ -> Property+sizeTable f bs =+ tabulate "size"+ [ "10^" ++ show (sizeBracket (BS.Strict.length bs))+ ]+ (f bs)+ where+ sizeBracket :: Int -> Int+ sizeBracket 0 = 1+ sizeBracket x = floor @Double . logBase 10 $ fromIntegral x++chunkSizeTable ::+ Testable prop+ => (EncodeParams -> prop)+ -> EncodeParams+ -> Property+chunkSizeTable f inp@(EncodeParams fs _) =+ tabulate "frame size"+ [ "10^" ++ show (sizeBracket (unFrameSize fs))+ ]+ (f inp)+ where+ sizeBracket :: Int -> Int+ sizeBracket 0 = 1+ sizeBracket x = floor @Double . logBase 10 $ fromIntegral x