hascar 0.1.1.0 → 0.2.0.0
raw patch · 7 files changed
+205/−137 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Codec.Archive.SAPCAR.FlatedFile: decompressBlock :: ByteString -> ByteString
+ Codec.Archive.SAPCAR.FlatedFile: decompressBlocks :: Int -> ByteString -> ByteString
Files
- app/Options.hs +2/−1
- changelog.md +19/−0
- hascar.cabal +3/−3
- src/Codec/Archive/SAPCAR.hs +2/−1
- src/Codec/Archive/SAPCAR/BitStream.hs +55/−65
- src/Codec/Archive/SAPCAR/CanonicalHuffmanTree.hs +7/−6
- src/Codec/Archive/SAPCAR/FlatedFile.hs +117/−61
app/Options.hs view
@@ -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)
+ changelog.md view
@@ -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
hascar.cabal view
@@ -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
src/Codec/Archive/SAPCAR.hs view
@@ -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 ()
src/Codec/Archive/SAPCAR/BitStream.hs view
@@ -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)
src/Codec/Archive/SAPCAR/CanonicalHuffmanTree.hs view
@@ -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
src/Codec/Archive/SAPCAR/FlatedFile.hs view
@@ -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+