diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Change-log +# 3.18.2.0 [Francesco Ariis](mailto:fa-ml@ariis.it) September 2026 + +* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.18.2.0.md + ## 3.18.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2026 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.18.1.0.md diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,7 +1,7 @@ Cabal-Version: 3.8 Name: cabal-install -Version: 3.18.1.0 +Version: 3.18.2.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -337,6 +337,7 @@ UnitTests.Distribution.Client.FetchUtils UnitTests.Distribution.Client.Get UnitTests.Distribution.Client.Glob + UnitTests.Distribution.Client.HttpUtils UnitTests.Distribution.Client.GZipUtils UnitTests.Distribution.Client.IndexUtils UnitTests.Distribution.Client.IndexUtils.ActiveRepos diff --git a/src/Distribution/Client/HttpUtils.hs b/src/Distribution/Client/HttpUtils.hs --- a/src/Distribution/Client/HttpUtils.hs +++ b/src/Distribution/Client/HttpUtils.hs @@ -541,7 +541,7 @@ , "--form" , "package=@" ++ path , "--write-out" - , "\n%{http_code}" + , "%{http_code}" , "--user-agent" , userAgent , "--silent" @@ -567,7 +567,7 @@ , "--data-binary" , "@" ++ path , "--write-out" - , "\n%{http_code}" + , "%{http_code}" , "--user-agent" , userAgent , "--silent" @@ -589,21 +589,21 @@ (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) - -- on success these curl invocations produces an output like "200" - -- and on failure it has the server error response first + -- On success these curl invocations produce an output like "200" (or body ending in "200"), + -- and on failure it has the server error response first followed by the HTTP status code. + -- The --write-out option appends the 3-digit HTTP status code directly to + -- the response body (e.g. "200"). We extract the last 3 characters as the status code. parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) parseResponse verbosity uri resp headers = - let codeerr = - case reverse (lines resp) of - (codeLine : rerrLines) -> - case readMaybe (trim codeLine) of - Just i -> - let errstr = mkErrstr rerrLines - in Just (i, errstr) - Nothing -> Nothing - [] -> Nothing + let respLen = length resp + codeerr + | respLen >= 3 + , let (body, codeStr) = splitAt (respLen - 3) resp + , Just code <- readMaybe codeStr = + Just (code, mkErrstr body) + | otherwise = Nothing - mkErrstr = unlines . reverse . dropWhile (all isSpace) + mkErrstr = unlines . reverse . dropWhile (all isSpace) . reverse . lines mb_etag :: Maybe ETag mb_etag = diff --git a/src/Distribution/Client/ProjectBuilding.hs b/src/Distribution/Client/ProjectBuilding.hs --- a/src/Distribution/Client/ProjectBuilding.hs +++ b/src/Distribution/Client/ProjectBuilding.hs @@ -92,7 +92,7 @@ import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Simple.PackageIndex (InstalledPackageIndex) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) -import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), ()) +import System.FilePath (makeRelative, normalise, takeDirectory, takeFileName, (<.>), ()) import System.Semaphore (SemaphoreIdentifier) import Distribution.Client.Errors @@ -502,8 +502,7 @@ invocation. -} --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. +-- | Create a package DB if it does not currently exist. createPackageDBIfMissing :: Verbosity -> Compiler @@ -515,11 +514,25 @@ compiler progdb (SpecificPackageDB dbPath) = do + -- If it already exists, skip locking. exists <- Cabal.doesPackageDBExist dbPath unless exists $ do createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb dbPath + withPackageDBLock verbosity dbPath $ do + -- Re-check under the lock. Another process may have created the DB + -- while we were waiting. + exists' <- Cabal.doesPackageDBExist dbPath + unless exists' $ + Cabal.createPackageDB verbosity compiler progdb dbPath createPackageDBIfMissing _ _ _ _ = return () + +-- | Hold an exclusive cross-process lock while initialising a package DB. +withPackageDBLock :: Verbosity -> FilePath -> IO a -> IO a +withPackageDBLock verbosity dbPath = + withFileLock verbosity lockPath waitMsg + where + lockPath = takeDirectory dbPath ('.' : takeFileName dbPath) <.> "lock" + waitMsg = "Waiting for file lock on package database " ++ dbPath -- | Given all the context and resources, (re)build an individual package. rebuildTarget diff --git a/src/Distribution/Client/ProjectConfig/Parsec.hs b/src/Distribution/Client/ProjectConfig/Parsec.hs --- a/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -236,12 +236,12 @@ | name == "program-options" = do verifyNullSubsections verifyNullSectionArgs - opts' <- lift $ parseProgramArgs programDb fields + opts' <- lift $ parseProgramArgs programDb True fields stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramArgs %= (opts' <>) | name == "program-locations" = do verifyNullSubsections verifyNullSectionArgs - paths' <- lift $ parseProgramPaths programDb fields + paths' <- lift $ parseProgramPaths programDb True fields stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramPaths %= (paths' <>) | name == "repository" = do verifyNullSubsections @@ -277,8 +277,8 @@ verifyNullSectionArgs = unless (null args) (lift $ parseFailure pos $ "The section '" <> show name <> "' takes no arguments") parsePackageConfig = do packageCfg <- lift $ parseFieldGrammar cabalSpec fields (packageConfigFieldGrammar programNames) - args' <- lift $ parseProgramArgs programDb fields - paths <- lift $ parseProgramPaths programDb fields + args' <- lift $ parseProgramArgs programDb False fields + paths <- lift $ parseProgramPaths programDb False fields return packageCfg{packageConfigProgramPaths = paths, packageConfigProgramArgs = args'} stanzas :: Set BS.ByteString @@ -344,24 +344,28 @@ P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec] -- | Parse fields of a program-options stanza. -parseProgramArgs :: ProgramDb -> Fields Position -> ParseResult src (MapMappend String [String]) -parseProgramArgs programDb fields = foldM parseField mempty (filter hasOptionsSuffix $ Map.toList fields) +parseProgramArgs :: ProgramDb -> Bool -> Fields Position -> ParseResult src (MapMappend String [String]) +parseProgramArgs programDb warnUnknown fields = foldM parseField mempty (filter hasOptionsSuffix $ Map.toList fields) where parseField programArgs (fieldName, fieldLines) = do case readProgramName "-options" programDb fieldName of - Nothing -> warnUnknownFields fieldName fieldLines >> return programArgs + Nothing -> do + when warnUnknown $ warnUnknownFields fieldName fieldLines + return programArgs Just program -> do args <- parseProgramArgsField $ reverse fieldLines return $ programArgs <> MapMappend (Map.singleton program args) hasOptionsSuffix (fieldName, _) = BS.isSuffixOf "-options" fieldName -- | Parse fields of a program-locations stanza. -parseProgramPaths :: ProgramDb -> Fields Position -> ParseResult src (MapLast String FilePath) -parseProgramPaths programDb fields = foldM parseField mempty (filter hasLocationSuffix $ Map.toList fields) +parseProgramPaths :: ProgramDb -> Bool -> Fields Position -> ParseResult src (MapLast String FilePath) +parseProgramPaths programDb warnUnknown fields = foldM parseField mempty (filter hasLocationSuffix $ Map.toList fields) where parseField paths (fieldName, fieldLines) = do case readProgramName "-location" programDb fieldName of - Nothing -> warnUnknownFields fieldName fieldLines >> return paths + Nothing -> do + when warnUnknown $ warnUnknownFields fieldName fieldLines + return paths Just program -> do case fieldLines of (MkNamelessField pos lines') : _ -> do diff --git a/src/Distribution/Client/ProjectPlanning.hs b/src/Distribution/Client/ProjectPlanning.hs --- a/src/Distribution/Client/ProjectPlanning.hs +++ b/src/Distribution/Client/ProjectPlanning.hs @@ -543,13 +543,23 @@ , projectConfigHcPkg , projectConfigProgPathExtra } + , projectConfigAllPackages = + PackageConfig + { packageConfigProgramPaths = packageConfigProgramPathsGlobal + } , projectConfigLocalPackages = PackageConfig - { packageConfigProgramPaths + { packageConfigProgramPaths = packageConfigProgramPathsLocal , packageConfigProgramPathExtra } } = do let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler" + userProgramPaths = + Map.toList + . getMapLast + $ packageConfigProgramPathsGlobal <> packageConfigProgramPathsLocal + userPaths :: ProgramDb -> ProgramDb + userPaths = userSpecifyPaths userProgramPaths progsearchpath <- liftIO getSystemSearchPath @@ -561,7 +571,8 @@ , hcPath , hcPkg , progsearchpath - , packageConfigProgramPaths + , packageConfigProgramPathsGlobal + , packageConfigProgramPathsLocal , packageConfigProgramPathExtra ) $ do @@ -571,7 +582,6 @@ let addPaths pathList = prependProgramSearchPath verbosity (fromNubList pathList) [] let globalPaths :: IO ProgramDb = addPaths projectConfigProgPathExtra defaultProgramDb let localPaths :: ProgramDb -> IO ProgramDb = addPaths packageConfigProgramPathExtra - let userPaths :: ProgramDb -> ProgramDb = userSpecifyPaths (Map.toList $ getMapLast packageConfigProgramPaths) (globalPaths >>= localPaths) <&> userPaths result@(_, _, progdb') <- liftIO $ @@ -597,7 +607,20 @@ -- (e.g. hsc2hs, haddock, ar, ld...). -- -- See Note [Caching the result of configuring the compiler] - finalProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hc (clearUnconfiguredPrograms hcProgDb) hcPkg + finalProgDb <- + liftIO $ do + progDb <- + Cabal.configCompilerProgDb + verbosity + hc + (clearUnconfiguredPrograms hcProgDb) + hcPkg + -- Re-apply the user-supplied program locations: 'configCompilerProgDb' + -- drops the unconfigured programs (along with any user-specified + -- locations) and re-adds the toolchain programs (gcc, ar, ld, ...) + -- without them. Without this, @--with-gcc@ and the @program-locations@ + -- section would have no effect (see #11881). + return $ userPaths progDb return (hc, plat, finalProgDb) where hcFlavor = flagToMaybe projectConfigHcFlavor @@ -2414,16 +2437,17 @@ elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo -- Combine the configured compiler prog settings with the user-supplied - -- config. For the compiler progs any user-supplied config was taken - -- into account earlier when configuring the compiler so its ok that - -- our configured settings for the compiler override the user-supplied - -- config here. + -- config. The user-supplied program locations take precedence over + -- the locations we discovered while configuring the compiler: this + -- is what makes @--with-gcc@ and the @program-locations@ section in + -- the config file win over the C compiler that GHC was built with. elabProgramPaths = - Map.fromList - [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerProgDb - ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths + perPkgOptionMapLast pkgid packageConfigProgramPaths + <> Map.fromList + [ (programId prog, programPath prog) + | prog <- configuredPrograms compilerProgDb + ] + elabProgramArgs = -- Workaround for -- diff --git a/src/Distribution/Client/Store.hs b/src/Distribution/Client/Store.hs --- a/src/Distribution/Client/Store.hs +++ b/src/Distribution/Client/Store.hs @@ -31,15 +31,13 @@ import Distribution.Simple.Utils ( debug , info + , withFileLock , withTempDirectory ) -import Control.Exception import qualified Data.Set as Set -import GHC.IO.Handle.Lock (LockMode (ExclusiveLock), hLock, hTryLock, hUnlock) import System.Directory import System.FilePath -import System.IO (IOMode (ReadWriteMode), hClose, openFile) -- $concurrency -- @@ -241,20 +239,10 @@ compiler unitid action = - bracket takeLock releaseLock (\_hnd -> action) + withFileLock verbosity (storeIncomingLock compiler unitid) waitMsg action where compid = compilerId compiler - takeLock = do - h <- openFile (storeIncomingLock compiler unitid) ReadWriteMode - -- First try non-blocking, but if we would have to wait then - -- log an explanation and do it again in blocking mode. - gotlock <- hTryLock h ExclusiveLock - unless gotlock $ do - info verbosity $ - "Waiting for file lock on store entry " - ++ prettyShow compid - prettyShow unitid - hLock h ExclusiveLock - return h - - releaseLock h = hUnlock h >> hClose h + waitMsg = + "Waiting for file lock on store entry " + ++ prettyShow compid + prettyShow unitid diff --git a/src/Distribution/Client/VCS.hs b/src/Distribution/Client/VCS.hs --- a/src/Distribution/Client/VCS.hs +++ b/src/Distribution/Client/VCS.hs @@ -502,8 +502,15 @@ gitProg ((primaryRepo, primaryLocalDir) : secondaryRepos) = do vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing + -- Each of the `secondaryRepos` clones the primary checkout as + -- `git clone --reference`, so that the group shares one object store. + -- But git refuses to reference a shallow clone, so only pass it on + -- when git's own marker `.git/shallow` is absent. + -- Fixes #12296. + primaryIsShallow <- doesFileExist (primaryLocalDir ".git" "shallow") + let peer = if primaryIsShallow then Nothing else Just primaryLocalDir sequence_ - [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) + [ vcsSyncRepo verbosity gitProg repo localDir peer | (repo, localDir) <- secondaryRepos ] return diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -8,6 +8,7 @@ import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Get import qualified UnitTests.Distribution.Client.Glob +import qualified UnitTests.Distribution.Client.HttpUtils import qualified UnitTests.Distribution.Client.IndexUtils import qualified UnitTests.Distribution.Client.IndexUtils.ActiveRepos import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp @@ -47,6 +48,9 @@ , testGroup "UnitTests.Distribution.Client.Glob" UnitTests.Distribution.Client.Glob.tests + , testGroup + "UnitTests.Distribution.Client.HttpUtils" + UnitTests.Distribution.Client.HttpUtils.tests , testGroup "Distribution.Client.GZipUtils" UnitTests.Distribution.Client.GZipUtils.tests diff --git a/tests/UnitTests/Distribution/Client/HttpUtils.hs b/tests/UnitTests/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Client/HttpUtils.hs @@ -0,0 +1,66 @@ +module UnitTests.Distribution.Client.HttpUtils + ( tests + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.HttpUtils + ( HttpTransport (..) + , isOldHackageURI + , remoteRepoTryUpgradeToHttps + ) +import Distribution.Client.Types (RemoteRepo (..), RepoName (..)) +import Distribution.Verbosity (Verbosity (..), defaultVerbosityHandles, normal) +import Network.URI (URI, nullURI, parseURI) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: [TestTree] +tests = + [ testGroup + "isOldHackageURI" + [ testCase "old hackage archive URI" $ + case parseURI "http://hackage.haskell.org/packages/archive" of + Just uri -> assertBool "should be old hackage URI" (isOldHackageURI uri) + Nothing -> assertFailure "failed to parse URI" + , testCase "modern hackage package URI" $ + case parseURI "http://hackage.haskell.org/package/foo" of + Just uri -> assertBool "should not be old hackage URI" (not (isOldHackageURI uri)) + Nothing -> assertFailure "failed to parse URI" + , testCase "non-hackage URI" $ + case parseURI "http://example.com/packages/archive" of + Just uri -> assertBool "should not be old hackage URI" (not (isOldHackageURI uri)) + Nothing -> assertFailure "failed to parse URI" + ] + , testGroup + "remoteRepoTryUpgradeToHttps" + [ testCase "upgrade http to https when supported" $ do + let dummyUri = fromMaybe nullURI (parseURI "http://hackage.haskell.org/") + repo = emptyTestRemoteRepo (RepoName "hackage") dummyUri + dummyTransport = + HttpTransport + { getHttp = \_ _ _ _ _ -> error "unused" + , postHttp = \_ _ _ _ -> error "unused" + , postHttpFile = \_ _ _ _ -> error "unused" + , putHttpFile = \_ _ _ _ _ -> error "unused" + , transportSupportsHttps = True + , transportManuallySelected = False + } + normalVerbosity = Verbosity normal defaultVerbosityHandles + upgraded <- remoteRepoTryUpgradeToHttps normalVerbosity dummyTransport repo + show (remoteRepoURI upgraded) @?= "https://hackage.haskell.org/" + ] + ] + +emptyTestRemoteRepo :: RepoName -> URI -> RemoteRepo +emptyTestRemoteRepo name uri = + RemoteRepo + { remoteRepoName = name + , remoteRepoURI = uri + , remoteRepoSecure = Nothing + , remoteRepoRootKeys = [] + , remoteRepoKeyThreshold = 0 + , remoteRepoShouldTryHttps = True + } diff --git a/tests/UnitTests/Distribution/Client/VCS.hs b/tests/UnitTests/Distribution/Client/VCS.hs --- a/tests/UnitTests/Distribution/Client/VCS.hs +++ b/tests/UnitTests/Distribution/Client/VCS.hs @@ -36,6 +36,7 @@ import Test.Tasty import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit (assertEqual, testCase) import Test.Tasty.QuickCheck import UnitTests.Distribution.Client.ArbitraryInstances @@ -69,6 +70,12 @@ [ testProperty "check VCS test framework" prop_framework_git , testProperty "cloneSourceRepo" prop_cloneRepo_git , testProperty "syncSourceRepos" prop_syncRepos_git + , testCase "syncSourceRepos, shallow, distinct tags" $ + unit_syncRepos_git fileUri NotShared ["tag-one", "tag-two"] + , testCase "syncSourceRepos, shallow, repeated tag" $ + unit_syncRepos_git fileUri NotShared ["tag-two", "tag-two"] + , testCase "syncSourceRepos, not shallow, distinct tags" $ + unit_syncRepos_git id Shared ["tag-one", "tag-two"] ] , -- ignoreTestBecause "for the moment they're not yet working" $ @@ -416,6 +423,79 @@ srcRepoPath destRepoPath (mkStdGen seed) + +-- | Whether the checkouts after the first one are expected to borrow the first +-- one's object store through @git clone --reference@. +data ObjectSharing = Shared | NotShared + deriving (Eq, Show) + +-- | Sync several checkouts of one repository, as a @cabal.project@ with more +-- than one @source-repository-package@ stanza for the same location does. +-- +-- 'prop_syncRepos_git' cannot cover this: it gives every stanza its own +-- repository, so the sharing between checkouts of one repository never comes +-- into play. How the location is spelled decides whether it can: over a URI +-- git honours @--depth@ and the checkouts are shallow, and git rejects a +-- shallow repository as the argument of @git clone --reference@ (#12296); for +-- a plain local path git ignores @--depth@, so the first checkout is a +-- complete repository and can be shared. +unit_syncRepos_git + :: (FilePath -> String) + -- ^ How to spell the repository location. + -> ObjectSharing + -- ^ What that spelling implies for the later checkouts. + -> [TagName] + -> IO () +unit_syncRepos_git mkLocation expectedSharing tags = + testSetup vcsGit vcsTestDriverGit recipe $ + \VCSTestDriver{vcsVCS, vcsRepoRoot, vcsIgnoreFiles} tmpdir repoState -> do + let destPaths = [tmpdir ("dest" ++ show i) | i <- [1 :: Int ..]] + repoAt tag = + SourceRepositoryPackage + { srpType = vcsRepoType vcsVCS + , srpLocation = mkLocation vcsRepoRoot + , srpTag = Just tag + , srpBranch = Nothing + , srpSubdir = Proxy + , srpCommand = [] + } + syncTargets = zip tags destPaths + _ <- + execRebuild "root-unused" $ + syncSourceRepos verbosity vcsVCS [(repoAt tag, dest) | (tag, dest) <- syncTargets] + sequence_ + [ checkExpectedWorkingState vcsIgnoreFiles dest (allTags repoState Map.! tag) + | (tag, dest) <- syncTargets + ] + sequence_ + [ do + borrows <- doesFileExist (dest ".git" "objects" "info" "alternates") + assertEqual + ("object sharing of " ++ dest) + expectedSharing + (if borrows then Shared else NotShared) + | dest <- drop 1 (map snd syncTargets) + ] + where + verbosity = mkVerbosity defaultVerbosityHandles silent + + recipe :: RepoRecipe 'SubmodulesNotSupported + recipe = + WithoutBranchingSupport $ + NonBranchingRepoRecipe + [ TaggedCommits "tag-one" [Commit [Left (FileUpdate ("file" "A") "one")]] + , TaggedCommits "tag-two" [Commit [Left (FileUpdate ("file" "B") "two")]] + ] + +-- | Git treats a plain local path and a @file://@ URI differently: the former +-- takes a shortcut that ignores @--depth@. +fileUri :: FilePath -> String +fileUri path = "file://" ++ root ++ map toPosixSeparator path + where + root = case buildOS of + Windows -> "/" + _ -> "" + toPosixSeparator c = if isPathSeparator c then '/' else c pickSyncTargetSets :: RepoType