From 63779b106ae04fa3d563da8430ae036329bff8f9 Mon Sep 17 00:00:00 2001
From: Mark Karpov <markkarpov92@gmail.com>
Date: Sat, 20 Apr 2024 20:23:27 +0200
Subject: [PATCH] Improve the test suite to catch cases like issue 111

---
 Codec/Archive/Zip/Internal.hs |  4 +--
 tests/Main.hs                 | 55 ++++++++++++++++++++++++++---------
 zip.cabal                     |  1 +
 3 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/Codec/Archive/Zip/Internal.hs b/Codec/Archive/Zip/Internal.hs
index 96c4dc3..1b7a0e4 100644
--- a/Codec/Archive/Zip/Internal.hs
+++ b/Codec/Archive/Zip/Internal.hs
@@ -1210,8 +1210,8 @@ fromMsDosTime MsDosTime {..} =
 ffff, ffffffff :: Natural
 
 #ifdef HASKELL_ZIP_DEV_MODE
-ffff     = 200
-ffffffff = 5000
+ffff     = 25
+ffffffff = 250
 #else
 ffff     = 0xffff
 ffffffff = 0xffffffff
diff --git a/tests/Main.hs b/tests/Main.hs
index c85dfe8..141eeca 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -30,6 +30,7 @@ import Data.Text.Encoding qualified as T
 import Data.Time
 import Data.Version
 import Data.Word
+import Numeric.Natural
 import System.Directory
 import System.FilePath ((</>))
 import System.FilePath qualified as FP
@@ -39,6 +40,14 @@ import System.IO.Temp
 import Test.Hspec
 import Test.QuickCheck hiding ((.&.))
 
+ffffffff :: Natural
+
+#ifdef HASKELL_ZIP_DEV_MODE
+ffffffff = 250
+#else
+ffffffff = 0xffffffff
+#endif
+
 -- | Zip tests. Please note that the Zip64 feature is not currently tested
 -- automatically because we'd need > 4GB of data. Handling such quantities
 -- of data locally is problematic and even more problematic on CI.
@@ -82,7 +91,7 @@ instance Arbitrary Text where
   arbitrary = T.pack <$> listOf1 arbitrary
 
 instance Arbitrary ByteString where
-  arbitrary = B.pack <$> listOf arbitrary
+  arbitrary = B.pack <$> scale (* 10) (listOf arbitrary)
 
 {- ORMOLU_DISABLE -}
 
@@ -385,14 +394,19 @@ versionNeededSpec =
     -- it should be mentioned that the version also depends on Zip64 feature
     property $ \(EM s desc z) -> do
       desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s)
-      edVersionNeeded desc'
-        `shouldBe` makeVersion
-          ( case edCompression desc of
-              Store -> [2, 0]
-              Deflate -> [2, 0]
-              BZip2 -> [4, 6]
-              Zstd -> [6, 3]
-          )
+      let minVersionZip64 =
+            makeVersion $
+              if edUncompressedSize desc' >= ffffffff
+                || edCompressedSize desc' >= ffffffff
+                then [4, 5]
+                else [2, 0]
+          minVersionCompression = makeVersion $ case edCompression desc of
+            Store -> [2, 0]
+            Deflate -> [2, 0]
+            BZip2 -> [4, 6]
+            Zstd -> [6, 3]
+          versionNeeded = max minVersionZip64 minVersionCompression
+      edVersionNeeded desc' `shouldBe` versionNeeded
 
 addEntrySpec :: SpecWith FilePath
 addEntrySpec =
@@ -402,6 +416,7 @@ addEntrySpec =
         info <- createArchive path $ do
           addEntry m b s
           commit
+          checkEntry' s
           (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)
         info `shouldBe` (b, m)
 
@@ -413,6 +428,7 @@ sinkEntrySpec =
         info <- createArchive path $ do
           sinkEntry m (C.yield b) s
           commit
+          checkEntry' s
           (,)
             <$> sourceEntry s (CL.foldMap id)
             <*> (edCompression . (! s) <$> getEntries)
@@ -429,6 +445,7 @@ loadEntrySpec =
         createArchive path $ do
           loadEntry m s vpath
           commit
+          checkEntry' s
           liftIO (removeFile vpath)
           saveEntry s vpath
         B.readFile vpath `shouldReturn` b
@@ -445,6 +462,7 @@ copyEntrySpec =
         info <- createArchive path $ do
           copyEntry vpath s s
           commit
+          checkEntry' s
           (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)
         info `shouldBe` (b, m)
 
@@ -452,12 +470,11 @@ checkEntrySpec :: SpecWith FilePath
 checkEntrySpec = do
   context "when entry is intact" $
     it "passes the check" $ \path ->
-      property $ \m b s -> do
-        check <- createArchive path $ do
+      property $ \m b s ->
+        asIO . createArchive path $ do
           addEntry m b s
           commit
-          checkEntry s
-        check `shouldBe` True
+          checkEntry' s
   context "when entry is corrupted" $
     it "does not pass the check" $ \path ->
       property $ \b s ->
@@ -485,8 +502,10 @@ recompressSpec =
         info <- createArchive path $ do
           addEntry m b s
           commit
+          checkEntry' s
           recompress m' s
           commit
+          checkEntry' s
           (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)
         info `shouldBe` (b, m')
 
@@ -796,6 +815,12 @@ withSandbox :: ActionWith FilePath -> IO ()
 withSandbox action = withSystemTempDirectory "zip-sandbox" $ \dir ->
   action (dir </> "foo.zip")
 
+-- | Like 'checkEntry' but automatically aborts the test if the check fails.
+checkEntry' :: EntrySelector -> ZipArchive ()
+checkEntry' s = do
+  r <- checkEntry s
+  liftIO (if r then return () else fail "Entry integrity check failed!")
+
 -- | Given a primary name (name of archive), generate a name that does not
 -- collide with it.
 deriveVacant :: FilePath -> FilePath
@@ -875,3 +900,7 @@ listDirRecur path = DList.toList <$> go ""
               if isDir
                 then go adir'
                 else return mempty
+
+-- | Constrain the type of the argument monad to 'IO'.
+asIO :: IO a -> IO a
+asIO = id
diff --git a/zip.cabal b/zip.cabal
index c13b833..dd0c768 100644
--- a/zip.cabal
+++ b/zip.cabal
@@ -137,6 +137,7 @@ test-suite tests
         zip
 
     if flag(dev)
+        cpp-options: -DHASKELL_ZIP_DEV_MODE
         ghc-options:
             -Wall -Werror -Wredundant-constraints -Wpartial-fields
             -Wunused-packages