{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ZlibException] -> ShowS
$cshowList :: [ZlibException] -> ShowS
show :: ZlibException -> String
$cshow :: ZlibException -> String
showsPrec :: Int -> ZlibException -> ShowS
$cshowsPrec :: Int -> 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
ZStream'
zstr <- IO ZStream'
zstreamNew
ZStream' -> WindowBits -> IO ()
inflateInit2 ZStream'
zstr WindowBits
w
ForeignPtr ZStreamStruct
fzstr <- forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (ZStream' -> IO ())
c_free_z_stream_inflate ZStream'
zstr
ForeignPtr CChar
fbuff <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
defaultChunkSize
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuff forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
IORef ByteString
lastBS <- forall a. a -> IO (IORef a)
newIORef ByteString
S.empty
IORef Bool
complete <- forall a. a -> IO (IORef a)
newIORef Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ZStreamPair
-> IORef ByteString -> IORef Bool -> Maybe ByteString -> Inflate
Inflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff) IORef ByteString
lastBS IORef Bool
complete forall a. Maybe a
Nothing
initInflateWithDictionary :: WindowBits -> S.ByteString -> IO Inflate
initInflateWithDictionary :: WindowBits -> ByteString -> IO Inflate
initInflateWithDictionary WindowBits
w ByteString
bs = do
ZStream'
zstr <- IO ZStream'
zstreamNew
ZStream' -> WindowBits -> IO ()
inflateInit2 ZStream'
zstr WindowBits
w
ForeignPtr ZStreamStruct
fzstr <- forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (ZStream' -> IO ())
c_free_z_stream_inflate ZStream'
zstr
ForeignPtr CChar
fbuff <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
defaultChunkSize
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuff forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
IORef ByteString
lastBS <- forall a. a -> IO (IORef a)
newIORef ByteString
S.empty
IORef Bool
complete <- forall a. a -> IO (IORef a)
newIORef Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ZStreamPair
-> IORef ByteString -> IORef Bool -> Maybe ByteString -> Inflate
Inflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff) IORef ByteString
lastBS IORef Bool
complete (forall a. a -> Maybe a
Just ByteString
bs)
initDeflate :: Int
-> WindowBits -> IO Deflate
initDeflate :: Int -> WindowBits -> IO Deflate
initDeflate Int
level WindowBits
w = do
ZStream'
zstr <- IO ZStream'
zstreamNew
ZStream' -> Int -> WindowBits -> Int -> Strategy -> IO ()
deflateInit2 ZStream'
zstr Int
level WindowBits
w Int
8 Strategy
StrategyDefault
ForeignPtr ZStreamStruct
fzstr <- forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (ZStream' -> IO ())
c_free_z_stream_deflate ZStream'
zstr
ForeignPtr CChar
fbuff <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
defaultChunkSize
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuff forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ZStreamPair -> Deflate
Deflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff)
initDeflateWithDictionary :: Int
-> S.ByteString
-> WindowBits -> IO Deflate
initDeflateWithDictionary :: Int -> ByteString -> WindowBits -> IO Deflate
initDeflateWithDictionary Int
level ByteString
bs WindowBits
w = do
ZStream'
zstr <- IO ZStream'
zstreamNew
ZStream' -> Int -> WindowBits -> Int -> Strategy -> IO ()
deflateInit2 ZStream'
zstr Int
level WindowBits
w Int
8 Strategy
StrategyDefault
ForeignPtr ZStreamStruct
fzstr <- forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (ZStream' -> IO ())
c_free_z_stream_deflate ZStream'
zstr
ForeignPtr CChar
fbuff <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
defaultChunkSize
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
len) -> do
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_call_deflate_set_dictionary ZStream'
zstr Ptr CChar
cstr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuff forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buff ->
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ZStreamPair -> Deflate
Deflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
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
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
lastBS ByteString
bs
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr ->
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs 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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a. a -> Maybe a
Just ByteString
bs) ZStream' -> IO CInt
inflate Bool
False
where
inflate :: ZStream' -> IO CInt
inflate ZStream'
zstr = do
CInt
res <- ZStream' -> IO CInt
c_call_inflate_noflush ZStream'
zstr
CInt
res2 <- if (CInt
res forall a. Eq a => a -> a -> Bool
== CInt
zNeedDict)
then forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return CInt
zNeedDict)
(\ByteString
dict -> (forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
dict 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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
ZStream' -> IO CInt
c_call_inflate_noflush ZStream'
zstr))
Maybe ByteString
inflateDictionary
else forall (m :: * -> *) a. Monad m => a -> m a
return CInt
res
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res2 forall a. Eq a => a -> a -> Bool
== CInt
zStreamEnd) (forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
complete Bool
True)
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
res2
type Popper = IO PopperRes
data PopperRes = PRDone
| PRNext !S.ByteString
| PRError !ZlibException
deriving (Int -> PopperRes -> ShowS
[PopperRes] -> ShowS
PopperRes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PopperRes] -> ShowS
$cshowList :: [PopperRes] -> ShowS
show :: PopperRes -> String
$cshow :: PopperRes -> String
showsPrec :: Int -> PopperRes -> ShowS
$cshowsPrec :: Int -> 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 = forall a. a -> a
id
keepAlive (Just ByteString
bs) = forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr -> forall a. Maybe ByteString -> IO a -> IO a
keepAlive Maybe ByteString
mbs forall a b. (a -> b) -> a -> b
$ do
CInt
res <- ZStream' -> IO CInt
func ZStream'
zstr
if CInt
res forall a. Ord a => a -> a -> Bool
< CInt
0 Bool -> Bool -> Bool
&& CInt
res forall a. Eq a => a -> a -> Bool
/= CInt
zBufError
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ZlibException -> PopperRes
PRError forall a b. (a -> b) -> a -> b
$ Int -> ZlibException
ZlibException forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
res
else do
CUInt
avail <- ZStream' -> IO CUInt
c_get_avail_out ZStream'
zstr
let size :: Int
size = Int
defaultChunkSize forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
avail
toOutput :: Bool
toOutput = CUInt
avail forall a. Eq a => a -> a -> Bool
== CUInt
0 Bool -> Bool -> Bool
|| (Bool
isFinish Bool -> Bool -> Bool
&& Int
size forall a. Eq a => a -> a -> Bool
/= Int
0)
if Bool
toOutput
then forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuff forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buff -> do
ByteString
bs <- CStringLen -> IO ByteString
S.packCStringLen (Ptr CChar
buff, Int
size)
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff
forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> PopperRes
PRNext ByteString
bs
else forall (m :: * -> *) a. Monad m => a -> m a
return PopperRes
PRDone
finishInflate :: Inflate -> IO S.ByteString
finishInflate :: Inflate -> IO ByteString
finishInflate (Inflate (ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff) IORef ByteString
_ IORef Bool
_ Maybe ByteString
_) =
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr ->
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuff forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buff -> do
CUInt
avail <- ZStream' -> IO CUInt
c_get_avail_out ZStream'
zstr
let size :: Int
size = Int
defaultChunkSize forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
avail
ByteString
bs <- CStringLen -> IO ByteString
S.packCStringLen (Ptr CChar
buff, Int
size)
ZStream' -> Ptr CChar -> CUInt -> IO ()
c_set_avail_out ZStream'
zstr Ptr CChar
buff forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
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
ByteString
bs <- forall a. IORef a -> IO a
readIORef IORef ByteString
ref
CUInt
len <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr ZStream' -> IO CUInt
c_get_avail_in
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
bs forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
len) ByteString
bs
isCompleteInflate :: Inflate -> IO Bool
isCompleteInflate :: Inflate -> IO Bool
isCompleteInflate (Inflate ZStreamPair
_ IORef ByteString
_ IORef Bool
complete Maybe ByteString
_) = 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
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ZStreamStruct
fzstr forall a b. (a -> b) -> a -> b
$ \ZStream'
zstr ->
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs 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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (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 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 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 forall a. Maybe a
Nothing ZStream' -> IO CInt
c_call_deflate_full_flush Bool
True