diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 diff --git a/src/Codec/Archive/Zip.hs b/src/Codec/Archive/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Zip.hs @@ -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) diff --git a/src/Codec/Archive/Zip/Internal.hs b/src/Codec/Archive/Zip/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Zip/Internal.hs @@ -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 diff --git a/src/Codec/Archive/Zip/Util.hs b/src/Codec/Archive/Zip/Util.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Zip/Util.hs @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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 "" diff --git a/zip-conduit.cabal b/zip-conduit.cabal new file mode 100644 --- /dev/null +++ b/zip-conduit.cabal @@ -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