From b92cbb046feb20be6b656752b25d12a2f26abd42 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sat, 29 Sep 2012 01:34:58 +0100 Subject: [PATCH 1/2] On install, update the .cabal file with the one from the index This allows us to make minor changes to packages after they have been released, without changing the package .tar.gz file. We already keep the .cabal file outsite the package in the index and use it for dependency planning. This already lets us do fixes such as making dependency constraints tighter. Currently we cannot make dep constraints more relaxed however, since the original .cabal file is the one used when we get to the actual configure step. So with this change, we now use the updated .cabal file for the configure and build too. So there's more fixes we can do post-release. In particlar, in combination with easier editing on hackage, this should help us address the problems around the PVP and open or closed version constraints. It should allow a system of conservative upper bounds, but allow editing them when new versions of deps are released and we find that they happen to work fine. --- .../Distribution/Client/Configure.hs | 7 ++-- .../Dependency/Modular/IndexConversion.hs | 2 +- .../Distribution/Client/Dependency/TopDown.hs | 8 ++--- .../Distribution/Client/IndexUtils.hs | 36 ++++++++++--------- cabal-install/Distribution/Client/Install.hs | 27 ++++++++++---- .../Distribution/Client/InstallSymlink.hs | 2 +- cabal-install/Distribution/Client/Targets.hs | 14 ++++---- cabal-install/Distribution/Client/Types.hs | 12 +++++-- 8 files changed, 67 insertions(+), 41 deletions(-) diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index b921de948ac..03cdff83183 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/cabal-install/Distribution/Client/Configure.hs @@ -82,7 +82,7 @@ configure verbosity packageDBs repos comp conf configureCommand (const configFlags) extraArgs Right installPlan -> case InstallPlan.ready installPlan of - [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _ _)] -> + [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] -> configurePackage verbosity (InstallPlan.planPlatform installPlan) (InstallPlan.planCompiler installPlan) @@ -138,7 +138,8 @@ planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex localPkg = SourcePackage { packageInfoId = packageId pkg, Source.packageDescription = pkg, - packageSource = LocalUnpackedPackage "." + packageSource = LocalUnpackedPackage ".", + packageDescrOverride = Nothing } testsEnabled = fromFlagOrDefault False $ configTests configFlags @@ -194,7 +195,7 @@ configurePackage :: Verbosity -> [String] -> IO () configurePackage verbosity platform comp scriptOptions configFlags - (ConfiguredPackage (SourcePackage _ gpkg _) flags stanzas deps) extraArgs = + (ConfiguredPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs = setupWrapper verbosity scriptOptions (Just pkg) configureCommand configureFlags extraArgs diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs index d22eeb9cd35..40e3aa05023 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -92,7 +92,7 @@ convSPI os arch cid = mkIndex . convSPI' os arch cid -- | Convert a single source package into the solver-specific format. convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo) -convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) = +convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo in (pn, i, convGPD os arch cid (PI pn i) gpd) diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs index fea86fb68fc..d7ecf18b4b6 100644 --- a/cabal-install/Distribution/Client/Dependency/TopDown.hs +++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs @@ -368,7 +368,7 @@ pruneBottomUp platform comp constraints = [ (dep, Constraints.conflicting cs dep) | dep <- missing ] - configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags stanzas) = + configure cs (UnconfiguredPackage (SourcePackage _ pkg _ _) _ flags stanzas) = finalizePackageDescription flags (dependencySatisfiable cs) platform comp [] (enableStanzas stanzas pkg) dependencySatisfiable cs = @@ -397,7 +397,7 @@ configurePackage platform comp available spkg = case spkg of InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg) (configure apkg) where - configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags stanzas) = + configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) = case finalizePackageDescription flags dependencySatisfiable platform comp [] (enableStanzas stanzas p) of Left missing -> Left missing @@ -481,7 +481,7 @@ topologicalSortNumbering installedPkgIndex sourcePkgIndex = ++ [ ((), packageName pkg, nub deps) | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex , let deps = [ depName - | SourcePackage _ pkg' _ <- pkgs + | SourcePackage _ pkg' _ _ <- pkgs , Dependency depName _ <- buildDepends (flattenPackageDescription pkg') ] ] @@ -517,7 +517,7 @@ selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty | pkg <- moreInstalled , dep <- depends pkg ] ++ [ name - | SourcePackage _ pkg _ <- moreSource + | SourcePackage _ pkg _ _ <- moreSource , Dependency name _ <- buildDepends (flattenPackageDescription pkg) ] installedPkgIndex'' = foldl' (flip PackageIndex.insert) diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs index 8501f60a854..ea4d5452ce7 100644 --- a/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal-install/Distribution/Client/IndexUtils.hs @@ -175,8 +175,11 @@ readRepoIndex verbosity repo = packageInfoId = pkgid, packageDescription = packageDesc pkgEntry, packageSource = case pkgEntry of - NormalPackage _ _ _ -> RepoTarballPackage repo pkgid Nothing - BuildTreeRef _ path _ _ -> LocalUnpackedPackage path + NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing + BuildTreeRef _ _ path _ -> LocalUnpackedPackage path, + packageDescrOverride = case pkgEntry of + NormalPackage _ _ pkgtxt _ -> Just pkgtxt + _ -> Nothing } where pkgid = packageId pkgEntry @@ -231,19 +234,18 @@ whenCacheOutOfDate origFile cacheFile action = do -- -- | An index entry is either a normal package, or a local build tree reference. -data PackageEntry = NormalPackage PackageId GenericPackageDescription BlockNo - | BuildTreeRef PackageId FilePath GenericPackageDescription - BlockNo +data PackageEntry = NormalPackage PackageId GenericPackageDescription ByteString BlockNo + | BuildTreeRef PackageId GenericPackageDescription FilePath BlockNo type MkPackageEntry = IO PackageEntry instance Package PackageEntry where - packageId (NormalPackage pkgid _ _ ) = pkgid - packageId (BuildTreeRef pkgid _ _ _ ) = pkgid + packageId (NormalPackage pkgid _ _ _) = pkgid + packageId (BuildTreeRef pkgid _ _ _) = pkgid packageDesc :: PackageEntry -> GenericPackageDescription -packageDesc (NormalPackage _ descr _ ) = descr -packageDesc (BuildTreeRef _ _ descr _ ) = descr +packageDesc (NormalPackage _ descr _ _) = descr +packageDesc (BuildTreeRef _ descr _ _) = descr -- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. -- @@ -302,7 +304,7 @@ extractPkg entry blockNo = case Tar.entryContent entry of | takeExtension fileName == ".cabal" -> case splitDirectories (normalise fileName) of [pkgname,vers,_] -> case simpleParse vers of - Just ver -> Just $ return (NormalPackage pkgid descr blockNo) + Just ver -> Just $ return (NormalPackage pkgid descr content blockNo) where pkgid = PackageIdentifier (PackageName pkgname) ver parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack @@ -320,7 +322,7 @@ extractPkg entry blockNo = case Tar.entryContent entry of let path = byteStringToFilePath content cabalFile <- findPackageDesc path descr <- PackageDesc.Parse.readPackageDescription normal cabalFile - return $ BuildTreeRef (packageId descr) path descr blockNo + return $ BuildTreeRef (packageId descr) descr path blockNo _ -> Nothing @@ -358,7 +360,7 @@ updatePackageIndexCacheFile indexFile cacheFile = do mkCache pkgs prefs = [ CachePreference pref | pref <- prefs ] ++ [ CachePackageId pkgid blockNo - | (NormalPackage pkgid _ blockNo) <- pkgs ] + | (NormalPackage pkgid _ _ blockNo) <- pkgs ] ++ [ CacheBuildTreeRef blockNo | (BuildTreeRef _ _ _ blockNo) <- pkgs] @@ -392,9 +394,11 @@ packageIndexFromCache mkPkg hnd = accum mempty [] -- The magic here is that we use lazy IO to read the .cabal file -- from the index tarball if it turns out that we need it. -- Most of the time we only need the package id. - pkg <- unsafeInterleaveIO $ do - getEntryContent blockno >>= readPackageDescription - let srcpkg = mkPkg (NormalPackage pkgid pkg blockno) + ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do + pkgtxt <- getEntryContent blockno + pkg <- readPackageDescription pkgtxt + return (pkg, pkgtxt) + let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) accum (srcpkg:srcpkgs) prefs entries accum srcpkgs prefs (CacheBuildTreeRef blockno : entries) = do @@ -404,7 +408,7 @@ packageIndexFromCache mkPkg hnd = accum mempty [] path <- liftM byteStringToFilePath . getEntryContent $ blockno pkg <- do cabalFile <- findPackageDesc path PackageDesc.Parse.readPackageDescription normal cabalFile - let srcpkg = mkPkg (BuildTreeRef (packageId pkg) path pkg blockno) + let srcpkg = mkPkg (BuildTreeRef (packageId pkg) pkg path blockno) accum (srcpkg:srcpkgs) prefs entries accum srcpkgs prefs (CachePreference pref : entries) = diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 274ceacd0dc..67c3b7a619d 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -96,7 +96,7 @@ import qualified Distribution.Simple.Setup as Cabal ( installCommand, InstallFlags(..), emptyInstallFlags , emptyTestFlags, testCommand, Flag(..) ) import Distribution.Simple.Utils - ( rawSystemExit, comparing ) + ( rawSystemExit, comparing, writeFileAtomic ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) @@ -781,13 +781,13 @@ performInstallations verbosity executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg -> installConfiguredPackage platform compid configFlags - cpkg $ \configFlags' src pkg -> + cpkg $ \configFlags' src pkg pkgoverride -> fetchSourcePackage verbosity fetchLimit src $ \src' -> installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath -> installUnpackedPackage verbosity buildLimit installLock numJobs (setupScriptOptions installedPkgIndex cacheLock) miscOptions configFlags' installFlags haddockFlags - compid pkg mpath useLogFile + compid pkg pkgoverride mpath useLogFile where platform = InstallPlan.planPlatform installPlan @@ -956,16 +956,17 @@ executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg = installConfiguredPackage :: Platform -> CompilerId -> ConfigFlags -> ConfiguredPackage -> (ConfigFlags -> PackageLocation (Maybe FilePath) - -> PackageDescription -> a) + -> PackageDescription + -> PackageDescriptionOverride -> a) -> a installConfiguredPackage platform comp configFlags - (ConfiguredPackage (SourcePackage _ gpkg source) flags stanzas deps) + (ConfiguredPackage (SourcePackage _ gpkg source pkgoverride) flags stanzas deps) installPkg = installPkg configFlags { configConfigurationsFlags = flags, configConstraints = map thisPackageVersion deps, configBenchmarks = toFlag False, configTests = toFlag (TestStanzas `elem` stanzas) - } source pkg + } source pkg pkgoverride where pkg = case finalizePackageDescription flags (const True) @@ -1051,13 +1052,25 @@ installUnpackedPackage -> HaddockFlags -> CompilerId -> PackageDescription + -> PackageDescriptionOverride -> Maybe FilePath -- ^ Directory to change to before starting the installation. -> UseLogFile -- ^ File to log output to (if any) -> IO BuildResult installUnpackedPackage verbosity buildLimit installLock numJobs scriptOptions miscOptions configFlags installConfigFlags haddockFlags - compid pkg workingDir useLogFile = + compid pkg pkgoverride workingDir useLogFile = do + + -- Override the .cabal file if necessary + case pkgoverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = fromMaybe "." workingDir + display (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " ++ display (packageName pkgid) <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt -- Configure phase onFailure ConfigureFailed $ withJobLimit buildLimit $ do diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs index e3c4fc12d70..2cf0abf98c8 100644 --- a/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/Distribution/Client/InstallSymlink.hs @@ -133,7 +133,7 @@ symlinkBinaries configFlags installFlags plan = , PackageDescription.buildable (PackageDescription.buildInfo exe) ] pkgDescription :: ConfiguredPackage -> PackageDescription - pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags stanzas _) = + pkgDescription (ConfiguredPackage (SourcePackage _ pkg _ _) flags stanzas _) = case finalizePackageDescription flags (const True) platform compilerId [] (enableStanzas stanzas pkg) of diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index 2863cbbb221..0cab91e37ab 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -472,9 +472,10 @@ readPackageTarget verbosity target = case target of pkg <- readPackageDescription verbosity =<< findPackageDesc dir return $ PackageTargetLocation $ SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing } LocalTarballPackage tarballFile -> @@ -497,9 +498,10 @@ readPackageTarget verbosity target = case target of Just pkg -> return $ PackageTargetLocation $ SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing } extractTarballPackageCabalFile :: FilePath -> String diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index 4f0376d8210..3ae23873200 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -29,6 +29,7 @@ import Distribution.Version import Data.Map (Map) import Network.URI (URI) +import Data.ByteString.Lazy (ByteString) import Distribution.Compat.Exception ( SomeException ) @@ -94,12 +95,17 @@ instance PackageFixedDeps ConfiguredPackage where -- | A package description along with the location of the package sources. -- data SourcePackage = SourcePackage { - packageInfoId :: PackageId, - packageDescription :: GenericPackageDescription, - packageSource :: PackageLocation (Maybe FilePath) + packageInfoId :: PackageId, + packageDescription :: GenericPackageDescription, + packageSource :: PackageLocation (Maybe FilePath), + packageDescrOverride :: PackageDescriptionOverride } deriving Show +-- | We sometimes need to override the .cabal file in the tarball with +-- the newer one from the package index. +type PackageDescriptionOverride = Maybe ByteString + instance Package SourcePackage where packageId = packageInfoId data OptionalStanza From b7565f941b2dd5d61a77e46826fd256358505de7 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sat, 29 Sep 2012 01:41:31 +0100 Subject: [PATCH 2/2] Extend the unpack command for the .cabal file updating By default, "cabal unpack blah" will also update the .cabal file with the one from the index, so it's consistent with what you get via cabal install. Also added a --pristine flag so you can get the original tarball without the updated .cabal file. --- cabal-install/Distribution/Client/Setup.hs | 17 +++++++++--- cabal-install/Distribution/Client/Unpack.hs | 30 +++++++++++++++------ 2 files changed, 35 insertions(+), 12 deletions(-) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index b263acc7d4b..a92cb410059 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -491,13 +491,15 @@ instance Monoid ReportFlags where data UnpackFlags = UnpackFlags { unpackDestDir :: Flag FilePath, - unpackVerbosity :: Flag Verbosity + unpackVerbosity :: Flag Verbosity, + unpackPristine :: Flag Bool } defaultUnpackFlags :: UnpackFlags defaultUnpackFlags = UnpackFlags { unpackDestDir = mempty, - unpackVerbosity = toFlag normal + unpackVerbosity = toFlag normal, + unpackPristine = toFlag False } unpackCommand :: CommandUI UnpackFlags @@ -514,14 +516,21 @@ unpackCommand = CommandUI { "where to unpack the packages, defaults to the current directory." unpackDestDir (\v flags -> flags { unpackDestDir = v }) (reqArgFlag "PATH") + + , option [] ["pristine"] + ("Unpack the original pristine tarball, rather than updating the " + ++ ".cabal file with the latest revision from the package archive.") + unpackPristine (\v flags -> flags { unpackPristine = v }) + trueArg ] } instance Monoid UnpackFlags where mempty = defaultUnpackFlags mappend a b = UnpackFlags { - unpackDestDir = combine unpackDestDir - ,unpackVerbosity = combine unpackVerbosity + unpackDestDir = combine unpackDestDir, + unpackVerbosity = combine unpackVerbosity, + unpackPristine = combine unpackPristine } where combine field = field a `mappend` field b diff --git a/cabal-install/Distribution/Client/Unpack.hs b/cabal-install/Distribution/Client/Unpack.hs index ccc9ed7e107..6e15c6c5791 100644 --- a/cabal-install/Distribution/Client/Unpack.hs +++ b/cabal-install/Distribution/Client/Unpack.hs @@ -19,11 +19,11 @@ module Distribution.Client.Unpack ( ) where import Distribution.Package - ( PackageId, packageId ) + ( PackageId, packageId, packageName ) import Distribution.Simple.Setup ( fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils - ( notice, die ) + ( notice, die, info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text(display) @@ -45,7 +45,7 @@ import Control.Monad import Data.Monoid ( mempty ) import System.FilePath - ( (), addTrailingPathSeparator ) + ( (), (<.>), addTrailingPathSeparator ) unpack :: Verbosity @@ -77,15 +77,17 @@ unpack verbosity repos globalFlags unpackFlags userTargets = do flip mapM_ pkgs $ \pkg -> do location <- fetchPackage verbosity (packageSource pkg) let pkgid = packageId pkg + descOverride | usePristine = Nothing + | otherwise = packageDescrOverride pkg case location of LocalTarballPackage tarballPath -> - unpackPackage verbosity prefix pkgid tarballPath + unpackPackage verbosity prefix pkgid descOverride tarballPath RemoteTarballPackage _tarballURL tarballPath -> - unpackPackage verbosity prefix pkgid tarballPath + unpackPackage verbosity prefix pkgid descOverride tarballPath RepoTarballPackage _repo _pkgid tarballPath -> - unpackPackage verbosity prefix pkgid tarballPath + unpackPackage verbosity prefix pkgid descOverride tarballPath LocalUnpackedPackage _ -> error "Distribution.Client.Unpack.unpack: the impossible happened." @@ -97,6 +99,7 @@ unpack verbosity repos globalFlags unpackFlags userTargets = do standardInstallPolicy mempty sourcePkgDb pkgSpecifiers prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags) + usePristine = fromFlagOrDefault False (unpackPristine unpackFlags) checkTarget :: UserTarget -> IO () checkTarget target = case target of @@ -108,8 +111,10 @@ checkTarget target = case target of "The 'unpack' command is for tarball packages. " ++ "The target '" ++ t ++ "' is not a tarball." -unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO () -unpackPackage verbosity prefix pkgid pkgPath = do +unpackPackage :: Verbosity -> FilePath -> PackageId + -> PackageDescriptionOverride + -> FilePath -> IO () +unpackPackage verbosity prefix pkgid descOverride pkgPath = do let pkgdirname = display pkgid pkgdir = prefix pkgdirname pkgdir' = addTrailingPathSeparator pkgdir @@ -121,3 +126,12 @@ unpackPackage verbosity prefix pkgid pkgPath = do "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' Tar.extractTarGzFile prefix pkgdirname pkgPath + + case descOverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = pkgdir display (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " ++ descFilePath + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt