diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ian Duncan (c) 2017 + +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 Ian Duncan 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hs-brotli.cabal b/hs-brotli.cabal new file mode 100644 --- /dev/null +++ b/hs-brotli.cabal @@ -0,0 +1,49 @@ +name: hs-brotli +version: 0.1.0.0 +synopsis: Compression and decompression in the brotli format +description: This package provides a pure interface for compressing and + decompressing streams of data represented as strict or lazy + 'ByteString's. It uses the + + so it has high performance. It supports the \"brotli\", + compression format. + . + It provides a convenient high level API suitable for most + tasks and for the few cases where more control is needed it + provides access to the full brotli feature set +homepage: https://github.com/iand675/brotli#readme +license: BSD3 +license-file: LICENSE +author: Ian Duncan +maintainer: ian@iankduncan.com +copyright: Ian Duncan +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Codec.Compression.Brotli, + Codec.Compression.Brotli.Internal + build-depends: base >= 4.7 && < 5, ghc-prim, bytestring + extra-libraries: brotlidec, brotlienc + pkgconfig-depends: libbrotlidec, libbrotlienc + default-language: Haskell2010 + +test-suite brotli-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , brotli + , bytestring + , QuickCheck + , tasty-quickcheck + , quickcheck-instances + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/iand675/hs-brotli diff --git a/src/Codec/Compression/Brotli.hs b/src/Codec/Compression/Brotli.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Brotli.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +module Codec.Compression.Brotli ( + Compress(..) + , compress + , decompress + , BrotliStream(..) + , Chunk(..) + , compressor + , decompressor + , maxCompressedSize + , CompressionSettings(..) + , defaultCompressionSettings + , setCompressionSettings + , I.minWindowBits + , I.maxWindowBits + , I.minInputBlockBits + , I.maxInputBlockBits + , I.minQuality + , I.maxQuality + , I.encoderModeGeneric + , I.encoderModeText + , I.encoderModeFont +) where +import Control.Monad (when, unless, forM) +import Control.Exception (SomeException, assert, handle, bracket, throw) +import qualified Codec.Compression.Brotli.Internal as I +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as LI +import Foreign.ForeignPtr +import Data.Maybe (catMaybes) +import Data.IORef +import Data.Int +import Data.Word +import Foreign.C +import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr) +import Foreign.Marshal (alloca, allocaBytes, callocBytes, free) +import Foreign.Storable (sizeOf, peek, poke) +import GHC.Int +import GHC.Types +import System.IO.Unsafe + +data CompressionSettings = CompressionSettings + { compressionQuality :: !Word32 + , compressionWindow :: !Word32 + , compressionMode :: !I.BrotliEncoderMode + , compressionBufferSize :: !Int + , compressionBlockSize :: !(Maybe Word32) + , compressionDisableLiteralContextModeling :: !(Maybe Word32) + , compressionSizeHint :: !(Maybe Word32) + } + +-- | The default set of parameters for compression. This is typically used with the compressWith function with specific parameters overridden. +defaultCompressionSettings :: CompressionSettings +defaultCompressionSettings = CompressionSettings + { compressionQuality = I.defaultQuality + , compressionWindow = I.defaultWindow + , compressionMode = I.defaultMode + , compressionBufferSize = 0 + , compressionBlockSize = Nothing + , compressionDisableLiteralContextModeling = Nothing + , compressionSizeHint = Nothing + } + +setCompressionSettings :: I.BrotliEncoderState -> CompressionSettings -> IO () +setCompressionSettings st CompressionSettings{..}= do + r1 <- I.encoderSetParameter st I.mode $ fromIntegral $ I.fromBrotliEncoderMode compressionMode + r2 <- I.encoderSetParameter st I.quality compressionQuality + r3 <- I.encoderSetParameter st I.lz77WindowSize compressionWindow + mr4 <- forM compressionBlockSize $ I.encoderSetParameter st I.lz77BlockSize + mr5 <- forM compressionDisableLiteralContextModeling $ I.encoderSetParameter st I.disableLiteralContextModeling + mr6 <- forM compressionSizeHint $ I.encoderSetParameter st I.brotliParamSizeHint + if any (/= 1) $ r1 : r2 : r3 : catMaybes [mr4, mr5, mr6] + then error "Invalid compression setting parameter" + else pure () + +-- | Like compress but with the ability to specify various compression parameters. Typical usage: +-- +-- > compressWith defaultCompressionSettings { ... } +-- +-- In particular you can set the compression level: +-- +-- > compressWith defaultCompressParams { compressionQuality = minQuality } +class Compress a b where + compressWith :: CompressionSettings -> a-> b + +-- | Compress a stream of data into the brotli format. +-- +-- This uses the default compression parameters. In particular it uses the highest compression level which favours a higher compression ratio over compression speed. +-- +-- Use compressWith to adjust the compression level or other compression parameters. +compress :: Compress a b => a -> b +compress = compressWith defaultCompressionSettings + +instance Compress B.ByteString B.ByteString where + compressWith CompressionSettings{..} b = unsafePerformIO $ do + let estBufSize = fromIntegral $ I.maxCompressedSize $ fromIntegral $ B.length b + res <- alloca $ \outSize -> do + poke outSize estBufSize + BI.createAndTrim (fromIntegral estBufSize) $ \outBuf -> B.unsafeUseAsCStringLen b $ \(inPtr, inLen) -> do + + ok <- I.encoderCompress (fromIntegral compressionQuality) (fromIntegral compressionWindow) compressionMode (fromIntegral inLen) (castPtr inPtr) outSize outBuf + os <- peek outSize + if (ok /= 1) + then error "Compression error or output buffer is too small" + else pure $ fromIntegral os + pure res + +isTrue :: CInt -> Bool +isTrue (CInt (I32# x)) = isTrue# x + +maxCompressedSize :: Int -> Int +maxCompressedSize = fromIntegral . I.maxCompressedSize . fromIntegral + +hasMoreOutput :: I.BrotliEncoderState -> IO Bool +hasMoreOutput = fmap isTrue . I.encoderHasMoreOutput + +isFinished :: I.BrotliEncoderState -> IO Bool +isFinished = fmap isTrue . I.encoderIsFinished + +takeOutput :: I.BrotliEncoderState -> IO B.ByteString +takeOutput st = alloca $ \sizeP -> do + poke sizeP 0 + ptr <- I.encoderTakeOutput st sizeP + takeSize <- peek sizeP + B.packCStringLen (castPtr ptr, fromIntegral takeSize) + +data StreamVars = StreamVars + { availableIn :: !(Ptr CSize) + , availableOut :: !(Ptr CSize) + , totalOut :: !(Ptr CSize) + , nextIn :: !(Ptr (Ptr Word8)) + , nextOut :: !(Ptr (Ptr Word8)) + } deriving (Show) + + +freeStreamVars :: StreamVars -> IO () +freeStreamVars = free . availableIn + +createStreamVars :: IO StreamVars +createStreamVars = do + bs <- callocBytes (3 * sizeOf (0 :: CSize) + 2 * sizeOf (nullPtr :: Ptr Word8)) + let aiPtr = bs + aoPtr = plusPtr aiPtr (sizeOf (0 :: CSize)) + toPtr = plusPtr aoPtr (sizeOf (0 :: CSize)) + niPtr = castPtr $ plusPtr toPtr (sizeOf (nullPtr :: Ptr Word8)) + noPtr = plusPtr niPtr (sizeOf (nullPtr :: Ptr Word8)) + vs@StreamVars{..} = StreamVars aiPtr aoPtr toPtr niPtr noPtr + pure vs + +newtype EncoderFeedResponse = EncoderFeedResponse + { pendingInput :: B.ByteString + } + +-- CAUTION: we aren't ensuring that bytestrings stay alive since the contents are +-- poked in and outlive the function (streaming and all) +-- +-- Must use only within the context of the bytestring be alive via an external unsafeUseAsCStringLen +feedEncoder' :: I.BrotliEncoderState -> StreamVars -> Int -> B.ByteString -> IO CSize +feedEncoder' st vs@StreamVars{..} bufSize bs = B.unsafeUseAsCStringLen bs $ \(bsP, len) -> do + poke availableIn (fromIntegral len) + poke nextIn (castPtr bsP) + res <- isTrue <$> I.encoderCompressStream st I.encoderOperationProcess availableIn nextIn availableOut nextOut totalOut + unless res $ error "Unknown stream encoding failure" + peek availableIn + +-- CAUTION: we aren't ensuring that bytestrings stay alive since the contents are +-- poked in and outlive the function (streaming and all) +-- +-- Must use only within the context of the bytestring be alive via an external unsafeUseAsCStringLen +feedEncoder :: I.BrotliEncoderState -> StreamVars -> Int -> B.ByteString -> IO EncoderFeedResponse +feedEncoder st vs@StreamVars{..} bufSize bs = B.unsafeUseAsCStringLen bs $ \(bsP, len) -> do + poke availableIn (fromIntegral len) + poke nextIn (castPtr bsP) + res <- isTrue <$> I.encoderCompressStream st I.encoderOperationProcess availableIn nextIn availableOut nextOut totalOut + unless res $ error "Unknown stream encoding failure" + unconsumedBytesCount <- peek availableIn + unconsumedBytesP <- peek nextIn + unusedInput <- if unconsumedBytesCount == 0 + then pure B.empty + else B.packCStringLen (castPtr unconsumedBytesP, fromIntegral unconsumedBytesCount) + pure $ EncoderFeedResponse unusedInput + +encoderMaybeTakeOutput :: I.BrotliEncoderState -> Int -> IO (Maybe B.ByteString) +encoderMaybeTakeOutput st bufSize = do + takeOut <- isTrue <$> I.encoderHasMoreOutput st + if takeOut + then alloca $ \s -> do + poke s $ fromIntegral bufSize + bsp <- I.encoderTakeOutput st s + len <- peek s + Just <$> B.packCStringLen (castPtr bsp, fromIntegral len) + else pure Nothing + +encoderTakeRestAvailable :: I.BrotliEncoderState -> IO () -> Int -> L.ByteString -> IO L.ByteString +encoderTakeRestAvailable st cleanup bufSize graft = do + out <- encoderMaybeTakeOutput st bufSize + case out of + Nothing -> pure graft + Just bs -> do + rest <- unsafeInterleaveIO $ encoderTakeRestAvailable st cleanup bufSize graft + pure $ LI.Chunk bs rest + +-- | Note that this should be called until returned bytestring is empty. Once is not enough. +finishStream :: I.BrotliEncoderState -> StreamVars -> IO () -> Int -> IO L.ByteString +finishStream st StreamVars{..} cleanup bufSize = do + poke availableIn 0 + poke nextIn nullPtr + res <- isTrue <$> I.encoderCompressStream st I.encoderOperationFinish availableIn nextIn availableOut nextOut totalOut + unless res $ error "Unknown stream encoding failure" + encoderTakeRestAvailable st cleanup bufSize L.empty + + +pOff :: Int -> Ptr a -> Ptr b +pOff n p = castPtr $ plusPtr p (n * sizeOf p) + +pushNoCheck :: B.ByteString -> L.ByteString -> L.ByteString +pushNoCheck = LI.Chunk + +instance Compress L.ByteString L.ByteString where + compressWith settings b = unsafePerformIO $ do + inst <- I.createEncoder + setCompressionSettings inst settings + vars <- createStreamVars + poke (availableOut vars) 0 + poke (nextOut vars) nullPtr + let cleanup = freeStreamVars vars >> I.destroyEncoder inst + lazyCompress cleanup inst vars b + where + lazyCompress cleanup st vars c = unsafeInterleaveIO $ readChunks cleanup st vars c + readChunks cleanup st vars c = do + case c of + LI.Chunk bs next -> handle (\(e :: SomeException) -> cleanup >> throw e) $ do + (EncoderFeedResponse unusedInput) <- feedEncoder st vars (compressionBufferSize settings) bs + -- NOTE: LI.chunk checks for empty string results so we don't have to worry about empty chunks ourselves. + rest <- lazyCompress cleanup st vars $ LI.chunk unusedInput next + encoderTakeRestAvailable st cleanup (compressionBufferSize settings) rest + LI.Empty -> finishStream st vars (freeStreamVars vars >> I.destroyEncoder st) $ compressionBufferSize settings + +data DecompressionVars = DecompressionVars + { dAvailableInput :: !(Ptr CSize) + , dAvailableOut :: !(Ptr CSize) + , dTotalOut :: !(Ptr CSize) + , dNextIn :: !(Ptr (Ptr Word8)) + , dNextOut :: !(Ptr (Ptr Word8)) + } + +createDecompressionVars :: IO DecompressionVars +createDecompressionVars = do + bs <- callocBytes (3 * sizeOf (0 :: CSize) + 2 * sizeOf (nullPtr :: Ptr Word8)) + let aiPtr = bs + aoPtr = plusPtr aiPtr (sizeOf (0 :: CSize)) + toPtr = plusPtr aoPtr (sizeOf (0 :: CSize)) + niPtr = castPtr $ plusPtr toPtr (sizeOf (nullPtr :: Ptr Word8)) + noPtr = plusPtr niPtr (sizeOf (nullPtr :: Ptr Word8)) + pure $ DecompressionVars aiPtr aoPtr toPtr niPtr noPtr + +destroyDecompressionVars :: DecompressionVars -> IO () +destroyDecompressionVars = free . dAvailableInput + +-- | Decompress a stream of data in the brotli format. +-- +-- There are a number of errors that can occur. In each case an exception will +-- be thrown. +-- +-- Note that the decompression is performed /lazily/. Errors in the data stream +-- may not be detected until the end of the stream is demanded (since it is +-- only at the end that the final checksum can be checked). If this is +-- important to you, you must make sure to consume the whole decompressed +-- stream before doing any IO action that depends on it. +-- +decompress :: L.ByteString -> L.ByteString +decompress b = unsafePerformIO $ do + st <- I.createDecoder + vs <- createDecompressionVars + poke (dAvailableOut vs) 0 + poke (dNextOut vs) nullPtr + lazyDecompress st vs b + where + lazyDecompress st vs rest = unsafeInterleaveIO $ writeChunks st vs rest + writeChunks st vs@DecompressionVars{..} lbs = do + case lbs of + LI.Chunk bs rest -> do + v@(res, unconsumed') <- B.unsafeUseAsCStringLen bs $ \(strP, strLen) -> do + poke dAvailableInput $ fromIntegral strLen + poke dNextIn $ castPtr strP + res <- I.decoderDecompressStream st dAvailableInput dNextIn dAvailableOut dNextOut dTotalOut + remainingInputBytes <- peek dAvailableInput + compressedBytesPtr <- peek dNextIn + unconsumed' <- B.packCStringLen (castPtr compressedBytesPtr, fromIntegral remainingInputBytes) + pure (res, unconsumed') + case I.decoderResult res of + I.Success -> do + -- allTheRest <- takeRestAvailable st (I.destroyDecoder st >> destroyDecompressionVars vs) L.empty + -- return allTheRest + pure L.empty + I.NeedsMoreInput -> do + lazyDecompress st vs $ LI.chunk unconsumed' rest + I.NeedsMoreOutput -> do + -- Sneak invariant breaking here by pushing what is quite possibly an empty Chunk. + -- this is intentional because we need one last empty string to trigger either success or error + -- depending on whether the string shouldn't have ended there + afterOut <- lazyDecompress st vs $ LI.Chunk unconsumed' rest + decoderTakeRestAvailable st (pure ()) afterOut + -- TODO need a safe version of decompress too + I.DecoderError e -> I.destroyDecoder st >> throw e + LI.Empty -> do + I.destroyDecoder st + destroyDecompressionVars vs + throw $ I.BrotliDecoderErrorCode 2 + +decoderMaybeTakeOutput :: I.BrotliDecoderState -> IO (Maybe B.ByteString) +decoderMaybeTakeOutput st = do + takeIn <- isTrue <$> I.decoderHasMoreOutput st + if takeIn + then alloca $ \s -> do + poke s 0 -- TODO settings + bsp <- I.decoderTakeOutput st s + len <- peek s + Just <$> B.packCStringLen (castPtr bsp, fromIntegral len) + else pure Nothing + +decoderTakeRestAvailable :: I.BrotliDecoderState -> IO () -> L.ByteString -> IO L.ByteString +decoderTakeRestAvailable st cleanup graft = do + out <- decoderMaybeTakeOutput st + case out of + Nothing -> cleanup >> pure graft + Just bs -> do + rest <- unsafeInterleaveIO $ decoderTakeRestAvailable st cleanup graft + pure $ LI.Chunk bs rest + +data Chunk + = Chunk !B.ByteString + | Flush + deriving (Show, Eq) + +data BrotliStream input + = Produce !B.ByteString (IO (BrotliStream input)) + | Consume (input -> IO (BrotliStream input)) + | Error + | Done + +withEncoder :: ForeignPtr I.BrotliEncoderState -> (I.BrotliEncoderState -> IO a) -> IO a +withEncoder p f = withForeignPtr p (f . I.BrotliEncoderState) + +-- | A strict, streaming compressor. This allows compressing +-- values in constant memory in addition to giving fine-grained +-- control of when to flush data in the stream. +compressor :: CompressionSettings -> IO (BrotliStream Chunk) +compressor settings = do + (I.BrotliEncoderState encoder) <- I.createEncoder + efp <- newForeignPtr I.destroyEncoder_ptr encoder + withEncoder efp $ \encoder -> setCompressionSettings encoder settings + vars <- createStreamVars + pure $ go efp vars + where + go efp vars = Consume (consume B.empty) + where + consume + :: B.ByteString + {- ^ Presently poked bytestring + Must `touch` underlying ForeignPtr until + the underlying contents have been consumed + + In other words, consumption must be wrapped in an unsafeUseAsCStringLen to keep it alive. + We could be a bit more fine-grained on things if we use bytestring internals, but maybe + not worth the hassle? + -} + -> Chunk + -> IO (BrotliStream Chunk) + consume !currentBs !chunk = B.unsafeUseAsCStringLen currentBs $ \_ -> do + let StreamVars{..} = vars + case chunk of + Chunk bs -> do + -- print vars + previousUnconsumedSize <- peek availableIn + if previousUnconsumedSize == 0 && B.null bs + then done + else withEncoder efp $ \encoder -> do + unconsumedSize <- + if previousUnconsumedSize == 0 + then feedEncoder' + encoder + vars + (compressionBufferSize settings) + bs + else do + _ <- I.encoderCompressStream + encoder + I.encoderOperationProcess + availableIn + nextIn + availableOut + nextOut + totalOut + -- TODO assert result + peek availableIn + + let bytestringRef = if unconsumedSize > 0 then currentBs else B.empty + moreOutput <- hasMoreOutput encoder + if moreOutput + then produce bytestringRef $ if previousUnconsumedSize == 0 + then Just chunk + else Nothing + else pure $ Consume (consume bytestringRef) + Flush -> withEncoder efp $ \encoder -> do + -- TODO make appropriate assertions here + -- around in state & out state + I.encoderCompressStream + encoder + I.encoderOperationFlush + availableIn + nextIn + availableOut + nextOut + totalOut + -- ls <- (,) <$> peek availableOut <*> peek availableIn + -- print ls + hasMore <- hasMoreOutput encoder + produce B.empty Nothing + + produce :: B.ByteString -> Maybe Chunk -> IO (BrotliStream Chunk) + produce currentInput unusedInput = withEncoder efp $ \encoder -> do + -- assert: this function is only called from other functions + -- when output is guaranteed + out <- takeOutput encoder + hasMore <- hasMoreOutput encoder + pure $ Produce out $ if hasMore + then produce currentInput unusedInput + else + maybe + (pure $ Consume $ consume B.empty) + (\c -> consume (case c of + Chunk bs -> bs + Flush -> B.empty) c) + unusedInput + + -- err = undefined + done :: IO (BrotliStream Chunk) + done = withEncoder efp $ \encoder -> do + let StreamVars {..} = vars + poke availableIn 0 + poke nextIn nullPtr + I.encoderCompressStream + encoder + I.encoderOperationFinish + availableIn + nextIn + availableOut + nextOut + totalOut + done' + + done' = withEncoder efp $ \encoder -> do + out <- encoderMaybeTakeOutput encoder (compressionBufferSize settings) + case out of + Nothing -> do + freeStreamVars vars + pure Done + Just str -> pure $ Produce str done' + +-- | A strict, streaming decompressor. This allows decompressing +-- values in constant memory as long as you don't need the full output +-- at one time. +decompressor :: IO (BrotliStream B.ByteString) +decompressor = do + st <- I.createDecoder + vs <- createDecompressionVars + poke (dAvailableOut vs) 0 + poke (dNextOut vs) nullPtr + go st vs + where + go st vs@DecompressionVars {..} = pure $ consume B.empty + where + consume :: B.ByteString -> BrotliStream B.ByteString + consume leftover = + Consume $ \bs -> do + v@(res, unconsumed') <- + B.unsafeUseAsCStringLen + (if B.null leftover + then bs + else if B.null bs + then B.empty + else leftover `mappend` bs) $ \(strP, strLen) -> do + poke dAvailableInput (fromIntegral strLen) + poke dNextIn (castPtr strP) + res <- + I.decoderDecompressStream + st + dAvailableInput + dNextIn + dAvailableOut + dNextOut + dTotalOut + remainingInputBytes <- peek dAvailableInput + compressedBytesPtr <- peek dNextIn + unconsumed' <- + B.packCStringLen + ( castPtr compressedBytesPtr + , fromIntegral remainingInputBytes) + pure (res, unconsumed') + case I.decoderResult res of + I.Success -> done + I.NeedsMoreInput -> pure $ consume B.empty + I.NeedsMoreOutput -> produce unconsumed' + I.DecoderError e -> err -- I.destroyDecoder st >> throw e + produce rem = do + out <- decoderMaybeTakeOutput st + case out of + Nothing -> pure (consume rem) + Just bs -> pure $ Produce bs (produce rem) + err = pure Error + done = do + I.destroyDecoder st + destroyDecompressionVars vs + pure Done + diff --git a/src/Codec/Compression/Brotli/Internal.hs b/src/Codec/Compression/Brotli/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Brotli/Internal.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Codec.Compression.Brotli.Internal where +import Control.Exception +import Data.Typeable (Typeable(..)) +import Data.Word +import Foreign.C +import Foreign.Marshal +import Foreign.Ptr +import System.IO.Unsafe + +type BrotliAlloc a = FunPtr (Ptr a -> CSize -> IO (Ptr ())) +type BrotliFree a = FunPtr (Ptr a -> Ptr () -> IO ()) + +minWindowBits, maxWindowBits, minInputBlockBits, maxInputBlockBits, minQuality, maxQuality, defaultQuality, defaultWindow :: Num a => a +minWindowBits = 10 +maxWindowBits = 24 +minInputBlockBits = 16 +maxInputBlockBits = 24 +minQuality = 0 +maxQuality = 11 +defaultQuality = 11 +defaultWindow = 22 +defaultMode = encoderModeGeneric + +newtype BrotliEncoderMode = BrotliEncoderMode { fromBrotliEncoderMode :: CInt } + deriving (Show) + +-- | Default compression mode. +-- +-- In this mode compressor does not know anything in advance about the +-- properties of the input. +encoderModeGeneric = BrotliEncoderMode 0 +-- | Compression mode for UTF-8 formatted text input. +encoderModeText = BrotliEncoderMode 1 +-- | Compression mode used in WOFF 2.0 +encoderModeFont = BrotliEncoderMode 2 + +newtype BrotliEncoderState = BrotliEncoderState (Ptr BrotliEncoderState) + deriving (Show) + +newtype BrotliEncoderOperation = BrotliEncoderOperation CInt + deriving (Show) + +encoderOperationProcess = BrotliEncoderOperation 0 +encoderOperationFlush = BrotliEncoderOperation 1 +encoderOperationFinish = BrotliEncoderOperation 2 +encoderOperationEmitMetadata = BrotliEncoderOperation 3 + +newtype BrotliEncoderParameter = BrotliEncoderParameter CInt + deriving (Show) + +mode = BrotliEncoderParameter 0 +quality = BrotliEncoderParameter 1 +lz77WindowSize = BrotliEncoderParameter 2 +lz77BlockSize = BrotliEncoderParameter 3 +disableLiteralContextModeling = BrotliEncoderParameter 4 +brotliParamSizeHint = BrotliEncoderParameter 5 + +foreign import ccall unsafe "BrotliEncoderCreateInstance" brotliEncoderCreateInstance :: BrotliAlloc a -> BrotliFree a -> Ptr a -> IO BrotliEncoderState + +createEncoder :: IO BrotliEncoderState +createEncoder = brotliEncoderCreateInstance nullFunPtr nullFunPtr nullPtr + +foreign import ccall unsafe "BrotliEncoderSetParameter" encoderSetParameter + :: BrotliEncoderState + -> BrotliEncoderParameter + -> Word32 + -> IO CInt -- ^ Bool + +foreign import ccall unsafe "BrotliEncoderDestroyInstance" destroyEncoder :: BrotliEncoderState -> IO () + +foreign import ccall unsafe "&BrotliEncoderDestroyInstance" destroyEncoder_ptr :: FunPtr (Ptr BrotliEncoderState -> IO ()) + + +foreign import ccall unsafe "BrotliEncoderMaxCompressedSize" maxCompressedSize :: CSize -> CSize + +foreign import ccall safe "BrotliEncoderCompress" encoderCompress + :: CInt + -> CInt + -> BrotliEncoderMode -- Sizeof? + -> CSize + -> Ptr Word8 + -> Ptr CSize + -> Ptr Word8 + -> IO CInt -- ^ Bool + +foreign import ccall safe "BrotliEncoderCompressStream" encoderCompressStream + :: BrotliEncoderState + -> BrotliEncoderOperation + -> Ptr CSize + -> Ptr (Ptr Word8) + -> Ptr CSize + -> Ptr (Ptr Word8) + -> Ptr CSize + -> IO CInt -- ^ Bool + +foreign import ccall unsafe "BrotliEncoderIsFinished" encoderIsFinished + :: BrotliEncoderState + -> IO CInt -- ^ Bool + +foreign import ccall unsafe "BrotliEncoderHasMoreOutput" encoderHasMoreOutput + :: BrotliEncoderState + -> IO CInt -- ^ Bool + +foreign import ccall unsafe "BrotliEncoderTakeOutput" encoderTakeOutput + :: BrotliEncoderState + -> Ptr CSize + -> IO (Ptr Word8) + +foreign import ccall unsafe "BrotliEncoderVersion" encoderVersion + :: IO Word32 + + +newtype BrotliDecoderState = BrotliDecoderState (Ptr BrotliDecoderState) + +foreign import ccall unsafe "BrotliDecoderCreateInstance" brotliDecoderCreateInstance + :: BrotliAlloc a + -> BrotliFree a + -> Ptr a + -> IO BrotliDecoderState + +createDecoder :: IO BrotliDecoderState +createDecoder = brotliDecoderCreateInstance nullFunPtr nullFunPtr nullPtr + +foreign import ccall unsafe "BrotliDecoderDestroyInstance" destroyDecoder + :: BrotliDecoderState + -> IO () + +foreign import ccall unsafe "&BrotliDecoderDestroyInstance" destroyDecoder_ptr + :: FunPtr (Ptr BrotliDecoderState -> IO ()) + +foreign import ccall safe "BrotliDecoderDecompress" decoderDecompress + :: CSize + -> Ptr Word8 + -> Ptr CSize + -> Ptr Word8 + -> IO CInt -- TODO result proper value + +foreign import ccall safe "BrotliDecoderDecompressStream" decoderDecompressStream + :: BrotliDecoderState + -> Ptr CSize + -> Ptr (Ptr Word8) + -> Ptr CSize + -> Ptr (Ptr Word8) + -> Ptr CSize + -> IO BrotliDecoderErrorCode -- TODO result proper value + +foreign import ccall unsafe "BrotliDecoderHasMoreOutput" decoderHasMoreOutput + :: BrotliDecoderState + -> IO CInt -- Bool + +foreign import ccall unsafe "BrotliDecoderTakeOutput" decoderTakeOutput + :: BrotliDecoderState + -> Ptr CSize + -> IO (Ptr Word8) + +foreign import ccall unsafe "BrotliDecoderIsUsed" decoderIsUsed + :: BrotliDecoderState + -> IO CInt + +foreign import ccall unsafe "BrotliDecoderIsFinished" decoderIsFinished + :: BrotliDecoderState + -> IO CInt + +newtype BrotliDecoderErrorCode = BrotliDecoderErrorCode CInt + deriving (Eq, Typeable) + +instance Show BrotliDecoderErrorCode where + show c = unsafePerformIO (decoderErrorString c >>= peekCString) + +instance Exception BrotliDecoderErrorCode + +data DecoderResult + = Success + | NeedsMoreInput + | NeedsMoreOutput + | DecoderError BrotliDecoderErrorCode + +decoderResult :: BrotliDecoderErrorCode -> DecoderResult +decoderResult c@(BrotliDecoderErrorCode n) = case n of + 1 -> Success + 2 -> NeedsMoreInput + 3 -> NeedsMoreOutput + _ -> DecoderError c +{-# INLINE decoderResult #-} + +foreign import ccall unsafe "BrotliDecoderGetErrorCode" decoderGetError + :: BrotliDecoderState + -> IO BrotliDecoderErrorCode + +foreign import ccall unsafe "BrotliDecoderErrorString" decoderErrorString + :: BrotliDecoderErrorCode + -> IO CString + +foreign import ccall unsafe "BrotliDecoderVersion" decoderVersion + :: IO Word32 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +import Control.Concurrent +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as CL +import Codec.Compression.Brotli +import Codec.Compression.Brotli.Internal +import Test.QuickCheck +import Test.QuickCheck.Instances + +fastSettings :: CompressionSettings +fastSettings = defaultCompressionSettings { compressionQuality = 4 } + +main :: IO () +main = do + putStrLn "" + {- + quickCheck $ \bs -> + let cbs = (compress (bs :: B.ByteString)) :: B.ByteString + dbs = (decompress cbs) :: B.ByteString + in dbs == bs + -} + + quickCheck $ \bs -> + let cbs = (compressWith fastSettings (bs :: L.ByteString)) :: L.ByteString + dbs = (decompress cbs) :: L.ByteString + in dbs == bs + + sampleRoundTrip ";" + sampleRoundTrip "\139\NUL\128\SOH\NUL\ETX" + sampleRoundTrip "" + sampleRoundTrip "What you need is an eclipse. However being a tidally locked planet you're not going to have a moon, at least your people would have been idiots for settling on a tidally locked planet with a moon as it would be unstable as discussed in this question: " + L.readFile "/usr/share/dict/words" >>= sampleRoundTrip + longReallyCompressable + {- + needsOutputL + let comped = compress f + print (L.length f, L.length comped, map B.length $ L.toChunks comped) + -} + -- print (compress str :: ByteString) + -- print (compress lstr :: L.ByteString) + -- + (Consume c) <- compressor fastSettings + putStrLn "Got consumer" + -- bs <- B.readFile "/usr/share/dict/words" -- B.replicate (2 ^ 18) 0 + putStrLn "Feed once" + (Consume c) <- c $ Chunk "Hello " + putStrLn "Flush" + (Produce compressedPt1 followup) <- c Flush + putStrLn "Got flush triggered produce" + (Consume c) <- followup + putStrLn "Back to consuming" + (Consume c) <- c $ Chunk "World" + putStrLn "Fed it some more" + (Produce compressedPt2 followup) <- c $ Chunk "" + putStrLn "Done, so should signal that now" + Done <- followup + putStrLn "Yup, hit the end" + print ("Hello World" == decompress (CL.fromStrict (compressedPt1 `mappend` compressedPt2))) + -- threadDelay 10000000 + +sampleRoundTrip :: L.ByteString -> IO () +sampleRoundTrip l = do + let rt = decompress $ compressWith fastSettings l + print (L.toStrict l == L.toStrict rt) + +sample :: IO () +sample = do + putStrLn "Creating encoder" + enc <- createEncoder + print enc + putStrLn "Destroying encoder" + destroyEncoder enc + encoderVersion >>= print + +longReallyCompressable :: IO () +longReallyCompressable = sampleRoundTrip (L.replicate (2 ^ 22) 0)