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
( Word8, Ptr, nullPtr, plusPtr, peekByteOff, pokeByteOff, mallocBytes
, ForeignPtr, FinalizerPtr, newForeignPtr_, addForeignPtrFinalizer
, finalizeForeignPtr, withForeignPtr, touchForeignPtr
, unsafeForeignPtrToPtr, unsafePerformIO )
import Foreign.C
( CInt, CUInt, CChar, CString, withCAString, peekCAString )
import Data.ByteString.Internal (nullForeignPtr)
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 24) ptr nullPtr
(\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
toStatus :: CInt -> Status
toStatus (0) = Ok
toStatus (1) = StreamEnd
toStatus (2) = NeedDict
toStatus (5) = BufferError
toStatus other = error ("unexpected zlib status: " ++ show other)
failIfError :: CInt -> Stream ()
failIfError errno
| errno >= 0
|| errno == 5 = return ()
| otherwise = fail =<< getErrorMessage errno
getErrorMessage :: CInt -> Stream String
getErrorMessage errno = do
msgPtr <- withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 24))
if msgPtr /= nullPtr
then unsafeLiftIO (peekCAString msgPtr)
else return $ case errno of
1 -> "file error"
2 -> "stream error"
3 -> "data error"
4 -> "insufficient memory"
6 -> "incompatible version"
_ -> "unknown error"
data Flush =
NoFlush
| SyncFlush
| FullFlush
| Finish
fromFlush :: Flush -> CInt
fromFlush NoFlush = 0
fromFlush SyncFlush = 2
fromFlush FullFlush = 3
fromFlush Finish = 4
data Format =
GZip
| Zlib
| Raw
| GZipOrZlib
deriving Eq
data Method = Deflated
fromMethod :: Method -> CInt
fromMethod Deflated = 8
data CompressionLevel =
DefaultCompression
| NoCompression
| BestSpeed
| BestCompression
| CompressionLevel Int
fromCompressionLevel :: CompressionLevel -> CInt
fromCompressionLevel DefaultCompression = 1
fromCompressionLevel NoCompression = 0
fromCompressionLevel BestSpeed = 1
fromCompressionLevel BestCompression = 9
fromCompressionLevel (CompressionLevel n)
| n >= 1 && n <= 9 = fromIntegral n
| otherwise = error "CompressLevel must be in the range 1..9"
data WindowBits = DefaultWindowBits
| WindowBits Int
windowBits :: Format -> WindowBits-> CInt
windowBits format bits = (formatModifier format) (checkWindowBits bits)
where checkWindowBits DefaultWindowBits = 15
checkWindowBits (WindowBits n)
| n >= 8 && n <= 15 = fromIntegral 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
fromMemoryLevel :: MemoryLevel -> CInt
fromMemoryLevel DefaultMemoryLevel = 8
fromMemoryLevel MinMemoryLevel = 1
fromMemoryLevel MaxMemoryLevel = 9
fromMemoryLevel (MemoryLevel n)
| n >= 1 && n <= 9 = fromIntegral n
| otherwise = error "MemoryLevel must be in the range 1..9"
data CompressionStrategy =
DefaultStrategy
| Filtered
| HuffmanOnly
fromCompressionStrategy :: CompressionStrategy -> CInt
fromCompressionStrategy DefaultStrategy = 0
fromCompressionStrategy Filtered = 1
fromCompressionStrategy HuffmanOnly = 2
withStreamPtr :: (Ptr StreamState -> IO a) -> Stream a
withStreamPtr f = do
stream <- getStreamState
unsafeLiftIO (withForeignPtr stream f)
withStreamState :: (StreamState -> IO a) -> Stream a
withStreamState f = do
stream <- getStreamState
unsafeLiftIO (withForeignPtr stream (f . StreamState))
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
checkFormatSupported format
err <- withStreamState $ \zstream ->
c_inflateInit2 zstream (fromIntegral (windowBits format bits))
failIfError err
getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer c_inflateEnd
deflateInit :: Format
-> CompressionLevel
-> Method
-> WindowBits
-> MemoryLevel
-> CompressionStrategy
-> Stream ()
deflateInit format compLevel method bits memLevel strategy = do
checkFormatSupported format
err <- withStreamState $ \zstream ->
c_deflateInit2 zstream
(fromCompressionLevel compLevel)
(fromMethod method)
(windowBits format bits)
(fromMemoryLevel memLevel)
(fromCompressionStrategy strategy)
failIfError err
getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer c_deflateEnd
inflate_ :: Flush -> Stream Status
inflate_ flush = do
err <- withStreamState $ \zstream ->
c_inflate zstream (fromFlush flush)
failIfError err
return (toStatus err)
deflate_ :: Flush -> Stream Status
deflate_ flush = do
err <- withStreamState $ \zstream ->
c_deflate zstream (fromFlush flush)
failIfError err
return (toStatus err)
finalise :: Stream ()
finalise = getStreamState >>= unsafeLiftIO . finalizeForeignPtr
checkFormatSupported :: Format -> Stream ()
checkFormatSupported format = do
version <- unsafeLiftIO (peekCAString =<< c_zlibVersion)
case version of
('1':'.':'1':'.':_)
| format == GZip
|| format == GZipOrZlib
-> fail $ "version 1.1.x of the zlib C library does not support the"
++ " 'gzip' format via the in-memory api, only the 'raw' and "
++ " 'zlib' formats."
_ -> return ()
newtype StreamState = StreamState (Ptr StreamState)
foreign import ccall unsafe "zlib.h inflateInit2_"
c_inflateInit2_ :: StreamState -> CInt -> Ptr CChar -> CInt -> IO CInt
c_inflateInit2 :: StreamState -> CInt -> IO CInt
c_inflateInit2 z n =
withCAString "1.2.3.4" $ \versionStr ->
c_inflateInit2_ z n versionStr (56 :: CInt)
foreign import ccall unsafe "zlib.h inflate"
c_inflate :: StreamState -> CInt -> IO CInt
foreign import ccall unsafe "zlib.h &inflateEnd"
c_inflateEnd :: FinalizerPtr StreamState
foreign import ccall unsafe "zlib.h deflateInit2_"
c_deflateInit2_ :: StreamState
-> CInt -> CInt -> CInt -> CInt -> CInt
-> Ptr CChar -> CInt
-> IO CInt
c_deflateInit2 :: StreamState
-> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt
c_deflateInit2 z a b c d e =
withCAString "1.2.3.4" $ \versionStr ->
c_deflateInit2_ z a b c d e versionStr (56 :: CInt)
foreign import ccall unsafe "zlib.h deflate"
c_deflate :: StreamState -> CInt -> IO CInt
foreign import ccall unsafe "zlib.h &deflateEnd"
c_deflateEnd :: FinalizerPtr StreamState
foreign import ccall unsafe "zlib.h zlibVersion"
c_zlibVersion :: IO CString