diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index bae62bb2e..d4ae8a9b0 100644 --- a/exes/BuildClient.hs +++ b/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 diff --git a/flake.nix b/flake.nix index 0243fac54..643bfef00 100644 --- a/flake.nix +++ b/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: { diff --git a/hackage-server.cabal b/hackage-server.cabal index 50576dfd5..1cf7a1b16 100644 --- a/hackage-server.cabal +++ b/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 diff --git a/src/Distribution/Server/Packages/Unpack.hs b/src/Distribution/Server/Packages/Unpack.hs index b939b59d7..a928f8c1f 100644 --- a/src/Distribution/Server/Packages/Unpack.hs +++ b/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)) diff --git a/tests/Distribution/Server/Packages/UnpackTest.hs b/tests/Distribution/Server/Packages/UnpackTest.hs index 5d9a0471c..940be9170 100644 --- a/tests/Distribution/Server/Packages/UnpackTest.hs +++ b/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 diff --git a/tests/PackageTestMain.hs b/tests/PackageTestMain.hs index bd5aecc16..cd4783e51 100644 --- a/tests/PackageTestMain.hs +++ b/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