zip-conduit (empty) → 0.1
raw patch · 8 files changed
+1205/−0 lines, 8 filesdep +HUnitdep +LibZipdep +basesetup-changed
Dependencies added: HUnit, LibZip, base, bytestring, cereal, conduit, criterion, digest, directory, filepath, hpc, mtl, old-time, random, temporary, test-framework, test-framework-hunit, time, transformers, utf8-string, zip-archive, zip-conduit, zlib-conduit
Files
- LICENSE +31/−0
- Setup.hs +2/−0
- bench/Bench.hs +128/−0
- src/Codec/Archive/Zip.hs +334/−0
- src/Codec/Archive/Zip/Internal.hs +390/−0
- src/Codec/Archive/Zip/Util.hs +117/−0
- tests/Tests.hs +111/−0
- zip-conduit.cabal +92/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2012, Tim Cherganov+Copyright (c) 2008-2012, John MacFarlane (jgm@berkeley.edu)++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 Tim nor the names of other+ 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE PackageImports #-}++module Main where++import Control.Monad+import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy as B+import Data.Word+import System.FilePath+import System.IO++import Criterion.Config+import Criterion.Main+import Criterion.Monad+import System.IO.Temp+import System.Random++import qualified Codec.Archive.LibZip as L+import qualified "zip-archive" Codec.Archive.Zip as A+import "zip-conduit" Codec.Archive.Zip+--import Codec.Archive.Zip+++main :: IO ()+main = do+ let sizes = [1024*1024, 10*1024*1024] -- ^ sizes of files for benchmarking++ withSystemTempDirectory "zip-conduit" $ \dir ->+ defaultMainWith myConfig+ (prepareFiles dir sizes)+ (prepareBench dir $ map show sizes)+++myConfig :: Config+myConfig = defaultConfig {+ cfgPerformGC = ljust True -- ^ always GC between runs+ }+++-- | Prepares benchmarks.+prepareBench :: FilePath -- ^ the path to the directory with files+ -> [FilePath] -- ^ file names+ -> [Benchmark]+prepareBench dir names =+ [ bgroup "archive"+ [ bgroup "zip-conduit" $ b zipConduit+ , bgroup "zip-archive" $ b zipArchive+ , bgroup "libZip" $ b libZip+ ]+ , bgroup "unarchive"+ [ bgroup "zip-conduit" $ b unZipConduit+ , bgroup "zip-archive" $ b unZipArchive+ -- , bgroup "libZip" $ b unLibZip+ ]+ ]+ where+ b f = map (\name -> bench name $ f dir name) names++++-- | Creates source files for archiving and archives with those+-- files. File name is the size of this file in bytes.+prepareFiles :: FilePath -- ^ the path to the directory for files+ -> [Int] -- ^ sizes of files to create+ -> Criterion ()+prepareFiles dir sizes = liftIO $+ forM_ sizes $ \s -> do+ let path = dir </> show s++ createFile path s+ withArchive (path <.> "zip") $ addFiles [path]+++-- | Creates a file of specified length with random content.+createFile :: FilePath -> Int -> IO ()+createFile path size =+ withFile path WriteMode $ \h -> do+ g <- getStdGen+ B.hPut h $ B.pack $ take size (randoms g :: [Word8])+++------------------------------------------------------------------------------+-- Create zip archive with three different packages.++zipConduit :: FilePath -> FilePath -> IO ()+zipConduit dir name =+ withTempDirectory dir "zip-conduit" $ \tmpDir ->+ withArchive (tmpDir </> name <.> "zip") $ addFiles [dir </> name]+++zipArchive :: FilePath -> FilePath -> IO ()+zipArchive dir name =+ withTempDirectory dir "zip-archive" $ \tmpDir -> do+ ar' <- A.addFilesToArchive [] A.emptyArchive [dir </> name]+ withFile (tmpDir </> name <.> "zip") WriteMode $ \h ->+ B.hPut h $ A.fromArchive ar'+++libZip :: FilePath -> FilePath -> IO ()+libZip dir name =+ withTempDirectory dir "libZip" $ \tmpDir ->+ L.withArchive [L.CreateFlag] (tmpDir </> name <.> "zip") $ do+ zs <- L.sourceFile (dir </> name) 0 0+ L.addFile (dir </> name) zs+ return ()+++------------------------------------------------------------------------------+-- Exctract files from archive with three different packages.++unZipConduit :: FilePath -> FilePath -> IO ()+unZipConduit dir name = do+ withArchive (dir </> name <.> "zip") $ do+ names <- fileNames+ extractFiles names $ dir -- </> "zip-conduit"+++unZipArchive :: FilePath -> FilePath -> IO ()+unZipArchive dir name = do+ bytes <- B.readFile (dir </> name <.> "zip")+ A.extractFilesFromArchive [] $ A.toArchive bytes+++unLibZip :: FilePath -> FilePath -> IO ()+unLibZip dir name = do+ bytes <- L.withArchive [] (dir </> name <.> "zip") $ L.fileContentsIx [] 0+ withFile (dir </> name) WriteMode $ \h ->+ hPutStr h bytes
+ src/Codec/Archive/Zip.hs view
@@ -0,0 +1,334 @@+{- | Sink file to the archive:++@+import Data.Time (getCurrentTime)+import System.Environment (getArgs)+import System.FilePath (takeFileName)+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import Codec.Archive.Zip++main = do+ filePath:_ <- getArgs+ time <- getCurrentTime+ withArchive \"some.zip\" $ do+ sink <- getSink (takeFileName filePath) time+ runResourceT $ CB.sourceFile filePath $$ sink+@++Source first file from the archive:++@+import System.Environment (getArgs)+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import Codec.Archive.Zip++main = do+ archivePath:_ <- getArgs+ withArchive archivePath $ do+ fileName:_ <- fileNames+ source <- getSource fileName+ runResourceT $ source $$ CB.sinkFile fileName+@++List files in the zip archive:++@+import System.Environment (getArgs)+import Codec.Archive.Zip++main = do+ archivePath:_ <- getArgs+ names <- withArchive archivePath fileNames+ mapM_ putStrLn names+@+++Add files to the archive:++@+import Control.Monad (filterM)+import System.Directory (doesFileExist, getDirectoryContents)+import System.Environment (getArgs)+import Codec.Archive.Zip++main = do+ dirPath:_ <- getArgs+ paths <- getDirectoryContents dirPath+ filePaths <- filterM doesFileExist paths+ withArchive \"some.zip\" $ addFiles filePaths+@++Extract all files from the archive:++@+import System.Environment (getArgs)+import Codec.Archive.Zip++main = do+ dirPath:_ <- getArgs+ withArchive \"some.zip\" $ do+ names <- fileNames+ extractFiles names dirPath+@++-}++module Codec.Archive.Zip+ ( -- * Archive monad+ Archive+ , withArchive++ -- * Operations+ , getComment+ , setComment+ , fileNames++ -- * Conduit interface+ , getSource+ , getSink++ -- * High level functions+ , addFiles+ , extractFiles+ ) where++import Prelude hiding (readFile, zip)+import Control.Applicative+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.List (find)+import Data.Time+import Data.Word+import System.Directory+import System.FilePath+import System.IO hiding (readFile)++import Control.Monad.IO.Class+import Control.Monad.State+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Util as CU+import Data.Conduit.Zlib++import Codec.Archive.Zip.Internal+import Codec.Archive.Zip.Util+++------------------------------------------------------------------------------+-- Archive monad+type Archive a = StateT Zip IO a+++data Zip = Zip+ { zipFilePath :: FilePath+ , zipFileHeaders :: [FileHeader]+ , zipCentralDirectoryOffset :: Int+ , zipComment :: ByteString+ } deriving (Show)+++withArchive :: FilePath -> Archive a -> IO a+withArchive path ar = do+ zip <- ifM (doesFileExist path)+ (readZip path)+ (return $ emptyZip path)++ evalStateT ar zip+++readZip :: FilePath -> IO Zip+readZip f =+ withFile f ReadMode $ \h -> do+ e <- readEnd h+ cd <- readCentralDirectory h e+ return $ Zip { zipFilePath = f+ , zipFileHeaders = cdFileHeaders cd+ , zipCentralDirectoryOffset =+ endCentralDirectoryOffset e+ , zipComment = endZipComment e+ }+++emptyZip :: FilePath -> Zip+emptyZip f = Zip { zipFilePath = f+ , zipFileHeaders = []+ , zipCentralDirectoryOffset = 0+ , zipComment = B.empty+ }+++------------------------------------------------------------------------------+-- Operations+fileNames :: Archive [FilePath]+fileNames = gets $ map fhFileName . zipFileHeaders+++getComment :: Archive ByteString+getComment = gets zipComment+++setComment :: ByteString -> Archive ()+setComment comment = modify $ \zip -> zip { zipComment = comment }+++------------------------------------------------------------------------------+-- Conduit interface+getSource :: MonadResource m => FilePath -> Archive (Source m ByteString)+getSource f = gets $ \zip -> sourceFile zip f+++getSink :: MonadResource m+ => FilePath -> UTCTime -> Archive (Sink ByteString m ())+getSink f time = gets $ \zip -> sinkFile zip f time+++sourceFile :: MonadResource m => Zip -> FilePath -> Source m ByteString+sourceFile zip f = do+ source $= CB.isolate (fromIntegral $ fhCompressedSize fileHeader)+ $= decomp+ where+ source = CB.sourceIOHandle $ do+ h <- openFile (zipFilePath zip) ReadMode+ offset <- calculateFileDataOffset h fileHeader+ hSeek h AbsoluteSeek offset+ return h++ fileHeader =+ maybe (error "No such file.")+ id+ $ find (\fh -> f == fhFileName fh) $ zipFileHeaders zip++ decomp =+ case fhCompressionMethod fileHeader of+ NoCompression -> CL.map id+ Deflate -> decompress $ WindowBits (-15)+++sinkFile :: MonadResource m+ => Zip -> FilePath -> UTCTime -> Sink ByteString m ()+sinkFile zip f time = do+ h <- liftIO $ openFile (zipFilePath zip) WriteMode+ fh <- liftIO $ appendLocalFileHeader h zip f time+ dd <- sinkData h+ liftIO $ do+ writeDataDescriptor' h dd offset+ let zip' = updateZip zip fh dd+ writeFinish h zip'+ hClose h+ where+ offset = fromIntegral $ zipCentralDirectoryOffset zip -- FIXME: old offset!+++------------------------------------------------------------------------------+-- High level functions+addFiles :: [FilePath] -> Archive ()+addFiles fs = do+ zip <- get+ zip' <- liftIO $ withFile (zipFilePath zip) ReadWriteMode $ \h -> do+ zip' <- foldM (addFile h) zip fs+ writeFinish h zip'+ return zip'+ put zip'+++extractFiles :: [FilePath] -> FilePath -> Archive ()+extractFiles fs dir = do+ zip <- get+ liftIO $ forM_ fs $ \fileName -> do+ createDirectoryIfMissing True $ dir </> takeDirectory fileName+ runResourceT $ sourceFile zip fileName $$ CB.sinkFile (dir </> fileName)+++------------------------------------------------------------------------------+-- Low level functions++-- | Appends file to the 'Zip'.+addFile :: Handle -> Zip -> FilePath -> IO Zip+addFile h zip f = do+ m <- clockTimeToUTCTime <$> getModificationTime f+ fh <- appendLocalFileHeader h zip (dropDrive f) m+ dd <- runResourceT $ CB.sourceFile f $$ sinkData h+ writeDataDescriptor' h dd offset+ return $ updateZip zip fh dd+ where+ offset = fromIntegral $ zipCentralDirectoryOffset zip -- FIXME: old offset!+++appendLocalFileHeader :: Handle -> Zip -> FilePath -> UTCTime -> IO FileHeader+appendLocalFileHeader h zip f time = do+ hSeek h AbsoluteSeek offset+ writeLocalFileHeader h fh+ return fh+ where+ offset = fromIntegral $ zipCentralDirectoryOffset zip+ fh = mkFileHeader f time (fromIntegral offset)+++mkFileHeader :: FilePath -> UTCTime -> Word32 -> FileHeader+mkFileHeader f lastModified relativeOffset =+ FileHeader { fhBitFlag = 2 -- max compression + data descriptor+ , fhCompressionMethod = Deflate+ , fhLastModified = lastModified+ , fhCRC32 = 0+ , fhCompressedSize = 0+ , fhUncompressedSize = 0+ , fhInternalFileAttributes = 0+ , fhExternalFileAttributes = 0+ , fhRelativeOffset = relativeOffset+ , fhFileName = f+ , fhExtraField = B.empty+ , fhFileComment = B.empty+ }+++sinkData :: MonadResource m => Handle -> Sink ByteString m DataDescriptor+sinkData h = do+ ((uncompressedSize, crc32), compressedSize) <-+ CU.zipSinks sizeCrc32Sink+ compressSink+ return $ DataDescriptor+ { ddCRC32 = crc32+ , ddCompressedSize = fromIntegral compressedSize+ , ddUncompressedSize = fromIntegral uncompressedSize+ }+ where+ compressSink :: MonadResource m => Sink ByteString m Int+ compressSink = compress 6 (WindowBits (-15)) =$ sizeDataSink++ sizeCrc32Sink :: MonadResource m => Sink ByteString m (Int, Word32)+ sizeCrc32Sink = CU.zipSinks sizeSink crc32Sink++ sizeDataSink :: MonadResource m => Sink ByteString m Int+ sizeDataSink = fst <$> CU.zipSinks sizeSink (CB.sinkHandle h)+++writeDataDescriptor' :: Handle -> DataDescriptor -> Integer -> IO ()+writeDataDescriptor' h dd offset = do+ old <- hTell h+ hSeek h AbsoluteSeek $ offset + 4 + 2 + 2 + 2 + 2 + 2+ writeDataDescriptor h dd+ hSeek h AbsoluteSeek old+++updateZip :: Zip -> FileHeader -> DataDescriptor -> Zip+updateZip zip fh dd =+ zip { zipFileHeaders = (zipFileHeaders zip)+ ++ [ fh { fhCRC32 = ddCRC32 dd+ , fhCompressedSize = ddCompressedSize dd+ , fhUncompressedSize = ddUncompressedSize dd+ } ]+ , zipCentralDirectoryOffset = (zipCentralDirectoryOffset zip) + (fromIntegral $ localFileHeaderLength fh + ddCompressedSize dd) -- the last is datadescriptor size+ }+++writeFinish :: Handle -> Zip -> IO ()+writeFinish h zip = do+ writeCentralDirectory h $ CentralDirectory (zipFileHeaders zip) -- FIXME: CentralDirectory?+ writeEnd h+ (length $ zipFileHeaders zip)+ (sum $ map fileHeaderLength $ zipFileHeaders zip)+ (zipCentralDirectoryOffset zip)
+ src/Codec/Archive/Zip/Internal.hs view
@@ -0,0 +1,390 @@+module Codec.Archive.Zip.Internal where++import Prelude hiding (readFile)+import Control.Applicative hiding (many)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Serialize hiding (get)+import Data.Time+import Data.Word (Word16, Word32)+import System.IO hiding (readFile)++import Control.Monad.Error+import Data.ByteString.UTF8 (fromString, toString)++import Codec.Archive.Zip.Util+++calculateFileDataOffset :: Handle -> FileHeader -> IO Integer+calculateFileDataOffset h fh = do+ lfhLength <- readLocalFileHeaderLength h fh+ return $ (fromIntegral $ fhRelativeOffset fh) + lfhLength+++------------------------------------------------------------------------------+-- Local file header:+--+-- local file header signature 4 bytes (0x04034b50)+-- version needed to extract 2 bytes+-- general purpose bit flag 2 bytes+-- compression method 2 bytes+-- last mod file time 2 bytes+-- last mod file date 2 bytes+-- crc-32 4 bytes+-- compressed size 4 bytes+-- uncompressed size 4 bytes+-- file name length 2 bytes+-- extra field length 2 bytes+--+-- file name (variable size)+-- extra field (variable size)++localFileHeaderConstantLength :: Int+localFileHeaderConstantLength = 4 + 2 + 2 + 2 + 2 + 2 + 4 + 4 + 4 + 2 + 2+++readLocalFileHeaderLength :: Handle -> FileHeader -> IO Integer+readLocalFileHeaderLength h header = do+ runGet' getLocalFileHeaderLength <$> hGetLocalFileHeader h header+++-- Gets length of the local file header, i.e. sum of lengths of its+-- constant and variable parts.+getLocalFileHeaderLength :: Get Integer+getLocalFileHeaderLength = do+ signature 0x04034b50+ skip $ 2 + 2 + 2 + 2 + 2 + 4 + 4 + 4+ fileNameLength <- fromIntegral <$> getWord16le+ extraFieldLength <- fromIntegral <$> getWord16le++ return $ (fromIntegral localFileHeaderConstantLength)+ + fileNameLength+ + extraFieldLength+++writeLocalFileHeader :: Handle -> FileHeader -> IO ()+writeLocalFileHeader h fh =+ B.hPut h . runPut $ putLocalFileHeader fh+++putLocalFileHeader :: FileHeader -> Put+putLocalFileHeader fh = do+ putWord32le 0x04034b50+ putWord16le 20 -- version needed to extract (>= 2.0)+ putWord16le $ fhBitFlag fh+ putWord16le compressionMethod+ putWord16le $ msDOSTime modTime+ putWord16le $ msDOSDate modTime+ putWord32le $ fhCRC32 fh+ putWord32le $ fhCompressedSize fh+ putWord32le $ fhUncompressedSize fh+ putWord16le . fromIntegral . B.length . fromString $ fhFileName fh+ putWord16le . fromIntegral . B.length $ fhExtraField fh+ putByteString . fromString $ fhFileName fh+ putByteString $ fhExtraField fh+ where+ modTime = utcTimeToMSDOSDateTime $ fhLastModified fh+ compressionMethod = case fhCompressionMethod fh of+ NoCompression -> 0+ Deflate -> 8+++-- Gets constant part of the local file header.+hGetLocalFileHeader :: Handle -> FileHeader -> IO ByteString+hGetLocalFileHeader h fh = do+ hSeek h AbsoluteSeek offset+ B.hGet h localFileHeaderConstantLength+ where+ offset = fromIntegral $ fhRelativeOffset fh+++localFileHeaderLength :: FileHeader -> Word32+localFileHeaderLength fh =+ fromIntegral $ 4 + 2 + 2 + 2 + 2 + 2 + 4 + 4 + 4 + 2 + 2+ + length (fhFileName fh) + B.length (fhExtraField fh)+++------------------------------------------------------------------------------+-- Data descriptor+--+-- crc-32 4 bytes+-- compressed size 4 bytes+-- uncompressed size 4 bytes+data DataDescriptor = DataDescriptor+ { ddCRC32 :: Word32+ , ddCompressedSize :: Word32+ , ddUncompressedSize :: Word32+ } deriving (Show)+++writeDataDescriptor :: Handle -> DataDescriptor -> IO ()+writeDataDescriptor h dd =+ B.hPut h . runPut $ putDataDescriptor dd+++putDataDescriptor :: DataDescriptor -> Put+putDataDescriptor dd = do+-- putWord32le 0x08074b50+ putWord32le $ ddCRC32 dd+ putWord32le $ ddCompressedSize dd+ putWord32le $ ddUncompressedSize dd+++------------------------------------------------------------------------------+-- Central directory structure:+--+-- [file header 1]+-- ...+-- [file header n]++data CentralDirectory = CentralDirectory+ { cdFileHeaders :: [FileHeader]+ } deriving (Show)+++readCentralDirectory :: Handle -> End -> IO CentralDirectory+readCentralDirectory h e =+ runGet' getCentralDirectory <$> hGetCentralDirectory h e+++writeCentralDirectory :: Handle -> CentralDirectory -> IO ()+writeCentralDirectory h cd =+ B.hPut h . runPut $ putCentralDirectory cd+++putCentralDirectory :: CentralDirectory -> Put+putCentralDirectory cd = do+ mapM_ putFileHeader $ cdFileHeaders cd+++getCentralDirectory :: Get CentralDirectory+getCentralDirectory = do+ headers <- many . maybeEmpty $ getFileHeader+ return $ CentralDirectory { cdFileHeaders = headers }+++hGetCentralDirectory :: Handle -> End -> IO ByteString+hGetCentralDirectory h e = do+ hSeek h AbsoluteSeek $ fromIntegral offset+ B.hGet h size+ where+ size = endCentralDirectorySize e+ offset = endCentralDirectoryOffset e+++------------------------------------------------------------------------------+-- File header:+--+-- central file header signature 4 bytes (0x02014b50)+-- version made by 2 bytes+-- version needed to extract 2 bytes+-- general purpose bit flag 2 bytes+-- compression method 2 bytes+-- last mod file time 2 bytes+-- last mod file date 2 bytes+-- crc-32 4 bytes+-- compressed size 4 bytes+-- uncompressed size 4 bytes+-- file name length 2 bytes+-- extra field length 2 bytes+-- file comment length 2 bytes+-- disk number start 2 bytes+-- internal file attributes 2 bytes+-- external file attributes 4 bytes+-- relative offset of local header 4 bytes++-- file name (variable size)+-- extra field (variable size)+-- file comment (variable size)++data FileHeader = FileHeader+ { fhBitFlag :: Word16+ , fhCompressionMethod :: CompressionMethod+ , fhLastModified :: UTCTime+ , fhCRC32 :: Word32+ , fhCompressedSize :: Word32+ , fhUncompressedSize :: Word32+ , fhInternalFileAttributes :: Word16+ , fhExternalFileAttributes :: Word32+ , fhRelativeOffset :: Word32+ , fhFileName :: FilePath+ , fhExtraField :: ByteString+ , fhFileComment :: ByteString+ } deriving (Show)+++data CompressionMethod = NoCompression+ | Deflate+ deriving (Show)+++getFileHeader :: Get FileHeader+getFileHeader = do+ signature 0x02014b50+ skip 2+ versionNeededToExtract <- getWord16le+ unless (versionNeededToExtract <= 20) $+ fail "This archive requires zip >= 2.0 to extract."+ bitFlag <- getWord16le+ rawCompressionMethod <- getWord16le+ compessionMethod <- case rawCompressionMethod of+ 0 -> return NoCompression+ 8 -> return Deflate+ _ -> fail $ "Unknown compression method "+ ++ show rawCompressionMethod+ lastModFileTime <- getWord16le+ lastModFileDate <- getWord16le+ crc32 <- getWord32le+ compressedSize <- fromIntegral <$> getWord32le+ uncompressedSize <- getWord32le+ fileNameLength <- fromIntegral <$> getWord16le+ extraFieldLength <- fromIntegral <$> getWord16le+ fileCommentLength <- fromIntegral <$> getWord16le+ skip 2+ internalFileAttributes <- getWord16le+ externalFileAttributes <- getWord32le+ relativeOffset <- fromIntegral <$> getWord32le+ fileName <- getByteString fileNameLength+ extraField <- getByteString extraFieldLength+ fileComment <- getByteString fileCommentLength+ return $ FileHeader+ { fhBitFlag = bitFlag+ , fhCompressionMethod = compessionMethod+ , fhLastModified = toUTC lastModFileDate lastModFileTime+ , fhCRC32 = crc32+ , fhCompressedSize = compressedSize+ , fhUncompressedSize = uncompressedSize+ , fhInternalFileAttributes = internalFileAttributes+ , fhExternalFileAttributes = externalFileAttributes+ , fhRelativeOffset = relativeOffset+ , fhFileName = toString fileName+ , fhExtraField = extraField+ , fhFileComment = fileComment+ }+ where+ toUTC date time =+ msDOSDateTimeToUTCTime $ MSDOSDateTime { msDOSDate = date+ , msDOSTime = time+ }+++putFileHeader :: FileHeader -> Put+putFileHeader fh = do+ putWord32le 0x02014b50+ putWord16le 0 -- version made by+ putWord16le 20 -- version needed to extract (>= 2.0)+ putWord16le $ fhBitFlag fh+ putWord16le compressionMethod+ putWord16le $ msDOSTime modTime+ putWord16le $ msDOSDate modTime+ putWord32le $ fhCRC32 fh+ putWord32le $ fhCompressedSize fh+ putWord32le $ fhUncompressedSize fh+ putWord16le . fromIntegral . B.length . fromString $ fhFileName fh+ putWord16le . fromIntegral . B.length $ fhExtraField fh+ putWord16le . fromIntegral . B.length $ fhFileComment fh+ putWord16le 0 -- disk number start+ putWord16le $ fhInternalFileAttributes fh+ putWord32le $ fhExternalFileAttributes fh+ putWord32le $ fhRelativeOffset fh+ putByteString . fromString $ fhFileName fh+ putByteString $ fhExtraField fh+ putByteString $ fhFileComment fh+ where+ modTime = utcTimeToMSDOSDateTime $ fhLastModified fh+ compressionMethod = case fhCompressionMethod fh of+ NoCompression -> 0+ Deflate -> 8+++fileHeaderLength :: FileHeader -> Word32+fileHeaderLength fh =+ fromIntegral $ 4 + 2 + 2 + 2 + 2 + 2 + 2 + 4 + 4 + 4 + 2 + 2 + 2 + 2 + 2 + 4 + 4+ + length (fhFileName fh) + B.length (fhExtraField fh)+ + B.length (fhFileComment fh)+++------------------------------------------------------------------------------+-- End of central directory record:+--+-- end of central dir signature 4 bytes (0x06054b50)+-- number of this disk 2 bytes+-- number of the disk with the+-- start of the central directory 2 bytes+-- total number of entries in the+-- central directory on this disk 2 bytes+-- total number of entries in+-- the central directory 2 bytes+-- size of the central directory 4 bytes+-- offset of start of central+-- directory with respect to+-- the starting disk number 4 bytes+-- .ZIP file comment length 2 bytes+-- .ZIP file comment (variable size)++data End = End+ { endCentralDirectorySize :: Int+ , endCentralDirectoryOffset :: Int+ , endZipComment :: ByteString+ } deriving (Show)+++readEnd :: Handle -> IO End+readEnd h =+ runGet' getEnd <$> hGetEnd h+++getEnd :: Get End+getEnd = do+ skip $ 2 + 2 + 2 + 2+ size <- fromIntegral <$> getWord32le+ offset <- fromIntegral <$> getWord32le+ commentLength <- fromIntegral <$> getWord16le+ comment <- getByteString commentLength+ return $ End+ { endCentralDirectorySize = size+ , endCentralDirectoryOffset = offset+ , endZipComment = comment+ }+++-- TODO: find a better way to find the end of central dir signature+hGetEnd :: Handle -> IO ByteString+hGetEnd h = do+ hSeek h SeekFromEnd (-4)+ loop+ where+ loop = do+ s <- B.hGet h 4++ if s == B.pack (reverse [0x06, 0x05, 0x4b, 0x50])+ then get+ else next++ get = do+ size <- hFileSize h+ offset <- hTell h+ B.hGet h $ fromIntegral (size - offset)++ next = do+ hSeek h RelativeSeek (-5)+ loop+++writeEnd :: Handle -> Int -> Word32 -> Int -> IO ()+writeEnd h number size offset =+ B.hPut h . runPut $ putEnd number size offset+++putEnd :: Int -> Word32 -> Int -> Put+putEnd number size offset = do+ putWord32le 0x06054b50+ putWord16le 0 -- disk number+ putWord16le 0 -- disk number of central directory+ putWord16le $ fromIntegral $ number -- number of entries this disk+ putWord16le $ fromIntegral $ number -- number of entries+ putWord32le size -- size of central directory+ putWord32le $ fromIntegral offset -- offset of central dir+ -- TODO: put comment+ putWord16le 0+ putByteString B.empty
+ src/Codec/Archive/Zip/Util.hs view
@@ -0,0 +1,117 @@+module Codec.Archive.Zip.Util where++import Control.Applicative hiding (many)+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Time+import Data.Time.Clock.POSIX+import Data.Word (Word16, Word32)+import System.Time++import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Digest.CRC32+import Data.Serialize.Get+++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM cond conseq altern = do+ c <- cond+ if c then conseq else altern+++many :: Monad m => m (Maybe a) -> m [a]+many p = do+ r <- p+ case r of+ Just x -> many p >>= return . (x:)+ Nothing -> return []+++------------------------------------------------------------------------------+-- Serialize utils.+maybeEmpty :: Get a -> Get (Maybe a)+maybeEmpty p = do+ e <- isEmpty+ if e+ then return Nothing+ else Just <$> p+++runGet' :: Get a -> ByteString -> a+runGet' g b =+ either error id $ runGet g b+++signature :: Word32 -> Get ()+signature sig = do+ s <- lookAhead getWord32le+ if s == sig+ then skip 4+ else fail "Wrong signature."+++------------------------------------------------------------------------------+-- Time utils.+data MSDOSDateTime = MSDOSDateTime+ { msDOSDate :: Word16+ , msDOSTime :: Word16+ } deriving (Show)+++msDOSDateTimeToUTCTime :: MSDOSDateTime -> UTCTime+msDOSDateTimeToUTCTime dosDateTime =+ UTCTime { utctDay = fromGregorian year month day+ , utctDayTime =+ secondsToDiffTime $ hours * 60 * 60 + minutes * 60 + seconds+ }+ where+ seconds = fromIntegral $ 2 * (dosTime .&. 0x1F)+ minutes = fromIntegral $ (shiftR dosTime 5) .&. 0x3F+ hours = fromIntegral $ shiftR dosTime 11++ day = fromIntegral $ dosDate .&. 0x1F+ month = fromIntegral $ (shiftR dosDate 5) .&. 0xF+ year = 1980 + (fromIntegral $ shiftR dosDate 9)++ dosDate = msDOSDate dosDateTime+ dosTime = msDOSTime dosDateTime+++utcTimeToMSDOSDateTime :: UTCTime -> MSDOSDateTime+utcTimeToMSDOSDateTime utcTime =+ MSDOSDateTime { msDOSDate = dosDate+ , msDOSTime = dosTime+ }+ where+ dosTime = fromIntegral $ seconds + shiftL minutes 5 + shiftL hours 11+ dosDate = fromIntegral $ day + shiftL month 5 + shiftL year 9++ seconds = (fromEnum $ todSec tod) `div` 2+ minutes = todMin tod+ hours = todHour tod+ tod = timeToTimeOfDay $ utctDayTime utcTime++ year = fromIntegral year' - 1980+ (year', month, day) = toGregorian $ utctDay utcTime+++clockTimeToUTCTime :: ClockTime -> UTCTime+clockTimeToUTCTime (TOD seconds picoseconds) =+ let utcTime = posixSecondsToUTCTime $ fromIntegral seconds in+ utcTime { utctDayTime = (utctDayTime utcTime) ++ picosecondsToDiffTime picoseconds+ }+++------------------------------------------------------------------------------+-- Conduit utils.+crc32Sink :: Monad m => Sink ByteString m Word32+crc32Sink =+ CL.fold (\state input -> crc32Update state input) 0+++sizeSink :: Monad m => Sink ByteString m Int+sizeSink =+ CL.fold (\acc input -> B.length input + acc) 0
+ tests/Tests.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Prelude hiding (zip)+import Control.Monad+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.List ((\\))+import Data.Time+import System.Directory+import System.FilePath+import System.IO++import Control.Monad.State+import Data.Conduit+import qualified Data.Conduit.List as CL+import System.IO.Temp+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test, path)++import Codec.Archive.Zip+++main :: IO ()+main = defaultMain tests+++tests :: [Test]+tests =+ [ testGroup "cases"+ [ testCase "conduit" assertConduit+ , testCase "files " assertFiles+ ]+ ]+++assertConduit :: Assertion+assertConduit =+ withSystemTempDirectory "zip-conduit" $ \dir -> do+ let archivePath = dir </> archiveName++ archive archivePath fileName content+ result <- unarchive archivePath fileName++ assertEqual "" content result+ where+ archiveName = "test.zip"+ fileName = "test.txt"+ content = "some not really long test text"+++assertFiles :: Assertion+assertFiles =+ withSystemTempDirectory "zip-conduit" $ \dir -> do+ -- create files+ filePaths <- putFiles dir filesInfo++ -- archive and unarchive+ withArchive (dir </> archiveName) $ do+ addFiles filePaths+ names <- fileNames+ extractFiles names dir++ -- read unarchived files+ result <- getFiles dir++ -- compare+ assertEqual "" [] (filesInfo \\ result)+ where+ archiveName = "test.zip"+ filesInfo = [ ("test1.txt", "some test text")+ , ("test2.txt", "some another test text")+ , ("test3.txt", "one more")+ ]++ putFiles :: FilePath -> [(FilePath, ByteString)] -> IO [FilePath]+ putFiles dir fileInfo =+ forM fileInfo $ \(name, content) -> do+ let path = dir </> name+ withFile path WriteMode $ \h -> do+ B.hPut h content+ return path++ getFiles :: FilePath -> IO [(FilePath, ByteString)]+ getFiles dir = do+ let path = dir </> dropDrive dir+ dirContents <- getDirectoryContents path+ let resultFiles = map (path </>) $ filter (`notElem` [".", ".."]) dirContents+ forM resultFiles $ \file -> do+ content <- withFile file ReadMode B.hGetContents+ return (takeFileName file, content)+++-- | Creates new archive at 'archivePath' and puts there file with+-- 'content'.+archive :: FilePath -> FilePath -> ByteString -> IO ()+archive archivePath fileName content = do+ time <- liftIO getCurrentTime+ withArchive archivePath $ do+ sink <- getSink fileName time+ runResourceT $ CL.sourceList [content] $$ sink+++-- | Gets content from 'fileName' in archive at 'arcihvePath'.+unarchive :: FilePath -> FilePath -> IO ByteString+unarchive archivePath fileName = do+ withArchive archivePath $ do+ source <- getSource fileName+ runResourceT $ source $$ CL.fold B.append ""
+ zip-conduit.cabal view
@@ -0,0 +1,92 @@+Name: zip-conduit+Version: 0.1+Synopsis: Working with zip archives via conduits.+Description: Working with zip archives via conduits.+License: BSD3+License-file: LICENSE+Author: Tim Cherganov+Maintainer: cherganov@gmail.com+Category: Codec, Conduit+Homepage: https://github.com/tymmym/zip-conduit+Bug-reports: https://github.com/tymmym/zip-conduit/issues+Build-type: Simple+Cabal-version: >=1.10+++Library+ Hs-source-dirs: src++ Build-depends:+ base >= 4.3 && < 5+ , bytestring == 0.9.*+ , cereal == 0.3.*+ , conduit == 0.5.*+ , digest == 0.0.*+ , directory == 1.1.*+ , filepath == 1.3.*+ , mtl == 2.1.*+ , old-time >= 1.0 && < 1.2+ , time == 1.4.*+ , transformers == 0.3.*+ , utf8-string == 0.3.*+ , zlib-conduit == 0.5.*++ Exposed-modules:+ Codec.Archive.Zip++ Other-modules:+ Codec.Archive.Zip.Internal+ Codec.Archive.Zip.Util++ Ghc-options: -Wall -fno-warn-unused-do-bind+ Default-language: Haskell2010+++Test-suite tests+ Type: exitcode-stdio-1.0+ Hs-source-dirs: tests+ Main-is: Tests.hs++ Build-depends:+ base >= 4.3 && < 5+ , bytestring == 0.9.*+ , conduit == 0.5.*+ , directory == 1.1.*+ , filepath == 1.3.*+ , HUnit == 1.2.*+ , hpc == 0.5.*+ , mtl == 2.1.*+ , temporary == 1.1.*+ , test-framework == 0.6.*+ , test-framework-hunit == 0.2.*+ , time == 1.4.*+ , zip-conduit++ Ghc-options: -Wall -fno-warn-unused-do-bind+ Default-language: Haskell2010+++Benchmark bench+ Type: exitcode-stdio-1.0+ Hs-source-dirs: bench+ Main-is: Bench.hs++ Build-depends:+ base >= 4.3 && < 5+ , bytestring == 0.9.*+ , criterion == 0.6.*+ , filepath == 1.3.*+ , LibZip == 0.10.*+ , random == 1.0.*+ , temporary == 1.1.*+ , transformers == 0.3.*+ , zip-archive == 0.1.*+ , zip-conduit++ Ghc-options: -Wall -fno-warn-unused-do-bind+ Default-language: Haskell2010+++Source-repository head+ type: git+ location: git://github.com/tymmym/zip-conduit.git