diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for snappy-c + +## 0.1.0 -- 2024-02-09 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,104 @@ +# snappy-c + +![CI Status Badge](https://github.com/well-typed/snappy-c/actions/workflows/haskell-ci.yml/badge.svg) + +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: + +![benchmark results](https://raw.githubusercontent.com/well-typed/snappy-c/main/.github/assets/bench-results.png) + +## `snappy-cli` performance + + + +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. + + +[snappy]: https://github.com/google/snappy diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 diff --git a/snappy-c.cabal b/snappy-c.cabal new file mode 100644 --- /dev/null +++ b/snappy-c.cabal @@ -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 diff --git a/snappy-cli/Main.hs b/snappy-cli/Main.hs new file mode 100644 --- /dev/null +++ b/snappy-cli/Main.hs @@ -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 diff --git a/src/Codec/Compression/SnappyC/Framed.hs b/src/Codec/Compression/SnappyC/Framed.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/SnappyC/Framed.hs @@ -0,0 +1,253 @@ +-- | +-- Module : Codec.Compression.SnappyC.Framed +-- Copyright : (c) 2024 Finley McIlwaine +-- License : BSD-3-Clause (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- Frame format Snappy compression/decompression. +-- See the framing format description here: +-- +-- +-- 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) diff --git a/src/Codec/Compression/SnappyC/Internal/Buffer.hs b/src/Codec/Compression/SnappyC/Internal/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/SnappyC/Internal/Buffer.hs @@ -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 diff --git a/src/Codec/Compression/SnappyC/Internal/C.hs b/src/Codec/Compression/SnappyC/Internal/C.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/SnappyC/Internal/C.hs @@ -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) diff --git a/src/Codec/Compression/SnappyC/Internal/Checksum.hs b/src/Codec/Compression/SnappyC/Internal/Checksum.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/SnappyC/Internal/Checksum.hs @@ -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" diff --git a/src/Codec/Compression/SnappyC/Internal/FrameFormat.hs b/src/Codec/Compression/SnappyC/Internal/FrameFormat.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/SnappyC/Internal/FrameFormat.hs @@ -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 diff --git a/src/Codec/Compression/SnappyC/Internal/Util.hs b/src/Codec/Compression/SnappyC/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/SnappyC/Internal/Util.hs @@ -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 diff --git a/src/Codec/Compression/SnappyC/Raw.hs b/src/Codec/Compression/SnappyC/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/SnappyC/Raw.hs @@ -0,0 +1,100 @@ +-- | +-- Module : Codec.Compression.SnappyC.Raw +-- Copyright : (c) 2024 Finley McIlwaine +-- License : BSD-3-Clause (see LICENSE) +-- +-- Maintainer : Finley McIlwaine +-- +-- 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 + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 () + ] diff --git a/test/Test/Prop/Orphans.hs b/test/Test/Prop/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Test/Prop/Orphans.hs @@ -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 ] diff --git a/test/Test/Prop/RoundTrip.hs b/test/Test/Prop/RoundTrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Prop/RoundTrip.hs @@ -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