{-# LANGUAGE DeriveDataTypeable #-}
module Codec.Zlib
(
Inflate
, initInflate
, initInflateWithDictionary
, feedInflate
, finishInflate
, flushInflate
, Deflate
, initDeflate
, initDeflateWithDictionary
, feedDeflate
, finishDeflate
, flushDeflate
, WindowBits (..)
, defaultWindowBits
, ZlibException (..)
, Popper
) where
import Codec.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 Control.Monad (when)
import Data.Typeable (Typeable)
import Control.Exception (Exception, throwIO)
type ZStreamPair = (ForeignPtr ZStreamStruct, ForeignPtr CChar)
newtype Inflate = Inflate (ZStreamPair, 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
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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (ZStreamPair, Maybe ByteString) -> Inflate
Inflate ((ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff), 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (ZStreamPair, Maybe ByteString) -> Inflate
Inflate ((ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff), 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), Maybe ByteString
inflateDictionary)) 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) ->
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
if (CInt
res forall a. Eq a => a -> a -> Bool
== CInt
zNeedDict)
then forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e a. Exception e => e -> IO a
throwIO 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
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
type Popper = IO (Maybe S.ByteString)
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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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)
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO 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
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
$ forall a. a -> Maybe a
Just ByteString
bs
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
finishInflate :: Inflate -> IO S.ByteString
finishInflate :: Inflate -> IO ByteString
finishInflate (Inflate ((ForeignPtr ZStreamStruct
fzstr, ForeignPtr CChar
fbuff), 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
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