{-# LANGUAGE TupleSections #-}

-- | Functions throw 'LZErrno' on failure
--
-- Compression functions should work on arbitrary data
module Codec.Lzip ( -- * Compression
                    compress
                  , compressBest
                  , compressFast
                  , compressSz
                  , compressSzBest
                  , compressSzFast
                  , compressWith
                  , compressWithSz
                  , compressFile
                  , compressFileLevel
                  , compressFileBest
                  , compressFileFast
                  , compressFineTune
                  , CompressionLevel (..)
                  , LzOptions (..)
                  -- * Decompression
                  , decompress
                  , LZErrno
                    ( LzMemError
                    , LzHeaderError
                    , LzUnexpectedEof
                    , LzDataError
                    , LzLibraryError
                    )
                  -- * Miscellany
                  , lZVersion
                  , lZApiVersion
                  ) where

import           Codec.Lzip.Raw
import           Control.Applicative
import           Control.Exception            (throw)
import           Control.Monad                (when)
import           Control.Monad.ST.Lazy        (runST)
import qualified Control.Monad.ST.Lazy        as LazyST
import qualified Control.Monad.ST.Lazy.Unsafe as LazyST
import           Data.Bits                    (shiftL)
import qualified Data.ByteString              as BS
import qualified Data.ByteString.Lazy         as BSL
import qualified Data.ByteString.Unsafe       as BS
import           Data.Functor                 (($>))
import           Data.Int                     (Int64)
import           Foreign.C.Types              (CInt)
import           Foreign.ForeignPtr           (ForeignPtr, castForeignPtr,
                                               mallocForeignPtrBytes,
                                               newForeignPtr, withForeignPtr)
import           Foreign.Ptr                  (castPtr)
import           System.IO                    (IOMode (ReadMode), hFileSize,
                                               withFile)

data CompressionLevel = Zero
    | One
    | Two
    | Three
    | Four
    | Five
    | Six
    | Seven
    | Eight
    | Nine
    deriving (Int -> CompressionLevel
CompressionLevel -> Int
CompressionLevel -> [CompressionLevel]
CompressionLevel -> CompressionLevel
CompressionLevel -> CompressionLevel -> [CompressionLevel]
CompressionLevel
-> CompressionLevel -> CompressionLevel -> [CompressionLevel]
(CompressionLevel -> CompressionLevel)
-> (CompressionLevel -> CompressionLevel)
-> (Int -> CompressionLevel)
-> (CompressionLevel -> Int)
-> (CompressionLevel -> [CompressionLevel])
-> (CompressionLevel -> CompressionLevel -> [CompressionLevel])
-> (CompressionLevel -> CompressionLevel -> [CompressionLevel])
-> (CompressionLevel
    -> CompressionLevel -> CompressionLevel -> [CompressionLevel])
-> Enum CompressionLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CompressionLevel
-> CompressionLevel -> CompressionLevel -> [CompressionLevel]
$cenumFromThenTo :: CompressionLevel
-> CompressionLevel -> CompressionLevel -> [CompressionLevel]
enumFromTo :: CompressionLevel -> CompressionLevel -> [CompressionLevel]
$cenumFromTo :: CompressionLevel -> CompressionLevel -> [CompressionLevel]
enumFromThen :: CompressionLevel -> CompressionLevel -> [CompressionLevel]
$cenumFromThen :: CompressionLevel -> CompressionLevel -> [CompressionLevel]
enumFrom :: CompressionLevel -> [CompressionLevel]
$cenumFrom :: CompressionLevel -> [CompressionLevel]
fromEnum :: CompressionLevel -> Int
$cfromEnum :: CompressionLevel -> Int
toEnum :: Int -> CompressionLevel
$ctoEnum :: Int -> CompressionLevel
pred :: CompressionLevel -> CompressionLevel
$cpred :: CompressionLevel -> CompressionLevel
succ :: CompressionLevel -> CompressionLevel
$csucc :: CompressionLevel -> CompressionLevel
Enum, CompressionLevel
CompressionLevel -> CompressionLevel -> Bounded CompressionLevel
forall a. a -> a -> Bounded a
maxBound :: CompressionLevel
$cmaxBound :: CompressionLevel
minBound :: CompressionLevel
$cminBound :: CompressionLevel
Bounded)

data LzOptions = LzOptions
    { LzOptions -> Int
dictionarySize :: !Int
    , LzOptions -> Int
matchLenLimit  :: !Int
    }

encoderOptions :: CompressionLevel -> LzOptions
encoderOptions :: CompressionLevel -> LzOptions
encoderOptions CompressionLevel
Zero  = Int -> Int -> LzOptions
LzOptions Int
65535 Int
16
encoderOptions CompressionLevel
One   = Int -> Int -> LzOptions
LzOptions (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
20) Int
5
encoderOptions CompressionLevel
Two   = Int -> Int -> LzOptions
LzOptions (Int
3 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
19) Int
6
encoderOptions CompressionLevel
Three = Int -> Int -> LzOptions
LzOptions (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
21) Int
8
encoderOptions CompressionLevel
Four  = Int -> Int -> LzOptions
LzOptions (Int
3 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
20) Int
12
encoderOptions CompressionLevel
Five  = Int -> Int -> LzOptions
LzOptions (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
22) Int
20
encoderOptions CompressionLevel
Six   = Int -> Int -> LzOptions
LzOptions (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
23) Int
36
encoderOptions CompressionLevel
Seven = Int -> Int -> LzOptions
LzOptions (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) Int
68
encoderOptions CompressionLevel
Eight = Int -> Int -> LzOptions
LzOptions (Int
3 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
23) Int
132
encoderOptions CompressionLevel
Nine  = Int -> Int -> LzOptions
LzOptions (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
25) Int
273

-- | This does not do any error recovery; for that you should use
-- [lziprecover](https://www.nongnu.org/lzip/lziprecover.html).
--
-- Doesn't work on empty 'BSL.ByteString's
--
-- Throws 'LZErrno' on error
decompress :: BSL.ByteString -> BSL.ByteString
decompress :: ByteString -> ByteString
decompress ByteString
bs = (forall s. ST s ByteString) -> ByteString
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s ByteString) -> ByteString)
-> (forall s. ST s ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ do

    let bss :: [ByteString]
bss = ByteString -> [ByteString]
BSL.toChunks ByteString
bs
        szOut :: Integral a => a
        szOut :: forall a. Integral a => a
szOut = a
64 a -> a -> a
forall a. Num a => a -> a -> a
* a
1024

    (ForeignPtr ()
dec, ForeignPtr UInt8
bufOut) <- IO (ForeignPtr (), ForeignPtr UInt8)
-> ST s (ForeignPtr (), ForeignPtr UInt8)
forall a s. IO a -> ST s a
LazyST.unsafeIOToST (IO (ForeignPtr (), ForeignPtr UInt8)
 -> ST s (ForeignPtr (), ForeignPtr UInt8))
-> IO (ForeignPtr (), ForeignPtr UInt8)
-> ST s (ForeignPtr (), ForeignPtr UInt8)
forall a b. (a -> b) -> a -> b
$ do
        ForeignPtr UInt8
bufOut <- Int -> IO (ForeignPtr UInt8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
forall a. Integral a => a
szOut
        Ptr LZDecoder
decoder <- IO (Ptr LZDecoder)
lZDecompressOpen
        ForeignPtr ()
dec <- FinalizerPtr () -> Ptr () -> IO (ForeignPtr ())
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr ()
lZDecompressClose (Ptr LZDecoder -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr LZDecoder
decoder)
        (ForeignPtr (), ForeignPtr UInt8)
-> IO (ForeignPtr (), ForeignPtr UInt8)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignPtr ()
dec, ForeignPtr UInt8
bufOut)

    [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString)
-> ST s [ByteString] -> ST s ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LZDecoderPtr
-> [ByteString] -> (ForeignPtr UInt8, CInt) -> ST s [ByteString]
forall s.
LZDecoderPtr
-> [ByteString] -> (ForeignPtr UInt8, CInt) -> ST s [ByteString]
loop (ForeignPtr () -> LZDecoderPtr
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr ()
dec) [ByteString]
bss (ForeignPtr UInt8
bufOut, CInt
forall a. Integral a => a
szOut)

    where

        -- TODO: not a fan of this loop!
        step :: LZDecoderPtr -> [BS.ByteString] -> (ForeignPtr UInt8, CInt) -> LazyST.ST s (Maybe BS.ByteString, [BS.ByteString])
        step :: forall s.
LZDecoderPtr
-> [ByteString]
-> (ForeignPtr UInt8, CInt)
-> ST s (Maybe ByteString, [ByteString])
step LZDecoderPtr
decoder [ByteString]
bss (ForeignPtr UInt8
buf, CInt
bufSz) = IO (Maybe ByteString, [ByteString])
-> ST s (Maybe ByteString, [ByteString])
forall a s. IO a -> ST s a
LazyST.unsafeIOToST (IO (Maybe ByteString, [ByteString])
 -> ST s (Maybe ByteString, [ByteString]))
-> IO (Maybe ByteString, [ByteString])
-> ST s (Maybe ByteString, [ByteString])
forall a b. (a -> b) -> a -> b
$ do
            Int
maxSz <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LZDecoderPtr -> IO CInt
lZDecompressWriteSize LZDecoderPtr
decoder
            [ByteString]
bss' <- case [ByteString]
bss of
                [ByteString
bs'] -> if ByteString -> Int
BS.length ByteString
bs' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSz
                    then
                        let (ByteString
bs'', ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
maxSz ByteString
bs' in
                        ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs'' ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz) ->
                            LZDecoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZDecompressWrite LZDecoderPtr
decoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [ByteString
rest]
                    else
                        ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs' ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz) ->
                            LZDecoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZDecompressWrite LZDecoderPtr
decoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) IO CInt -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                            LZDecoderPtr -> IO CInt
lZDecompressFinish LZDecoderPtr
decoder IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
                (ByteString
bs':[ByteString]
bss') -> if ByteString -> Int
BS.length ByteString
bs' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSz
                    then
                        let (ByteString
bs'', ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
maxSz ByteString
bs' in
                        ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs'' ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz) ->
                            LZDecoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZDecompressWrite LZDecoderPtr
decoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ByteString
restByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
bss'
                    else
                        ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs' ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz) ->
                            LZDecoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZDecompressWrite LZDecoderPtr
decoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>
                            [ByteString]
bss'
                [] -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

            CInt
res <- LZDecoderPtr -> IO CInt
lZDecompressFinished LZDecoderPtr
decoder
            if CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1
                then (Maybe ByteString, [ByteString])
-> IO (Maybe ByteString, [ByteString])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
forall a. Maybe a
Nothing, [Char] -> [ByteString]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in lzlib-hs")
                else
                    ForeignPtr UInt8
-> (Ptr UInt8 -> IO (Maybe ByteString, [ByteString]))
-> IO (Maybe ByteString, [ByteString])
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr UInt8
buf ((Ptr UInt8 -> IO (Maybe ByteString, [ByteString]))
 -> IO (Maybe ByteString, [ByteString]))
-> (Ptr UInt8 -> IO (Maybe ByteString, [ByteString]))
-> IO (Maybe ByteString, [ByteString])
forall a b. (a -> b) -> a -> b
$ \Ptr UInt8
b -> do
                        CInt
bytesRead <- LZDecoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZDecompressRead LZDecoderPtr
decoder Ptr UInt8
b CInt
bufSz
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
bytesRead CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            LZErrno -> IO ()
forall a e. Exception e => e -> a
throw (LZErrno -> IO ()) -> IO LZErrno -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LZDecoderPtr -> IO LZErrno
lZDecompressErrno LZDecoderPtr
decoder
                        (, [ByteString]
bss') (Maybe ByteString -> (Maybe ByteString, [ByteString]))
-> (ByteString -> Maybe ByteString)
-> ByteString
-> (Maybe ByteString, [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> (Maybe ByteString, [ByteString]))
-> IO ByteString -> IO (Maybe ByteString, [ByteString])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStringLen -> IO ByteString
BS.packCStringLen (Ptr UInt8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr UInt8
b, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
bytesRead)

        loop :: LZDecoderPtr -> [BS.ByteString] -> (ForeignPtr UInt8, CInt) -> LazyST.ST s [BS.ByteString]
        loop :: forall s.
LZDecoderPtr
-> [ByteString] -> (ForeignPtr UInt8, CInt) -> ST s [ByteString]
loop LZDecoderPtr
decoder [ByteString]
bss (ForeignPtr UInt8, CInt)
bufOut = do
            (Maybe ByteString
res, [ByteString]
bss') <- LZDecoderPtr
-> [ByteString]
-> (ForeignPtr UInt8, CInt)
-> ST s (Maybe ByteString, [ByteString])
forall s.
LZDecoderPtr
-> [ByteString]
-> (ForeignPtr UInt8, CInt)
-> ST s (Maybe ByteString, [ByteString])
step LZDecoderPtr
decoder [ByteString]
bss (ForeignPtr UInt8, CInt)
bufOut
            case Maybe ByteString
res of
                Maybe ByteString
Nothing -> [ByteString] -> ST s [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Just ByteString
x  -> (ByteString
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> ST s [ByteString] -> ST s [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LZDecoderPtr
-> [ByteString] -> (ForeignPtr UInt8, CInt) -> ST s [ByteString]
forall s.
LZDecoderPtr
-> [ByteString] -> (ForeignPtr UInt8, CInt) -> ST s [ByteString]
loop LZDecoderPtr
decoder [ByteString]
bss' (ForeignPtr UInt8, CInt)
bufOut

-- | Alias for @'compressWith' 'Six'@
compress :: BSL.ByteString -> BSL.ByteString
compress :: ByteString -> ByteString
compress = CompressionLevel -> ByteString -> ByteString
compressWith CompressionLevel
Six

-- | Alias for @'compressWithSz' 'Six'@
--
-- @since 1.0.2.0
compressSz :: BSL.ByteString
           -> Int -- ^ Size of input data, in bytes
           -> BSL.ByteString
compressSz :: ByteString -> Int -> ByteString
compressSz = CompressionLevel -> ByteString -> Int -> ByteString
compressWithSz CompressionLevel
Six

-- | Alias for @'compressWithSz' 'maxBound'@
--
-- @since 1.0.2.0
compressSzBest :: BSL.ByteString
           -> Int -- ^ Size of input data, in bytes
           -> BSL.ByteString
compressSzBest :: ByteString -> Int -> ByteString
compressSzBest = CompressionLevel -> ByteString -> Int -> ByteString
compressWithSz CompressionLevel
forall a. Bounded a => a
maxBound

-- | Alias for @'compressWithSz' 'minBound'@
--
-- @since 1.0.2.0
compressSzFast :: BSL.ByteString
           -> Int -- ^ Size of input data, in bytes
           -> BSL.ByteString
compressSzFast :: ByteString -> Int -> ByteString
compressSzFast = CompressionLevel -> ByteString -> Int -> ByteString
compressWithSz CompressionLevel
forall a. Bounded a => a
minBound

-- | Alias for @'compressWith' 'maxBound'@
--
-- @since 0.3.2.0
compressBest :: BSL.ByteString -> BSL.ByteString
compressBest :: ByteString -> ByteString
compressBest = CompressionLevel -> ByteString -> ByteString
compressWith CompressionLevel
forall a. Bounded a => a
maxBound

-- | Alias for @'compressWith' 'minBound'@
--
-- @since 0.3.2.0
compressFast :: BSL.ByteString -> BSL.ByteString
compressFast :: ByteString -> ByteString
compressFast = CompressionLevel -> ByteString -> ByteString
compressWith CompressionLevel
forall a. Bounded a => a
minBound

-- | Use this to avoid forcing the whole file into memory at once
--
-- @since 1.0.0.0
compressFile :: FilePath -> IO BSL.ByteString
compressFile :: [Char] -> IO ByteString
compressFile = CompressionLevel -> [Char] -> IO ByteString
compressFileLevel CompressionLevel
Six

-- | @since 1.0.3.0
compressFileBest :: FilePath -> IO BSL.ByteString
compressFileBest :: [Char] -> IO ByteString
compressFileBest = CompressionLevel -> [Char] -> IO ByteString
compressFileLevel CompressionLevel
forall a. Bounded a => a
maxBound

-- | @since 1.0.3.0
compressFileFast :: FilePath -> IO BSL.ByteString
compressFileFast :: [Char] -> IO ByteString
compressFileFast = CompressionLevel -> [Char] -> IO ByteString
compressFileLevel CompressionLevel
Zero

-- | @since 1.0.3.0
compressFileLevel :: CompressionLevel -> FilePath -> IO BSL.ByteString
compressFileLevel :: CompressionLevel -> [Char] -> IO ByteString
compressFileLevel CompressionLevel
lvl [Char]
fp =
    CompressionLevel -> ByteString -> Int -> ByteString
compressWithSz CompressionLevel
lvl (ByteString -> Int -> ByteString)
-> IO ByteString -> IO (Int -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BSL.readFile [Char]
fp IO (Int -> ByteString) -> IO Int -> IO ByteString
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO Int
fileSizeInt [Char]
fp

fileSizeInt :: FilePath -> IO Int
fileSizeInt :: [Char] -> IO Int
fileSizeInt [Char]
fp = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> IO Integer -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IOMode -> (Handle -> IO Integer) -> IO Integer
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
fp IOMode
ReadMode Handle -> IO Integer
hFileSize

compressWith :: CompressionLevel -> BSL.ByteString -> BSL.ByteString
compressWith :: CompressionLevel -> ByteString -> ByteString
compressWith CompressionLevel
level ByteString
bstr =
    let sz :: Int64
sz = ByteString -> Int64
BSL.length ByteString
bstr in
        CompressionLevel -> ByteString -> Int -> ByteString
compressWithSz CompressionLevel
level ByteString
bstr (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
sz)

-- | @since 1.0.0.0
compressWithSz :: CompressionLevel
               -> BSL.ByteString
               -> Int -- ^ Size of data being compressed, in bytes.
               -> BSL.ByteString
compressWithSz :: CompressionLevel -> ByteString -> Int -> ByteString
compressWithSz CompressionLevel
cl = LzOptions -> ByteString -> Int -> ByteString
compressFineTune (CompressionLevel -> LzOptions
encoderOptions CompressionLevel
cl)

compressFineTune :: LzOptions
                 -> BSL.ByteString
                 -> Int -- ^ Size of data being compressed, in bytes.
                 -> BSL.ByteString
compressFineTune :: LzOptions -> ByteString -> Int -> ByteString
compressFineTune LzOptions
opts ByteString
bstr Int
sz = (forall s. ST s ByteString) -> ByteString
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s ByteString) -> ByteString)
-> (forall s. ST s ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ do

    let bss :: [ByteString]
bss = ByteString -> [ByteString]
BSL.toChunks ByteString
bstr
        delta :: Int
delta = Int
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
64

    (ForeignPtr UInt8
buf, ForeignPtr ()
enc) <- IO (ForeignPtr UInt8, ForeignPtr ())
-> ST s (ForeignPtr UInt8, ForeignPtr ())
forall a s. IO a -> ST s a
LazyST.unsafeIOToST (IO (ForeignPtr UInt8, ForeignPtr ())
 -> ST s (ForeignPtr UInt8, ForeignPtr ()))
-> IO (ForeignPtr UInt8, ForeignPtr ())
-> ST s (ForeignPtr UInt8, ForeignPtr ())
forall a b. (a -> b) -> a -> b
$ do
        ForeignPtr UInt8
buf <- Int -> IO (ForeignPtr UInt8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
delta
        Ptr LZEncoder
encoder <- CInt -> CInt -> CULLong -> IO (Ptr LZEncoder)
lZCompressOpen (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Int -> Int
dictionarySize' Int
sz) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
matchLenLimit') (Int64 -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
memberSize)
        ForeignPtr ()
enc <- FinalizerPtr () -> Ptr () -> IO (ForeignPtr ())
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr ()
lZCompressClose (Ptr LZEncoder -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr LZEncoder
encoder)
        (ForeignPtr UInt8, ForeignPtr ())
-> IO (ForeignPtr UInt8, ForeignPtr ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignPtr UInt8
buf, ForeignPtr ()
enc)

    [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString)
-> ST s [ByteString] -> ST s ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LZEncoderPtr
-> [ByteString] -> ForeignPtr UInt8 -> ST s [ByteString]
forall s.
LZEncoderPtr
-> [ByteString] -> ForeignPtr UInt8 -> ST s [ByteString]
loop (ForeignPtr () -> LZEncoderPtr
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr ()
enc) [ByteString]
bss ForeignPtr UInt8
buf

    where
        step :: LZEncoderPtr -> [BS.ByteString] -> ForeignPtr UInt8 -> LazyST.ST s (Bool, BS.ByteString, [BS.ByteString])
        step :: forall s.
LZEncoderPtr
-> [ByteString]
-> ForeignPtr UInt8
-> ST s (Bool, ByteString, [ByteString])
step LZEncoderPtr
encoder [ByteString]
bss ForeignPtr UInt8
buf = IO (Bool, ByteString, [ByteString])
-> ST s (Bool, ByteString, [ByteString])
forall a s. IO a -> ST s a
LazyST.unsafeIOToST (IO (Bool, ByteString, [ByteString])
 -> ST s (Bool, ByteString, [ByteString]))
-> IO (Bool, ByteString, [ByteString])
-> ST s (Bool, ByteString, [ByteString])
forall a b. (a -> b) -> a -> b
$ do
            Int
maxSz <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LZEncoderPtr -> IO CInt
lZCompressWriteSize LZEncoderPtr
encoder
            [ByteString]
bss' <- case [ByteString]
bss of
                [ByteString
bs] -> if ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSz
                    then
                        let (ByteString
bs', ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
maxSz ByteString
bs in
                            ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs' ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz') ->
                                LZEncoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZCompressWrite LZEncoderPtr
encoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz') IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [ByteString
rest]
                    else
                        ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz') ->
                            LZEncoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZCompressWrite LZEncoderPtr
encoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz') IO CInt -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                            LZEncoderPtr -> IO CInt
lZCompressFinish LZEncoderPtr
encoder IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
                (ByteString
bs:[ByteString]
bss') -> if ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSz
                    then
                        let (ByteString
bs', ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
maxSz ByteString
bs in
                        ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs' ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz') ->
                            LZEncoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZCompressWrite LZEncoderPtr
encoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz') IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ByteString
restByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
bss'
                    else
                        ByteString -> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO [ByteString]) -> IO [ByteString])
-> (CStringLen -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
sz') ->
                            LZEncoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZCompressWrite LZEncoderPtr
encoder (Ptr CChar -> Ptr UInt8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz') IO CInt -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [ByteString]
bss'
                [] -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

            ForeignPtr UInt8
-> (Ptr UInt8 -> IO (Bool, ByteString, [ByteString]))
-> IO (Bool, ByteString, [ByteString])
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr UInt8
buf ((Ptr UInt8 -> IO (Bool, ByteString, [ByteString]))
 -> IO (Bool, ByteString, [ByteString]))
-> (Ptr UInt8 -> IO (Bool, ByteString, [ByteString]))
-> IO (Bool, ByteString, [ByteString])
forall a b. (a -> b) -> a -> b
$ \Ptr UInt8
b -> do
                CInt
bytesActual <- LZEncoderPtr -> Ptr UInt8 -> CInt -> IO CInt
lZCompressRead LZEncoderPtr
encoder Ptr UInt8
b (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
maxSz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& CInt
bytesActual CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in lzlib-hs: no progress made; maybe delta is too high?"
                CInt
res <- LZEncoderPtr -> IO CInt
lZCompressFinished LZEncoderPtr
encoder
                ByteString
bsActual <- CStringLen -> IO ByteString
BS.packCStringLen (Ptr UInt8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr UInt8
b, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
bytesActual)
                if CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1
                    then (Bool, ByteString, [ByteString])
-> IO (Bool, ByteString, [ByteString])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, ByteString
bsActual, [Char] -> [ByteString]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in lzlib-hs")
                    else (Bool, ByteString, [ByteString])
-> IO (Bool, ByteString, [ByteString])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, ByteString
bsActual, [ByteString]
bss')

        loop :: LZEncoderPtr -> [BS.ByteString] -> ForeignPtr UInt8 -> LazyST.ST s [BS.ByteString]
        loop :: forall s.
LZEncoderPtr
-> [ByteString] -> ForeignPtr UInt8 -> ST s [ByteString]
loop LZEncoderPtr
encoder [ByteString]
bss ForeignPtr UInt8
bufOut = do

            (Bool
stop, ByteString
res, [ByteString]
bss') <- LZEncoderPtr
-> [ByteString]
-> ForeignPtr UInt8
-> ST s (Bool, ByteString, [ByteString])
forall s.
LZEncoderPtr
-> [ByteString]
-> ForeignPtr UInt8
-> ST s (Bool, ByteString, [ByteString])
step LZEncoderPtr
encoder [ByteString]
bss ForeignPtr UInt8
bufOut
            if Bool
stop
                then [ByteString] -> ST s [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ByteString
res]
                else (ByteString
resByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> ST s [ByteString] -> ST s [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LZEncoderPtr
-> [ByteString] -> ForeignPtr UInt8 -> ST s [ByteString]
forall s.
LZEncoderPtr
-> [ByteString] -> ForeignPtr UInt8 -> ST s [ByteString]
loop LZEncoderPtr
encoder [ByteString]
bss' ForeignPtr UInt8
bufOut

        memberSize :: Int64
        memberSize :: Int64
memberSize = Int64
forall a. Bounded a => a
maxBound

        -- saves memory
        dictionarySize' :: Int -> Int
dictionarySize' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
lZMinDictionarySize) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (LzOptions -> Int
dictionarySize LzOptions
opts)
        matchLenLimit' :: Int
matchLenLimit' = LzOptions -> Int
matchLenLimit LzOptions
opts