zip 2.1.0 → 2.2.0
raw patch · 7 files changed
+155/−98 lines, 7 files
Files
- CHANGELOG.md +6/−0
- Codec/Archive/Zip.hs +1/−1
- Codec/Archive/Zip/Internal.hs +75/−56
- Codec/Archive/Zip/Internal/Type.hs +6/−7
- README.md +1/−1
- tests/Main.hs +57/−24
- zip.cabal +9/−9
CHANGELOG.md view
@@ -1,3 +1,9 @@+## Zip 2.2.0++* Skip the addition of Zip64 extra fields when sufficiently short strict+ input is provided (e.g. via `addEntry`). [Issue+ 126](https://github.com/mrkkrp/zip/issues/126).+ ## Zip 2.1.0 * Exposed `Codec.Archive.Zip.Internal` and `Codec.Archive.Zip.Internal.Type`
Codec/Archive/Zip.hs view
@@ -431,7 +431,7 @@ -- | Name of the entry to add EntrySelector -> ZipArchive ()-addEntry t b s = addPending (I.SinkEntry t (C.yield b) s)+addEntry t b s = addPending (I.StrictEntry t b s) -- | Stream data from the specified source to an archive entry. sinkEntry ::
Codec/Archive/Zip/Internal.hs view
@@ -36,8 +36,7 @@ import Data.Conduit.Zlib qualified as Z import Data.Digest.CRC32 (crc32Update) import Data.Fixed (Fixed (..))-import Data.Foldable (foldl')-import Data.Map.Strict (Map, (!))+import Data.Map.Strict (Map) import Data.Map.Strict qualified as M import Data.Maybe (catMaybes, fromJust, isNothing) import Data.Sequence (Seq, (><), (|>))@@ -69,6 +68,10 @@ import qualified Data.Conduit.Zstd as Zstandard #endif +#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+ ---------------------------------------------------------------------------- -- Data types @@ -80,6 +83,8 @@ CompressionMethod (ConduitT () ByteString (ResourceT IO) ()) EntrySelector+ | -- | Add an entry given its content as a string ByteString.+ StrictEntry CompressionMethod ByteString EntrySelector | -- | Copy an entry form another archive without re-compression CopyEntry FilePath EntrySelector EntrySelector | -- | Change the name of the entry inside archive@@ -109,7 +114,7 @@ -- archive. data ProducingActions = ProducingActions { paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector),- paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())+ paSinkEntry :: Map EntrySelector (EntryOrigin, ConduitT () ByteString (ResourceT IO) ()) } -- | A collection of editing actions, that is, actions that modify already@@ -127,11 +132,13 @@ -- | The origin of entries that can be streamed into archive. data EntryOrigin = GenericOrigin+ | StrictOrigin Natural -- uncompressed length | Borrowed EntryDescription+ deriving (Eq) -- | The type of the file header: local or central directory. data HeaderType- = LocalHeader+ = LocalHeader EntryOrigin | CentralDirHeader deriving (Eq) @@ -257,31 +264,29 @@ FilePath -> -- | Archive description ArchiveDescription ->- -- | Current list of entires+ -- | Current list of entries Map EntrySelector EntryDescription -> -- | Collection of pending actions Seq PendingAction -> IO () commit path ArchiveDescription {..} entries xs = withNewFile path $ \h -> do- let (ProducingActions coping sinking, editing) =+ let (ProducingActions copying sinking, editing) = optimize (toRecreatingActions path entries >< xs) comment = predictComment adComment xs copiedCD <- M.unions- <$> forM- (M.keys coping)- ( \srcPath ->- copyEntries h srcPath (coping ! srcPath) editing+ <$> M.traverseWithKey+ ( \srcPath m ->+ copyEntries h srcPath m editing )- let sinkingKeys = M.keys $ sinking `M.difference` copiedCD+ copying sunkCD <-- M.fromList- <$> forM- sinkingKeys- ( \selector ->- sinkEntry h selector GenericOrigin (sinking ! selector) editing- )+ M.traverseWithKey+ ( \selector (origin, source) ->+ sinkEntry h selector origin source editing+ )+ (sinking `M.difference` copiedCD) writeCD h comment (copiedCD `M.union` sunkCD) -- | Create a new file with the guarantee that in the case of an exception@@ -348,13 +353,24 @@ f (pa, ea) a = case a of SinkEntry m src s -> ( pa- { paSinkEntry = M.insert s src (paSinkEntry pa),+ { paSinkEntry = M.insert s (GenericOrigin, src) (paSinkEntry pa), paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa) }, (clearEditingFor s ea) { eaCompression = M.insert s m (eaCompression ea) } )+ StrictEntry m bs s ->+ ( pa+ { paSinkEntry = M.insert s (origin, C.yield bs) (paSinkEntry pa),+ paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa)+ },+ (clearEditingFor s ea)+ { eaCompression = M.insert s m (eaCompression ea)+ }+ )+ where+ origin = StrictOrigin (fromIntegral $ B.length bs) CopyEntry path os ns -> ( pa { paSinkEntry = M.delete ns (paSinkEntry pa),@@ -452,19 +468,21 @@ EditingActions -> -- | Info to generate central directory file headers later IO (Map EntrySelector EntryDescription)-copyEntries h path m e = do+copyEntries h path names editing = do entries <- snd <$> scanArchive path- done <- forM (M.keys m) $ \s ->- case s `M.lookup` entries of- Nothing -> throwM (EntryDoesNotExist path s)- Just desc ->- sinkEntry- h- (m ! s)- (Borrowed desc)- (sourceEntry path desc False)- e- return (M.fromList done)+ M.foldlWithKey+ ( \acc oldName newName ->+ case M.lookup oldName entries of+ Nothing -> throwM (EntryDoesNotExist path oldName)+ Just oldDesc ->+ M.insert newName+ <$> sinkEntry h newName (Borrowed oldDesc) src editing+ <*> acc+ where+ src = sourceEntry path oldDesc False+ )+ mempty+ names -- | Sink an entry from the given stream into the file associated with the -- given 'Handle'.@@ -480,31 +498,28 @@ -- | Additional info that can influence result EditingActions -> -- | Info to generate the central directory file headers later- IO (EntrySelector, EntryDescription)+ IO EntryDescription sinkEntry h s o src EditingActions {..} = do currentTime <- getCurrentTime offset <- hTell h let compressed = case o of- GenericOrigin -> Store Borrowed ed -> edCompression ed+ _ -> Store compression = M.findWithDefault compressed s eaCompression recompression = compression /= compressed modTime = case o of- GenericOrigin -> currentTime Borrowed ed -> edModTime ed- extFileAttr = case o of- GenericOrigin -> M.findWithDefault defaultFileMode s eaExtFileAttr- Borrowed _ -> M.findWithDefault defaultFileMode s eaExtFileAttr+ _ -> currentTime+ extFileAttr = M.findWithDefault defaultFileMode s eaExtFileAttr oldExtraFields = case o of- GenericOrigin -> M.empty Borrowed ed -> edExtraField ed+ _ -> M.empty extraField = (M.findWithDefault M.empty s eaExtraField `M.union` oldExtraFields) `M.difference` M.findWithDefault M.empty s eaDeleteField oldComment = case (o, M.lookup s eaDeleteComment) of- (GenericOrigin, _) -> Nothing (Borrowed ed, Nothing) -> edComment ed- (Borrowed _, Just ()) -> Nothing+ _ -> Nothing desc0 = EntryDescription -- to write in local header { edVersionMadeBy = zipVersion,@@ -519,7 +534,7 @@ edExtraField = extraField, edExternalFileAttrs = extFileAttr }- B.hPut h (runPut (putHeader LocalHeader s desc0))+ B.hPut h (runPut (putHeader (LocalHeader o) s desc0)) DataDescriptor {..} <- C.runConduitRes $ if recompression@@ -530,12 +545,6 @@ else src .| sinkData h Store afterStreaming <- hTell h let desc1 = case o of- GenericOrigin ->- desc0- { edCRC32 = ddCRC32,- edCompressedSize = ddCompressedSize,- edUncompressedSize = ddUncompressedSize- } Borrowed ed -> desc0 { edCRC32 =@@ -545,15 +554,21 @@ edUncompressedSize = bool (edUncompressedSize ed) ddUncompressedSize recompression }+ _ ->+ desc0+ { edCRC32 = ddCRC32,+ edCompressedSize = ddCompressedSize,+ edUncompressedSize = ddUncompressedSize+ } desc2 = desc1 { edVersionNeeded = getZipVersion (needsZip64 desc1) (Just compression) } hSeek h AbsoluteSeek offset- B.hPut h (runPut (putHeader LocalHeader s desc2))+ B.hPut h (runPut (putHeader (LocalHeader o) s desc2)) hSeek h AbsoluteSeek afterStreaming- return (s, desc2)+ return desc2 {- ORMOLU_DISABLE -} @@ -772,7 +787,7 @@ ByteString makeZip64ExtraField headerType Zip64ExtraField {..} = runPut $ do case headerType of- LocalHeader -> do+ LocalHeader _ -> do putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size putWord64le (fromIntegral z64efCompressedSize) -- compressed size CentralDirHeader -> do@@ -785,16 +800,15 @@ -- | Create 'ByteString' representing an extra field. putExtraField :: Map Word16 ByteString -> Put-putExtraField m = forM_ (M.keys m) $ \headerId -> do- let b = B.take 0xffff (m ! headerId)+putExtraField = M.foldMapWithKey $ \headerId bs -> do+ let b = B.take 0xffff bs putWord16le headerId putWord16le (fromIntegral $ B.length b) putByteString b -- | Create 'ByteString' representing the entire central directory. putCD :: Map EntrySelector EntryDescription -> Put-putCD m = forM_ (M.keys m) $ \s ->- putHeader CentralDirHeader s (m ! s)+putCD = M.foldMapWithKey (putHeader CentralDirHeader) -- | Create 'ByteString' representing either a local file header or a -- central directory file header.@@ -807,8 +821,7 @@ EntryDescription -> Put putHeader headerType s entry@EntryDescription {..} = do- let isLocalHeader = headerType == LocalHeader- isCentralDirHeader = headerType == CentralDirHeader+ let isCentralDirHeader = headerType == CentralDirHeader putWord32le (bool 0x04034b50 0x02014b50 isCentralDirHeader) -- ↑ local/central file header signature when isCentralDirHeader $@@ -838,9 +851,14 @@ z64efCompressedSize = edCompressedSize, z64efOffset = edOffset }+ appendZip64 =+ case headerType of+ LocalHeader (StrictOrigin size) -> size >= ffffffff+ LocalHeader _ -> True+ CentralDirHeader -> needsZip64 entry extraField = B.take 0xffff . runPut . putExtraField $- if needsZip64 entry || isLocalHeader+ if appendZip64 then M.insert 1 zip64ef edExtraField else edExtraField putWord16le (fromIntegral $ B.length extraField) -- extra field length@@ -1049,6 +1067,7 @@ -- | Determine the target entry of an action. targetEntry :: PendingAction -> Maybe EntrySelector targetEntry (SinkEntry _ _ s) = Just s+targetEntry (StrictEntry _ _ s) = Just s targetEntry (CopyEntry _ _ s) = Just s targetEntry (RenameEntry s _) = Just s targetEntry (DeleteEntry s) = Just s
Codec/Archive/Zip/Internal/Type.hs view
@@ -46,7 +46,6 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Time.Clock (UTCTime)-import Data.Typeable (Typeable) import Data.Version (Version) import Data.Word (Word16, Word32) import Numeric.Natural@@ -75,7 +74,7 @@ { -- | Path pieces of relative path inside archive unES :: NonEmpty (CI String) }- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance Show EntrySelector where show = show . unEntrySelector@@ -130,7 +129,7 @@ newtype EntrySelectorException = -- | 'EntrySelector' cannot be created from this path InvalidEntrySelector FilePath- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance Show EntrySelectorException where show (InvalidEntrySelector path) = "Cannot build selector from " ++ show path@@ -170,7 +169,7 @@ -- @since 1.2.0 edExternalFileAttrs :: Word32 }- deriving (Eq, Typeable, Show)+ deriving (Eq, Show) -- | The supported compression methods. data CompressionMethod@@ -184,7 +183,7 @@ -- -- @since 1.6.0 Zstd- deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable)+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Data) ---------------------------------------------------------------------------- -- Archive description@@ -198,7 +197,7 @@ -- | The size of central directory record adCDSize :: Natural }- deriving (Show, Read, Eq, Ord, Typeable, Data)+ deriving (Show, Read, Eq, Ord, Data) ---------------------------------------------------------------------------- -- Exceptions@@ -215,7 +214,7 @@ UnsupportedCompressionMethod CompressionMethod | -- | Thrown when archive structure cannot be parsed. ParsingFailed FilePath String- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance Show ZipException where show (EntryDoesNotExist file s) =
README.md view
@@ -4,7 +4,7 @@ [](https://hackage.haskell.org/package/zip) [](http://stackage.org/nightly/package/zip) [](http://stackage.org/lts/package/zip)-+[](https://github.com/mrkkrp/zip/actions/workflows/ci.yaml) * [Why this library was written](#why-this-library-was-written) * [zip-archive](#zip-archive)
tests/Main.hs view
@@ -452,31 +452,64 @@ checkEntrySpec :: SpecWith FilePath checkEntrySpec = do- context "when entry is intact" $- it "passes the check" $ \path ->- property $ \m b s ->- asIO . createArchive path $ do- addEntry m b s- commit- checkEntry' s- context "when entry is corrupted" $- it "does not pass the check" $ \path ->- property $ \b s ->- not (B.null b) ==> do- let headerLength = 50 + (B.length . T.encodeUtf8 . getEntryName $ s)- localFileHeaderOffset <- createArchive path $ do- addEntry Store b s+ context "for entries added via addEntry" $ do+ context "when entry is intact" $+ it "passes the check" $ \path ->+ property $ \m b s ->+ asIO . createArchive path $ do+ addEntry m b s commit- fromIntegral . edOffset . (! s) <$> getEntries- withFile path ReadWriteMode $ \h -> do- hSeek- h- AbsoluteSeek- (localFileHeaderOffset + fromIntegral headerLength)- byte <- B.map complement <$> B.hGet h 1- hSeek h RelativeSeek (-1)- B.hPut h byte- withArchive path (checkEntry s) `shouldReturn` False+ checkEntry' s+ context "when entry is corrupted" $+ it "does not pass the check" $ \path ->+ property $ \b s ->+ not (B.null b) ==> do+ let nameLength = B.length . T.encodeUtf8 . getEntryName $ s+ zip64Length =+ if fromIntegral (B.length b) >= ffffffff+ then 20+ else 0+ headerLength = 30 + nameLength + zip64Length+ localFileHeaderOffset <- createArchive path $ do+ addEntry Store b s+ commit+ fromIntegral . edOffset . (! s) <$> getEntries+ withFile path ReadWriteMode $ \h -> do+ hSeek+ h+ AbsoluteSeek+ (localFileHeaderOffset + fromIntegral headerLength)+ byte <- B.map complement <$> B.hGet h 1+ hSeek h RelativeSeek (-1)+ B.hPut h byte+ withArchive path (checkEntry s) `shouldReturn` False+ context "for entries added via sinkEntry" $ do+ context "when entry is intact" $+ it "passes the check" $ \path ->+ property $ \m b s ->+ asIO . createArchive path $ do+ sinkEntry m (C.yield b) s+ commit+ checkEntry' s+ context "when entry is corrupted" $+ it "does not pass the check" $ \path ->+ property $ \b s ->+ not (B.null b) ==> do+ let nameLength = B.length . T.encodeUtf8 . getEntryName $ s+ headerLength = 50 + nameLength+ localFileHeaderOffset <- createArchive path $ do+ sinkEntry Store (C.yield b) s+ commit+ fromIntegral . edOffset . (! s) <$> getEntries+ withFile path ReadWriteMode $ \h -> do+ hSeek+ h+ AbsoluteSeek+ (localFileHeaderOffset + fromIntegral headerLength)+ byte <- B.map complement <$> B.hGet h 1+ hSeek h RelativeSeek (-1)+ B.hPut h byte+ withArchive path (checkEntry s) `shouldReturn` False recompressSpec :: SpecWith FilePath recompressSpec =
zip.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.4 name: zip-version: 2.1.0+version: 2.2.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov <markkarpov92@gmail.com> author: Mark Karpov <markkarpov92@gmail.com>-tested-with: ghc ==9.4.7 ghc ==9.6.3 ghc ==9.8.1+tested-with: ghc ==9.8.4 ghc ==9.10.1 ghc ==9.12.1 homepage: https://github.com/mrkkrp/zip bug-reports: https://github.com/mrkkrp/zip/issues synopsis: Operations on zip archives@@ -55,17 +55,17 @@ cereal >=0.3 && <0.6, conduit >=1.3 && <1.4, conduit-extra >=1.3 && <1.4,- containers >=0.5 && <0.7,+ containers >=0.5 && <0.8, digest <0.1, directory >=1.2.2 && <1.4, dlist >=0.8 && <2.0, exceptions >=0.6 && <0.11,- filepath >=1.2 && <1.5,+ filepath >=1.2 && <1.6, monad-control >=1.0 && <1.1, mtl >=2 && <3, resourcet >=1.2 && <1.4, text >=0.2 && <2.2,- time >=1.4 && <1.13,+ time >=1.4 && <1.15, transformers >=0.4 && <0.7, transformers-base @@ -103,7 +103,7 @@ default-language: GHC2021 build-depends: base >=4.15 && <5,- filepath >=1.2 && <1.5,+ filepath >=1.2 && <1.6, zip if flag(dev)@@ -124,14 +124,14 @@ QuickCheck >=2.4 && <3, bytestring >=0.9 && <0.13, conduit >=1.3 && <1.4,- containers >=0.5 && <0.7,+ containers >=0.5 && <0.8, directory >=1.2.2 && <1.4, dlist >=0.8 && <2,- filepath >=1.2 && <1.5,+ filepath >=1.2 && <1.6, hspec >=2 && <3, temporary >=1.1 && <1.4, text >=0.2 && <2.2,- time >=1.4 && <1.13,+ time >=1.4 && <1.15, zip if flag(dev)