Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Improved Gzip module by Lucas Salvatore
  • Loading branch information
l1salvatore authored and gaa-cifasis committed Sep 27, 2016
1 parent 390a44e commit 5b092d1
Show file tree
Hide file tree
Showing 4 changed files with 118 additions and 9 deletions.
1 change: 1 addition & 0 deletions .gitignore
Expand Up @@ -19,3 +19,4 @@ cabal.sandbox.config
*.hp
./QuickFuzz
report.html
make.sh
2 changes: 1 addition & 1 deletion QuickFuzz.cabal
Expand Up @@ -86,7 +86,7 @@ executable QuickFuzz
build-depends: zlib, JuicyPixels, svg-tree, xml, AC-PPM

if flag(archs)
build-depends: zlib, tar, zip-archive, base16-bytestring
build-depends: time, bitwise, tuple, zlib, tar, zip-archive, base16-bytestring

if flag(docs)
build-depends: pandoc-types, pandoc, data-default, hps, hcg-minus, iCalendar
Expand Down
121 changes: 113 additions & 8 deletions src/Gzip.hs
Expand Up @@ -2,19 +2,124 @@

module Gzip where

import Test.QuickCheck
import Codec.Compression.GZip
--import Data.Binary( Binary(..), encode )

import qualified Data.ByteString.Lazy as L

import Data.DeriveTH
import DeriveArbitrary
import ByteString

type MGzipFile = (CompressParams,L.ByteString)
import Data.Bits.Bitwise
import Data.Bits as B
import Data.ByteString
import Data.ByteString.Char8 as C
import Data.Binary.Put
import Data.Binary
import Data.Tuple.Select
import Data.Time.Clock as T
import Control.Monad
import Data.Int

import Test.QuickCheck
import DeriveArbitrary


data FLG = FLG {
ftext :: Bool,
fhcrc :: Bool,
fextra :: Bool,
fname :: Bool,
fcomment :: Bool
}
deriving(Show,Eq)

data MGzipFile = GZIP {
flg :: FLG,
mtime :: Word32,
xfl :: ExtraFlag,
os :: FileSystem,
extras :: ExtraBlock,
compressedBlocks :: [Word8],
crc32 :: (Word8,Word8,Word8,Word8),
isize :: Int32
}
deriving(Show,Eq)

data ExtraBlock = EB {
xlen :: Int16,
ident :: (Char,Char),
len :: Int16,
subfield :: String,
fileName :: String,
fileComment :: String
}
deriving(Show,Eq)

data FileSystem = Fat
| Amiga
| VMS
| Unix
| CMS
| AtariTOS
| HPFS
| Macintosh
| ZSystem
| CPM
| TOPS20
| NTFS
| QDOS
| AcornRISCOS
| UNKNOWN
deriving(Enum,Show,Eq)

data ExtraFlag = SlowestAlgorithmCompression
| FastestAlgorithmCompression
deriving(Enum,Show,Eq)

class CustomEnum a where
enum :: a -> Word8

instance CustomEnum FileSystem where
enum UNKNOWN = 255
enum x = fromIntegral $ fromEnum $ x

instance CustomEnum ExtraFlag where
enum SlowestAlgorithmCompression = 2
enum FastestAlgorithmCompression = 4

putList :: [Word8] -> Put
putList [] = return ()
putList (w:words) = do putWord8 w
putList words
instance Binary FLG where
put flg = putWord8 $ packWord8LE (ftext $ flg) (fhcrc $ flg) (fextra $ flg) (fname $ flg) (fcomment $ flg) False False False
get = undefined

instance Binary MGzipFile where
put gzip = do putWord8 $ 31
putWord8 $ 139
putWord8 $ 8
put $ flg $ gzip
putWord32le $ mtime gzip
putWord8 $ enum $ xfl gzip
putWord8 $ enum $ os gzip
when (fextra $ flg gzip) $ do putWord16le $ fromIntegral $ xlen $ extras gzip
putByteString $ C.pack $ ([(fst $ ident $ extras gzip)] ++ [(snd $ ident $ extras gzip)])
putWord16le $ fromIntegral $ (xlen $ extras gzip) - 4
putByteString $ C.pack $ subfield $ extras gzip
when (fname $ flg gzip) $ putByteString $ C.pack $ (fileName $ extras gzip) ++ "\0"
when (fcomment $ flg gzip) $ putByteString $ C.pack $ (fileComment $ extras gzip) ++ "\0"
when (fhcrc $ flg gzip) $ do putWord8 $ sel1 $ crc32 gzip
putWord8 $ sel2 $ crc32 gzip
putList $ compressedBlocks gzip
putWord8 $ sel1 $ crc32 gzip
putWord8 $ sel2 $ crc32 gzip
putWord8 $ sel3 $ crc32 gzip
putWord8 $ sel4 $ crc32 gzip
putWord32le $ fromIntegral $ isize gzip
get = undefined


$(devArbitrary ''MGzipFile)

mencode :: MGzipFile -> L.ByteString
mencode (p,bs) = compressWith p bs
mencode = encode


3 changes: 3 additions & 0 deletions stack.yaml
Expand Up @@ -37,6 +37,9 @@ extra-deps:
- concurrent-extra-0.7.0.10
- language-bash-0.6.1
- shell-escape-0.2.0
- OneTuple-0.2.1
- tuple-0.3.0.2
- bitwise-0.1.1.1

# Override default flag values for local packages and extra-deps
flags:
Expand Down

0 comments on commit 5b092d1

Please sign in to comment.