diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/Codec/Archive/Zip.hs b/Codec/Archive/Zip.hs --- a/Codec/Archive/Zip.hs +++ b/Codec/Archive/Zip.hs @@ -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 :: diff --git a/Codec/Archive/Zip/Internal.hs b/Codec/Archive/Zip/Internal.hs --- a/Codec/Archive/Zip/Internal.hs +++ b/Codec/Archive/Zip/Internal.hs @@ -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 diff --git a/Codec/Archive/Zip/Internal/Type.hs b/Codec/Archive/Zip/Internal/Type.hs --- a/Codec/Archive/Zip/Internal/Type.hs +++ b/Codec/Archive/Zip/Internal/Type.hs @@ -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) = diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/zip.svg?style=flat)](https://hackage.haskell.org/package/zip) [![Stackage Nightly](http://stackage.org/package/zip/badge/nightly)](http://stackage.org/nightly/package/zip) [![Stackage LTS](http://stackage.org/package/zip/badge/lts)](http://stackage.org/lts/package/zip) -![CI](https://github.com/mrkkrp/zip/workflows/CI/badge.svg?branch=master) +[![CI](https://github.com/mrkkrp/zip/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/zip/actions/workflows/ci.yaml) * [Why this library was written](#why-this-library-was-written) * [zip-archive](#zip-archive) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 = diff --git a/zip.cabal b/zip.cabal --- a/zip.cabal +++ b/zip.cabal @@ -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 author: Mark Karpov -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)