cabal-install/src/Distribution/Client/Freeze.hs

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