{-# LINE 1 "src/Codec/Compression/BZip/Pack.chs" #-}
module Codec.Compression.BZip.Pack ( compress
, compressWith
) where
import qualified Foreign.C.Types as C2HSImp
import qualified Foreign.Ptr as C2HSImp
import qualified Foreign.Storable as C2HSImp
import Codec.Compression.BZip.Foreign
import Codec.Compression.BZip.Common
import Control.Applicative
import Control.Arrow (second)
import Control.Exception (bracket)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Unsafe as BS
import Foreign.C.Types (CInt)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Marshal.Alloc (free, mallocBytes)
import System.IO.Unsafe (unsafeDupablePerformIO)
{-# NOINLINE compress #-}
compress :: BSL.ByteString -> BSL.ByteString
compress = compressWith 9 30
{-# NOINLINE compressWith #-}
compressWith :: CInt
-> CInt
-> BSL.ByteString
-> BSL.ByteString
compressWith blkSize wf bsl = unsafeDupablePerformIO $
let bss = BSL.toChunks bsl in
BSL.fromChunks <$> bracket
(do { p <- bzStreamInit ; bzCompressInit blkSize wf p ; pure p })
bZ2BzCompressEnd
(\p -> bzCompressChunks p bss)
bzCompressChunks :: Ptr BzStream -> [BS.ByteString] -> IO [BS.ByteString]
bzCompressChunks p bs =
bracket
(mallocBytes bufSz)
free
(fmap snd . extractBuf bs)
where
fillBuf :: [BS.ByteString] -> BZAction -> Ptr a -> IO (BZError, [BS.ByteString])
fillBuf bs' f bufOut = do
(\ptr val -> do {C2HSImp.pokeByteOff ptr 32 (val :: C2HSImp.CUInt)}) p bufSz
(\ptr val -> do {C2HSImp.pokeByteOff ptr 24 (val :: (C2HSImp.Ptr C2HSImp.CChar))}) p (castPtr bufOut)
ret <- bZ2BzCompress p f
szOut <- fromIntegral <$> (\ptr -> do {C2HSImp.peekByteOff ptr 32 :: IO C2HSImp.CUInt}) p
let bytesAvail = bufSz - szOut
newBSAp <- if bytesAvail /= 0
then (:) <$> BS.packCStringLen (castPtr bufOut, bytesAvail)
else pure id
if ret == BzStreamEnd
then pure (ret, newBSAp [])
else if szOut == 0
then second newBSAp <$> fillBuf bs' f bufOut
else second newBSAp <$> extractBuf bs' bufOut
extractBuf :: [BS.ByteString] -> Ptr a -> IO (BZError, [BS.ByteString])
extractBuf [] bufOut = do
(res, blocks) <- fillBuf [] BzFinish bufOut
if res == BzStreamEnd
then pure (BzStreamEnd, blocks)
else extractBuf [] bufOut
extractBuf (b:bs') bufOut =
BS.unsafeUseAsCStringLen b $ \(buf, sz) -> do
(\ptr val -> do {C2HSImp.pokeByteOff ptr 8 (val :: C2HSImp.CUInt)}) p (fromIntegral sz)
(\ptr val -> do {C2HSImp.pokeByteOff ptr 0 (val :: (C2HSImp.Ptr C2HSImp.CChar))}) p buf
(res, blocks) <- fillBuf bs' BzRun bufOut
if res == BzStreamEnd
then pure (BzStreamEnd, blocks)
else extractBuf bs' bufOut
bufSz :: Integral a => a
bufSz = 32 * 1024
bzCompressInit :: CInt -> CInt -> Ptr BzStream -> IO ()
bzCompressInit blkSize wf p = do
(\ptr val -> do {C2HSImp.pokeByteOff ptr 0 (val :: (C2HSImp.Ptr C2HSImp.CChar))}) p nullPtr
(\ptr val -> do {C2HSImp.pokeByteOff ptr 8 (val :: C2HSImp.CUInt)}) p 0
bZ2BzCompressInit p blkSize 0 wf