FlatedFile.hs

{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module: FlatedFile
-- Copyright: (C) 2015-2016, Virtual Forge GmbH
-- License: GPL2
-- Maintainer: Hans-Christian Esperer <hans-christian.esperer@virtualforge.com>
-- Stability: experimental
-- Portability: portable
-- |
-- (De-)compress SAPCAR files
--
-- Copyright (C) 2016, Virtual Forge GmbH
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or (at
-- your option) any later version.
--
-- This program is distributed in the hope that it will be useful, but
-- WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA
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

-- Copied from vpa108csulzh.cpp under GPL by SAP AG
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]
-- End copied from vpa108csulzh.cpp under GPL by SAP AG

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 = BS.pack . toList <$> decodeIt' empty
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 - 16)
                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
      

-- |Decompress one or more lzh compressed blocks
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
    -- Length and dist codes copied from vpa108csulzh.cpp under GPL by SAP AG
    let lengthCodes = replicate 144 8 ++ replicate 112 9 ++ replicate 24 7 ++ replicate 8 8
        distCodes   = replicate 30 5
    -- End length and dist codes copied from vpa108csulzh.cpp under GPL by SAP AG
    let lengthTree  = makeHuffmanTree lengthCodes 257 cplens csExtraLenBits
        distTree    = makeHuffmanTree distCodes 0 cpdist csExtraDistBits
    decodeIt lengthTree distTree acc