module Codec.Archive.SAPCAR.FlatedFile
( decompressBlock
) where
import Control.Applicative
import Control.Monad
import Control.Monad.State.Strict
import Data.Char
import Data.Foldable (toList)
import Data.Functor.Identity
import Data.Sequence ((><), (|>))
import Data.Word
import System.IO
import qualified Control.Exception as CE
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Sequence as DS
import Codec.Archive.SAPCAR.BitStream
import Codec.Archive.SAPCAR.CanonicalHuffmanTree
import Codec.Archive.SAPCAR.FlexibleUtils
border :: [Int]
border = [16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15]
cplens :: [Int]
cplens = [3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43,
51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0]
cpdist :: [Int]
cpdist = [1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257,
385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289,
16385, 24577]
csExtraDistBits :: [Int]
csExtraDistBits = [0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7,
8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13]
csExtraLenBits :: [Int]
csExtraLenBits = [0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3,
3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, 99, 99]
readInt32Big :: Handle -> IO Int
readInt32Big h = do
[b1, b2, b3, b4] <- replicateM 4 $ ord <$> hGetChar h
return $ b1 * 16777216 + b2 * 65536 + b3 * 256 + b4
entryReader :: [[Int]]
-> CanonicalHuffmanTree
-> Int
-> Int
-> StateT
BitStream Data.Functor.Identity.Identity [Int]
entryReader entries huft entriesToRead lastEntry
| (length . concat $ entries) >= entriesToRead = return . concat . reverse $ entries
| otherwise = do
entry <- readEntry huft
newEntries <- handleEntry entry
entryReader (newEntries:entries) huft entriesToRead $ last newEntries
where
handleEntry :: Int -> State BitStream [Int]
handleEntry code
| code < 16 = return [code]
| code == 16 = do
numRepetitions <- (3 +) <$> getAndConsume 2
return $ replicate numRepetitions lastEntry
| code == 17 = do
numZeroes <- (3 +) <$> getAndConsume 3
return $ replicate numZeroes 0
| code == 18 = do
numZeroes <- (11 +) <$> getAndConsume 7
return $ replicate numZeroes 0
| otherwise = error "Corrupted file"
decodeIt
:: CanonicalHuffmanTree
-> CanonicalHuffmanTree
-> DS.Seq Word8
-> State BitStream (DS.Seq Word8)
decodeIt lt dt = decodeIt'
where
decodeIt' acc = do
entry <- readEntryRaw lt
case numExtraBits entry of
n | n == eobcode -> return acc
n | n == litcode -> decodeIt' $ acc |> (fromIntegral $ value entry)
n | n > litcode -> error "Sonderfall not handled"
_ -> do
n <- (+ value entry) <$> getAndConsume (numExtraBits entry)
distEntry <- readEntryRaw dt
dist <- (+ value distEntry) <$> getAndConsume (numExtraBits distEntry)
let new = DS.drop (length acc dist) acc
new' = foldl (\a _ -> a >< new) empty [0..m]
m = n `div` dist
l = (acc >< (DS.take n new'))
decodeIt' l
decompressBlock :: BS.ByteString -> BS.ByteString
decompressBlock inp = blocks
where
blocks = evalState decompressor . makeStream $ inp
skipNonsenseBits :: State BitStream ()
skipNonsenseBits = do
numNonsenseBits <- getAndConsume 2
when (numNonsenseBits > 0) $
void $ getAndConsume numNonsenseBits
decompressor :: State BitStream BS.ByteString
decompressor = skipNonsenseBits >> (BS.pack . toList <$> decompressor' empty)
decompressor' :: DS.Seq Word8 -> State BitStream (DS.Seq Word8)
decompressor' acc = do
lastBlock <- getAndConsume 1
blockType <- getAndConsume 2
res <- case blockType of
1 -> decompressStaticBlock acc
2 -> decompressDynamicBlock acc
_ -> error $ "Block type " ++ show blockType ++ " not supported!"
case lastBlock of
1 -> return res
0 -> decompressor' res
decompressDynamicBlock :: DS.Seq Word8 -> State BitStream (DS.Seq Word8)
decompressDynamicBlock acc = do
numLiterals <- (+ 257) <$> getAndConsume 5
numDistanceCodes <- (+ 1) <$> getAndConsume 5
numBitLengths <- (+ 4) <$> getAndConsume 4
let bitLengthPositions = Prelude.take numBitLengths border
bitLengths' <- mapM (\blp -> (,) blp <$> getAndConsume 3) bitLengthPositions
let bitLengths = makeFlexList (0, 18) 0 bitLengths'
huft = makeHuffmanTree bitLengths 19 [] []
entriesToRead = numLiterals + numDistanceCodes
ll <- entryReader [] huft entriesToRead (1)
let lengthCodes = take numLiterals ll
distCodes = take numDistanceCodes $ drop numLiterals ll
lengthTree = makeHuffmanTree lengthCodes 257 cplens csExtraLenBits
distTree = makeHuffmanTree distCodes 0 cpdist csExtraDistBits
decodeIt lengthTree distTree acc
decompressStaticBlock :: DS.Seq Word8 -> State BitStream (DS.Seq Word8)
decompressStaticBlock acc = do
let lengthCodes = replicate 144 8 ++ replicate 112 9 ++ replicate 24 7 ++ replicate 8 8
distCodes = replicate 30 5
let lengthTree = makeHuffmanTree lengthCodes 257 cplens csExtraLenBits
distTree = makeHuffmanTree distCodes 0 cpdist csExtraDistBits
decodeIt lengthTree distTree acc