Merge pull request #1283 from haskell/tar-0.6

Migrate to tar-0.6

Author: ysangkok

flake.nix

@@ -32,8 +32,8 @@
             ap-normalize.check = false;
             extensions.jailbreak = true;
             # https://community.flake.parts/haskell-flake/dependency#nixpkgs
-            # tar = { super, ... }:
-            #   { custom = _: super.tar_0_6_0_0; };
+            tar = { super, ... }:
+              { custom = _: super.tar_0_6_0_0; };
             # tasty = { super, ... }:
             #   { custom = _: super.tasty_1_5; };
           };

hackage-server.cabal

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

src/Data/TarIndex.hs

@@ -18,7 +18,7 @@ module Data.TarIndex (
 import Data.SafeCopy (base, deriveSafeCopy)
 import Data.Typeable (Typeable)
 
-import Codec.Archive.Tar (Entry(..), EntryContent(..), Entries(..), entryPath)
+import Codec.Archive.Tar (Entry, GenEntry(..), GenEntryContent(..), Entries, GenEntries(..), entryPath)
 import qualified Data.StringTable as StringTable
 import Data.StringTable (StringTable)
 import qualified Data.IntTrie as IntTrie

src/Distribution/Client/Index.hs

@@ -16,9 +16,6 @@ module Distribution.Client.Index (
   ) where
 
 import qualified Codec.Archive.Tar       as Tar
-         ( read, Entries(..) )
-import qualified Codec.Archive.Tar.Entry as Tar
-         ( Entry(..), entryPath )
 
 import Distribution.Package
 import Distribution.Text

src/Distribution/Server/Features/Documentation.hs

@@ -27,6 +27,7 @@ import Distribution.Server.Features.BuildReports.BuildReport (PkgDetails(..), Bu
 import Data.TarIndex (TarIndex)
 import qualified Codec.Archive.Tar       as Tar
 import qualified Codec.Archive.Tar.Check as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
 
 import Distribution.Text
 import Distribution.Package
@@ -448,17 +449,20 @@ documentationFeature name
 checkDocTarball :: PackageId -> BSL.ByteString -> Either String ()
 checkDocTarball pkgid =
      checkEntries
-   . fmapErr (either id show) . Tar.checkTarbomb (display pkgid ++ "-docs")
-   . fmapErr (either id show) . Tar.checkSecurity
-   . fmapErr (either id show) . Tar.checkPortability
+   . fmapErr (either id show) . chainChecks (Tar.checkEntryTarbomb (display pkgid ++ "-docs"))
+   . fmapErr (either id show) . chainChecks Tar.checkEntrySecurity
+   . fmapErr (either id show) . chainChecks Tar.checkEntryPortability
+   . fmapErr (either id show) . Tar.decodeLongNames
    . fmapErr show             . Tar.read
   where
     fmapErr f    = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f)
+    chainChecks check = Tar.mapEntries (\entry -> maybe (Right entry) Left (check entry))
+
     checkEntries = Tar.foldEntries checkEntry (Right ()) Left
 
     checkEntry entry remainder
-      | Tar.entryPath entry == docMetaPath = checkDocMeta entry remainder
-      | otherwise                          = remainder
+      | Tar.entryTarPath entry == docMetaPath = checkDocMeta entry remainder
+      | otherwise                             = remainder
 
     checkDocMeta entry remainder =
       case Tar.entryContent entry of

src/Distribution/Server/Packages/Index.hs

@@ -10,9 +10,7 @@ module Distribution.Server.Packages.Index (
   ) where
 
 import qualified Codec.Archive.Tar       as Tar
-         ( write )
 import qualified Codec.Archive.Tar.Entry as Tar
-         ( Entry(..), fileEntry, toTarPath, Ownership(..) )
 import Distribution.Server.Packages.PackageIndex (PackageIndex)
 import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 import Distribution.Server.Framework.MemSize

src/Distribution/Server/Packages/Unpack.hs

@@ -138,10 +138,10 @@ tarPackageChecks lax now tarGzFile contents = do
       expectedDir = display pkgid
 
       selectEntry entry = case Tar.entryContent entry of
-        Tar.NormalFile bs _         -> Just (normalise (Tar.entryPath entry), NormalFile bs)
-        Tar.Directory               -> Just (normalise (Tar.entryPath entry), Directory)
-        Tar.SymbolicLink linkTarget -> Just (normalise (Tar.entryPath entry), Link (Tar.fromLinkTarget linkTarget))
-        Tar.HardLink     linkTarget -> Just (normalise (Tar.entryPath entry), Link (Tar.fromLinkTarget linkTarget))
+        Tar.NormalFile bs _         -> Just (normalise (Tar.entryTarPath entry), NormalFile bs)
+        Tar.Directory               -> Just (normalise (Tar.entryTarPath entry), Directory)
+        Tar.SymbolicLink linkTarget -> Just (normalise (Tar.entryTarPath entry), Link linkTarget)
+        Tar.HardLink     linkTarget -> Just (normalise (Tar.entryTarPath entry), Link linkTarget)
         _                           -> Nothing
   files <- selectEntries explainTarError selectEntry entries
   return (pkgid, files)
@@ -331,14 +331,14 @@ warn msg = tell [msg]
 runUploadMonad :: UploadMonad a -> Either String (a, [String])
 runUploadMonad (UploadMonad m) = runIdentity . runExceptT . runWriterT $ m
 
-selectEntries :: forall err a.
+selectEntries :: forall tarPath linkTarget err a.
                  (err -> String)
-              -> (Tar.Entry -> Maybe a)
-              -> Tar.Entries err
+              -> (Tar.GenEntry tarPath linkTarget -> Maybe a)
+              -> Tar.GenEntries tarPath linkTarget err
               -> UploadMonad [a]
 selectEntries formatErr select = extract []
   where
-    extract :: [a] -> Tar.Entries err -> UploadMonad [a]
+    extract :: [a] -> Tar.GenEntries tarPath linkTarget err -> UploadMonad [a]
     extract _        (Tar.Fail err)           = throwError (formatErr err)
     extract selected  Tar.Done                = return selected
     extract selected (Tar.Next entry entries) =
@@ -352,18 +352,20 @@ data CombinedTarErrs =
    | TarBombError     FilePath FilePath
    | FutureTimeError  FilePath UTCTime UTCTime
    | PermissionsError FilePath Tar.Permissions
+   | LongNamesError   Tar.DecodeLongNamesError
 
 tarballChecks :: Bool -> UTCTime -> FilePath
               -> Tar.Entries Tar.FormatError
-              -> Tar.Entries CombinedTarErrs
+              -> Tar.GenEntries FilePath FilePath CombinedTarErrs
 tarballChecks lax now expectedDir =
     (if not lax then checkFutureTimes now else id)
   . checkTarbomb expectedDir
   . (if not lax then checkUselessPermissions else id)
   . (if lax then ignoreShortTrailer
             else fmapTarError (either id PortabilityError)
-               . Tar.checkPortability)
-  . fmapTarError FormatError
+               . Tar.mapEntries (\entry -> maybe (Right entry) Left (Tar.checkEntryPortability entry)))
+  . fmapTarError (either FormatError LongNamesError)
+  . Tar.decodeLongNames
   where
     ignoreShortTrailer =
       Tar.foldEntries Tar.Next Tar.Done
@@ -373,32 +375,39 @@ tarballChecks lax now expectedDir =
     fmapTarError f = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f)
 
 checkFutureTimes :: UTCTime
-                 -> Tar.Entries CombinedTarErrs
-                 -> Tar.Entries CombinedTarErrs
+                 -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
+                 -> Tar.GenEntries 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 entry
       | entryUTCTime > now'
       = Just (FutureTimeError posixPath entryUTCTime now')
       where
         entryUTCTime = posixSecondsToUTCTime (realToFrac (Tar.entryTime entry))
-        posixPath    = Tar.fromTarPathToPosixPath (Tar.entryTarPath entry)
+        posixPath    = Tar.entryTarPath entry
 
     checkEntry _ = Nothing
 
-checkTarbomb :: FilePath -> Tar.Entries CombinedTarErrs -> Tar.Entries CombinedTarErrs
+checkTarbomb
+  :: FilePath
+  -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
+  -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
 checkTarbomb expectedTopDir =
     checkEntries checkEntry
   where
     checkEntry entry =
-      case splitDirectories (Tar.entryPath entry) of
+      case splitDirectories (Tar.entryTarPath entry) of
         (topDir:_) | topDir == expectedTopDir -> Nothing
-        _ -> Just $ TarBombError (Tar.entryPath entry) expectedTopDir
+        _ -> Just $ TarBombError (Tar.entryTarPath entry) expectedTopDir
 
-checkUselessPermissions :: Tar.Entries CombinedTarErrs -> Tar.Entries CombinedTarErrs
+checkUselessPermissions
+  :: Tar.GenEntries FilePath linkTarget CombinedTarErrs
+  -> Tar.GenEntries FilePath linkTarget CombinedTarErrs
 checkUselessPermissions =
     checkEntries checkEntry
   where
@@ -410,11 +419,14 @@ checkUselessPermissions =
       where
         checkPermissions expected actual =
             if expected .&. actual /= expected
-                then Just $ PermissionsError (Tar.entryPath entry) actual
+                then Just $ PermissionsError (Tar.entryTarPath entry) actual
                 else Nothing
 
 
-checkEntries :: (Tar.Entry -> Maybe e) -> Tar.Entries e -> Tar.Entries e
+checkEntries
+  :: (Tar.GenEntry tarPath linkTarget -> Maybe e)
+  -> Tar.GenEntries tarPath linkTarget e
+  -> Tar.GenEntries tarPath linkTarget e
 checkEntries checkEntry =
   Tar.foldEntries (\entry rest -> maybe (Tar.Next entry rest) Tar.Fail
                                         (checkEntry entry))
@@ -468,6 +480,10 @@ explainTarError (PermissionsError entryname mode) =
   where
     showMode :: Tar.Permissions -> String
     showMode m = printf "%.3o" (fromIntegral m :: Int)
+explainTarError (LongNamesError err) =
+    "There is an error in the format of entries with long names in the tar file: " ++ show err
+ ++ ". Check that it is a valid tar file (e.g. 'tar -xtf thefile.tar'). "
+ ++ "You may need to re-create the package tarball and try again."
 
 quote :: String -> String
 quote s = "'" ++ s ++ "'"

tests/Distribution/Server/Packages/UnpackTest.hs

@@ -19,10 +19,14 @@ deriving instance Eq CombinedTarErrs
 
 -- | Test that check permissions does the right thing
 testPermissions :: FilePath                              -- ^ .tar.gz file to test
-                -> (Tar.Entry -> Maybe CombinedTarErrs)  -- ^ Converter to create errors if necessary
+                -> (Tar.GenEntry FilePath FilePath -> Maybe CombinedTarErrs)  -- ^ Converter to create errors if necessary
                 -> Assertion
 testPermissions tarPath mangler = do
     entries <- Tar.read . GZip.decompress <$> BL.readFile tarPath
-    let mappedEntries = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . FormatError) entries
+    let mappedEntries = Tar.foldEntries
+            Tar.Next
+            Tar.Done
+            (Tar.Fail . either FormatError LongNamesError)
+            (Tar.decodeLongNames entries)
     when (checkEntries mangler mappedEntries /= checkUselessPermissions mappedEntries) $
         assertFailure ("Permissions check did not match expected for: " ++ tarPath)

tests/PackageTestMain.hs

@@ -9,6 +9,7 @@ import Data.Time (getCurrentTime)
 import Data.List (isInfixOf)
 
 import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
 import qualified Codec.Compression.GZip as GZip
 
 import Distribution.Server.Packages.Unpack
@@ -42,19 +43,19 @@ tarPermissions =
         (testPermissions "tests/permissions-tarballs/bad-dir-perms.tar.gz" badDirMangler)
     ]
 
-goodMangler :: (Tar.Entry -> Maybe CombinedTarErrs)
+goodMangler :: (Tar.GenEntry tarPath linkTarget -> Maybe CombinedTarErrs)
 goodMangler = const Nothing
 
-badFileMangler :: (Tar.Entry -> Maybe CombinedTarErrs)
+badFileMangler :: (Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs)
 badFileMangler entry =
   case Tar.entryContent entry of
-    (Tar.NormalFile _ _) -> Just $ PermissionsError (Tar.entryPath entry) 0o600
+    (Tar.NormalFile _ _) -> Just $ PermissionsError (Tar.entryTarPath entry) 0o600
     _ -> Nothing
 
-badDirMangler :: (Tar.Entry -> Maybe CombinedTarErrs)
+badDirMangler :: (Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs)
 badDirMangler entry =
   case Tar.entryContent entry of
-    Tar.Directory -> Just $ PermissionsError (Tar.entryPath entry) 0o700
+    Tar.Directory -> Just $ PermissionsError (Tar.entryTarPath entry) 0o700
     _ -> Nothing
 
 ---------------------------------------------------------------------------