From 6b71d1659500aba50b6a1e48aa53039046720af8 Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Sun, 7 Jan 2024 23:20:57 +0000 Subject: [PATCH] Migrate to tar-0.6 --- flake.nix | 4 +- hackage-server.cabal | 2 +- src/Data/TarIndex.hs | 2 +- src/Distribution/Client/Index.hs | 3 - .../Server/Features/Documentation.hs | 14 +++-- src/Distribution/Server/Packages/Index.hs | 2 - src/Distribution/Server/Packages/Unpack.hs | 56 ++++++++++++------- .../Server/Packages/UnpackTest.hs | 8 ++- tests/PackageTestMain.hs | 11 ++-- 9 files changed, 61 insertions(+), 41 deletions(-) diff --git a/flake.nix b/flake.nix index a70e82553..a3986f40b 100644 --- a/flake.nix +++ b/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; }; }; diff --git a/hackage-server.cabal b/hackage-server.cabal index 6bea36a21..19c1f76ab 100644 --- a/hackage-server.cabal +++ b/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 diff --git a/src/Data/TarIndex.hs b/src/Data/TarIndex.hs index 4541e605f..cd111d962 100644 --- a/src/Data/TarIndex.hs +++ b/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 diff --git a/src/Distribution/Client/Index.hs b/src/Distribution/Client/Index.hs index daf3eb274..8d0ed9992 100644 --- a/src/Distribution/Client/Index.hs +++ b/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 diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index c73135903..511a8ddb3 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/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 diff --git a/src/Distribution/Server/Packages/Index.hs b/src/Distribution/Server/Packages/Index.hs index 4adaf0b3c..a822b3250 100644 --- a/src/Distribution/Server/Packages/Index.hs +++ b/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 diff --git a/src/Distribution/Server/Packages/Unpack.hs b/src/Distribution/Server/Packages/Unpack.hs index f3881bb2c..6e8303dc0 100644 --- a/src/Distribution/Server/Packages/Unpack.hs +++ b/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 ++ "'" diff --git a/tests/Distribution/Server/Packages/UnpackTest.hs b/tests/Distribution/Server/Packages/UnpackTest.hs index 1d0fd0e64..5d9a0471c 100644 --- a/tests/Distribution/Server/Packages/UnpackTest.hs +++ b/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) diff --git a/tests/PackageTestMain.hs b/tests/PackageTestMain.hs index ec4f38656..bd5aecc16 100644 --- a/tests/PackageTestMain.hs +++ b/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 ---------------------------------------------------------------------------