{-# LANGUAGE MultiWayIf #-}
module Codec.Compression.Zlib(
         DecompressionError(..)
       , ZlibDecoder(NeedMore, Chunk, Done, DecompError)
       , decompress
       , decompressIncremental
       )
 where

import           Codec.Compression.Zlib.Deflate(inflate)
import           Codec.Compression.Zlib.Monad(ZlibDecoder(..), DeflateM,
                                              DecompressionError(..),
                                              runDeflateM, raise, nextByte)
import           Control.Monad(unless, when, replicateM_)
import           Data.Bits((.|.), (.&.), shiftL, shiftR, testBit)
import           Data.ByteString.Builder(lazyByteString,toLazyByteString)
import qualified Data.ByteString.Lazy as L
import           Data.Semigroup ((<>))
import           Data.Word(Word16)
import           Prelude()
import           Prelude.Compat

decompressIncremental :: ZlibDecoder
decompressIncremental :: ZlibDecoder
decompressIncremental = DeflateM () -> ZlibDecoder
runDeflateM DeflateM ()
inflateWithHeaders

decompress :: L.ByteString -> Either DecompressionError L.ByteString
decompress :: ByteString -> Either DecompressionError ByteString
decompress ByteString
ifile = ZlibDecoder
-> [ByteString] -> Builder -> Either DecompressionError ByteString
run ZlibDecoder
decompressIncremental (ByteString -> [ByteString]
L.toChunks ByteString
ifile) Builder
forall a. Monoid a => a
mempty
 where
  run :: ZlibDecoder
-> [ByteString] -> Builder -> Either DecompressionError ByteString
run (NeedMore ByteString -> ZlibDecoder
_) [] Builder
_ =
    DecompressionError -> Either DecompressionError ByteString
forall a b. a -> Either a b
Left (String -> DecompressionError
DecompressionError String
"Ran out of data mid-decompression 2.")
  run (NeedMore ByteString -> ZlibDecoder
f) (ByteString
first:[ByteString]
rest) Builder
acc =
    ZlibDecoder
-> [ByteString] -> Builder -> Either DecompressionError ByteString
run (ByteString -> ZlibDecoder
f ByteString
first) [ByteString]
rest Builder
acc
  run (Chunk ByteString
c ZlibDecoder
m) [ByteString]
ls Builder
acc =
    ZlibDecoder
-> [ByteString] -> Builder -> Either DecompressionError ByteString
run ZlibDecoder
m [ByteString]
ls (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteString ByteString
c)
  run ZlibDecoder
Done        [] Builder
acc =
    ByteString -> Either DecompressionError ByteString
forall a b. b -> Either a b
Right (Builder -> ByteString
toLazyByteString Builder
acc)
  run ZlibDecoder
Done        (ByteString
_:[ByteString]
_) Builder
_ =
    DecompressionError -> Either DecompressionError ByteString
forall a b. a -> Either a b
Left (String -> DecompressionError
DecompressionError String
"Finished with data remaining.")
  run (DecompError DecompressionError
e) [ByteString]
_ Builder
_ =
    DecompressionError -> Either DecompressionError ByteString
forall a b. a -> Either a b
Left DecompressionError
e

inflateWithHeaders :: DeflateM ()
inflateWithHeaders :: DeflateM ()
inflateWithHeaders =
  do Word8
cmf <- DeflateM Word8
nextByte
     Word8
flg <- DeflateM Word8
nextByte
     let both :: Word16
both   = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
cmf Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
flg
         cm :: Word8
cm     = Word8
cmf Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0f
         cinfo :: Word8
cinfo  = Word8
cmf Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
4
         fdict :: Bool
fdict  = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flg Int
5
--       flevel = flg `shiftR` 6
     Bool -> DeflateM () -> DeflateM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Word16
both :: Word16) Word16 -> Word16 -> Word16
forall a. Integral a => a -> a -> a
`mod` Word16
31 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0) (DeflateM () -> DeflateM ()) -> DeflateM () -> DeflateM ()
forall a b. (a -> b) -> a -> b
$
       DecompressionError -> DeflateM ()
forall a. DecompressionError -> DeflateM a
raise (String -> DecompressionError
HeaderError String
"Header checksum failed")
     Bool -> DeflateM () -> DeflateM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
cm Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
8) (DeflateM () -> DeflateM ()) -> DeflateM () -> DeflateM ()
forall a b. (a -> b) -> a -> b
$
       DecompressionError -> DeflateM ()
forall a. DecompressionError -> DeflateM a
raise (String -> DecompressionError
HeaderError (String
"Bad compression method: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
cm))
     Bool -> DeflateM () -> DeflateM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
cinfo Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
7) (DeflateM () -> DeflateM ()) -> DeflateM () -> DeflateM ()
forall a b. (a -> b) -> a -> b
$
       DecompressionError -> DeflateM ()
forall a. DecompressionError -> DeflateM a
raise (String -> DecompressionError
HeaderError (String
"Window size too big: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
cinfo))
     Bool -> DeflateM () -> DeflateM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fdict (DeflateM () -> DeflateM ()) -> DeflateM () -> DeflateM ()
forall a b. (a -> b) -> a -> b
$ Int -> DeflateM Word8 -> DeflateM ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
4 DeflateM Word8
nextByte -- just skip them for now (FIXME)
     DeflateM ()
inflate