diff --git a/app/Options.hs b/app/Options.hs --- a/app/Options.hs +++ b/app/Options.hs @@ -4,6 +4,7 @@ , runWithHeader ) where +import Control.Monad import Options.Applicative import qualified Data.Text as T @@ -25,7 +26,7 @@ } deriving (Show) runWithHeader :: (Options -> IO a) -> IO a -runWithHeader o = run (\l -> putGpl >> o l) +runWithHeader o = run (\l -> unless (oQuiet l) putGpl >> o l) run :: (Options -> IO a) -> IO a run = (>>=) (execParser spec) diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,19 @@ +0.2.0.0 +------- + +- Use ST unboxed arrays instead of Data.Sequence and + avoid usage of "temporary lists" during conversion + to ByteStrings +- Add a parameter "size" to the decompressBlock + function for more efficiency +- Rename the decompressBlock function to + decompressBlocks for clarity +- Limit the maximum SAPCAR block size to make memory + exhaustion attacks a bit less easy +- Compile the application single threadedly for more + efficiency (yes, it does help in this case!) + +0.1.1.0 +------- + +- Expose the decompressBlock function directly diff --git a/hascar.cabal b/hascar.cabal --- a/hascar.cabal +++ b/hascar.cabal @@ -1,5 +1,5 @@ name: hascar -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Decompress SAPCAR archives description: Decompress SAPCAR archives homepage: https://github.com/VirtualForgeGmbH/hascar @@ -10,7 +10,7 @@ copyright: 2016, Virtual Forge GmbH category: Codec build-type: Simple -extra-source-files: README.md +extra-source-files: README.md changelog.md cabal-version: >=1.10 library @@ -38,7 +38,7 @@ main-is: Main.hs other-modules: GPL , Options - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -rtsopts build-depends: base , ansi-wl-pprint >= 0.6.7.3 && < 0.7 , binary >= 0.7.5.0 && < 0.9 diff --git a/src/Codec/Archive/SAPCAR.hs b/src/Codec/Archive/SAPCAR.hs --- a/src/Codec/Archive/SAPCAR.hs +++ b/src/Codec/Archive/SAPCAR.hs @@ -374,7 +374,8 @@ let (fCompLen, compHdr) = runGet ((,) <$> getWord32le <*> parseCompHdr) hdr when (chAlg compHdr /= CompLzh) $ error "Currently only LZH is supported, not LZC" blob <- S.hGet h $ fromIntegral fCompLen - 8 - return $ FF.decompressBlock blob + when (chLen compHdr > 655360) $ error "Max 640k block size supported!" + return $ FF.decompressBlocks (fromIntegral $ chLen compHdr) blob -- | Parse (ignore, for now) the SAPCAR global header parseFileHdr :: Get () diff --git a/src/Codec/Archive/SAPCAR/BitStream.hs b/src/Codec/Archive/SAPCAR/BitStream.hs --- a/src/Codec/Archive/SAPCAR/BitStream.hs +++ b/src/Codec/Archive/SAPCAR/BitStream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} -- | -- Module: BitStream -- Copyright: (C) 2015, Virtual Forge GmbH @@ -31,90 +32,79 @@ , consume , getAndConsume , Codec.Archive.SAPCAR.BitStream.isEmpty - , getRest ) where +import Control.Monad.ST import Control.Monad.State.Strict +import Data.Array.MArray +import Data.Array.ST import Data.Bits import Data.ByteString import Data.ByteString.Char8 import Data.Char +import Data.STRef +import Data.Word import Debug.Trace +import qualified Data.ByteString as S + -- |Opaque data type that contains a bitstream -data BitStream = BitStreamy - { bytes :: !ByteString - , number :: !Int - , offset :: !Int - } deriving (Show) +data BitStream s = BitStreamy + { bytes :: STUArray s Int Word8 + , len :: Int + , number :: STRef s Int + , offset :: STRef s Int + , position :: STRef s Int + } -- |Make a bitstream out of a ByteString -makeStream :: ByteString -> BitStream -makeStream theBytes = BitStreamy - { bytes=theBytes - , number=0 - , offset=0 } - -getBits_ :: BitStream -> Int -> (BitStream, Int) -getBits_ stream numBits = - if numBits > offset stream - then getBits_ newStream numBits - else (consumedStream, bits) - where - newStream = stream { number=number stream .|. byte `shiftL` offset stream, - offset=offset stream + 8, - bytes=Data.ByteString.Char8.tail $ bytes stream } - byte = ord . Data.ByteString.Char8.head $ bytes stream - consumedStream = stream -- { number=newNumber } - newNumber = if numBits == 32 - then 0 - else number stream `shiftR` numBits - bits = number stream .&. ((1 `shiftL` numBits) - 1) +makeStream :: ByteString -> ST s (BitStream s) +makeStream theBytes = do + array <- newArray (0, S.length theBytes) 0 :: ST s (STUArray s Int Word8) + mapM_ (\i -> writeArray array i $ S.index theBytes i) [0..(S.length theBytes - 1)] + number <- newSTRef 0 + offset <- newSTRef 0 + position <- newSTRef 0 + return $ BitStreamy + { bytes=array + , len=S.length theBytes + , number=number + , offset=offset + , position=position } -- |Return the specified number of bits from a BitStream, -- converted to an integer using big endian coding -getBits :: Int -> State BitStream Int -getBits 0 = return 0 -getBits numBits = do - stream <- get - let (newstream, result) = getBits_ stream numBits - put newstream - return result - -consume_ :: BitStream -> Int -> BitStream -consume_ stream numBits = - stream { offset=offset stream - numBits, - number=if numBits == 32 - then 0 - else number stream `shiftR` numBits } +getBits :: BitStream s -> Int -> ST s Int +getBits _ 0 = return 0 +getBits stream numBits = do + offs <- readSTRef $ offset stream + num <- readSTRef $ number stream + if numBits > offs + then do + pos <- readSTRef $ position stream + newByte <- fromIntegral <$> readArray (bytes stream) pos + writeSTRef (position stream) $ pos + 1 + let num' = num .|. newByte `shiftL` offs + writeSTRef (offset stream) $ offs + 8 + writeSTRef (number stream) num' + getBits stream numBits + else let bits = num .&. ((1 `shiftL` numBits) - 1) + in return bits -- |Consume the specified number of bits -consume :: Int -> State BitStream () -consume numBits = do - stream <- get - put $ consume_ stream numBits - -getAndConsume_ :: BitStream -> Int -> (BitStream, Int) -getAndConsume_ stream numBits = (newStream, bits) - where - (stream', bits) = getBits_ stream numBits - newStream = consume_ stream' numBits +consume :: BitStream s -> Int -> ST s () +consume stream numBits = do + modifySTRef (offset stream) $ subtract numBits + modifySTRef (number stream) $ \n -> if numBits == 32 then 0 else n `shiftR` numBits -- |A combination of the getBits and consume functions -getAndConsume :: Int -> State BitStream Int -getAndConsume 0 = return 0 -getAndConsume numBits = do - stream <- get - let (newstream, bits) = getAndConsume_ stream numBits - put newstream - return bits +getAndConsume :: BitStream s -> Int -> ST s Int +getAndConsume stream numBits = do + res <- getBits stream numBits + consume stream numBits + return res -- | Is the BitStream empty? -isEmpty :: State BitStream Bool -isEmpty = (== empty) . bytes <$> get - --- | Return a new BitStream that contains the unread --- rest of the given BitStream. -getRest :: State BitStream BitStream -getRest = get +isEmpty :: BitStream s -> ST s Bool +isEmpty bs = (==) (len bs) <$> readSTRef (position bs) diff --git a/src/Codec/Archive/SAPCAR/CanonicalHuffmanTree.hs b/src/Codec/Archive/SAPCAR/CanonicalHuffmanTree.hs --- a/src/Codec/Archive/SAPCAR/CanonicalHuffmanTree.hs +++ b/src/Codec/Archive/SAPCAR/CanonicalHuffmanTree.hs @@ -32,6 +32,7 @@ isLitcode, isEobcode, readEntryRaw) where import Control.Applicative +import Control.Monad.ST import Control.Monad.State.Strict import Data.Bits import Data.List @@ -73,17 +74,17 @@ -- |Read one entry from a bitstream using the given -- CanonicalHuffmanTree, returning the entry in the -- huffman tree, not the value it encodes -readEntryRaw :: CanonicalHuffmanTree -> State BitStream CHTEntry -readEntryRaw (CHT arry maxNumBits) = do - bits' <- getBits maxNumBits +readEntryRaw :: CanonicalHuffmanTree -> BitStream s -> ST s CHTEntry +readEntryRaw (CHT arry maxNumBits) stream = do + bits' <- getBits stream maxNumBits let entry = arry ! bits' - consume $ numBits entry + consume stream $ numBits entry return entry -- |Read one entry from a bitstream using the given -- CanonicalHuffmanTree -readEntry :: CanonicalHuffmanTree -> State BitStream Int -readEntry cht = value <$> readEntryRaw cht +readEntry :: CanonicalHuffmanTree -> BitStream s -> ST s Int +readEntry cht s = value <$> readEntryRaw cht s -- |A constant for literal entries litcode :: Int diff --git a/src/Codec/Archive/SAPCAR/FlatedFile.hs b/src/Codec/Archive/SAPCAR/FlatedFile.hs --- a/src/Codec/Archive/SAPCAR/FlatedFile.hs +++ b/src/Codec/Archive/SAPCAR/FlatedFile.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module: FlatedFile -- Copyright: (C) 2015-2016, Virtual Forge GmbH @@ -26,28 +28,37 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA module Codec.Archive.SAPCAR.FlatedFile - ( decompressBlock + ( decompressBlocks ) where import Control.Applicative import Control.Monad +import Control.Monad.ST import Control.Monad.State.Strict +import Data.Array.Base +import Data.Array.MArray +import Data.Array.ST +import Data.Array.Unboxed import Data.Char import Data.Foldable (toList) import Data.Functor.Identity import Data.Sequence ((><), (|>)) +import Data.STRef 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.ByteString.Short.Internal as SB import qualified Data.Sequence as DS import Codec.Archive.SAPCAR.BitStream import Codec.Archive.SAPCAR.CanonicalHuffmanTree import Codec.Archive.SAPCAR.FlexibleUtils +import Debug.Trace + -- 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] @@ -70,6 +81,10 @@ 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, 99, 99] -- End copied from vpa108csulzh.cpp under GPL by SAP AG +data OutStream s = OutStream + { osBuf :: STUArray s Int Word8 + , osPos :: STRef s Int } + readInt32Big :: Handle -> IO Int readInt32Big h = do [b1, b2, b3, b4] <- replicateM 4 $ ord <$> hGetChar h @@ -79,105 +94,146 @@ -> CanonicalHuffmanTree -> Int -> Int - -> StateT - BitStream Data.Functor.Identity.Identity [Int] -entryReader entries huft entriesToRead lastEntry + -> BitStream s + -> ST s [Int] +entryReader entries huft entriesToRead lastEntry stream | (length . concat $ entries) >= entriesToRead = return . concat . reverse $ entries - | otherwise = do - entry <- readEntry huft + | otherwise = do + entry <- readEntry huft stream newEntries <- handleEntry entry - entryReader (newEntries:entries) huft entriesToRead $ last newEntries + entryReader (newEntries:entries) huft entriesToRead (last newEntries) stream where - handleEntry :: Int -> State BitStream [Int] handleEntry code | code < 16 = return [code] | code == 16 = do - numRepetitions <- (3 +) <$> getAndConsume 2 + numRepetitions <- (3 +) <$> getAndConsume stream 2 return $ replicate numRepetitions lastEntry | code == 17 = do - numZeroes <- (3 +) <$> getAndConsume 3 + numZeroes <- (3 +) <$> getAndConsume stream 3 return $ replicate numZeroes 0 | code == 18 = do - numZeroes <- (11 +) <$> getAndConsume 7 + numZeroes <- (11 +) <$> getAndConsume stream 7 return $ replicate numZeroes 0 | otherwise = error "Corrupted file" decodeIt :: CanonicalHuffmanTree -> CanonicalHuffmanTree - -> DS.Seq Word8 - -> State BitStream (DS.Seq Word8) + -> BitStream s + -> OutStream s + -> ST s () -- decodeIt lt dt = BS.pack . toList <$> decodeIt' empty -decodeIt lt dt = decodeIt' - where - decodeIt' acc = do - entry <- readEntryRaw lt +decodeIt lt dt stream out = do + entry <- readEntryRaw lt stream + return () case numExtraBits entry of - n | n == eobcode -> return acc - n | n == litcode -> decodeIt' $ acc |> (fromIntegral $ value entry) + n | n == eobcode -> return () + n | n == litcode -> writeOut out (fromIntegral $ value entry) >> + decodeIt lt dt stream out 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 - + n <- (+ value entry) <$> getAndConsume stream (numExtraBits entry) + distEntry <- readEntryRaw dt stream + dist <- (+ value distEntry) <$> getAndConsume stream (numExtraBits distEntry) + return () + copyBytes out dist n + decodeIt lt dt stream out +writeOut :: OutStream s -> Word8 -> ST s () +writeOut s b = do + pos <- readSTRef $ osPos s + writeArray (osBuf s) pos b + writeSTRef (osPos s) $ pos + 1 + +copyBytes :: OutStream s -> Int -> Int -> ST s () +copyBytes buf dist len = do + minPos <- (subtract dist) <$> readSTRef (osPos buf) + copyBytes' buf minPos $ minPos + len + +copyBytes' :: OutStream s -> Int -> Int -> ST s () +copyBytes' s n m + | n < m = do + readArray (osBuf s) n >>= writeOut s + copyBytes' s (n + 1) m + | otherwise = return () + -- |Decompress one or more lzh compressed blocks -decompressBlock :: BS.ByteString -> BS.ByteString -decompressBlock inp = blocks +decompressBlocks :: Int -> BS.ByteString -> BS.ByteString +decompressBlocks uncompressedSize c = SB.fromShort $ SB.SBS a where - blocks = evalState decompressor . makeStream $ inp + (_, array) = decompressBlock' uncompressedSize c + (!UArray _ _ _ a) = array -skipNonsenseBits :: State BitStream () -skipNonsenseBits = do - numNonsenseBits <- getAndConsume 2 +decompressBlock' :: Int -> BS.ByteString -> (Int, UArray Int Word8) +decompressBlock' uncompressedSize inp = runST $ do + stream <- makeStream inp + o <- decompressor uncompressedSize stream + o' <- freeze $ osBuf o + l <- readSTRef $ osPos o + return (l, o') + +skipNonsenseBits :: BitStream s -> ST s () +skipNonsenseBits stream = do + numNonsenseBits <- getAndConsume stream 2 when (numNonsenseBits > 0) $ - void $ getAndConsume numNonsenseBits + void $ getAndConsume stream numNonsenseBits -decompressor :: State BitStream BS.ByteString -decompressor = skipNonsenseBits >> (BS.pack . toList <$> decompressor' empty) +makeOutStream :: Int -> ST s (OutStream s) +makeOutStream len = OutStream + <$> (newArray (0, len - 1) 0 :: ST s (STUArray s Int Word8)) + <*> newSTRef 0 -decompressor' :: DS.Seq Word8 -> State BitStream (DS.Seq Word8) -decompressor' acc = do - lastBlock <- getAndConsume 1 - blockType <- getAndConsume 2 +decompressor :: Int -> BitStream s -> ST s (OutStream s) +decompressor uncompressedSize s = do + skipNonsenseBits s + o <- makeOutStream uncompressedSize + decompressor' s o + return o + + +decompressor' :: BitStream s -> OutStream s -> ST s () +decompressor' stream out = do + lastBlock <- getAndConsume stream 1 + blockType <- getAndConsume stream 2 res <- case blockType of - 1 -> decompressStaticBlock acc - 2 -> decompressDynamicBlock acc + 1 -> decompressStaticBlock stream out + 2 -> decompressDynamicBlock stream out _ -> error $ "Block type " ++ show blockType ++ " not supported!" case lastBlock of - 1 -> return res - 0 -> decompressor' res + 1 -> return () + 0 -> decompressor' stream out -decompressDynamicBlock :: DS.Seq Word8 -> State BitStream (DS.Seq Word8) -decompressDynamicBlock acc = do - numLiterals <- (+ 257) <$> getAndConsume 5 - numDistanceCodes <- (+ 1) <$> getAndConsume 5 - numBitLengths <- (+ 4) <$> getAndConsume 4 +decompressDynamicBlock :: BitStream s -> OutStream s -> ST s () +decompressDynamicBlock stream out = do + numLiterals <- (+ 257) <$> getAndConsume stream 5 + numDistanceCodes <- (+ 1) <$> getAndConsume stream 5 + numBitLengths <- (+ 4) <$> getAndConsume stream 4 let bitLengthPositions = Prelude.take numBitLengths border - bitLengths' <- mapM (\blp -> (,) blp <$> getAndConsume 3) bitLengthPositions + bitLengths' <- mapM (\blp -> (,) blp <$> getAndConsume stream 3) bitLengthPositions let bitLengths = makeFlexList (0, 18) 0 bitLengths' huft = makeHuffmanTree bitLengths 19 [] [] entriesToRead = numLiterals + numDistanceCodes - ll <- entryReader [] huft entriesToRead (-1) + ll <- entryReader [] huft entriesToRead (-1) stream 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 + return () + decodeIt lengthTree distTree stream out -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 +staticLengthTree = makeHuffmanTree lengthCodes 257 cplens csExtraLenBits + where + -- Length and dist codes copied from vpa108csulzh.cpp under GPL by SAP AG + lengthCodes = replicate 144 8 ++ replicate 112 9 ++ replicate 24 7 ++ replicate 8 8 + -- End length and dist codes copied from vpa108csulzh.cpp under GPL by SAP AG + +staticDistTree = makeHuffmanTree distCodes 0 cpdist csExtraDistBits + where + -- Length and dist codes copied from vpa108csulzh.cpp under GPL by SAP AG 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 + -- End Length and dist codes copied from vpa108csulzh.cpp under GPL by SAP AG + +decompressStaticBlock :: BitStream s -> OutStream s -> ST s () +decompressStaticBlock = decodeIt staticLengthTree staticDistTree +