module Codec.Compression.BZip.Stream (
Stream,
run,
unsafeInterleave,
unsafeLiftIO,
finalise,
compressInit,
decompressInit,
BlockSize(..),
WorkFactor(..),
MemoryLevel(..),
Verbosity(..),
compress,
decompress,
Status(..),
Action(..),
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)
compress :: Action -> Stream Status
compress action = do
outFree <- getOutFree
assert (outFree > 0) $ return ()
result <- compress_ action
outFree' <- getOutFree
let outExtra = outFree outFree'
outAvail <- getOutAvail
setOutAvail (outAvail + outExtra)
return result
decompress :: Stream Status
decompress = do
outFree <- getOutFree
assert (outFree > 0) $ return ()
result <- decompress_
outFree' <- getOutFree
let outExtra = outFree outFree'
outAvail <- getOutAvail
setOutAvail (outAvail + outExtra)
return result
newtype Stream a = BZ {
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 = BZ $ \_ inBuf outBuf outOffset outLength ->
return (inBuf, outBuf, outOffset, outLength, a)
thenZ :: Stream a -> (a -> Stream b) -> Stream b
thenZ (BZ m) f =
BZ $ \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_ (BZ m) f =
BZ $ \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 = BZ (\_ _ _ _ _ -> fail ("Codec.Compression.BZip: " ++ msg))
run :: Stream a -> a
run (BZ m) = unsafePerformIO $ do
ptr <- mallocBytes (48)
(\hsc_ptr -> pokeByteOff hsc_ptr 36) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 40) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 44) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr nullPtr
(\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (0 :: CUInt)
(\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr (0 :: CUInt)
stream <- newForeignPtr_ ptr
(_,_,_,_,a) <- m stream nullForeignPtr nullForeignPtr 0 0
return a
unsafeLiftIO :: IO a -> Stream a
unsafeLiftIO m = BZ $ \_stream inBuf outBuf outOffset outLength -> do
a <- m
return (inBuf, outBuf, outOffset, outLength, a)
unsafeInterleave :: Stream a -> Stream a
unsafeInterleave (BZ m) = BZ $ \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 = BZ $ \stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, stream)
getInBuf :: Stream (ForeignPtr Word8)
getInBuf = BZ $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, inBuf)
getOutBuf :: Stream (ForeignPtr Word8)
getOutBuf = BZ $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, outBuf)
getOutOffset :: Stream Int
getOutOffset = BZ $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, outOffset)
getOutAvail :: Stream Int
getOutAvail = BZ $ \_stream inBuf outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, outLength)
setInBuf :: ForeignPtr Word8 -> Stream ()
setInBuf inBuf = BZ $ \_stream _ outBuf outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, ())
setOutBuf :: ForeignPtr Word8 -> Stream ()
setOutBuf outBuf = BZ $ \_stream inBuf _ outOffset outLength -> do
return (inBuf, outBuf, outOffset, outLength, ())
setOutOffset :: Int -> Stream ()
setOutOffset outOffset = BZ $ \_stream inBuf outBuf _ outLength -> do
return (inBuf, outBuf, outOffset, outLength, ())
setOutAvail :: Int -> Stream ()
setOutAvail outLength = BZ $ \_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
instance Enum Status where
toEnum (0) = Ok
toEnum (1) = Ok
toEnum (2) = Ok
toEnum (3) = Ok
toEnum (4) = StreamEnd
toEnum other = error ("unexpected bzip2 status: " ++ show other)
failIfError :: CInt -> Stream ()
failIfError errno
| errno >= 0 = return ()
| otherwise = fail (getErrorMessage errno)
getErrorMessage :: CInt -> String
getErrorMessage errno = case errno of
1 -> "incorrect sequence of calls"
2 -> "incorrect parameter"
3 -> "not enough memory"
4 -> "compressed data stream is corrupt"
5 -> "data stream is not a bzip2 file"
9 -> "configuration error in bzip2 lib"
other -> "unknown or impossible error code: "
++ show other
data Action =
Run
| Flush
| Finish
instance Enum Action where
fromEnum Run = 0
fromEnum Flush = 1
fromEnum Finish = 2
data BlockSize =
DefaultBlockSize
| BlockSize Int
instance Enum BlockSize where
fromEnum DefaultBlockSize = 9
fromEnum (BlockSize n)
| n >= 1 && n <= 9 = n
| otherwise = error "BlockSize must be in the range 1..9"
data MemoryLevel =
DefaultMemoryLevel
| MinMemoryLevel
instance Enum MemoryLevel where
fromEnum DefaultMemoryLevel = 0
fromEnum MinMemoryLevel = 1
data WorkFactor =
DefaultWorkFactor
| WorkFactor Int
instance Enum WorkFactor where
fromEnum DefaultWorkFactor = 0
fromEnum (WorkFactor n)
| n >= 1 && n <= 250 = n
| otherwise = error "WorkFactor must be in the range 1..250"
data Verbosity = Silent
| Verbosity Int
instance Enum Verbosity where
fromEnum Silent = 0
fromEnum (Verbosity n)
| n >= 0 && n <= 4 = n
| otherwise = error "Verbosity must be in the range 0..4"
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 20) ptr (fromIntegral val :: CUInt)
getOutFree :: Stream Int
getOutFree = liftM (fromIntegral :: CUInt -> Int) $
withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 20))
setOutNext :: Ptr Word8 -> Stream ()
setOutNext val = withStreamPtr (\ptr -> (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr val)
getOutNext :: Stream (Ptr Word8)
getOutNext = withStreamPtr ((\hsc_ptr -> peekByteOff hsc_ptr 16))
decompressInit :: Verbosity -> MemoryLevel -> Stream ()
decompressInit verbosity memoryLevel = do
err <- withStreamState $ \bzstream ->
bzDecompressInit bzstream
(fromIntegral (fromEnum verbosity))
(fromIntegral (fromEnum memoryLevel))
failIfError err
getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer bzDecompressEnd
compressInit :: BlockSize -> Verbosity -> WorkFactor -> Stream ()
compressInit blockSize verbosity workFactor = do
err <- withStreamState $ \bzstream ->
bzCompressInit bzstream
(fromIntegral (fromEnum blockSize))
(fromIntegral (fromEnum verbosity))
(fromIntegral (fromEnum workFactor))
failIfError err
getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer bzCompressEnd
decompress_ :: Stream Status
decompress_ = do
err <- withStreamState $ \bzstream ->
bzDecompress bzstream
failIfError err
return (toEnum (fromIntegral err))
compress_ :: Action -> Stream Status
compress_ action = do
err <- withStreamState $ \bzstream ->
bzCompress bzstream (fromIntegral (fromEnum action))
failIfError err
return (toEnum (fromIntegral err))
finalise :: Stream ()
finalise = getStreamState >>= unsafeLiftIO . finalizeForeignPtr
newtype StreamState = StreamState (Ptr StreamState)
foreign import ccall unsafe "bzlib.h BZ2_bzDecompressInit"
bzDecompressInit :: StreamState -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "bzlib.h BZ2_bzDecompress"
bzDecompress :: StreamState -> IO CInt
foreign import ccall unsafe "bzlib.h &BZ2_bzDecompressEnd"
bzDecompressEnd :: FinalizerPtr StreamState
foreign import ccall unsafe "bzlib.h BZ2_bzCompressInit"
bzCompressInit :: StreamState -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "bzlib.h BZ2_bzCompress"
bzCompress :: StreamState -> CInt -> IO CInt
foreign import ccall unsafe "bzlib.h &BZ2_bzCompressEnd"
bzCompressEnd :: FinalizerPtr StreamState