diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2010 Galois Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pure-zlib.cabal b/pure-zlib.cabal new file mode 100644 --- /dev/null +++ b/pure-zlib.cabal @@ -0,0 +1,49 @@ +name: pure-zlib +version: 0.3 +synopsis: A Haskell-only implementation of zlib / DEFLATE +homepage: http://github.com/GaloisInc/pure-zlib +license: BSD3 +license-file: LICENSE +author: Adam Wick +maintainer: awick@galois.com +category: Codec +build-type: Simple +cabal-version: >=1.10 +description: A Haskell-only implementation of the zlib / DEFLATE + protocol. Currently only implements the decompression + algorithm. + +library + default-language: Haskell2010 + 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 + exposed-modules: + Codec.Compression.Zlib, + Codec.Compression.Zlib.Adler32, + Codec.Compression.Zlib.Deflate, + Codec.Compression.Zlib.HuffmanTree, + Codec.Compression.Zlib.Monad, + Codec.Compression.Zlib.OutputWindow + +test-suite test-zlib + type: exitcode-stdio-1.0 + main-is: Test.hs + ghc-options: -Wall + hs-source-dirs: test + 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 diff --git a/src/Codec/Compression/Zlib.hs b/src/Codec/Compression/Zlib.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Zlib.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiWayIf #-} +module Codec.Compression.Zlib( + decompress + ) + where + +import Codec.Compression.Zlib.Deflate +import Codec.Compression.Zlib.Monad +import Data.Bits +import Data.ByteString.Lazy(ByteString) +import qualified Data.ByteString.Lazy as BS + +decompress :: ByteString -> Maybe ByteString +decompress ifile = + case BS.uncons ifile of + Nothing -> error "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' diff --git a/src/Codec/Compression/Zlib/Adler32.hs b/src/Codec/Compression/Zlib/Adler32.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Zlib/Adler32.hs @@ -0,0 +1,34 @@ +module Codec.Compression.Zlib.Adler32( + AdlerState + , initialAdlerState + , advanceAdler + , finalizeAdler + ) + where + +import Data.Bits +import Data.Word + +data AdlerState = AdlerState { adlerA :: !Word16, adlerB :: !Word16 } + +initialAdlerState :: AdlerState +initialAdlerState = AdlerState 1 0 + +adlerAdd :: (Integral a, Integral b) => a -> b -> Word16 +adlerAdd x y = fromIntegral ((x32 + y32) `mod` 65521) + where + x32, y32 :: Word32 + x32 = fromIntegral x + y32 = fromIntegral y + +advanceAdler :: AdlerState -> Word8 -> AdlerState +advanceAdler state b = AdlerState a' b' + where + a' = adlerAdd (adlerA state) b + b' = adlerAdd (adlerB state) a' + +finalizeAdler :: AdlerState -> Word32 +finalizeAdler state = ((fromIntegral (adlerB state)) `shiftL` 16) + .|. fromIntegral (adlerA state) + + diff --git a/src/Codec/Compression/Zlib/Deflate.hs b/src/Codec/Compression/Zlib/Deflate.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Zlib/Deflate.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE MultiWayIf #-} +module Codec.Compression.Zlib.Deflate( + inflate + , computeCodeValues + ) + where + +import Codec.Compression.Zlib.HuffmanTree +import Codec.Compression.Zlib.Monad +import Control.Monad +import Data.Bits +import Data.ByteString.Lazy(ByteString) +import qualified Data.ByteString.Lazy as BS +import Data.Int +import Data.List +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map +import Data.Word + +inflate :: DeflateM (Maybe 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) + else inflate + where shiftAdd x y = (x `shiftL` 8) .|. fromIntegral y + +inflateBlock :: DeflateM Bool +inflateBlock = + do bfinal <- nextBit + btype <- nextBits 2 + case btype :: Word8 of + 0 -> -- no compression + do advanceToByte + len <- nextWord16 + nlen <- nextWord16 + unless (len == complement nlen) $ + fail "Len/nlen mismatch in uncompressed block." + emitBlock =<< nextBlock len + return bfinal + 1 -> -- compressed with fixed Huffman codes + do runInflate fixedLitTree fixedDistanceTree + return bfinal + 2 -> -- compressed with dynamic Huffman codes + do hlit <- (257+) `fmap` nextBits 5 + hdist <- (1+) `fmap` nextBits 5 + hclen <- (4+) `fmap` nextBits 4 + codeLens <- replicateM hclen (nextBits 3) + let codeLens' = zip codeLengthOrder 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 + -- need to pull off the hdist items. + 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) + runInflate litTree distTree + return bfinal + _ -> -- reserved / error + error ("Unacceptable BTYPE: " ++ show btype) + where + runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM () + runInflate litTree distTree = + do code <- nextCode litTree + if | code < 256 -> do emitByte (fromIntegral code) + runInflate litTree distTree + | code == 256 -> return () + | code > 256 -> do len <- getLength code + distCode <- nextCode distTree + dist <- getDistance distCode + emitPastChunk dist len + runInflate litTree distTree + +-- ----------------------------------------------------------------------------- + +getCodeLengths :: HuffmanTree Int -> + Int -> Int -> Int -> + Map Int Int -> + DeflateM (Map Int Int) +getCodeLengths tree n maxl prev acc + | n >= maxl = return acc + | otherwise = + do code <- nextCode tree + if | code <= 15 -> + getCodeLengths tree (n+1) maxl code (Map.insert n code acc) + | code == 16 -> -- copy the previous code length 3 - 6 times + do num <- (3+) `fmap` nextBits 2 + getCodeLengths tree (n+num) maxl prev (addNTimes n num prev acc) + | code == 17 -> -- repeat a code length of 0 for 3 - 10 times + do num <- (3+) `fmap` nextBits 3 + getCodeLengths tree (n+num) maxl 0 (addNTimes n num 0 acc) + | code == 18 -> -- repeat a code length of 0 for 11 - 138 times + do num <- (11+) `fmap` nextBits 7 + getCodeLengths tree (n+num) maxl 0 (addNTimes n num 0 acc) + where + addNTimes idx count val old = + let idxs = take count [idx..] + vals = replicate count val + in Map.union old (Map.fromList (zip idxs vals)) + +-- ----------------------------------------------------------------------------- + +getLength :: Int -> DeflateM Int64 +getLength c = + case Map.lookup c getLengthMap of + Nothing -> error ("getLength for bad code: " ++ show c) + Just m -> m + +getLengthMap :: Map Int (DeflateM Int64) +getLengthMap = Map.fromList [ + (257, return 3) + , (258, return 4) + , (259, return 5) + , (260, return 6) + , (261, return 7) + , (262, return 8) + , (263, return 9) + , (264, return 10) + , (265, (+ 11) `fmap` nextBits 1) + , (266, (+ 13) `fmap` nextBits 1) + , (267, (+ 15) `fmap` nextBits 1) + , (268, (+ 17) `fmap` nextBits 1) + , (269, (+ 19) `fmap` nextBits 2) + , (270, (+ 23) `fmap` nextBits 2) + , (271, (+ 27) `fmap` nextBits 2) + , (272, (+ 31) `fmap` nextBits 2) + , (273, (+ 35) `fmap` nextBits 3) + , (274, (+ 43) `fmap` nextBits 3) + , (275, (+ 51) `fmap` nextBits 3) + , (276, (+ 59) `fmap` nextBits 3) + , (277, (+ 67) `fmap` nextBits 4) + , (278, (+ 83) `fmap` nextBits 4) + , (279, (+ 99) `fmap` nextBits 4) + , (280, (+ 115) `fmap` nextBits 4) + , (281, (+ 131) `fmap` nextBits 5) + , (282, (+ 163) `fmap` nextBits 5) + , (283, (+ 195) `fmap` nextBits 5) + , (284, (+ 227) `fmap` nextBits 5) + , (285, return 258) + ] + +getDistance :: Int -> DeflateM Int +getDistance c = + case Map.lookup c getDistanceMap of + Nothing -> error ("getDistance for bad code: " ++ show c) + Just m -> m + +getDistanceMap :: Map Int (DeflateM Int) +getDistanceMap = Map.fromList [ + (0, return 1) + , (1, return 2) + , (2, return 3) + , (3, return 4) + , (4, (+ 5) `fmap` nextBits 1) + , (5, (+ 7) `fmap` nextBits 1) + , (6, (+ 9) `fmap` nextBits 2) + , (7, (+ 13) `fmap` nextBits 2) + , (8, (+ 17) `fmap` nextBits 3) + , (9, (+ 25) `fmap` nextBits 3) + , (10, (+ 33) `fmap` nextBits 4) + , (11, (+ 49) `fmap` nextBits 4) + , (12, (+ 65) `fmap` nextBits 5) + , (13, (+ 97) `fmap` nextBits 5) + , (14, (+ 129) `fmap` nextBits 6) + , (15, (+ 193) `fmap` nextBits 6) + , (16, (+ 257) `fmap` nextBits 7) + , (17, (+ 385) `fmap` nextBits 7) + , (18, (+ 513) `fmap` nextBits 8) + , (19, (+ 769) `fmap` nextBits 8) + , (20, (+ 1025) `fmap` nextBits 9) + , (21, (+ 1537) `fmap` nextBits 9) + , (22, (+ 2049) `fmap` nextBits 10) + , (23, (+ 3073) `fmap` nextBits 10) + , (24, (+ 4097) `fmap` nextBits 11) + , (25, (+ 6145) `fmap` nextBits 11) + , (26, (+ 8193) `fmap` nextBits 12) + , (27, (+ 12289) `fmap` nextBits 12) + , (28, (+ 16385) `fmap` nextBits 13) + , (29, (+ 24577) `fmap` nextBits 13) + ] + +-- ----------------------------------------------------------------------------- + +fixedLitTree :: 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 = computeHuffmanTree [(x,5) | x <- [0..31]] + +-- ----------------------------------------------------------------------------- + +computeHuffmanTree :: [(Int, Int)] -> HuffmanTree Int +computeHuffmanTree = createHuffmanTree . computeCodeValues + +computeCodeValues :: Ord a => [(a, Int)] -> [(a, Int, Int)] +computeCodeValues vals = Map.foldrWithKey (\ v (l, c) a -> (v,l,c):a) [] codes + where + valsNo0s = filter (\ (_, b) -> (b /= 0)) vals + valsSort = sortBy (\ (a,_) (b,_) -> compare a b) valsNo0s + blCount = foldr (\ (_,k) m -> Map.insertWith (+) k 1 m) Map.empty valsNo0s + nextcode = step2 0 1 (Map.insert 0 0 Map.empty) + lenTree = Map.fromList valsSort + codeTree = step3 (map fst valsSort) nextcode Map.empty + maxBits = maximum (map snd valsSort) + codes = Map.intersectionWith (,) lenTree codeTree + -- + step2 code bits nc + | bits > maxBits = nc + | otherwise = + let prevCount = Map.findWithDefault 0 (bits - 1) blCount + code' = (code + prevCount) `shiftL` 1 + in step2 code' (bits + 1) (Map.insert bits code' nc) + -- + step3 [] _ ct = ct + step3 (n:rest) nc ct = + let len = Map.findWithDefault 0 n lenTree + Just ncLen = Map.lookup len nc + ct' = Map.insert n ncLen ct + nc' = Map.insert len (ncLen + 1) nc + in if len == 0 + then step3 rest nc ct + else step3 rest nc' ct' + +codeLengthOrder :: [Int] +codeLengthOrder = + [16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15] + + diff --git a/src/Codec/Compression/Zlib/HuffmanTree.hs b/src/Codec/Compression/Zlib/HuffmanTree.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Zlib/HuffmanTree.hs @@ -0,0 +1,48 @@ +module Codec.Compression.Zlib.HuffmanTree( + HuffmanTree + , createHuffmanTree + , advanceTree + ) + where + +import Data.Bits + +data HuffmanTree a = HuffmanNode (HuffmanTree a) (HuffmanTree a) + | HuffmanValue a + | HuffmanEmpty + deriving (Show) + +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 + +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 + diff --git a/src/Codec/Compression/Zlib/Monad.hs b/src/Codec/Compression/Zlib/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Zlib/Monad.hs @@ -0,0 +1,163 @@ +module Codec.Compression.Zlib.Monad( + DeflateM + , runDeflateM + -- * Getting data from the input stream. + , nextBit + , nextBits + , nextByte + , nextWord16 + , nextBlock + , nextCode + , readRest + -- * Aligning + , advanceToByte + -- * Emitting data + , emitByte + , emitBlock + , emitPastChunk + -- * Getting output + , finalAdler + , finalOutput + ) + where + +import Codec.Compression.Zlib.Adler32 +import Codec.Compression.Zlib.HuffmanTree +import Codec.Compression.Zlib.OutputWindow +import Control.Monad +import Data.Bits +import Data.ByteString.Lazy(ByteString) +import qualified Data.ByteString.Lazy as BS +import Data.Int +import Data.Word +import MonadLib +import MonadLib.Monads + +data DecompressState = DecompressState { + dcsNextBitNo :: Int + , dcsCurByte :: Word8 + , dcsAdler32 :: AdlerState + , dcsInput :: ByteString + , dcsOutput :: OutputWindow + } + +type DeflateM = State DecompressState + +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 + +-- ----------------------------------------------------------------------------- + +nextBit :: DeflateM Bool +nextBit = + do dcs <- get + let v = dcsCurByte dcs `testBit` dcsNextBitNo dcs + set $ advanceBit dcs + return v + where + advanceBit dcs + | dcsNextBitNo dcs == 7 = + case BS.uncons (dcsInput dcs) of + Nothing -> + error "Bit required, but no bits available!" + Just (nextb, rest) -> + dcs{ dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest } + | otherwise = + dcs{ dcsNextBitNo = dcsNextBitNo dcs + 1 } + +nextBits :: (Num a, Bits a) => Int -> DeflateM a +nextBits x + | x < 1 = error "nextBits called with x < 1" + | x == 1 = toNum `fmap` nextBit + | otherwise = do cur <- toNum `fmap` nextBit + rest <- nextBits (x - 1) + return ((rest `shiftL` 1) .|. cur) + where + toNum False = 0 + toNum True = 1 + +nextByte :: DeflateM Word8 +nextByte = + do dcs <- get + case BS.uncons (dcsInput dcs) of + _ | dcsNextBitNo dcs /= 0 -> + nextBits 8 + Nothing -> + error "nextByte called with no more data." + Just (nextb, rest) -> + do set dcs{ dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest } + return (dcsCurByte dcs) + +nextWord16 :: DeflateM Word16 +nextWord16 = + do high <- fromIntegral `fmap` nextByte + low <- fromIntegral `fmap` nextByte + return ((high `shiftL` 8) .|. low) + +nextBlock :: Integral a => a -> DeflateM ByteString +nextBlock amt = + do dcs <- get + unless (dcsNextBitNo dcs == 0) $ + fail "Can't get a block on a non-byte boundary." + let curBlock = BS.cons (dcsCurByte dcs) (dcsInput dcs) + (block, rest) = BS.splitAt (fromIntegral amt) curBlock + case BS.uncons rest of + Nothing -> + fail "Not enough data left after nextBlock." + Just (first, rest') -> + do set dcs{ dcsNextBitNo = 0, dcsCurByte = first, dcsInput = rest' } + return block + +nextCode :: Show a => HuffmanTree a -> DeflateM a +nextCode tree = + do b <- nextBit + case advanceTree b tree of + Left tree' -> nextCode tree' + Right x -> return x + +readRest :: DeflateM ByteString +readRest = + do dcs <- get + return (BS.cons (dcsCurByte dcs) (dcsInput dcs)) + +advanceToByte :: DeflateM () +advanceToByte = + do dcs <- get + when (dcsNextBitNo dcs /= 0) $ + case BS.uncons (dcsInput dcs) of + Nothing -> error "Advanced with no bytes left!" + Just (nextb, rest) -> + set dcs{ dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest } + +emitByte :: Word8 -> DeflateM () +emitByte b = + do dcs <- get + set dcs{ dcsOutput = dcsOutput dcs `addByte` b + , dcsAdler32 = advanceAdler (dcsAdler32 dcs) b } + +emitBlock :: ByteString -> DeflateM () +emitBlock b = + do dcs <- get + set dcs { dcsOutput = dcsOutput dcs `addChunk` b + , dcsAdler32 = BS.foldl advanceAdler (dcsAdler32 dcs) b } + +emitPastChunk :: Int -> Int64 -> DeflateM () +emitPastChunk dist len = + do dcs <- get + let (output', newChunk) = addOldChunk (dcsOutput dcs) dist len + set dcs { dcsOutput = output' + , dcsAdler32 = BS.foldl advanceAdler (dcsAdler32 dcs) newChunk } + +finalAdler :: DeflateM Word32 +finalAdler = (finalizeAdler . dcsAdler32) `fmap` get + +finalOutput :: DeflateM ByteString +finalOutput = (outByteString . dcsOutput) `fmap` get + diff --git a/src/Codec/Compression/Zlib/OutputWindow.hs b/src/Codec/Compression/Zlib/OutputWindow.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Zlib/OutputWindow.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Codec.Compression.Zlib.OutputWindow( + OutputWindow + , emptyWindow + , addByte + , addChunk + , addOldChunk + , outByteString + ) + where + +import Data.ByteString.Builder +import Data.ByteString.Lazy(ByteString) +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Lazy as BS +import Data.Int +import Data.FingerTree +import Data.Foldable(foldMap) +import Data.Monoid +import Data.Word + +data OutputWindow = OutputWindow { + owCommitted :: FingerTree Int SBS.ByteString + , owRecent :: Builder + } + +instance Monoid Int where + mempty = 0 + mappend = (+) + +instance Measured Int SBS.ByteString where + measure = SBS.length + +emptyWindow :: OutputWindow +emptyWindow = OutputWindow empty mempty + +addByte :: OutputWindow -> Word8 -> OutputWindow +addByte ow b = ow{ owRecent = owRecent ow <> word8 b } + +addChunk :: OutputWindow -> ByteString -> OutputWindow +addChunk ow bs = ow{ owRecent = owRecent ow <> lazyByteString bs } + +addOldChunk :: OutputWindow -> Int -> Int64 -> (OutputWindow, ByteString) +addOldChunk ow dist len = (OutputWindow output (lazyByteString chunk), chunk) + where + output = owCommitted ow |> BS.toStrict (toLazyByteString (owRecent ow)) + dropAmt = measure output - dist + (prev, sme) = split (> dropAmt) output + s :< rest = viewl sme + start = SBS.take (fromIntegral len) (SBS.drop (dropAmt-measure prev) s) + len' = fromIntegral len - SBS.length start + (m, rest') = split (> len') rest + middle = BS.toStrict (toLazyByteString (outFinger m)) + end = case viewl rest' of + EmptyL -> SBS.empty + bs2 :< _ -> SBS.take (len' - measure m) bs2 + chunkInf = BS.fromChunks [start, middle, end] `BS.append` chunk + chunk = BS.take len chunkInf + +outFinger :: FingerTree Int SBS.ByteString -> Builder +outFinger = foldMap byteString + +outByteString :: OutputWindow -> ByteString +outByteString ow = + toLazyByteString (outFinger (owCommitted ow) <> owRecent ow) + + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,57 @@ +import Codec.Compression.Zlib.Deflate +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit(assertEqual) + +rfcSimpleTestLengths :: [(Char, Int)] +rfcSimpleTestLengths = [ + ('A', 3) + , ('B', 3) + , ('C', 3) + , ('D', 3) + , ('E', 3) + , ('F', 2) + , ('G', 4) + , ('H', 4) + ] + +rfcSimpleTestResults :: [(Char, Int, Int)] +rfcSimpleTestResults = [ + ('A', 3, 2) -- 010 + , ('B', 3, 3) -- 011 + , ('C', 3, 4) -- 100 + , ('D', 3, 5) -- 101 + , ('E', 3, 6) -- 110 + , ('F', 2, 0) -- 00 + , ('G', 4, 14) -- 1110 + , ('H', 4, 15) -- 1111 + ] + +fixedHuffmanLengths :: [(Int, Int)] +fixedHuffmanLengths = + ([(x, 8) | x <- [0 .. 143]] ++ + [(x, 9) | x <- [144 .. 255]] ++ + [(x, 7) | x <- [256 .. 279]] ++ + [(x, 8) | x <- [280 .. 287]]) + +fixedHuffmanResults :: [(Int, Int, Int)] +fixedHuffmanResults = + ([(fst x, 8, snd x) | x <- zip [0 ..143] [48 ..191]] ++ -- 00110000 through 10111111 + [(fst x, 9, snd x) | x <- zip [144..255] [400..511]] ++ -- 110010000 through 111111111 + [(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 +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) + ] + +main :: IO () +main = defaultMain [zlibTests] +