pure-zlib 0.4 → 0.5
raw patch · 7 files changed
+237/−102 lines, 7 filesdep +base-compatdep +bytestring-builderdep +filepathdep −test-frameworkdep −test-framework-hunitdep −test-framework-quickcheck2dep ~basedep ~pure-zlib
Dependencies added: base-compat, bytestring-builder, filepath, tasty, tasty-hunit, tasty-quickcheck
Dependencies removed: test-framework, test-framework-hunit, test-framework-quickcheck2
Dependency ranges changed: base, pure-zlib
Files
- Deflate.hs +2/−2
- pure-zlib.cabal +24/−17
- src/Codec/Compression/Zlib.hs +27/−10
- src/Codec/Compression/Zlib/Deflate.hs +33/−22
- src/Codec/Compression/Zlib/HuffmanTree.hs +52/−29
- src/Codec/Compression/Zlib/Monad.hs +46/−9
- test/Test.hs +53/−13
Deflate.hs view
@@ -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]"
pure-zlib.cabal view
@@ -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
src/Codec/Compression/Zlib.hs view
@@ -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
src/Codec/Compression/Zlib/Deflate.hs view
@@ -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
src/Codec/Compression/Zlib/HuffmanTree.hs view
@@ -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
src/Codec/Compression/Zlib/Monad.hs view
@@ -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 =
test/Test.hs view
@@ -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