{-# LINE 1 "src/Codec/Compression/BZip/Pack.chs" #-}
{-# LANGUAGE TupleSections #-}
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.Common
import Codec.Compression.BZip.Foreign.Compress
import Codec.Compression.BZip.Common
import Control.Applicative
import Control.Monad.ST.Lazy as LazyST
import Control.Monad.ST.Lazy.Unsafe as LazyST
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.ForeignPtr (castForeignPtr, ForeignPtr, newForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
compress :: BSL.ByteString -> BSL.ByteString
compress = compressWith 9 30
type Step = Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> (BZAction -> IO BZError) -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])
compressWith :: CInt
-> CInt
-> BSL.ByteString
-> BSL.ByteString
compressWith blkSize wf bsl =
let bss = BSL.toChunks bsl in
BSL.fromChunks $ LazyST.runST $ do
(p, bufOut) <- LazyST.unsafeIOToST $ do
ptr <- bzStreamInit
p <- castForeignPtr <$> newForeignPtr bZ2BzCompressEnd (castPtr ptr)
bzCompressInit blkSize wf p
bufOut <- mallocForeignPtrBytes bufSz
pure (p, bufOut)
bzCompressChunks p bss bufOut
bzCompressChunks :: ForeignPtr BzStream -> [BS.ByteString] -> ForeignPtr a -> LazyST.ST s [BS.ByteString]
bzCompressChunks ptr' bs bufO = do
fillBuf ptr' Nothing bs pushBytes bufO
where
fillBuf :: ForeignPtr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> Step -> ForeignPtr a -> LazyST.ST s [BS.ByteString]
fillBuf pForeign passFwd bs' step bufOutForeign = do
(ret, szOut, newBSAp, bs'', keepAlive) <- LazyST.unsafeIOToST $ do
withForeignPtr pForeign $ \p ->
withForeignPtr bufOutForeign $ \bufOut -> do
let act f = 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)
bZ2BzCompress ptr' f
(ret, keepAlive, bs'') <- step p passFwd bs' act
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
pure (ret, szOut, newBSAp, bs'', keepAlive)
let step' = if szOut == 0
then keepBytesAlive
else pushBytes
if ret == BzStreamEnd
then pure (newBSAp [])
else newBSAp <$> fillBuf pForeign keepAlive bs'' step' bufOutForeign
keepBytesAlive :: Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> (BZAction -> IO BZError) -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])
keepBytesAlive _ Nothing [] act = (, Nothing, []) <$> act BzFinish
keepBytesAlive _ Nothing bs' act = (, Nothing, bs') <$> act BzRun
keepBytesAlive _ passFwd@(Just b) [] act =
BS.unsafeUseAsCStringLen b $ \_ ->
(, passFwd, []) <$> act BzFinish
keepBytesAlive _ passFwd@(Just b) bs' act =
BS.unsafeUseAsCStringLen b $ \_ ->
(, passFwd, bs') <$> act BzRun
pushBytes :: Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> (BZAction -> IO BZError) -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])
pushBytes _ _ [] act = (, Nothing, []) <$> act BzFinish
pushBytes p _ (b:bs') act =
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
(, Just b, bs') <$> act BzRun
bufSz :: Integral a => a
bufSz = 16 * 1024
bzCompressInit :: CInt -> CInt -> ForeignPtr BzStream -> IO ()
bzCompressInit blkSize wf ptr' = do
withForeignPtr ptr' $ \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 ptr' blkSize 0 wf