Merge pull request #9597 from ffaf1/tar-backport

Relax `tar` upper bound
haskell · Jan 8, 2024 · f1a168a · f1a168a
2 parents d09cd57 + 68159bc
commit f1a168a
Show file tree

Hide file tree

Showing 5 changed files with 95 additions and 42 deletions.
diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal
@@ -160,7 +160,7 @@ test-suite hackage-tests
     , clock                 >=0.8      && <0.9
     , optparse-applicative  >=0.13.2.0 && <0.19
     , stm                   >=2.4.5.0  && <2.6
-    , tar                   >=0.5.0.3  && <0.6
+    , tar                   >=0.5.0.3  && <0.7
     , tree-diff             >=0.1      && <0.4
 
   ghc-options:        -Wall -rtsopts -threaded

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
@@ -42,7 +42,9 @@ common warnings
     ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wincomplete-uni-patterns -Wincomplete-record-updates
     if impl(ghc < 8.8)
       ghc-options: -Wnoncanonical-monadfail-instances
-    if impl(ghc >=8.10)
+    if impl(ghc >=9.0)
+      -- Warning: even though introduced with GHC 8.10, -Wunused-packages
+      -- gives false positives with GHC 8.10.
       ghc-options: -Wunused-packages
 
 common base-dep
@@ -103,6 +105,7 @@ library
         Distribution.Client.Compat.Orphans
         Distribution.Client.Compat.Prelude
         Distribution.Client.Compat.Semaphore
+        Distribution.Client.Compat.Tar
         Distribution.Client.Config
         Distribution.Client.Configure
         Distribution.Client.Dependency
@@ -224,7 +227,7 @@ library
         process    >= 1.2.3.0  && < 1.7,
         random     >= 1.2      && < 1.3,
         stm        >= 2.0      && < 2.6,
-        tar        >= 0.5.0.3  && < 0.6,
+        tar        >= 0.5.0.3  && < 0.7,
         time       >= 1.5.0.1  && < 1.13,
         zlib       >= 0.5.3    && < 0.7,
         hackage-security >= 0.6.2.0 && < 0.7,

diff --git a/cabal-install/src/Distribution/Client/Compat/Tar.hs b/cabal-install/src/Distribution/Client/Compat/Tar.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{- FOURMOLU_DISABLE -}
+module Distribution.Client.Compat.Tar
+  ( extractTarGzFile
+#if MIN_VERSION_tar(0,6,0)
+  , Tar.Entry
+  , Tar.Entries
+  , Tar.GenEntries (..)
+  , Tar.GenEntryContent (..)
+  , Tar.entryContent
+#else
+  , Tar.Entries (..)
+  , Tar.Entry (..)
+  , Tar.EntryContent (..)
+#endif
+  ) where
+{- FOURMOLU_ENABLE -}
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Check as Tar
+#if MIN_VERSION_tar(0,6,0)
+#else
+import qualified Codec.Archive.Tar.Entry as Tar
+#endif
+import qualified Data.ByteString.Lazy as BS
+import qualified Distribution.Client.GZipUtils as GZipUtils
+
+instance (Exception a, Exception b) => Exception (Either a b) where
+  toException (Left e) = toException e
+  toException (Right e) = toException e
+
+  fromException e =
+    case fromException e of
+      Just e' -> Just (Left e')
+      Nothing -> case fromException e of
+        Just e' -> Just (Right e')
+        Nothing -> Nothing
+
+{- FOURMOLU_DISABLE -}
+extractTarGzFile
+  :: FilePath
+  -- ^ Destination directory
+  -> FilePath
+  -- ^ Expected subdir (to check for tarbombs)
+  -> FilePath
+  -- ^ Tarball
+  -> IO ()
+extractTarGzFile dir expected tar =
+#if MIN_VERSION_tar(0,6,0)
+  Tar.unpackAndCheck
+    ( \x ->
+        SomeException <$> Tar.checkEntryTarbomb expected x
+          <|> SomeException <$> Tar.checkEntrySecurity x
+    )
+    dir
+#else
+  Tar.unpack dir
+    . Tar.checkTarbomb expected
+#endif
+  . Tar.read
+  . GZipUtils.maybeDecompress
+  =<< BS.readFile tar
+{- FOURMOLU_ENABLE -}
diff --git a/cabal-install/src/Distribution/Client/Tar.hs b/cabal-install/src/Distribution/Client/Tar.hs
@@ -14,10 +14,11 @@
 -- Reading, writing and manipulating \"@.tar@\" archive files.
 --
 -----------------------------------------------------------------------------
-module Distribution.Client.Tar (
-  -- * @tar.gz@ operations
+
+module Distribution.Client.Tar
+  ( -- * @tar.gz@ operations
   createTarGzFile,
-  extractTarGzFile,
+  TarComp.extractTarGzFile,
 
   -- * Other local utils
   buildTreeRefTypeCode,
@@ -31,12 +32,11 @@ module Distribution.Client.Tar (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import qualified Data.ByteString.Lazy    as BS
-import qualified Codec.Archive.Tar       as Tar
+import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Archive.Tar.Entry as Tar
-import qualified Codec.Archive.Tar.Check as Tar
-import qualified Codec.Compression.GZip  as GZip
-import qualified Distribution.Client.GZipUtils as GZipUtils
+import qualified Codec.Compression.GZip as GZip
+import qualified Data.ByteString.Lazy as BS
+import qualified Distribution.Client.Compat.Tar as TarComp
 
 -- for foldEntries...
 import Control.Exception (throw)
@@ -52,26 +52,6 @@ createTarGzFile :: FilePath  -- ^ Full Tarball path
 createTarGzFile tar base dir =
   BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]
 
-extractTarGzFile :: FilePath -- ^ Destination directory
-                 -> FilePath -- ^ Expected subdir (to check for tarbombs)
-                 -> FilePath -- ^ Tarball
-                -> IO ()
-extractTarGzFile dir expected tar =
-  Tar.unpack dir . Tar.checkTarbomb expected . Tar.read
-  . GZipUtils.maybeDecompress =<< BS.readFile tar
-
-instance (Exception a, Exception b) => Exception (Either a b) where
-  toException (Left  e) = toException e
-  toException (Right e) = toException e
-
-  fromException e =
-    case fromException e of
-      Just e' -> Just (Left e')
-      Nothing -> case fromException e of
-                   Just e' -> Just (Right e')
-                   Nothing -> Nothing
-
-
 -- | Type code for the local build tree reference entry type. We don't use the
 -- symbolic link entry type because it allows only 100 ASCII characters for the
 -- path.

diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs b/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs
@@ -2,17 +2,17 @@ module UnitTests.Distribution.Client.Tar (
   tests
   ) where
 
-import Distribution.Client.Tar ( filterEntries
-                               , filterEntriesM
-                               )
-import Codec.Archive.Tar       ( Entries(..)
-                               , foldEntries
-                               )
-import Codec.Archive.Tar.Entry ( EntryContent(..)
-                               , simpleEntry
-                               , Entry(..)
-                               , toTarPath
-                               )
+import Codec.Archive.Tar
+  ( foldEntries
+  )
+import Codec.Archive.Tar.Entry
+  ( simpleEntry
+  , toTarPath
+  )
+import Distribution.Client.Tar
+  ( filterEntries
+  , filterEntriesM
+  )
 
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -21,6 +21,8 @@ import qualified Data.ByteString.Lazy as BS
 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 import Control.Monad.Writer.Lazy (runWriterT, tell)
 
+import Distribution.Client.Compat.Tar
+
 tests :: [TestTree]
 tests = [ testCase "filterEntries" filterTest
         , testCase "filterEntriesM" filterMTest