diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -111,7 +111,7 @@ unZipConduit :: FilePath -> FilePath -> IO () unZipConduit dir name = do withArchive (dir name <.> "zip") $ do - names <- fileNames + names <- entryNames extractFiles names $ dir -- "zip-conduit" diff --git a/src/Codec/Archive/Zip.hs b/src/Codec/Archive/Zip.hs --- a/src/Codec/Archive/Zip.hs +++ b/src/Codec/Archive/Zip.hs @@ -1,38 +1,33 @@ -{- | Sink file to the archive: +{- | Sink entries to the archive: @ -import Data.Time (getCurrentTime) -import System.Environment (getArgs) -import System.FilePath (takeFileName) -import Data.Conduit +\{\-\# LANGUAGE OverloadedStrings \#\-\} + 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 + sinkEntry \"first\" $ CB.sourceLbs \"hello\" + sinkEntry \"second\" $ CB.sourceLbs \"world\" @ -Source first file from the archive: +Source first entry 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 + name:_ <- entryNames + sourceEntry name $ CB.sinkFile name @ -List files in the zip archive: +List entries in the archive: @ import System.Environment (getArgs) @@ -40,7 +35,7 @@ main = do archivePath:_ <- getArgs - names <- withArchive archivePath fileNames + names <- withArchive archivePath entryNames mapM_ putStrLn names @ @@ -60,7 +55,7 @@ withArchive \"some.zip\" $ addFiles filePaths @ -Extract all files from the archive: +Extract files from the archive: @ import System.Environment (getArgs) @@ -69,7 +64,7 @@ main = do dirPath:_ <- getArgs withArchive \"some.zip\" $ do - names <- fileNames + names <- entryNames extractFiles names dirPath @ @@ -83,15 +78,21 @@ -- * Operations , getComment , setComment - , fileNames + , entryNames -- * Conduit interface - , getSource - , getSink + , sourceEntry + , sinkEntry + , sinkEntryUncompressed -- * High level functions - , addFiles , extractFiles + , addFiles + + -- * Deprecated + , fileNames + , getSource + , getSink ) where import Prelude hiding (readFile, zip) @@ -100,6 +101,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.List (find) +import Data.Maybe import Data.Time import Data.Word import System.Directory @@ -120,7 +122,7 @@ ------------------------------------------------------------------------------ -- Archive monad -type Archive a = StateT Zip IO a +type Archive = StateT Zip IO data Zip = Zip @@ -145,12 +147,12 @@ withFile f ReadMode $ \h -> do e <- readEnd h cd <- readCentralDirectory h e - return $ Zip { zipFilePath = f - , zipFileHeaders = cdFileHeaders cd - , zipCentralDirectoryOffset = + return Zip { zipFilePath = f + , zipFileHeaders = cdFileHeaders cd + , zipCentralDirectoryOffset = endCentralDirectoryOffset e - , zipComment = endZipComment e - } + , zipComment = endZipComment e + } emptyZip :: FilePath -> Zip @@ -163,8 +165,8 @@ ------------------------------------------------------------------------------ -- Operations -fileNames :: Archive [FilePath] -fileNames = gets $ map fhFileName . zipFileHeaders +entryNames :: Archive [FilePath] +entryNames = gets $ map fhFileName . zipFileHeaders getComment :: Archive ByteString @@ -177,17 +179,32 @@ ------------------------------------------------------------------------------ -- Conduit interface -getSource :: MonadResource m => FilePath -> Archive (Source m ByteString) -getSource f = gets $ \zip -> sourceFile zip f +-- | Stream the contents of an archive entry to the specified sink. +sourceEntry :: FilePath -> Sink ByteString (ResourceT Archive) a -> Archive a +sourceEntry e sink = do + zip <- get + runResourceT $ sourceFile zip e $$ sink +-- | Stream data from the specified source to an archive entry. +sinkEntry :: FilePath -> Source (ResourceT Archive) ByteString -> Archive () +sinkEntry e source = do + zip <- get + time <- liftIO getCurrentTime + zip' <- runResourceT $ source $$ sinkFile zip e Deflate time + put zip' -getSink :: MonadResource m - => FilePath -> UTCTime -> Archive (Sink ByteString m ()) -getSink f time = gets $ \zip -> sinkFile zip f time +-- | Stream data from the specified source to an uncompressed archive entry. +sinkEntryUncompressed :: FilePath -> Source (ResourceT Archive) ByteString -> Archive () +sinkEntryUncompressed f source = do + zip <- get + time <- liftIO getCurrentTime + zip' <- runResourceT $ source $$ sinkFile zip f NoCompression time + put zip' + sourceFile :: MonadResource m => Zip -> FilePath -> Source m ByteString -sourceFile zip f = do +sourceFile zip f = source $= CB.isolate (fromIntegral $ fhCompressedSize fileHeader) $= decomp where @@ -198,9 +215,8 @@ return h fileHeader = - maybe (error "No such file.") - id - $ find (\fh -> f == fhFileName fh) $ zipFileHeaders zip + fromMaybe (error "No such file.") $ find (\fh -> f == fhFileName fh) + $ zipFileHeaders zip decomp = case fhCompressionMethod fileHeader of @@ -208,19 +224,20 @@ 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 +sinkFile :: MonadResource m => Zip -> FilePath -> CompressionMethod -> UTCTime + -> Sink ByteString m Zip +sinkFile zip f compression time = do + h <- liftIO $ openFile (zipFilePath zip) ReadWriteMode -- not WriteMode because if the file already exists, then it would be truncated to zero length + fh <- liftIO $ appendLocalFileHeader h zip f compression time + dd <- sinkData h compression liftIO $ do - writeDataDescriptor' h dd offset + writeDataDescriptorFields h dd offset let zip' = updateZip zip fh dd writeFinish h zip' hClose h + return zip' where - offset = fromIntegral $ zipCentralDirectoryOffset zip -- FIXME: old offset! + offset = fromIntegral $ zipCentralDirectoryOffset zip ------------------------------------------------------------------------------ @@ -250,28 +267,29 @@ 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 + fh <- appendLocalFileHeader h zip (dropDrive f) Deflate m + dd <- runResourceT $ CB.sourceFile f $$ sinkData h Deflate + writeDataDescriptorFields h dd offset return $ updateZip zip fh dd where - offset = fromIntegral $ zipCentralDirectoryOffset zip -- FIXME: old offset! + offset = fromIntegral $ zipCentralDirectoryOffset zip -appendLocalFileHeader :: Handle -> Zip -> FilePath -> UTCTime -> IO FileHeader -appendLocalFileHeader h zip f time = do +appendLocalFileHeader :: Handle -> Zip -> FilePath -> CompressionMethod + -> UTCTime -> IO FileHeader +appendLocalFileHeader h zip f compression time = do hSeek h AbsoluteSeek offset writeLocalFileHeader h fh return fh where offset = fromIntegral $ zipCentralDirectoryOffset zip - fh = mkFileHeader f time (fromIntegral offset) + fh = mkFileHeader f compression time (fromIntegral offset) -mkFileHeader :: FilePath -> UTCTime -> Word32 -> FileHeader -mkFileHeader f lastModified relativeOffset = - FileHeader { fhBitFlag = 2 -- max compression + data descriptor - , fhCompressionMethod = Deflate +mkFileHeader :: FilePath -> CompressionMethod -> UTCTime -> Word32 -> FileHeader +mkFileHeader f compression lastModified relativeOffset = + FileHeader { fhBitFlag = 2 -- max compression for deflate compression method + , fhCompressionMethod = compression , fhLastModified = lastModified , fhCRC32 = 0 , fhCompressedSize = 0 @@ -285,12 +303,14 @@ } -sinkData :: MonadResource m => Handle -> Sink ByteString m DataDescriptor -sinkData h = do +sinkData :: MonadResource m + => Handle -> CompressionMethod -> Sink ByteString m DataDescriptor +sinkData h compression = do ((uncompressedSize, crc32), compressedSize) <- - CU.zipSinks sizeCrc32Sink - compressSink - return $ DataDescriptor + case compression of + NoCompression -> CU.zipSinks sizeCrc32Sink sizeDataSink + Deflate -> CU.zipSinks sizeCrc32Sink compressSink + return DataDescriptor { ddCRC32 = crc32 , ddCompressedSize = fromIntegral compressedSize , ddUncompressedSize = fromIntegral uncompressedSize @@ -306,8 +326,10 @@ sizeDataSink = fst <$> CU.zipSinks sizeSink (CB.sinkHandle h) -writeDataDescriptor' :: Handle -> DataDescriptor -> Integer -> IO () -writeDataDescriptor' h dd offset = do +-- Writes data descriptor fields (crc-32, compressed size and +-- uncompressed size) in the middle of the local file header. +writeDataDescriptorFields :: Handle -> DataDescriptor -> Integer -> IO () +writeDataDescriptorFields h dd offset = do old <- hTell h hSeek h AbsoluteSeek $ offset + 4 + 2 + 2 + 2 + 2 + 2 writeDataDescriptor h dd @@ -316,19 +338,37 @@ 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 + zip { zipFileHeaders = zipFileHeaders zip + ++ [ fh { fhCRC32 = ddCRC32 dd + , fhCompressedSize = ddCompressedSize dd + , fhUncompressedSize = ddUncompressedSize dd + } ] + , zipCentralDirectoryOffset = zipCentralDirectoryOffset zip + + fromIntegral (localFileHeaderLength fh + ddCompressedSize dd) } writeFinish :: Handle -> Zip -> IO () writeFinish h zip = do - writeCentralDirectory h $ CentralDirectory (zipFileHeaders zip) -- FIXME: CentralDirectory? + writeCentralDirectory h $ CentralDirectory (zipFileHeaders zip) writeEnd h - (length $ zipFileHeaders zip) + (length $ zipFileHeaders zip) -- total number of entries in the central directory on this disk (sum $ map fileHeaderLength $ zipFileHeaders zip) (zipCentralDirectoryOffset zip) + + +------------------------------------------------------------------------------ +-- Deprecated +fileNames :: Archive [FilePath] +fileNames = entryNames + + +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 -> do + sinkFile zip f Deflate time + return () diff --git a/src/Codec/Archive/Zip/Internal.hs b/src/Codec/Archive/Zip/Internal.hs --- a/src/Codec/Archive/Zip/Internal.hs +++ b/src/Codec/Archive/Zip/Internal.hs @@ -18,10 +18,16 @@ calculateFileDataOffset :: Handle -> FileHeader -> IO Integer calculateFileDataOffset h fh = do lfhLength <- readLocalFileHeaderLength h fh - return $ (fromIntegral $ fhRelativeOffset fh) + lfhLength + return $ fromIntegral (fhRelativeOffset fh) + lfhLength ------------------------------------------------------------------------------ +-- Overall zipfile format: +-- [local file header + file data + data_descriptor] . . . +-- [central directory] end of central directory record + + +------------------------------------------------------------------------------ -- Local file header: -- -- local file header signature 4 bytes (0x04034b50) @@ -44,7 +50,7 @@ readLocalFileHeaderLength :: Handle -> FileHeader -> IO Integer -readLocalFileHeaderLength h header = do +readLocalFileHeaderLength h header = runGet' getLocalFileHeaderLength <$> hGetLocalFileHeader h header @@ -57,7 +63,7 @@ fileNameLength <- fromIntegral <$> getWord16le extraFieldLength <- fromIntegral <$> getWord16le - return $ (fromIntegral localFileHeaderConstantLength) + return $ fromIntegral localFileHeaderConstantLength + fileNameLength + extraFieldLength @@ -153,14 +159,14 @@ putCentralDirectory :: CentralDirectory -> Put -putCentralDirectory cd = do +putCentralDirectory cd = mapM_ putFileHeader $ cdFileHeaders cd getCentralDirectory :: Get CentralDirectory getCentralDirectory = do headers <- many . maybeEmpty $ getFileHeader - return $ CentralDirectory { cdFileHeaders = headers } + return CentralDirectory { cdFileHeaders = headers } hGetCentralDirectory :: Handle -> End -> IO ByteString @@ -247,7 +253,7 @@ fileName <- getByteString fileNameLength extraField <- getByteString extraFieldLength fileComment <- getByteString fileCommentLength - return $ FileHeader + return FileHeader { fhBitFlag = bitFlag , fhCompressionMethod = compessionMethod , fhLastModified = toUTC lastModFileDate lastModFileTime @@ -263,9 +269,9 @@ } where toUTC date time = - msDOSDateTimeToUTCTime $ MSDOSDateTime { msDOSDate = date - , msDOSTime = time - } + msDOSDateTimeToUTCTime MSDOSDateTime { msDOSDate = date + , msDOSTime = time + } putFileHeader :: FileHeader -> Put @@ -341,8 +347,7 @@ offset <- fromIntegral <$> getWord32le commentLength <- fromIntegral <$> getWord16le comment <- getByteString commentLength - return $ End - { endCentralDirectorySize = size + return End { endCentralDirectorySize = size , endCentralDirectoryOffset = offset , endZipComment = comment } @@ -379,12 +384,12 @@ 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 + 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 --- a/src/Codec/Archive/Zip/Util.hs +++ b/src/Codec/Archive/Zip/Util.hs @@ -21,11 +21,11 @@ if c then conseq else altern -many :: Monad m => m (Maybe a) -> m [a] +many :: (Monad m, Functor m) => m (Maybe a) -> m [a] many p = do r <- p case r of - Just x -> many p >>= return . (x:) + Just x -> (x:) <$> many p Nothing -> return [] @@ -73,7 +73,7 @@ day = fromIntegral $ dosDate .&. 0x1F month = fromIntegral $ (shiftR dosDate 5) .&. 0xF - year = 1980 + (fromIntegral $ shiftR dosDate 9) + year = 1980 + fromIntegral (shiftR dosDate 9) dosDate = msDOSDate dosDateTime dosTime = msDOSTime dosDateTime @@ -88,7 +88,7 @@ dosTime = fromIntegral $ seconds + shiftL minutes 5 + shiftL hours 11 dosDate = fromIntegral $ day + shiftL month 5 + shiftL year 9 - seconds = (fromEnum $ todSec tod) `div` 2 + seconds = fromEnum (todSec tod) `div` 2 minutes = todMin tod hours = todHour tod tod = timeToTimeOfDay $ utctDayTime utcTime @@ -100,8 +100,8 @@ clockTimeToUTCTime :: ClockTime -> UTCTime clockTimeToUTCTime (TOD seconds picoseconds) = let utcTime = posixSecondsToUTCTime $ fromIntegral seconds in - utcTime { utctDayTime = (utctDayTime utcTime) + - picosecondsToDiffTime picoseconds + utcTime { utctDayTime = utctDayTime utcTime + + picosecondsToDiffTime picoseconds } @@ -109,7 +109,7 @@ -- Conduit utils. crc32Sink :: Monad m => Sink ByteString m Word32 crc32Sink = - CL.fold (\state input -> crc32Update state input) 0 + CL.fold crc32Update 0 sizeSink :: Monad m => Sink ByteString m Int diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -30,25 +30,30 @@ tests :: [Test] tests = [ testGroup "cases" - [ testCase "conduit" assertConduit - , testCase "files " assertFiles + [ testCase "conduit " (assertConduit sinkEntry) + , testCase "conduit-un " (assertConduit sinkEntryUncompressed) + , testCase "conduit-dep" assertConduitDeprecated + , testCase "files " assertFiles ] ] -assertConduit :: Assertion -assertConduit = +assertConduit :: Monad m + => (FilePath -> Source m ByteString -> Archive b) -> IO () +assertConduit s = withSystemTempDirectory "zip-conduit" $ \dir -> do let archivePath = dir archiveName - archive archivePath fileName content - result <- unarchive archivePath fileName + archive s archivePath entriesInfo + result <- unarchive archivePath entriesInfo - assertEqual "" content result + assertEqual "" [] (entriesInfo \\ result) where archiveName = "test.zip" - fileName = "test.txt" - content = "some not really long test text" + entriesInfo = [ ("test1.txt", "some test text") + , ("test2.txt", "some another test text") + , ("test3.txt", "one more") + ] assertFiles :: Assertion @@ -60,7 +65,7 @@ -- archive and unarchive withArchive (dir archiveName) $ do addFiles filePaths - names <- fileNames + names <- entryNames extractFiles names dir -- read unarchived files @@ -93,10 +98,44 @@ return (takeFileName file, content) +archive :: Monad m + => (FilePath -> Source m ByteString -> Archive b) + -> FilePath -> [(FilePath, ByteString)] -> IO () +archive s archivePath entriesInfo = + withArchive archivePath $ + forM_ entriesInfo $ \(entryName, content) -> + s entryName $ CL.sourceList [content] + + +unarchive :: FilePath -> [(FilePath, ByteString)] -> IO [(FilePath, ByteString)] +unarchive archivePath entriesInfo = + withArchive archivePath $ + forM entriesInfo $ \(entryName, _) -> do + content <- sourceEntry entryName $ CL.fold B.append "" + return (entryName, content) + + +------------------------------------------------------------------------------ +-- Tests for deprecated functions +assertConduitDeprecated :: Assertion +assertConduitDeprecated = + withSystemTempDirectory "zip-conduit" $ \dir -> do + let archivePath = dir archiveName + + archiveD archivePath fileName content + result <- unarchiveD archivePath fileName + + assertEqual "" content result + where + archiveName = "test.zip" + fileName = "test.txt" + content = "some not really long test text" + + -- | Creates new archive at 'archivePath' and puts there file with -- 'content'. -archive :: FilePath -> FilePath -> ByteString -> IO () -archive archivePath fileName content = do +archiveD :: FilePath -> FilePath -> ByteString -> IO () +archiveD archivePath fileName content = do time <- liftIO getCurrentTime withArchive archivePath $ do sink <- getSink fileName time @@ -104,8 +143,8 @@ -- | Gets content from 'fileName' in archive at 'arcihvePath'. -unarchive :: FilePath -> FilePath -> IO ByteString -unarchive archivePath fileName = do +unarchiveD :: FilePath -> FilePath -> IO ByteString +unarchiveD archivePath fileName = withArchive archivePath $ do source <- getSource fileName runResourceT $ source $$ CL.fold B.append "" diff --git a/zip-conduit.cabal b/zip-conduit.cabal --- a/zip-conduit.cabal +++ b/zip-conduit.cabal @@ -1,5 +1,5 @@ Name: zip-conduit -Version: 0.1 +Version: 0.2 Synopsis: Working with zip archives via conduits. Description: Working with zip archives via conduits. License: BSD3