diff --git a/Deflate.hs b/Deflate.hs --- a/Deflate.hs +++ b/Deflate.hs @@ -12,8 +12,8 @@ if ".z" `isSuffixOf` ifile then do bstr <- readFile ifile case decompress bstr of - Nothing -> putStrLn "Decompression failure." - Just o -> writeFile (take (length ifile - 2) ifile) o + Left err -> putStrLn (show err) + Right bs -> writeFile (take (length ifile - 2) ifile) bs else putStrLn "Unexpected file name." _ -> putStrLn "USAGE: deflate [filename]" diff --git a/pure-zlib.cabal b/pure-zlib.cabal --- a/pure-zlib.cabal +++ b/pure-zlib.cabal @@ -1,5 +1,5 @@ name: pure-zlib -version: 0.4 +version: 0.5 synopsis: A Haskell-only implementation of zlib / DEFLATE homepage: http://github.com/GaloisInc/pure-zlib license: BSD3 @@ -18,11 +18,13 @@ ghc-options: -Wall hs-source-dirs: src build-depends: - base >= 4.7 && < 5.0, - bytestring >= 0.10 && < 0.11, - containers >= 0.5 && < 0.7, - fingertree >= 0.1 && < 0.3, - monadLib >= 3.7 && < 3.9 + base >= 4.6 && < 5.0, + base-compat >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, + bytestring-builder >= 0.10 && < 0.11, + containers >= 0.5 && < 0.7, + fingertree >= 0.1 && < 0.3, + monadLib >= 3.7 && < 3.9 exposed-modules: Codec.Compression.Zlib, Codec.Compression.Zlib.Adler32, @@ -32,6 +34,8 @@ Codec.Compression.Zlib.OutputWindow default-extensions: BangPatterns, + DeriveDataTypeable, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, MultiWayIf @@ -40,9 +44,10 @@ main-is: Deflate.hs ghc-options: -Wall build-depends: - base >= 4.7 && < 5.0, - bytestring >= 0.10 && < 0.11, - pure-zlib >= 0.3 && < 0.5 + base >= 4.6 && < 5.0, + base-compat >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, + pure-zlib >= 0.5 && < 0.8 test-suite test-zlib type: exitcode-stdio-1.0 @@ -52,14 +57,16 @@ default-language: Haskell2010 ghc-options: -fno-warn-orphans build-depends: - base >= 4.7 && < 5.0, - bytestring >= 0.10 && < 0.11, - pure-zlib >= 0.3 && < 1.1, - HUnit >= 1.2 && < 1.4, - QuickCheck >= 2.7 && < 2.9, - test-framework >= 0.8 && < 0.10, - test-framework-hunit >= 0.3 && < 0.5, - test-framework-quickcheck2 >= 0.3 && < 0.5 + base >= 4.6 && < 5.0, + base-compat >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, + filepath >= 1.4.1 && < 1.6, + HUnit >= 1.2 && < 1.4, + QuickCheck >= 2.7 && < 2.9, + pure-zlib >= 0.5 && < 0.8, + tasty >= 0.11.0.4 && < 0.13, + tasty-hunit >= 0.9.2 && < 0.11, + tasty-quickcheck >= 0.8.4 && < 0.11 source-repository head type: git diff --git a/src/Codec/Compression/Zlib.hs b/src/Codec/Compression/Zlib.hs --- a/src/Codec/Compression/Zlib.hs +++ b/src/Codec/Compression/Zlib.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MultiWayIf #-} module Codec.Compression.Zlib( - decompress + DecompressionError(..) + , decompress ) where @@ -9,17 +10,33 @@ import Data.Bits import Data.ByteString.Lazy(ByteString) import qualified Data.ByteString.Lazy as BS +import Data.Word -decompress :: ByteString -> Maybe ByteString +decompress :: ByteString -> Either DecompressionError ByteString decompress ifile = case BS.uncons ifile of - Nothing -> error "Could not read CMF." + Nothing -> Left (HeaderError "Could not read CMF.") Just (cmf, rest) -> case BS.uncons rest of - Nothing -> error "Could not read FLG." - Just (_, rest') -> - let cm = cmf .&. 0x0F - cinfo = cmf `shiftR` 4 - in if| cm /= 8 -> error "Non-DEFLATE compression method." - | cinfo > 7 -> error "Window size too big." - | otherwise -> runDeflateM inflate rest' + Nothing -> Left (HeaderError "Could not read FLG.") + Just (flg, body) -> + runDecompression cmf flg body + +runDecompression :: Word8 -> Word8 -> ByteString -> + Either DecompressionError ByteString +runDecompression cmf flg body + | both `mod` 31 /= 0 = Left (HeaderError ("Header checksum failed")) + | cm /= 8 = Left (HeaderError ("Bad method ("++show cm++")")) + | cinfo > 7 = Left (HeaderError "Window size too big.") + | otherwise = runDeflateM inflate body' + where + cm = cmf .&. 0x0f + cinfo = cmf `shiftR` 4 + fdict = testBit flg 5 +-- flevel = flg `shiftR` 6 + -- + body' | fdict = BS.drop 4 body + | otherwise = body + -- + both :: Word16 + both = (fromIntegral cmf `shiftL` 8) .|. fromIntegral flg diff --git a/src/Codec/Compression/Zlib/Deflate.hs b/src/Codec/Compression/Zlib/Deflate.hs --- a/src/Codec/Compression/Zlib/Deflate.hs +++ b/src/Codec/Compression/Zlib/Deflate.hs @@ -16,22 +16,28 @@ import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map import Data.Word +import MonadLib(raise) -inflate :: DeflateM (Maybe ByteString) +inflate :: DeflateM ByteString inflate = do isFinal <- inflateBlock if isFinal - then do advanceToByte - rest <- readRest - ourAdler <- finalAdler - result <- finalOutput - let theirAdler = BS.foldl shiftAdd 0 rest - if | BS.length rest /= 4 -> return Nothing - | theirAdler /= ourAdler -> return Nothing - | otherwise -> return (Just result) + then checkChecksum >> finalOutput else inflate - where shiftAdd x y = (x `shiftL` 8) .|. fromIntegral y + where + shiftAdd x y = (x `shiftL` 8) .|. fromIntegral y + -- + checkChecksum = + do advanceToByte + rest <- readRest + ourAdler <- finalAdler + let theirAdler = BS.foldl shiftAdd 0 rest + if | BS.length rest < 4 -> raise (ChecksumError "checksum missing") + | BS.length rest > 4 -> raise (FormatError "Ends in middle of file") + | theirAdler /= ourAdler -> raise (ChecksumError "checksum mismatch") + | otherwise -> return () + inflateBlock :: DeflateM Bool inflateBlock = do bfinal <- nextBit @@ -42,11 +48,13 @@ len <- nextWord16 nlen <- nextWord16 unless (len == complement nlen) $ - fail "Len/nlen mismatch in uncompressed block." + raise (FormatError "Len/nlen mismatch in uncompressed block.") emitBlock =<< nextBlock len return bfinal 1 -> -- compressed with fixed Huffman codes - do runInflate fixedLitTree fixedDistanceTree + do flt <- fixedLitTree + fdt <- fixedDistanceTree + runInflate flt fdt return bfinal 2 -> -- compressed with dynamic Huffman codes do hlit <- (257+) `fmap` nextBits 5 @@ -54,7 +62,7 @@ hclen <- (4+) `fmap` nextBits 4 codeLens <- replicateM hclen (nextBits 3) let codeLens' = zip codeLengthOrder codeLens - codeTree = computeHuffmanTree codeLens' + codeTree <- computeHuffmanTree codeLens' lens <- getCodeLengths codeTree 0 (hlit + hdist) 0 Map.empty -- We do this as a big chunk and then split it up because the spec -- allows repeat codes to cross the hlit / hdist boundary. So now we @@ -62,12 +70,12 @@ let (litlens, offdistlens) = Map.partitionWithKey (\ k _ -> k < hlit) lens distlens = Map.mapKeys (\ k -> k - hlit) offdistlens - litTree = computeHuffmanTree (Map.toList litlens) - distTree = computeHuffmanTree (Map.toList distlens) + litTree <- computeHuffmanTree (Map.toList litlens) + distTree <- computeHuffmanTree (Map.toList distlens) runInflate litTree distTree return bfinal _ -> -- reserved / error - error ("Unacceptable BTYPE: " ++ show btype) + raise (FormatError ("Unacceptable BTYPE: " ++ show btype)) where runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM () runInflate litTree distTree = @@ -113,7 +121,7 @@ getLength :: Int -> DeflateM Int64 getLength c = case Map.lookup c getLengthMap of - Nothing -> error ("getLength for bad code: " ++ show c) + Nothing -> raise (DecompressionError ("getLength for bad code: "++show c)) Just m -> m getLengthMap :: Map Int (DeflateM Int64) @@ -152,7 +160,7 @@ getDistance :: Int -> DeflateM Int getDistance c = case Map.lookup c getDistanceMap of - Nothing -> error ("getDistance for bad code: " ++ show c) + Nothing -> raise (DecompressionError ("getDistance for bad code: "++show c)) Just m -> m getDistanceMap :: Map Int (DeflateM Int) @@ -191,20 +199,23 @@ -- ----------------------------------------------------------------------------- -fixedLitTree :: HuffmanTree Int +fixedLitTree :: DeflateM (HuffmanTree Int) fixedLitTree = computeHuffmanTree ([(x, 8) | x <- [0 .. 143]] ++ [(x, 9) | x <- [144 .. 255]] ++ [(x, 7) | x <- [256 .. 279]] ++ [(x, 8) | x <- [280 .. 287]]) -fixedDistanceTree :: HuffmanTree Int +fixedDistanceTree :: DeflateM (HuffmanTree Int) fixedDistanceTree = computeHuffmanTree [(x,5) | x <- [0..31]] -- ----------------------------------------------------------------------------- -computeHuffmanTree :: [(Int, Int)] -> HuffmanTree Int -computeHuffmanTree = createHuffmanTree . computeCodeValues +computeHuffmanTree :: [(Int, Int)] -> DeflateM (HuffmanTree Int) +computeHuffmanTree initialData = + case createHuffmanTree (computeCodeValues initialData) of + Left err -> raise (HuffmanTreeError err) + Right x -> return x computeCodeValues :: Ord a => [(a, Int)] -> [(a, Int, Int)] computeCodeValues vals = Map.foldrWithKey (\ v (l, c) a -> (v,l,c):a) [] codes diff --git a/src/Codec/Compression/Zlib/HuffmanTree.hs b/src/Codec/Compression/Zlib/HuffmanTree.hs --- a/src/Codec/Compression/Zlib/HuffmanTree.hs +++ b/src/Codec/Compression/Zlib/HuffmanTree.hs @@ -1,5 +1,6 @@ module Codec.Compression.Zlib.HuffmanTree( HuffmanTree + , AdvanceResult(..) , createHuffmanTree , advanceTree ) @@ -12,37 +13,59 @@ | HuffmanEmpty deriving (Show) +data AdvanceResult a = AdvanceError String + | NewTree (HuffmanTree a) + | Result a + emptyHuffmanTree :: HuffmanTree a emptyHuffmanTree = HuffmanEmpty -createHuffmanTree :: Show a => [(a, Int, Int)] -> HuffmanTree a -createHuffmanTree = foldr addHuffmanNode' emptyHuffmanTree - where addHuffmanNode' (a, b, c) = addHuffmanNode a b c - -addHuffmanNode :: Show a => a -> Int -> Int -> HuffmanTree a -> HuffmanTree a -addHuffmanNode val 0 _ (HuffmanNode _ _) = - error ("Tried to add where the leaf is a node: " ++ show val) -addHuffmanNode _ 0 _ (HuffmanValue _) = - error "Two values point to the same place!" -addHuffmanNode val 0 _ HuffmanEmpty = - HuffmanValue val -addHuffmanNode val len code (HuffmanNode l r) - | testBit code (len - 1) = HuffmanNode l (addHuffmanNode val (len - 1) code r) - | otherwise = HuffmanNode (addHuffmanNode val (len - 1) code l) r -addHuffmanNode _ _ _ (HuffmanValue _) = - error "HuffmanValue hit while inserting a value!" -addHuffmanNode val len code HuffmanEmpty = - let newNode = addHuffmanNode val (len - 1) code HuffmanEmpty - in if testBit code (len - 1) - then HuffmanNode HuffmanEmpty newNode - else HuffmanNode newNode HuffmanEmpty +createHuffmanTree :: Show a => + [(a, Int, Int)] -> + Either String (HuffmanTree a) +createHuffmanTree = foldr addHuffmanNode' (Right emptyHuffmanTree) + where addHuffmanNode' (a, b, c) acc = + case acc of + Left err -> Left err + Right tree -> addHuffmanNode a b c tree -advanceTree :: Bool -> HuffmanTree a -> Either (HuffmanTree a) a -advanceTree _ HuffmanEmpty = error "Tried to advance empty tree!" -advanceTree _ (HuffmanValue _) = error "Tried to advance empty value!" -advanceTree x (HuffmanNode l r) = - case if x then r else l of - HuffmanEmpty -> error "Advanced to empty tree!" - HuffmanValue y -> Right y - t -> Left t +addHuffmanNode :: Show a => + a -> Int -> Int -> HuffmanTree a -> + Either String (HuffmanTree a) +addHuffmanNode val len code node = + case node of + HuffmanEmpty | len == 0 -> + Right (HuffmanValue val) + HuffmanEmpty -> + case addHuffmanNode val (len - 1) code HuffmanEmpty of + Left err -> Left err + Right newNode + | testBit code (len - 1) -> Right (HuffmanNode HuffmanEmpty newNode) + | otherwise -> Right (HuffmanNode newNode HuffmanEmpty) + -- + HuffmanValue _ | len == 0 -> + Left "Two values point to the same place!" + HuffmanValue _ -> + Left "HuffmanValue hit while inserting a value!" + -- + HuffmanNode _ _ | len == 0 -> + Left ("Tried to add where the leaf is a node: " ++ show val) + HuffmanNode l r | testBit code (len - 1) -> + case addHuffmanNode val (len - 1) code r of + Left err -> Left err + Right r' -> Right (HuffmanNode l r') + HuffmanNode l r -> + case addHuffmanNode val (len - 1) code l of + Left err -> Left err + Right l' -> Right (HuffmanNode l' r) +advanceTree :: Bool -> HuffmanTree a -> AdvanceResult a +advanceTree x node = + case node of + HuffmanEmpty -> AdvanceError "Tried to advance empty tree!" + HuffmanValue _ -> AdvanceError "Tried to advance value!" + HuffmanNode l r -> + case if x then r else l of + HuffmanEmpty -> AdvanceError "Advanced to empty tree!" + HuffmanValue y -> Result y + t -> NewTree t diff --git a/src/Codec/Compression/Zlib/Monad.hs b/src/Codec/Compression/Zlib/Monad.hs --- a/src/Codec/Compression/Zlib/Monad.hs +++ b/src/Codec/Compression/Zlib/Monad.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Codec.Compression.Zlib.Monad( DeflateM , runDeflateM + , DecompressionError(..) -- * Getting data from the input stream. , nextBit , nextBits @@ -24,14 +27,17 @@ import Codec.Compression.Zlib.Adler32 import Codec.Compression.Zlib.HuffmanTree import Codec.Compression.Zlib.OutputWindow +import Control.Exception(Exception) import Control.Monad import Data.Bits import Data.ByteString.Lazy(ByteString) import qualified Data.ByteString.Lazy as BS import Data.Int +import Data.Typeable import Data.Word import MonadLib -import MonadLib.Monads +import Prelude() +import Prelude.Compat data DecompressState = DecompressState { dcsNextBitNo :: !Int @@ -41,17 +47,47 @@ , dcsOutput :: !OutputWindow } -type DeflateM = State DecompressState +data DecompressionError = HuffmanTreeError String + | FormatError String + | DecompressionError String + | HeaderError String + | ChecksumError String + deriving (Typeable, Eq) +instance Show DecompressionError where + show x = + case x of + HuffmanTreeError s -> "Huffman tree manipulation error: " ++ s + FormatError s -> "Block format error: " ++ s + DecompressionError s -> "Decompression error: " ++ s + HeaderError s -> "Header error: " ++ s + ChecksumError s -> "Checksum error: " ++ s + +instance Exception DecompressionError + +newtype DeflateM a = DeflateM (StateT DecompressState + (ExceptionT DecompressionError Id) + a) + deriving (Applicative, Functor, Monad) + +instance StateM DeflateM DecompressState where + get = DeflateM get + set x = DeflateM (set x) + +instance ExceptionM DeflateM DecompressionError where + raise e = DeflateM (lift (raise e)) + initialState :: ByteString -> DecompressState initialState bstr = case BS.uncons bstr of Nothing -> error "No compressed data to inflate." Just (f,rest) -> DecompressState 0 f initialAdlerState rest emptyWindow -runDeflateM :: Show a => DeflateM a -> ByteString -> a -runDeflateM m i = result - where (result, _) = runState (initialState i) m +runDeflateM :: DeflateM a -> ByteString -> Either DecompressionError a +runDeflateM (DeflateM m) i = + case runId (runExceptionT (runStateT (initialState i) m)) of + Left err -> Left err + Right (res, _) -> Right res -- ----------------------------------------------------------------------------- @@ -97,8 +133,8 @@ nextWord16 :: DeflateM Word16 nextWord16 = - do high <- fromIntegral `fmap` nextByte - low <- fromIntegral `fmap` nextByte + do low <- fromIntegral `fmap` nextByte + high <- fromIntegral `fmap` nextByte return ((high `shiftL` 8) .|. low) nextBlock :: Integral a => a -> DeflateM ByteString @@ -119,8 +155,9 @@ nextCode tree = do b <- nextBit case advanceTree b tree of - Left tree' -> nextCode tree' - Right x -> return x + AdvanceError str -> raise (HuffmanTreeError str) + NewTree tree' -> nextCode tree' + Result x -> return x readRest :: DeflateM ByteString readRest = diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,8 +1,14 @@ +import Codec.Compression.Zlib import Codec.Compression.Zlib.Deflate -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit(assertEqual) +import Data.ByteString.Lazy(readFile) +import Data.List(last, isPrefixOf) +import Prelude hiding (readFile) +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +-- ----------------------------------------------------------------------------- + rfcSimpleTestLengths :: [(Char, Int)] rfcSimpleTestLengths = [ ('A', 3) @@ -41,17 +47,51 @@ [(fst x, 7, snd x) | x <- zip [256..279] [0 .. 23]] ++ -- 0000000 through 0010111 [(fst x, 8, snd x) | x <- zip [280..287] [192..199]]) -- 11000000 through 11000111 -zlibTests :: Test +-- ----------------------------------------------------------------------------- + +testCases :: [FilePath] +testCases = [ "randtest1", "randtest2", "randtest3", + "rfctest1", "rfctest2", "rfctest3", + "zerotest1", "zerotest2", "zerotest3" ] + +buildGoldTestCases :: IO TestTree +buildGoldTestCases = + do trees <- mapM buildGoldTest testCases + return (testGroup "Decompression Tests" trees) + +buildGoldTest :: FilePath -> IO TestTree +buildGoldTest test = + do let compressedFile = "test" "test-cases" test <.> "z" + goldFile = "test" "test-cases" test <.> "gold" + compressedBStr <- readFile compressedFile + goldBStr <- readFile goldFile + return (testCase (toTestCaseName test) + (assertEqual test (Right goldBStr) (decompress compressedBStr))) + +toTestCaseName :: FilePath -> String +toTestCaseName fpath = prefix ++ suffix + where + prefix | "zero" `isPrefixOf` fpath = "Zero test #" + | "rand" `isPrefixOf` fpath = "Random test #" + | "rfc" `isPrefixOf` fpath = "RFC test #" + | otherwise = error "Bad test case prefix." + suffix = [last fpath] + +-- ----------------------------------------------------------------------------- + +zlibTests :: IO TestTree zlibTests = - testGroup "DEFLATE / ZLib Algorithm Testing" [ - testCase "RFC 1951 Code Generation Test" - (assertEqual "" (computeCodeValues rfcSimpleTestLengths) - rfcSimpleTestResults) - , testCase "Fixed Huffman lengths make right tree" - (assertEqual "" (computeCodeValues fixedHuffmanLengths) - fixedHuffmanResults) - ] + do decompTests <- buildGoldTestCases + return $ testGroup "DEFLATE / ZLib Algorithm Testing" [ + testCase "RFC 1951 Code Generation Test" + (assertEqual "" (computeCodeValues rfcSimpleTestLengths) + rfcSimpleTestResults) + , testCase "Fixed Huffman lengths make right tree" + (assertEqual "" (computeCodeValues fixedHuffmanLengths) + fixedHuffmanResults) + , decompTests + ] main :: IO () -main = defaultMain [zlibTests] +main = defaultMain =<< zlibTests