Skip to content

Support tar 0.7 #1449

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
ysangkok merged 2 commits into from
Jan 9, 2026
Merged

Support tar 0.7 #1449

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
f19dffb
Support tar 0.7
spencerjanssen Jan 5, 2026
13c5b51
Use Tar.pack' and Tar.write'
spencerjanssen Jan 6, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
11 changes: 6 additions & 5 deletions exes/BuildClient.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions flake.nix
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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: {
Expand Down
2 changes: 1 addition & 1 deletion hackage-server.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
30 changes: 15 additions & 15 deletions src/Distribution/Server/Packages/Unpack.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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) =
Expand All @@ -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
Expand All @@ -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')
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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))
Expand Down
2 changes: 1 addition & 1 deletion tests/Distribution/Server/Packages/UnpackTest.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
11 changes: 6 additions & 5 deletions tests/PackageTestMain.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down