{-# LANGUAGE DeriveDataTypeable #-}
module Data.Streaming.Zlib
(
Inflate
, initInflate
, initInflateWithDictionary
, feedInflate
, finishInflate
, flushInflate
, getUnusedInflate
, isCompleteInflate
, Deflate
, initDeflate
, initDeflateWithDictionary
, feedDeflate
, finishDeflate
, flushDeflate
, fullFlushDeflate
, WindowBits (..)
, defaultWindowBits
, ZlibException (..)
, Popper
, PopperRes (..)
) where
import Data.Streaming.Zlib.Lowlevel
import Foreign.ForeignPtr
import Foreign.C.Types
import Data.ByteString.Unsafe
import Codec.Compression.Zlib (WindowBits(WindowBits), defaultWindowBits)
import qualified Data.ByteString as S
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import Control.Monad (when)
import Data.IORef
type ZStreamPair = (ForeignPtr ZStreamStruct, ForeignPtr CChar)
data Inflate = Inflate
ZStreamPair
(IORef S.ByteString)
(IORef Bool)
(Maybe S.ByteString)
newtype Deflate = Deflate ZStreamPair
data ZlibException = ZlibException Int
deriving (Int -> ZlibException -> ShowS
[ZlibException] -> ShowS
ZlibException -> String
(Int -> ZlibException -> ShowS)
-> (ZlibException -> String)
-> ([ZlibException] -> ShowS)
-> Show ZlibException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ZlibException -> ShowS
showsPrec :: Int -> ZlibException -> ShowS
$cshow :: ZlibException -> String
show :: ZlibException -> String
$cshowList :: [ZlibException] -> ShowS
showList :: [ZlibException] -> ShowS
Show, Typeable)
instance Exception ZlibException
zStreamEnd :: CInt
zStreamEnd :: CInt
zStreamEnd = CInt
1
zNeedDict :: CInt
zNeedDict :: CInt
zNeedDict = CInt
2
zBufError :: CInt
zBufError :: CInt
zBufError = -CInt
5
initInflate :: WindowBits -> IO Inflate
initInflate :: WindowBits -> IO Inflate
initInflate WindowBits
w = do
zstr <- IO ZStream'
zstreamNew
inflateInit2 zstr w
fzstr <- newForeignPtr c_free_z_stream_inflate zstr
fbuff <- mallocForeignPtrBytes defaultChunkSize
withForeignPtr fbuff $ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
lastBS <- newIORef S.empty
complete <- newIORef False
return $ Inflate (fzstr, fbuff) lastBS complete Nothing
initInflateWithDictionary :: WindowBits -> S.ByteString -> IO Inflate
initInflateWithDictionary :: WindowBits -> ByteString -> IO Inflate
initInflateWithDictionary WindowBits
w ByteString
bs = do
zstr <- IO ZStream'
zstreamNew
inflateInit2 zstr w
fzstr <- newForeignPtr c_free_z_stream_inflate zstr
fbuff <- mallocForeignPtrBytes defaultChunkSize
withForeignPtr fbuff $ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
lastBS <- newIORef S.empty
complete <- newIORef False
return $ Inflate (fzstr, fbuff) lastBS complete (Just bs)
initDeflate :: Int
-> WindowBits -> IO Deflate
initDeflate :: Int -> WindowBits -> IO Deflate
initDeflate Int
level WindowBits
w = do
zstr <- IO ZStream'
zstreamNew
deflateInit2 zstr level w 8 StrategyDefault
fzstr <- newForeignPtr c_free_z_stream_deflate zstr
fbuff <- mallocForeignPtrBytes defaultChunkSize
withForeignPtr fbuff $ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
return $ Deflate (fzstr, fbuff)
initDeflateWithDictionary :: Int
-> S.ByteString
-> WindowBits -> IO Deflate
initDeflateWithDictionary :: Int -> ByteString -> WindowBits -> IO Deflate
initDeflateWithDictionary Int
level ByteString
bs WindowBits
w = do
zstr <- IO ZStream'
zstreamNew
deflateInit2 zstr level w 8 StrategyDefault
fzstr <- newForeignPtr c_free_z_stream_deflate zstr
fbuff <- mallocForeignPtrBytes defaultChunkSize
unsafeUseAsCStringLen bs $ \(Ptr CChar
cstr, Int
len) -> do
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_call_deflate_set_dictionary ZStream'
zstr Ptr CChar
cstr (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
withForeignPtr fbuff $ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
return $ Deflate (fzstr, fbuff)
feedInflate
:: Inflate
-> S.ByteString
-> IO Popper
feedInflate :: Inflate -> ByteString -> IO Popper
feedInflate (Inflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff) IORef ByteString
lastBS IORef Bool
complete Maybe ByteString
inflateDictionary) ByteString
bs = do
IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
lastBS ByteString
bs
ForeignPtr ZStreamStruct -> (ZStream' -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr ((ZStream' -> IO ()) -> IO ()) -> (ZStream' -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr ->
ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
len) ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_in ZStream'
zstr Ptr CChar
cstr (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
Popper -> IO Popper
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Popper -> IO Popper) -> Popper -> IO Popper
forall a b. (a -> b) -> a -> b
$ ForeignPtr CChar
-> ForeignPtr ZStreamStruct
-> Maybe ByteString
-> (ZStream' -> IO CInt)
-> Bool
-> Popper
drain ForeignPtr CChar
fbuff ForeignPtr ZStreamStruct
fzstr (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs) ZStream' -> IO CInt
inflate Bool
False
where
inflate :: ZStream' -> IO CInt
inflate ZStream'
zstr = do
res <- ZStream' -> IO CInt
c_call_inflate_noflush ZStream'
zstr
res2 <- if (res == zNeedDict)
then maybe (return zNeedDict)
(\ByteString
dict -> (ByteString -> (CStringLen -> IO CInt) -> IO CInt
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
dict ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
len) -> do
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_call_inflate_set_dictionary ZStream'
zstr Ptr CChar
cstr (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
ZStream' -> IO CInt
c_call_inflate_noflush ZStream'
zstr))
inflateDictionary
else return res
when (res2 == zStreamEnd) (writeIORef complete True)
return res2
type Popper = IO PopperRes
data PopperRes = PRDone
| PRNext !S.ByteString
| PRError !ZlibException
deriving (Int -> PopperRes -> ShowS
[PopperRes] -> ShowS
PopperRes -> String
(Int -> PopperRes -> ShowS)
-> (PopperRes -> String)
-> ([PopperRes] -> ShowS)
-> Show PopperRes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PopperRes -> ShowS
showsPrec :: Int -> PopperRes -> ShowS
$cshow :: PopperRes -> String
show :: PopperRes -> String
$cshowList :: [PopperRes] -> ShowS
showList :: [PopperRes] -> ShowS
Show, Typeable)
keepAlive :: Maybe S.ByteString -> IO a -> IO a
keepAlive :: forall a. Maybe ByteString -> IO a -> IO a
keepAlive Maybe ByteString
Nothing = IO a -> IO a
forall a. a -> a
id
keepAlive (Just ByteString
bs) = ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO a) -> IO a)
-> (IO a -> CStringLen -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> CStringLen -> IO a
forall a b. a -> b -> a
const
drain :: ForeignPtr CChar
-> ForeignPtr ZStreamStruct
-> Maybe S.ByteString
-> (ZStream' -> IO CInt)
-> Bool
-> Popper
drain :: ForeignPtr CChar
-> ForeignPtr ZStreamStruct
-> Maybe ByteString
-> (ZStream' -> IO CInt)
-> Bool
-> Popper
drain ForeignPtr CChar
fbuff ForeignPtr ZStreamStruct
fzstr Maybe ByteString
mbs ZStream' -> IO CInt
func Bool
isFinish = ForeignPtr ZStreamStruct -> (ZStream' -> Popper) -> Popper
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr ((ZStream' -> Popper) -> Popper) -> (ZStream' -> Popper) -> Popper
forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr -> Maybe ByteString -> Popper -> Popper
forall a. Maybe ByteString -> IO a -> IO a
keepAlive Maybe ByteString
mbs (Popper -> Popper) -> Popper -> Popper
forall a b. (a -> b) -> a -> b
$ do
res <- ZStream' -> IO CInt
func ZStream'
zstr
if res < 0 && res /= zBufError
then return $ PRError $ ZlibException $ fromIntegral res
else do
avail <- c_get_avail_out zstr
let size = Int
defaultChunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
avail
toOutput = CUInt
avail CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
0 Bool -> Bool -> Bool
|| (Bool
isFinish Bool -> Bool -> Bool
&& Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)
if toOutput
then withForeignPtr fbuff $ \Ptr CChar
buff -> do
bs <- CStringLen -> IO ByteString
S.packCStringLen (Ptr CChar
buff, Int
size)
c_set_avail_out zstr buff
$ fromIntegral defaultChunkSize
return $ PRNext bs
else return PRDone
finishInflate :: Inflate -> IO S.ByteString
finishInflate :: Inflate -> IO ByteString
finishInflate (Inflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff) IORef ByteString
_ IORef Bool
_ Maybe ByteString
_) =
ForeignPtr ZStreamStruct
-> (ZStream' -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr ((ZStream' -> IO ByteString) -> IO ByteString)
-> (ZStream' -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr ->
ForeignPtr CChar -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuff ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buff -> do
avail <- ZStream' -> IO CUInt
c_get_avail_out ZStream'
zstr
let size = Int
defaultChunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
avail
bs <- S.packCStringLen (buff, size)
c_set_avail_out zstr buff $ fromIntegral defaultChunkSize
return bs
flushInflate :: Inflate -> IO S.ByteString
flushInflate :: Inflate -> IO ByteString
flushInflate = Inflate -> IO ByteString
finishInflate
getUnusedInflate :: Inflate -> IO S.ByteString
getUnusedInflate :: Inflate -> IO ByteString
getUnusedInflate (Inflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
_) IORef ByteString
ref IORef Bool
_ Maybe ByteString
_) = do
bs <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
ref
len <- withForeignPtr fzstr c_get_avail_in
return $ S.drop (S.length bs - fromIntegral len) bs
isCompleteInflate :: Inflate -> IO Bool
isCompleteInflate :: Inflate -> IO Bool
isCompleteInflate (Inflate ZStreamPair
_ IORef ByteString
_ IORef Bool
complete Maybe ByteString
_) = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
complete
feedDeflate :: Deflate -> S.ByteString -> IO Popper
feedDeflate :: Deflate -> ByteString -> IO Popper
feedDeflate (Deflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff)) ByteString
bs = do
ForeignPtr ZStreamStruct -> (ZStream' -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr ((ZStream' -> IO ()) -> IO ()) -> (ZStream' -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr ->
ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
len) -> do
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_in ZStream'
zstr Ptr CChar
cstr (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
Popper -> IO Popper
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Popper -> IO Popper) -> Popper -> IO Popper
forall a b. (a -> b) -> a -> b
$ ForeignPtr CChar
-> ForeignPtr ZStreamStruct
-> Maybe ByteString
-> (ZStream' -> IO CInt)
-> Bool
-> Popper
drain ForeignPtr CChar
fbuff ForeignPtr ZStreamStruct
fzstr (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs) ZStream' -> IO CInt
c_call_deflate_noflush Bool
False
finishDeflate :: Deflate -> Popper
finishDeflate :: Deflate -> Popper
finishDeflate (Deflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff)) =
ForeignPtr CChar
-> ForeignPtr ZStreamStruct
-> Maybe ByteString
-> (ZStream' -> IO CInt)
-> Bool
-> Popper
drain ForeignPtr CChar
fbuff ForeignPtr ZStreamStruct
fzstr Maybe ByteString
forall a. Maybe a
Nothing ZStream' -> IO CInt
c_call_deflate_finish Bool
True
flushDeflate :: Deflate -> Popper
flushDeflate :: Deflate -> Popper
flushDeflate (Deflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff)) =
ForeignPtr CChar
-> ForeignPtr ZStreamStruct
-> Maybe ByteString
-> (ZStream' -> IO CInt)
-> Bool
-> Popper
drain ForeignPtr CChar
fbuff ForeignPtr ZStreamStruct
fzstr Maybe ByteString
forall a. Maybe a
Nothing ZStream' -> IO CInt
c_call_deflate_flush Bool
True
fullFlushDeflate :: Deflate -> Popper
fullFlushDeflate :: Deflate -> Popper
fullFlushDeflate (Deflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff)) =
ForeignPtr CChar
-> ForeignPtr ZStreamStruct
-> Maybe ByteString
-> (ZStream' -> IO CInt)
-> Bool
-> Popper
drain ForeignPtr CChar
fbuff ForeignPtr ZStreamStruct
fzstr Maybe ByteString
forall a. Maybe a
Nothing ZStream' -> IO CInt
c_call_deflate_full_flush Bool
True