1----------------------------------------------------------------------------- 2-- | 3-- Module : Distribution.Client.Freeze 4-- Copyright : (c) David Himmelstrup 2005 5-- Duncan Coutts 2011 6-- License : BSD-like 7-- 8-- Maintainer : cabal-devel@gmail.com 9-- Stability : provisional 10-- Portability : portable 11-- 12-- The cabal freeze command 13----------------------------------------------------------------------------- 14module Distribution.Client.Freeze ( 15 freeze, getFreezePkgs 16 ) where 17 18import Prelude () 19import Distribution.Client.Compat.Prelude 20 21import Distribution.Client.Config ( SavedConfig(..) ) 22import Distribution.Client.Types 23import Distribution.Client.Targets 24import Distribution.Client.Dependency 25import Distribution.Client.IndexUtils as IndexUtils 26 ( getSourcePackages, getInstalledPackages ) 27import Distribution.Client.SolverInstallPlan 28 ( SolverInstallPlan, SolverPlanPackage ) 29import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan 30import Distribution.Client.Setup 31 ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) 32 , RepoContext(..) ) 33import Distribution.Client.Sandbox.PackageEnvironment 34 ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment, 35 userPackageEnvironmentFile ) 36import Distribution.Client.Sandbox.Types 37 ( SandboxPackageInfo(..) ) 38 39import Distribution.Solver.Types.ConstraintSource 40import Distribution.Solver.Types.LabeledPackageConstraint 41import Distribution.Solver.Types.OptionalStanza 42import Distribution.Solver.Types.PkgConfigDb 43import Distribution.Solver.Types.SolverId 44 45import Distribution.Package 46 ( Package, packageId, packageName, packageVersion ) 47import Distribution.Simple.Compiler 48 ( Compiler, compilerInfo, PackageDBStack ) 49import Distribution.Simple.PackageIndex (InstalledPackageIndex) 50import Distribution.Simple.Program 51 ( ProgramDb ) 52import Distribution.Simple.Setup 53 ( fromFlag, fromFlagOrDefault, flagToMaybe ) 54import Distribution.Simple.Utils 55 ( die', notice, debug, writeFileAtomic ) 56import Distribution.System 57 ( Platform ) 58import Distribution.Deprecated.Text 59 ( display ) 60import Distribution.Verbosity 61 ( Verbosity ) 62 63import qualified Data.ByteString.Lazy.Char8 as BS.Char8 64import Distribution.Version 65 ( thisVersion ) 66 67-- ------------------------------------------------------------ 68-- * The freeze command 69-- ------------------------------------------------------------ 70 71-- | Freeze all of the dependencies by writing a constraints section 72-- constraining each dependency to an exact version. 73-- 74freeze :: Verbosity 75 -> PackageDBStack 76 -> RepoContext 77 -> Compiler 78 -> Platform 79 -> ProgramDb 80 -> Maybe SandboxPackageInfo 81 -> GlobalFlags 82 -> FreezeFlags 83 -> IO () 84freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo 85 globalFlags freezeFlags = do 86 87 pkgs <- getFreezePkgs 88 verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo 89 globalFlags freezeFlags 90 91 if null pkgs 92 then notice verbosity $ "No packages to be frozen. " 93 ++ "As this package has no dependencies." 94 else if dryRun 95 then notice verbosity $ unlines $ 96 "The following packages would be frozen:" 97 : formatPkgs pkgs 98 99 else freezePackages verbosity globalFlags pkgs 100 101 where 102 dryRun = fromFlag (freezeDryRun freezeFlags) 103 104-- | Get the list of packages whose versions would be frozen by the @freeze@ 105-- command. 106getFreezePkgs :: Verbosity 107 -> PackageDBStack 108 -> RepoContext 109 -> Compiler 110 -> Platform 111 -> ProgramDb 112 -> Maybe SandboxPackageInfo 113 -> GlobalFlags 114 -> FreezeFlags 115 -> IO [SolverPlanPackage] 116getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo 117 globalFlags freezeFlags = do 118 119 installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb 120 sourcePkgDb <- getSourcePackages verbosity repoCtxt 121 pkgConfigDb <- readPkgConfigDb verbosity progdb 122 123 pkgSpecifiers <- resolveUserTargets verbosity repoCtxt 124 (fromFlag $ globalWorldFile globalFlags) 125 (packageIndex sourcePkgDb) 126 [UserTargetLocalDir "."] 127 128 sanityCheck pkgSpecifiers 129 planPackages 130 verbosity comp platform mSandboxPkgInfo freezeFlags 131 installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers 132 where 133 sanityCheck pkgSpecifiers = do 134 when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ 135 die' verbosity $ "internal error: 'resolveUserTargets' returned " 136 ++ "unexpected named package specifiers!" 137 when (length pkgSpecifiers /= 1) $ 138 die' verbosity $ "internal error: 'resolveUserTargets' returned " 139 ++ "unexpected source package specifiers!" 140 141planPackages :: Verbosity 142 -> Compiler 143 -> Platform 144 -> Maybe SandboxPackageInfo 145 -> FreezeFlags 146 -> InstalledPackageIndex 147 -> SourcePackageDb 148 -> PkgConfigDb 149 -> [PackageSpecifier UnresolvedSourcePackage] 150 -> IO [SolverPlanPackage] 151planPackages verbosity comp platform mSandboxPkgInfo freezeFlags 152 installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do 153 154 solver <- chooseSolver verbosity 155 (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) 156 notice verbosity "Resolving dependencies..." 157 158 installPlan <- foldProgress logMsg (die' verbosity) return $ 159 resolveDependencies 160 platform (compilerInfo comp) pkgConfigDb 161 solver 162 resolverParams 163 164 return $ pruneInstallPlan installPlan pkgSpecifiers 165 166 where 167 resolverParams = 168 169 setMaxBackjumps (if maxBackjumps < 0 then Nothing 170 else Just maxBackjumps) 171 172 . setIndependentGoals independentGoals 173 174 . setReorderGoals reorderGoals 175 176 . setCountConflicts countConflicts 177 178 . setFineGrainedConflicts fineGrainedConflicts 179 180 . setMinimizeConflictSet minimizeConflictSet 181 182 . setShadowPkgs shadowPkgs 183 184 . setStrongFlags strongFlags 185 186 . setAllowBootLibInstalls allowBootLibInstalls 187 188 . setOnlyConstrained onlyConstrained 189 190 . setSolverVerbosity verbosity 191 192 . addConstraints 193 [ let pkg = pkgSpecifierTarget pkgSpecifier 194 pc = PackageConstraint (scopeToplevel pkg) 195 (PackagePropertyStanzas stanzas) 196 in LabeledPackageConstraint pc ConstraintSourceFreeze 197 | pkgSpecifier <- pkgSpecifiers ] 198 199 . maybe id applySandboxInstallPolicy mSandboxPkgInfo 200 201 $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers 202 203 logMsg message rest = debug verbosity message >> rest 204 205 stanzas = [ TestStanzas | testsEnabled ] 206 ++ [ BenchStanzas | benchmarksEnabled ] 207 testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags 208 benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags 209 210 reorderGoals = fromFlag (freezeReorderGoals freezeFlags) 211 countConflicts = fromFlag (freezeCountConflicts freezeFlags) 212 fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) 213 minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) 214 independentGoals = fromFlag (freezeIndependentGoals freezeFlags) 215 shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) 216 strongFlags = fromFlag (freezeStrongFlags freezeFlags) 217 maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) 218 allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) 219 onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) 220 221 222-- | Remove all unneeded packages from an install plan. 223-- 224-- A package is unneeded if it is either 225-- 226-- 1) the package that we are freezing, or 227-- 228-- 2) not a dependency (directly or transitively) of the package we are 229-- freezing. This is useful for removing previously installed packages 230-- which are no longer required from the install plan. 231-- 232-- Invariant: @pkgSpecifiers@ must refer to packages which are not 233-- 'PreExisting' in the 'SolverInstallPlan'. 234pruneInstallPlan :: SolverInstallPlan 235 -> [PackageSpecifier UnresolvedSourcePackage] 236 -> [SolverPlanPackage] 237pruneInstallPlan installPlan pkgSpecifiers = 238 removeSelf pkgIds $ 239 SolverInstallPlan.dependencyClosure installPlan pkgIds 240 where 241 pkgIds = [ PlannedId (packageId pkg) 242 | SpecificSourcePackage pkg <- pkgSpecifiers ] 243 removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) 244 removeSelf _ = error $ "internal error: 'pruneInstallPlan' given " 245 ++ "unexpected package specifiers!" 246 247 248freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO () 249freezePackages verbosity globalFlags pkgs = do 250 251 pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ 252 loadUserConfig verbosity "" 253 (flagToMaybe . globalConstraintsFile $ globalFlags) 254 writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv 255 where 256 addFrozenConstraints config = 257 config { 258 savedConfigureExFlags = (savedConfigureExFlags config) { 259 configExConstraints = map constraint pkgs 260 } 261 } 262 constraint pkg = 263 (pkgIdToConstraint $ packageId pkg 264 ,ConstraintSourceUserConfig userPackageEnvironmentFile) 265 where 266 pkgIdToConstraint pkgId = 267 UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) 268 (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) 269 createPkgEnv config = mempty { pkgEnvSavedConfig = config } 270 showPkgEnv = BS.Char8.pack . showPackageEnvironment 271 272 273formatPkgs :: Package pkg => [pkg] -> [String] 274formatPkgs = map $ showPkg . packageId 275 where 276 showPkg pid = name pid ++ " == " ++ version pid 277 name = display . packageName 278 version = display . packageVersion 279