diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,8 +10,8 @@ This is not yet in a stable state. It should successfully unpack lzh compressed files and uncompressed files. -The SAPCAR container format decoder is based on research done by -Martin Gallo (https://github.com/CoreSecurity/pysap) with further +The SAPCAR container format decoder is based on [research done by +Martin Gallo](https://github.com/CoreSecurity/pysap) with further investigation by Hans-Christian Esperer , who also did the LZH decompressor reimplementation. @@ -29,15 +29,61 @@ * Make the LZH algorithm more efficient (the author just about started to learn haskell when he embarked on implementing that algorithm :-) + => Some work on this has been done; more is required. +# Performance + +The lzh algorithm is implemented in pure haskell. I have spent some time +optimizing it, but more can certainly be done. Currently the performance is +probably acceptable for most cases, but it is still a factor ten compared to +the reference C implementation: + +Decompressing a 136 MB payload (34MB compressed), the performance looks like +this: + + hascar: 7.94user 0.10system 0:08.05elapsed 99%CPU (0avgtext+0avgdata 102676maxresident)k + + sapcar: 0.84user 0.07system 0:00.92elapsed 99%CPU (0avgtext+0avgdata 8244maxresident)k + +Both executed on a single CPU core. (Intel(R) Core(TM) i7-4770 CPU @ 3.40GHz) + # Installing hascar -To compile and install, first get stack ( +# nixos + +Users of [nixos](https://nixos.org) can simply install hascar by issuing "nix-env -iaP haskellPackages.hascar". +You need to be subscribed to the unstable channel at this time. + +# Windows/GNU Linux/FreeBSD/OSX + +To compile and install, first [get stack]( http://docs.haskellstack.org/en/stable/README/), then issue: stack build && stack install -hascar will be installed to ~/.local/bin +hascar will be installed to ~/.local/bin . You should set your PATH variable to point +to this directory. + +# Verifying signatures + +You can use hascar to decompress and subsequently inspect the contents +of a SAR file. You would normally not install the contents from +untrusted SAR files, so there is no need to verify the signature. + +If, OTOH, you do trust the original SAR file but wish to verify the +signature to ensure you are indeed dealing with the original SAR +file's contents, like when installing patches to your SAP system, then +you will need to do the following: Since hascar at this time does not +support verifying signatures, you need to use SAP's own tool for that +purpose. You can use hascar to initially decompress the archive. This +step ensures that only archives with a correct and untampered file +header and compressed contents are accepted. Then, use SAP's own +sapcar tool to create a new archive from the decompressed archive. You +will now have a trusted archive, because you created it yourself. You +can then use SAP's original tool to decompress it again, while +verifying the signature. + +The only attack vector left is the signature checking algorithm. # Usage diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -48,37 +48,36 @@ main = runWithHeader it it :: Options -> IO () -it options = do - withSapCarFile (oFilename options) $ do - entries <- getEntries - let files = ((== CarFile) . cfFileType) `filter` entries - let dirs = ((== CarDirectory) . cfFileType) `filter` entries - unless (oQuiet options) . liftIO . putStrLn $ show (length entries) ++ " entrie(s) in the archive." +it options = withSapCarFile (oFilename options) $ do + entries <- getEntries + let files = ((== CarFile) . cfFileType) `filter` entries + let dirs = ((== CarDirectory) . cfFileType) `filter` entries + unless (oQuiet options) . liftIO . putStrLn $ show (length entries) ++ " entrie(s) in the archive." - when (oListEntries options) $ liftIO $ do - putStrLn "\nAll entries:" - forM_ entries print - putStrLn "" + when (oListEntries options) $ liftIO $ do + putStrLn "\nAll entries:" + forM_ entries print + putStrLn "" - when (oDecompress options) $ do - forM_ dirs $ \dir -> do - dirname <- parseRelDir $ T.unpack $ carEntryFilename dir - when (oVerbose options) $ - liftIO $ putStrLn $ "Creating " ++ show dirname - liftIO $ do - createDirectoryIfMissing True $ fromRelDir dirname + when (oDecompress options) $ do + forM_ dirs $ \dir -> do + dirname <- parseRelDir $ T.unpack $ carEntryFilename dir + when (oVerbose options) $ + liftIO $ putStrLn $ "Creating " ++ show dirname + liftIO $ do + createDirectoryIfMissing True $ fromRelDir dirname #ifndef mingw32_HOST_OS - SPF.setFileMode (fromRelDir dirname) $ CMode $ cfPermissions dir + SPF.setFileMode (fromRelDir dirname) $ CMode $ cfPermissions dir #endif - forM_ files $ \file -> do - filename <- parseRelFile $ T.unpack $ carEntryFilename file - liftIO $ cdim $ fromRelFile filename - when (oVerbose options) $ - liftIO $ putStrLn $ "Extracting " ++ show filename - writeToFile file filename + forM_ files $ \file -> do + filename <- parseRelFile $ T.unpack $ carEntryFilename file + liftIO $ cdim $ fromRelFile filename + when (oVerbose options) $ + liftIO $ putStrLn $ "Extracting " ++ show filename + writeToFile file filename #ifndef mingw32_HOST_OS - liftIO $ SPF.setFileMode (fromRelFile filename) $ CMode $ cfPermissions file + liftIO $ SPF.setFileMode (fromRelFile filename) $ CMode $ cfPermissions file #endif diff --git a/hascar.cabal b/hascar.cabal --- a/hascar.cabal +++ b/hascar.cabal @@ -1,5 +1,5 @@ name: hascar -version: 0.2.0.0 +version: 0.2.0.1 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 changelog.md +extra-source-files: README.md changelog.md test/test6.sar cabal-version: >=1.10 library 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 @@ -270,12 +270,7 @@ writer h = do chunk <- await case chunk of - Just chunk' -> do - liftIO $ do - -- S.hPut h "================== BEGIN CHUNK =======================================\n" - S.hPut h chunk' - -- S.hPut h "\n============================ END CHUNK ===============================\n" - writer h + Just chunk' -> liftIO (S.hPut h chunk') >> writer h Nothing -> return () -- | Parse the compression header of one SAPCAR block. @@ -321,8 +316,8 @@ ed <- getByteString 2 skipBlock case ed of - "ED" -> getWord32le >> return () - "UE" -> getWord32le >> return () + "ED" -> void getWord32le + "UE" -> void getWord32le "DA" -> skipBlocks "UD" -> skipBlocks _ -> error $ "Unknown block type " ++ show ed @@ -338,23 +333,22 @@ case ed of -- Compressed block (any algorithm; last block) "ED" -> do - (liftIO $ decompressBlock h) >>= yield + liftIO (decompressBlock h) >>= yield void $ liftIO $ S.hGet h 4 -- TODO: This is the crc value. Use it! -- Compressed block (any algorithm; more to follow) "DA" -> do - (liftIO $ decompressBlock h) >>= yield - -- liftIO $ print blocks + liftIO (decompressBlock h) >>= yield decompressBlocks h -- Uncompressed block (more to follow) "UD" -> do - (liftIO $ uncompressedBlock h) >>= yield + liftIO (uncompressedBlock h) >>= yield decompressBlocks h -- Uncompressed block (last block) -- Looks like uncompressed files don't have a CRC appended - "UE" -> (liftIO $ uncompressedBlock h) >>= yield + "UE" -> liftIO (uncompressedBlock h) >>= yield _ -> error $ "(while decompressing) unknown block type " ++ show ed 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 @@ -66,7 +66,7 @@ number <- newSTRef 0 offset <- newSTRef 0 position <- newSTRef 0 - return $ BitStreamy + return BitStreamy { bytes=array , len=S.length theBytes , number=number @@ -79,18 +79,46 @@ 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 + then case numBits - offs of + n | n < 9 -> refill False stream >> returnBits stream numBits + n | n < 17 -> refill True stream >> returnBits stream numBits + _ -> refill True stream >> getBits stream numBits + else returnBits stream numBits + +returnBits :: BitStream s -> Int -> ST s Int +returnBits stream numBits = do + num <- readSTRef $ number stream + return $ num .&. ((1 `shiftL` numBits) - 1) + +refill :: Bool -> BitStream s-> ST s () +{-# INLINE refill #-} +refill two stream = do + pos <- readSTRef $ position stream + num <- readSTRef $ number stream + offs <- readSTRef $ offset stream + if two + then refillTwoBits pos num offs stream + else refillOneBit pos num offs stream + +refillOneBit :: Int -> Int -> Int -> BitStream s -> ST s () +{-# INLINE refillOneBit #-} +refillOneBit pos num offs stream = do + 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' + +refillTwoBits :: Int -> Int -> Int -> BitStream s -> ST s () +{-# INLINE refillTwoBits #-} +refillTwoBits pos num offs stream = do + newByte1 <- fromIntegral <$> readArray (bytes stream) pos + newByte2 <- fromIntegral <$> readArray (bytes stream) (pos + 1) + writeSTRef (position stream) $ pos + 2 + let num' = num .|. newByte1 `shiftL` offs .|. newByte2 `shiftL` (offs + 8) + writeSTRef (offset stream) $ offs + 16 + writeSTRef (number stream) num' -- |Consume the specified number of bits consume :: BitStream s -> Int -> ST s () 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,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE BangPatterns #-} -- | -- Module: FlatedFile @@ -83,7 +82,7 @@ data OutStream s = OutStream { osBuf :: STUArray s Int Word8 - , osPos :: STRef s Int } + , osPos :: STUArray s Int Int } readInt32Big :: Handle -> IO Int readInt32Big h = do @@ -142,13 +141,13 @@ writeOut :: OutStream s -> Word8 -> ST s () writeOut s b = do - pos <- readSTRef $ osPos s + pos <- readArray (osPos s) 0 writeArray (osBuf s) pos b - writeSTRef (osPos s) $ pos + 1 + writeArray (osPos s) 0 $ pos + 1 copyBytes :: OutStream s -> Int -> Int -> ST s () copyBytes buf dist len = do - minPos <- (subtract dist) <$> readSTRef (osPos buf) + minPos <- subtract dist <$> readArray (osPos buf) 0 copyBytes' buf minPos $ minPos + len copyBytes' :: OutStream s -> Int -> Int -> ST s () @@ -170,7 +169,7 @@ stream <- makeStream inp o <- decompressor uncompressedSize stream o' <- freeze $ osBuf o - l <- readSTRef $ osPos o + l <- readArray (osPos o) 0 return (l, o') skipNonsenseBits :: BitStream s -> ST s () @@ -182,7 +181,7 @@ makeOutStream :: Int -> ST s (OutStream s) makeOutStream len = OutStream <$> (newArray (0, len - 1) 0 :: ST s (STUArray s Int Word8)) - <*> newSTRef 0 + <*> (newArray (0, 1) 0 :: ST s (STUArray s Int Int)) decompressor :: Int -> BitStream s -> ST s (OutStream s) decompressor uncompressedSize s = do @@ -222,12 +221,14 @@ return () decodeIt lengthTree distTree stream out +staticLengthTree :: CanonicalHuffmanTree 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 :: CanonicalHuffmanTree staticDistTree = makeHuffmanTree distCodes 0 cpdist csExtraDistBits where -- Length and dist codes copied from vpa108csulzh.cpp under GPL by SAP AG diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -27,7 +27,7 @@ res <- withSapCarPath path $ do entries <- getEntries unless (length entries == 1) $ error "test6.sar should contain exactly one entry!" - let entry = entries !! 0 + let entry = head entries unless (cfFileName entry == "pg244.txt") $ error "Entry in test6.sar should be called 'pg244.txt'!" unless (cfFileType entry == CarFile) $ error "Entry in test6.sar should be of type 'file'!" sourceEntry entry bufSink diff --git a/test/test6.sar b/test/test6.sar new file mode 100644 Binary files /dev/null and b/test/test6.sar differ