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.Attoparsec.ByteString.Lazy as DABL
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