zip-conduit 0.1 → 0.2
raw patch · 6 files changed
+197/−113 lines, 6 files
Files
- bench/Bench.hs +1/−1
- src/Codec/Archive/Zip.hs +113/−73
- src/Codec/Archive/Zip/Internal.hs +22/−17
- src/Codec/Archive/Zip/Util.hs +7/−7
- tests/Tests.hs +53/−14
- zip-conduit.cabal +1/−1
bench/Bench.hs view
@@ -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"
src/Codec/Archive/Zip.hs view
@@ -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 ()
src/Codec/Archive/Zip/Internal.hs view
@@ -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
src/Codec/Archive/Zip/Util.hs view
@@ -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
tests/Tests.hs view
@@ -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 ""
zip-conduit.cabal view
@@ -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