cabal-install 3.18.1.0 → 3.18.2.0
raw patch · 11 files changed
+252/−61 lines, 11 files
Files
- ChangeLog.md +4/−0
- cabal-install.cabal +2/−1
- src/Distribution/Client/HttpUtils.hs +14/−14
- src/Distribution/Client/ProjectBuilding.hs +17/−4
- src/Distribution/Client/ProjectConfig/Parsec.hs +14/−10
- src/Distribution/Client/ProjectPlanning.hs +37/−13
- src/Distribution/Client/Store.hs +6/−18
- src/Distribution/Client/VCS.hs +8/−1
- tests/UnitTests.hs +4/−0
- tests/UnitTests/Distribution/Client/HttpUtils.hs +66/−0
- tests/UnitTests/Distribution/Client/VCS.hs +80/−0
ChangeLog.md view
@@ -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
cabal-install.cabal view
@@ -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
src/Distribution/Client/HttpUtils.hs view
@@ -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. "<body>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 =
src/Distribution/Client/ProjectBuilding.hs view
@@ -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
src/Distribution/Client/ProjectConfig/Parsec.hs view
@@ -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
src/Distribution/Client/ProjectPlanning.hs view
@@ -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 <https://github.com/haskell/cabal/issues/4010> --
src/Distribution/Client/Store.hs view
@@ -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
src/Distribution/Client/VCS.hs view
@@ -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
tests/UnitTests.hs view
@@ -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
+ tests/UnitTests/Distribution/Client/HttpUtils.hs view
@@ -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+ }
tests/UnitTests/Distribution/Client/VCS.hs view
@@ -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