Merge pull request #1449 from spencerjanssen/tar-0.7

Support tar 0.7

Author: ysangkok

exes/BuildClient.hs

@@ -866,13 +866,14 @@ pruneHaddockFiles dir = do
 
 tarGzDirectory :: FilePath -> IO BS.ByteString
 tarGzDirectory dir = do
-    res <- liftM (GZip.compress . Tar.write) $
-               Tar.pack containing_dir [nested_dir]
-    -- This seq is extremely important! Tar.pack is lazy, scanning
-    -- directories as entries are demanded.
+    entries <- Tar.pack' containing_dir [nested_dir]
+    tarcontents <- Tar.write' entries
+    let gzipped = GZip.compress tarcontents
+    -- This seq is extremely important! Tar.write' is lazy, reading
+    -- files as entries are demanded.
     -- This interacts very badly with the renameDirectory stuff with
     -- which tarGzDirectory gets wrapped.
-    BS.length res `seq` return res
+    BS.length gzipped `seq` return gzipped
   where (containing_dir, nested_dir) = splitFileName dir
 
 uploadResults :: Verbosity -> BuildConfig -> DocInfo -> Maybe FilePath

flake.nix

@@ -60,6 +60,7 @@
           packages = {
             # https://community.flake.parts/haskell-flake/dependency#path
             # tls.source = "1.9.0";
+            tar.source = "0.7.0.0";
           };
           devShell = {
             tools = hp: {

hackage-server.cabal

@@ -172,7 +172,7 @@ common defaults
     , network-bsd           ^>= 2.8
     , network-uri           ^>= 2.6
     , parsec                ^>= 3.1.13
-    , tar                   ^>= 0.6
+    , tar                   ^>= 0.7
     , unordered-containers  ^>= 0.2.10
     , vector                ^>= 0.12 || ^>= 0.13.0.0
     , zlib                  ^>= 0.6.2  || ^>= 0.7.0.0

src/Distribution/Server/Packages/Unpack.hs

@@ -341,14 +341,14 @@ warn msg = tell [msg]
 runUploadMonad :: UploadMonad a -> Either String (a, [String])
 runUploadMonad (UploadMonad m) = runIdentity . runExceptT . runWriterT $ m
 
-selectEntries :: forall tarPath linkTarget err a.
+selectEntries :: forall content tarPath linkTarget err a.
                  (err -> String)
-              -> (Tar.GenEntry tarPath linkTarget -> Maybe a)
-              -> Tar.GenEntries tarPath linkTarget err
+              -> (Tar.GenEntry content tarPath linkTarget -> Maybe a)
+              -> Tar.GenEntries content tarPath linkTarget err
               -> UploadMonad [a]
 selectEntries formatErr select = extract []
   where
-    extract :: [a] -> Tar.GenEntries tarPath linkTarget err -> UploadMonad [a]
+    extract :: [a] -> Tar.GenEntries content tarPath linkTarget err -> UploadMonad [a]
     extract _        (Tar.Fail err)           = throwError (formatErr err)
     extract selected  Tar.Done                = return selected
     extract selected (Tar.Next entry entries) =
@@ -366,7 +366,7 @@ data CombinedTarErrs =
 
 tarballChecks :: Bool -> UTCTime -> FilePath
               -> Tar.Entries Tar.FormatError
-              -> Tar.GenEntries FilePath FilePath CombinedTarErrs
+              -> Tar.GenEntries ByteString FilePath FilePath CombinedTarErrs
 tarballChecks lax now expectedDir =
     (if not lax then checkFutureTimes now else id)
   . checkTarbomb expectedDir
@@ -385,15 +385,15 @@ tarballChecks lax now expectedDir =
     fmapTarError f = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f)
 
 checkFutureTimes :: UTCTime
-                 -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
-                 -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
+                 -> Tar.GenEntries content FilePath linkTarget CombinedTarErrs
+                 -> Tar.GenEntries content FilePath linkTarget CombinedTarErrs
 checkFutureTimes now =
     checkEntries checkEntry
   where
     -- Allow 30s for client clock skew
     now' = addUTCTime 30 now
 
-    checkEntry :: Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs
+    checkEntry :: Tar.GenEntry content FilePath linkTarget -> Maybe CombinedTarErrs
     checkEntry entry
       | entryUTCTime > now'
       = Just (FutureTimeError posixPath entryUTCTime now')
@@ -405,8 +405,8 @@ checkFutureTimes now =
 
 checkTarbomb
   :: FilePath
-  -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
-  -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
+  -> Tar.GenEntries content FilePath linkTarget CombinedTarErrs
+  -> Tar.GenEntries content FilePath linkTarget CombinedTarErrs
 checkTarbomb expectedTopDir =
     checkEntries checkEntry
   where
@@ -416,8 +416,8 @@ checkTarbomb expectedTopDir =
         _ -> Just $ TarBombError (Tar.entryTarPath entry) expectedTopDir
 
 checkUselessPermissions
-  :: Tar.GenEntries FilePath linkTarget CombinedTarErrs
-  -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
+  :: Tar.GenEntries content FilePath linkTarget CombinedTarErrs
+  -> Tar.GenEntries content FilePath linkTarget CombinedTarErrs
 checkUselessPermissions =
     checkEntries checkEntry
   where
@@ -434,9 +434,9 @@ checkUselessPermissions =
 
 
 checkEntries
-  :: (Tar.GenEntry tarPath linkTarget -> Maybe e)
-  -> Tar.GenEntries tarPath linkTarget e
-  -> Tar.GenEntries tarPath linkTarget e
+  :: (Tar.GenEntry content tarPath linkTarget -> Maybe e)
+  -> Tar.GenEntries content tarPath linkTarget e
+  -> Tar.GenEntries content tarPath linkTarget e
 checkEntries checkEntry =
   Tar.foldEntries (\entry rest -> maybe (Tar.Next entry rest) Tar.Fail
                                         (checkEntry entry))

tests/Distribution/Server/Packages/UnpackTest.hs

@@ -19,7 +19,7 @@ deriving instance Eq CombinedTarErrs
 
 -- | Test that check permissions does the right thing
 testPermissions :: FilePath                              -- ^ .tar.gz file to test
-                -> (Tar.GenEntry FilePath FilePath -> Maybe CombinedTarErrs)  -- ^ Converter to create errors if necessary
+                -> (Tar.GenEntry BL.ByteString FilePath FilePath -> Maybe CombinedTarErrs)  -- ^ Converter to create errors if necessary
                 -> Assertion
 testPermissions tarPath mangler = do
     entries <- Tar.read . GZip.decompress <$> BL.readFile tarPath

tests/PackageTestMain.hs

@@ -43,16 +43,16 @@ tarPermissions =
         (testPermissions "tests/permissions-tarballs/bad-dir-perms.tar.gz" badDirMangler)
     ]
 
-goodMangler :: (Tar.GenEntry tarPath linkTarget -> Maybe CombinedTarErrs)
+goodMangler :: (Tar.GenEntry content tarPath linkTarget -> Maybe CombinedTarErrs)
 goodMangler = const Nothing
 
-badFileMangler :: (Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs)
+badFileMangler :: (Tar.GenEntry content FilePath linkTarget -> Maybe CombinedTarErrs)
 badFileMangler entry =
   case Tar.entryContent entry of
     (Tar.NormalFile _ _) -> Just $ PermissionsError (Tar.entryTarPath entry) 0o600
     _ -> Nothing
 
-badDirMangler :: (Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs)
+badDirMangler :: (Tar.GenEntry content FilePath linkTarget -> Maybe CombinedTarErrs)
 badDirMangler entry =
   case Tar.entryContent entry of
     Tar.Directory -> Just $ PermissionsError (Tar.entryTarPath entry) 0o700
@@ -153,8 +153,9 @@ successTestTGZ pkg tar = do
 
 tarGzFile :: String -> IO ByteString
 tarGzFile name = do
-  entries <- Tar.pack "tests/unpack-checks" [name]
-  return (GZip.compress (Tar.write entries))
+  entries <- Tar.pack' "tests/unpack-checks" [name]
+  tarcontents <- Tar.write' entries
+  return (GZip.compress tarcontents)
 
 -- | Remove all Tar.Entries that are not files.
 keepOnlyFiles :: ByteString -> ByteString