From 2f8f0411142bd8247650f39234dc3a622a0e7349 Mon Sep 17 00:00:00 2001
From: Mark Karpov <markkarpov92@gmail.com>
Date: Fri, 19 Apr 2024 22:48:05 +0200
Subject: [PATCH] Fix corruption of large files when zip64 is used

Previously the code did not account for the fact that the initial stub local
header (with uncompressed and compressed sizes set to 0) could not serve for
correct estimation of the final local header size due to the fact that the
local header size was determined by the uncompressed and compressed sizes of
the corresponding data, which are only known after streaming of the data.
These sizes dictated whether or not a zip64 extra field entry should be
included in the header or not. Thus, before this fix there would be cases of
corruption where the final (longer) local header written by seeking back to
the beginning of the initial stub local header after the data had been
streamed would overwrite the beginning of the data.

This is fixed by

* always writing a zip64 entry in local headers, which does not violate the
  spec and will be safely ignored in the case of smaller entries, and
* respecting the spec more precisely where it says that whenever there is a
  zip64 extra field entry in a local header both uncompressed and compressed
  sizes must always be written.

This is deemed safe because the only source of size variation for local
headers is the uncompressed and compressed sizes of the corresponding data.
---
 Codec/Archive/Zip/Internal.hs | 20 +++++++++++++-------
 1 file changed, 13 insertions(+), 7 deletions(-)

diff --git a/Codec/Archive/Zip/Internal.hs b/Codec/Archive/Zip/Internal.hs
index d6d2164..96c4dc3 100644
--- a/Codec/Archive/Zip/Internal.hs
+++ b/Codec/Archive/Zip/Internal.hs
@@ -779,11 +779,16 @@ makeZip64ExtraField ::
   -- | Resulting representation
   ByteString
 makeZip64ExtraField headerType Zip64ExtraField {..} = runPut $ do
-  when (headerType == LocalHeader || z64efUncompressedSize >= ffffffff) $
-    putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size
-  when (headerType == LocalHeader || z64efCompressedSize >= ffffffff) $
-    putWord64le (fromIntegral z64efCompressedSize) -- compressed size
-  when (headerType == CentralDirHeader && z64efOffset >= ffffffff) $
+  case headerType of
+    LocalHeader -> do
+      putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size
+      putWord64le (fromIntegral z64efCompressedSize) -- compressed size
+    CentralDirHeader -> do
+      when (z64efUncompressedSize >= ffffffff) $
+        putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size
+      when (z64efCompressedSize >= ffffffff) $
+        putWord64le (fromIntegral z64efCompressedSize) -- compressed size
+  when (z64efOffset >= ffffffff) $
     putWord64le (fromIntegral z64efOffset) -- offset of local file header
 
 -- | Create 'ByteString' representing an extra field.
@@ -810,7 +815,8 @@ putHeader ::
   EntryDescription ->
   Put
 putHeader headerType s entry@EntryDescription {..} = do
-  let isCentralDirHeader = headerType == CentralDirHeader
+  let isLocalHeader = headerType == LocalHeader
+      isCentralDirHeader = headerType == CentralDirHeader
   putWord32le (bool 0x04034b50 0x02014b50 isCentralDirHeader)
   -- ↑ local/central file header signature
   when isCentralDirHeader $
@@ -842,7 +848,7 @@ putHeader headerType s entry@EntryDescription {..} = do
             }
       extraField =
         B.take 0xffff . runPut . putExtraField $
-          if needsZip64 entry
+          if needsZip64 entry || isLocalHeader
             then M.insert 1 zip64ef edExtraField
             else edExtraField
   putWord16le (fromIntegral $ B.length extraField) -- extra field length