Raw.hsc

{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Hopfli.Raw
-- License     : Apache 2.0
-- Copyright   : (c) 2014 Anantha Kumaran
-- Stability   : experimental
-- Portability : unknown
--
-----------------------------------------------------------------------------

module Codec.Compression.Hopfli.Raw (
    Options(Options)
  , Format(..)
  , compress
  ) where

import qualified Codec.Compression.GZip     as G
import qualified Codec.Compression.Zlib     as Z
import qualified Codec.Compression.Zlib.Raw as ZR
import qualified Data.ByteString            as B
import           Data.ByteString.Char8      ()
import           Data.ByteString.Internal   (fromForeignPtr, toForeignPtr)
import qualified Data.ByteString.Lazy       as BL
import           Data.ByteString.Lazy.Char8 ()
import           Foreign
import           Foreign.C.Types
import           Prelude                    hiding (length)
import           System.IO.Unsafe           (unsafePerformIO)

#include "zopfli.h"

data Options = Options { verbose            :: CInt
                       , verbose_more       :: CInt
                       , numiterations      :: CInt
                       , blocksplitting     :: CInt
                       , blocksplittinglast :: CInt
                       , blocksplittingmax  :: CInt
                       } deriving (Show)
instance Storable Options where
    sizeOf    _ = (#size ZopfliOptions)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = do
        verbose            <- (#peek ZopfliOptions, verbose) ptr
        verbose_more       <- (#peek ZopfliOptions, verbose_more) ptr
        numiterations      <- (#peek ZopfliOptions, numiterations) ptr
        blocksplitting     <- (#peek ZopfliOptions, blocksplitting) ptr
        blocksplittinglast <- (#peek ZopfliOptions, blocksplittinglast) ptr
        blocksplittingmax  <- (#peek ZopfliOptions, blocksplittingmax) ptr
        pure Options{..}
    poke ptr (Options verbose' verbose_more' numiterations' blocksplitting' blocksplittinglast' blocksplittingmax') = do
        (#poke ZopfliOptions, verbose) ptr verbose'
        (#poke ZopfliOptions, verbose_more) ptr verbose_more'
        (#poke ZopfliOptions, numiterations) ptr numiterations'
        (#poke ZopfliOptions, blocksplitting) ptr blocksplitting'
        (#poke ZopfliOptions, blocksplittinglast) ptr blocksplittinglast'
        (#poke ZopfliOptions, blocksplittingmax) ptr blocksplittingmax'

data Format = GZIP
            | ZLIB
            | DEFLATE
  deriving (Eq, Show)

newtype ZopfliFormat = ZopfliFormat CInt

fromFormat :: Format -> ZopfliFormat
fromFormat GZIP    = ZopfliFormat #{const ZOPFLI_FORMAT_GZIP}
fromFormat ZLIB    = ZopfliFormat #{const ZOPFLI_FORMAT_ZLIB}
fromFormat DEFLATE = ZopfliFormat #{const ZOPFLI_FORMAT_DEFLATE}

foreign import ccall unsafe "zopfli.h ZopfliCompress"
  c_zopfli_compress :: Ptr Options -> ZopfliFormat -> Ptr Word8 -> CSize
                    -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()

compress :: Options -> Format -> B.ByteString -> B.ByteString
-- zopfli doesn't handle zero length data
compress _ GZIP ""            = mconcat . BL.toChunks $ G.compress ""
compress _ ZLIB ""            = mconcat . BL.toChunks $ Z.compress ""
compress _ DEFLATE ""         = mconcat . BL.toChunks $ ZR.compress ""
compress options format input = unsafePerformIO $ do
  let (inputFptr, start, length) = toForeignPtr input
  withForeignPtr inputFptr $ \inputPtr -> do
    alloca $ \outSizePtr -> do
      poke outSizePtr 0
      alloca $ \optionsPtr -> do
        poke optionsPtr options
        alloca $ \outPtrPtr -> do
          poke outPtrPtr nullPtr
          _ <- c_zopfli_compress optionsPtr (fromFormat format) (plusPtr inputPtr start) (fromIntegral length) outPtrPtr outSizePtr
          outSize <- peek outSizePtr
          resultPtr <- throwIfNull "Zopfli compression failed" (peek outPtrPtr)
          resultFptr <- newForeignPtr finalizerFree resultPtr
          pure $ fromForeignPtr resultFptr 0 (fromIntegral outSize)