module Codec.Compression.Zlib.Stream (
Stream,
run,
unsafeInterleave,
unsafeLiftIO,
finalise,
deflateInit,
inflateInit,
Format(..),
CompressionLevel(..),
Method(..),
WindowBits(..),
MemoryLevel(..),
CompressionStrategy(..),
deflate,
inflate,
Status(..),
Flush(..),
pushInputBuffer,
inputBufferEmpty,
pushOutputBuffer,
popOutputBuffer,
outputBufferBytesAvailable,
outputBufferSpaceRemaining,
outputBufferFull,
consistencyCheck,
dump,
trace,
) where
import Foreign
import Foreign.C
import Data.ByteString.Internal
import System.IO.Unsafe (unsafeInterleaveIO)
import System.IO (hPutStrLn, stderr)
import Control.Monad (liftM)
import Control.Exception (assert)
import Prelude hiding (length)
pushInputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream ()
pushInputBuffer inBuf' offset length = do
inAvail <- getInAvail
assert (inAvail == 0) $ return ()
inBuf <- getInBuf
unsafeLiftIO $ touchForeignPtr inBuf
setInBuf inBuf'
setInAvail length
setInNext (unsafeForeignPtrToPtr inBuf' `plusPtr` offset)
inputBufferEmpty :: Stream Bool
inputBufferEmpty = getInAvail >>= return . (==0)
pushOutputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream ()
pushOutputBuffer outBuf' offset length = do
outAvail <- getOutAvail
assert (outAvail == 0) $ return ()
outBuf <- getOutBuf
unsafeLiftIO $ touchForeignPtr outBuf
setOutBuf outBuf'
setOutFree length
setOutNext (unsafeForeignPtrToPtr outBuf' `plusPtr` offset)
setOutOffset offset
setOutAvail 0
popOutputBuffer :: Stream (ForeignPtr Word8, Int, Int)
popOutputBuffer = do
outBuf <- getOutBuf
outOffset <- getOutOffset
outAvail <- getOutAvail
assert (outAvail > 0) $ return ()
setOutOffset (outOffset + outAvail)
setOutAvail 0
return (outBuf, outOffset, outAvail)
outputBufferBytesAvailable :: Stream Int
outputBufferBytesAvailable = getOutAvail
outputBufferSpaceRemaining :: Stream Int
outputBufferSpaceRemaining = getOutFree
outputBufferFull :: Stream Bool
outputBufferFull = getOutFree >>= return . (==0)
deflate :: Flush -> Stream Status
deflate flush = do
outFree <- getOutFree
assert (outFree > 0) $ return ()
result <- deflate_ flush
outFree' <- getOutFree
let outExtra = outFree outFree'
outAvail <- getOutAvail
setOutAvail (outAvail + outExtra)
return result
inflate :: Flush -> Stream Status
inflate flush = do
outFree <- getOutFree
assert (outFree > 0) $ return ()
result <- inflate_ flush
outFree' <- getOutFree
let outExtra = outFree outFree'
outAvail <- getOutAvail
setOutAvail (outAvail + outExtra)
return result
newtype Stream a = Z {
unZ :: ForeignPtr StreamState
-> ForeignPtr Word8
-> ForeignPtr Word8
-> Int -> Int
-> IO (ForeignPtr Word8
,ForeignPtr Word8
,Int, Int, a)
}
instance Monad Stream where
(>>=) = thenZ
(>>) = thenZ_
return = returnZ
fail = (finalise >>) . failZ
returnZ :: a -> Stream a
returnZ a = Z $ \_ inBuf outBuf outOffset outLength ->
return (inBuf, outBuf, outOffset, outLength, a)
thenZ :: Stream a -> (a -> Stream b) -> Stream b
thenZ (Z m) f =
Z $ \stream inBuf outBuf outOffset outLength ->
m stream inBuf outBuf outOffset outLength >>=
\(inBuf', outBuf', outOffset', outLength', a) ->
unZ (f a) stream inBuf' outBuf' outOffset' outLength'
thenZ_ :: Stream a -> Stream b -> Stream b
thenZ_ (Z m) f =
Z $ \stream inBuf outBuf outOffset outLength ->
m stream inBuf outBuf outOffset outLength >>=
\(inBuf', outBuf', outOffset', outLength', _) ->
unZ f stream inBuf' outBuf' outOffset' outLength'
failZ :: String -> Stream a
failZ msg = Z (\_ _ _ _ _ -> fail ("Codec.Compression.Zlib: " ++ msg))
run :: Stream a -> a
run (Z m) = unsafePerformIO $ do
ptr <- mallocBytes (56)
(\hsc_ptr -> pokeByteOff hsc_ptr 32) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 36) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 40) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (0 :: CUInt)
(\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (0 :: CUInt)
stream <- newForeignPtr_ ptr
(_,_,_,_,a) <- m stream nullForeignPtr nullForeignPtr 0 0
return a
unsafeLiftIO :: IO a -> Stream a
unsafeLiftIO m = Z $ \_stream inBuf outBuf outOffset outLength -> do
a <- m
return (inBuf, outBuf, outOffset, outLength, a)
unsafeInterleave :: Stream a -> Stream a
unsafeInterleave (Z m) = Z $ \stream inBuf outBuf outOffset outLength -> do
res <- unsafeInterleaveIO (m stream inBuf outBuf outOffset outLength)
let select (_,_,_,_,a) = a
return (inBuf, outBuf, outOffset, outLength, select res)
getStreamState :: Stream (ForeignPtr StreamState)
getStreamState = Z $ \stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, stream)
getInBuf :: Stream (ForeignPtr Word8)
getInBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, inBuf)
getOutBuf :: Stream (ForeignPtr Word8)
getOutBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, outBuf)
getOutOffset :: Stream Int
getOutOffset = Z $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, outOffset)
getOutAvail :: Stream Int
getOutAvail = Z $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, outLength)
setInBuf :: ForeignPtr Word8 -> Stream ()
setInBuf inBuf = Z $ \_stream _ outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, ())
setOutBuf :: ForeignPtr Word8 -> Stream ()
setOutBuf outBuf = Z $ \_stream inBuf _ outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, ())
setOutOffset :: Int -> Stream ()
setOutOffset outOffset = Z $ \_stream inBuf outBuf _ outLength -> do
return (inBuf, outBuf, outOffset, outLength, ())
setOutAvail :: Int -> Stream ()
setOutAvail outLength = Z $ \_stream inBuf outBuf outOffset _ -> do
return (inBuf, outBuf, outOffset, outLength, ())
trace :: String -> Stream ()
trace = unsafeLiftIO . hPutStrLn stderr
dump :: Stream ()
dump = do
inNext <- getInNext
inAvail <- getInAvail
outNext <- getOutNext
outFree <- getOutFree
outAvail <- getOutAvail
outOffset <- getOutOffset
unsafeLiftIO $ hPutStrLn stderr $
"Stream {\n" ++
" inNext = " ++ show inNext ++ ",\n" ++
" inAvail = " ++ show inAvail ++ ",\n" ++
"\n" ++
" outNext = " ++ show outNext ++ ",\n" ++
" outFree = " ++ show outFree ++ ",\n" ++
" outAvail = " ++ show outAvail ++ ",\n" ++
" outOffset = " ++ show outOffset ++ "\n" ++
"}"
consistencyCheck
consistencyCheck :: Stream ()
consistencyCheck = do
outBuf <- getOutBuf
outOffset <- getOutOffset
outAvail <- getOutAvail
outNext <- getOutNext
let outBufPtr = unsafeForeignPtrToPtr outBuf
assert (outBufPtr `plusPtr` (outOffset + outAvail) == outNext) $ return ()
data Status =
Ok
| StreamEnd
| NeedDict
| BufferError
instance Enum Status where
toEnum (0) = Ok
toEnum (1) = StreamEnd
toEnum (2) = NeedDict
toEnum (5) = BufferError
toEnum other = error ("unexpected zlib status: " ++ show other)
isFatalError :: CInt -> Bool
isFatalError n | n >= 0 = False
isFatalError (5) = False
isFatalError _ = True
throwError :: Stream a
throwError = do
msg <- withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 24))
msg' <- unsafeLiftIO (peekCString msg)
fail msg'
data Flush =
NoFlush
| SyncFlush
| FullFlush
| Finish
instance Enum Flush where
fromEnum NoFlush = 0
fromEnum SyncFlush = 2
fromEnum FullFlush = 3
fromEnum Finish = 4
data Format =
GZip
| Zlib
| Raw
| GZipOrZlib
data Method = Deflated
instance Enum Method where
fromEnum Deflated = 8
data CompressionLevel =
DefaultCompression
| NoCompression
| BestSpeed
| BestCompression
| CompressionLevel Int
instance Enum CompressionLevel where
fromEnum DefaultCompression = 1
fromEnum NoCompression = 0
fromEnum BestSpeed = 1
fromEnum BestCompression = 9
fromEnum (CompressionLevel n)
| n >= 1 && n <= 9 = n
| otherwise = error "CompressLevel must be in the range 1..9"
data WindowBits = DefaultWindowBits
| WindowBits Int
windowBits :: Format -> WindowBits-> Int
windowBits format bits = (formatModifier format) (checkWindowBits bits)
where checkWindowBits DefaultWindowBits = 15
checkWindowBits (WindowBits n)
| n >= 8 && n <= 15 = n
| otherwise = error "WindowBits must be in the range 8..15"
formatModifier Zlib = id
formatModifier GZip = (+16)
formatModifier GZipOrZlib = (+32)
formatModifier Raw = negate
data MemoryLevel =
DefaultMemoryLevel
| MinMemoryLevel
| MaxMemoryLevel
| MemoryLevel Int
instance Enum MemoryLevel where
fromEnum DefaultMemoryLevel = 8
fromEnum MinMemoryLevel = 1
fromEnum MaxMemoryLevel = 9
fromEnum (MemoryLevel n)
| n >= 1 && n <= 9 = n
| otherwise = error "MemoryLevel must be in the range 1..9"
data CompressionStrategy =
DefaultStrategy
| Filtered
| HuffmanOnly
instance Enum CompressionStrategy where
fromEnum DefaultStrategy = 0
fromEnum Filtered = 1
fromEnum HuffmanOnly = 2
withStreamPtr :: (Ptr StreamState -> IO a) -> Stream a
withStreamPtr f = do
stream <- getStreamState
unsafeLiftIO (withForeignPtr stream f)
setInAvail :: Int -> Stream ()
setInAvail val = withStreamPtr $ \ptr ->
(\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (fromIntegral val :: CUInt)
getInAvail :: Stream Int
getInAvail = liftM (fromIntegral :: CUInt -> Int) $
withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 4))
setInNext :: Ptr Word8 -> Stream ()
setInNext val = withStreamPtr (\ptr -> (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr val)
getInNext :: Stream (Ptr Word8)
getInNext = withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 0))
setOutFree :: Int -> Stream ()
setOutFree val = withStreamPtr $ \ptr ->
(\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (fromIntegral val :: CUInt)
getOutFree :: Stream Int
getOutFree = liftM (fromIntegral :: CUInt -> Int) $
withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 16))
setOutNext :: Ptr Word8 -> Stream ()
setOutNext val = withStreamPtr (\ptr -> (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr val)
getOutNext :: Stream (Ptr Word8)
getOutNext = withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 12))
inflateInit :: Format -> WindowBits -> Stream ()
inflateInit format bits = do
err <- withStreamPtr $ \ptr ->
c_inflateInit2 ptr (fromIntegral (windowBits format bits))
if isFatalError err
then throwError
else do stream <- getStreamState
unsafeLiftIO $ addForeignPtrFinalizer c_inflateEnd stream
deflateInit :: Format
-> CompressionLevel
-> Method
-> WindowBits
-> MemoryLevel
-> CompressionStrategy
-> Stream ()
deflateInit format compLevel method bits memLevel strategy = do
err <- withStreamPtr $ \ptr ->
c_deflateInit2 ptr
(fromIntegral (fromEnum compLevel))
(fromIntegral (fromEnum method))
(fromIntegral (windowBits format bits))
(fromIntegral (fromEnum memLevel))
(fromIntegral (fromEnum strategy))
if isFatalError err
then throwError
else do stream <- getStreamState
unsafeLiftIO $ addForeignPtrFinalizer c_deflateEnd stream
inflate_ :: Flush -> Stream Status
inflate_ flush = do
err <- withStreamPtr (\ptr -> c_inflate ptr (fromIntegral (fromEnum flush)))
if isFatalError err
then throwError
else return (toEnum (fromIntegral err))
deflate_ :: Flush -> Stream Status
deflate_ flush = do
err <- withStreamPtr (\ptr -> c_deflate ptr (fromIntegral (fromEnum flush)))
if isFatalError err
then throwError
else return (toEnum (fromIntegral err))
finalise :: Stream ()
finalise = getStreamState >>= unsafeLiftIO . finalizeForeignPtr
data StreamState = StreamState ()
foreign import ccall unsafe "zlib.h inflateInit2"
c_inflateInit2 :: Ptr StreamState -> CInt -> IO CInt
foreign import ccall unsafe "zlib.h inflate"
c_inflate :: Ptr StreamState -> CInt -> IO CInt
foreign import ccall unsafe "zlib.h &inflateEnd"
c_inflateEnd :: FinalizerPtr StreamState
foreign import ccall unsafe "zlib.h deflateInit2"
c_deflateInit2 :: Ptr StreamState
-> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "zlib.h deflate"
c_deflate :: Ptr StreamState -> CInt -> IO CInt
foreign import ccall unsafe "zlib.h &deflateEnd"
c_deflateEnd :: FinalizerPtr StreamState