Block.hsc

module Codec.Compression.Lzo.Block ( compress
                                   , decompress
                                   , LzoError
                                   , lzoOk
                                   , lzoError
                                   , lzoOutOfMemory
                                   , lzoNotCompressible
                                   , lzoInputOverrun
                                   , lzoOutputOverrun
                                   , lzoLookbehindOverrun
                                   , lzoEofNotFound
                                   , lzoEInputNotConsumed
                                   , lzoENotYetImplemented
                                   , lzoEInvalidArgument
                                   , lzoEInvalidAlignment
                                   , lzoEOutputNotConsumed
                                   , lzoEInternalError
                                   , lzoVersion
                                   , lzoVersionString
                                   , lzoVersionDate
                                   ) where

import Control.Applicative
import Control.Exception (Exception, throw)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Foreign.C.String (CString, peekCString)
import Foreign.C.Types (CChar, CInt (..), CUInt (..))
import Control.Monad (when)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Storable (peek, poke)
import System.IO.Unsafe (unsafePerformIO)

#include <minilzo.h>

type Byte = CChar

foreign import ccall lzo1x_1_compress :: Ptr Byte -> CUInt -> Ptr Byte -> Ptr CUInt -> Ptr a -> IO CInt
foreign import ccall lzo1x_decompress_safe :: Ptr Byte -> CUInt -> Ptr Byte -> Ptr CUInt -> Ptr a -> IO CInt

foreign import ccall lzo_version :: CUInt
foreign import ccall lzo_version_string :: CString
foreign import ccall lzo_version_date :: CString

-- | @since 0.1.1.0
lzoVersion :: Word
lzoVersion = fromIntegral lzo_version

-- | @since 0.1.1.0
lzoVersionString :: String
lzoVersionString = unsafePerformIO $ peekCString lzo_version_string

-- | @since 0.1.1.0
lzoVersionDate :: String
lzoVersionDate = unsafePerformIO $ peekCString lzo_version_date

lzo1MemCompress :: Integral a => a
lzo1MemCompress = #{const LZO1X_1_MEM_COMPRESS}

newtype LzoError = LzoError CInt deriving (Eq)

instance Exception LzoError

instance Show LzoError where
    show err | err == lzoOk = "LZO_E_OK"
             | err == lzoError = "LZO_E_ERROR"
             | err == lzoOutOfMemory = "LZO_E_OUT_OF_MEMORY"
             | err == lzoNotCompressible = "LZO_E_NOT_COMPRESSIBLE"
             | err == lzoInputOverrun = "LZO_E_INPUT_OVERRUN"
             | err == lzoOutputOverrun = "LZO_E_OUTPUT_OVERRUN"
             | err == lzoLookbehindOverrun = "LZO_E_LOOKBEHIND_OVERRUN"
             | err == lzoEofNotFound = "LZO_E_EOF_NOT_FOUND"
             | err == lzoEInputNotConsumed = "LZO_E_INPUT_NOT_CONSUMED"
             | err == lzoENotYetImplemented = "LZO_E_NOT_YET_IMPLEMENTED"
             | err == lzoEInvalidArgument = "LZO_E_INVALID_ARGUMENT"
             | err == lzoEInvalidAlignment = "LZO_E_INVALID_ALIGNMENT"
             | err == lzoEOutputNotConsumed = "LZO_E_OUTPUT_NOT_CONSUMED"
             | err == lzoEInternalError = "LZO_E_INTERNAL_ERROR"
             | otherwise = "Invalid error code"

isError :: LzoError -> Bool
isError err | err /= lzoOk = True
            | otherwise = False

#{enum LzoError, LzoError
    , lzoOk = LZO_E_OK
    , lzoError = LZO_E_ERROR
    , lzoOutOfMemory = LZO_E_OUT_OF_MEMORY
    , lzoNotCompressible = LZO_E_NOT_COMPRESSIBLE
    , lzoInputOverrun = LZO_E_INPUT_OVERRUN
    , lzoOutputOverrun = LZO_E_OUTPUT_OVERRUN
    , lzoLookbehindOverrun = LZO_E_LOOKBEHIND_OVERRUN
    , lzoEofNotFound = LZO_E_EOF_NOT_FOUND
    , lzoEInputNotConsumed = LZO_E_INPUT_NOT_CONSUMED
    , lzoENotYetImplemented = LZO_E_NOT_YET_IMPLEMENTED
    , lzoEInvalidArgument = LZO_E_INVALID_ARGUMENT
    , lzoEInvalidAlignment = LZO_E_INVALID_ALIGNMENT
    , lzoEOutputNotConsumed = LZO_E_OUTPUT_NOT_CONSUMED
    , lzoEInternalError = LZO_E_INTERNAL_ERROR
  }

compressBufSz :: Integral a => a -> a
compressBufSz l' = l' + (l' `div` 16) + 64 + 3

-- TODO: file format
compress :: BS.ByteString -> BS.ByteString
compress inBs = unsafePerformIO $
    allocaBytes lzo1MemCompress $ \memBuf ->
        BS.unsafeUseAsCStringLen inBs $ \(buf, bufSz) ->
            allocaBytes (compressBufSz bufSz) $ \bytePtr ->
                alloca $ \szPtr -> do
                    res <- LzoError <$> lzo1x_1_compress buf (fromIntegral bufSz) bytePtr szPtr memBuf
                    when (isError res) $
                        throw res
                    sz <- peek szPtr
                    BS.packCStringLen (bytePtr, fromIntegral sz)

decompress :: BS.ByteString
           -> Int -- ^ Maximum bound on output bytes
           -> BS.ByteString
decompress inBs outSz = unsafePerformIO $
    BS.unsafeUseAsCStringLen inBs $ \(buf, bufSz) ->
        allocaBytes outSz $ \bytePtr ->
            alloca $ \szPtr -> do
                poke szPtr (fromIntegral outSz)
                res <- LzoError <$> lzo1x_decompress_safe buf (fromIntegral bufSz) bytePtr szPtr nullPtr
                when (isError res) $
                    throw res
                sz <- peek szPtr
                BS.packCStringLen (bytePtr, fromIntegral sz)