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

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3
   4 -- | cabal-install CLI command: freeze
   5 module Distribution.Client.CmdFreeze
   6   ( freezeCommand
   7   , freezeAction
   8   ) where
   9
  10 import Distribution.Client.Compat.Prelude
  11 import Prelude ()
  12
  13 import Distribution.Client.DistDirLayout
  14   ( DistDirLayout (distProjectFile)
  15   )
  16 import Distribution.Client.IndexUtils (ActiveRepos, TotalIndexState, filterSkippedActiveRepos)
  17 import qualified Distribution.Client.InstallPlan as InstallPlan
  18 import Distribution.Client.NixStyleOptions
  19   ( NixStyleFlags (..)
  20   , defaultNixStyleFlags
  21   , nixStyleOptions
  22   )
  23 import Distribution.Client.ProjectConfig
  24   ( ProjectConfig (..)
  25   , ProjectConfigShared (..)
  26   , writeProjectLocalFreezeConfig
  27   )
  28 import Distribution.Client.ProjectOrchestration
  29 import Distribution.Client.ProjectPlanning
  30 import Distribution.Client.Targets
  31   ( UserConstraint (..)
  32   , UserConstraintScope (..)
  33   , UserQualifier (..)
  34   )
  35 import Distribution.Solver.Types.ConstraintSource
  36   ( ConstraintSource (..)
  37   )
  38 import Distribution.Solver.Types.PackageConstraint
  39   ( PackageProperty (..)
  40   )
  41
  42 import Distribution.Client.Setup
  43   ( ConfigFlags (..)
  44   , GlobalFlags
  45   )
  46 import Distribution.Package
  47   ( PackageName
  48   , packageName
  49   , packageVersion
  50   )
  51 import Distribution.PackageDescription
  52   ( FlagAssignment
  53   , nullFlagAssignment
  54   )
  55 import Distribution.Simple.Flag (Flag (..), fromFlagOrDefault)
  56 import Distribution.Simple.Utils
  57   ( dieWithException
  58   , notice
  59   , wrapText
  60   )
  61 import Distribution.Verbosity
  62   ( normal
  63   )
  64 import Distribution.Version
  65   ( VersionRange
  66   , simplifyVersionRange
  67   , thisVersion
  68   , unionVersionRanges
  69   )
  70
  71 import qualified Data.Map as Map
  72
  73 import Distribution.Client.Errors
  74 import Distribution.Simple.Command
  75   ( CommandUI (..)
  76   , usageAlternatives
  77   )
  78
  79 freezeCommand :: CommandUI (NixStyleFlags ())
  80 freezeCommand =
  81   CommandUI
  82     { commandName = "v2-freeze"
  83     , commandSynopsis = "Freeze dependencies."
  84     , commandUsage = usageAlternatives "v2-freeze" ["[FLAGS]"]
  85     , commandDescription = Just $ \_ ->
  86         wrapText $
  87           "The project configuration is frozen so that it will be reproducible "
  88             ++ "in future.\n\n"
  89             ++ "The precise dependency configuration for the project is written to "
  90             ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if "
  91             ++ "'--project-file' is specified). This file extends the configuration "
  92             ++ "from the 'cabal.project' file and thus is used as the project "
  93             ++ "configuration for all other commands (such as 'v2-build', "
  94             ++ "'v2-repl' etc).\n\n"
  95             ++ "The freeze file can be kept in source control. To make small "
  96             ++ "adjustments it may be edited manually, or to make bigger changes "
  97             ++ "you may wish to delete the file and re-freeze. For more control, "
  98             ++ "one approach is to try variations using 'v2-build --dry-run' with "
  99             ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "
 100             ++ "a satisfactory solution to freeze it using the 'v2-freeze' command "
 101             ++ "with the same set of flags."
 102     , commandNotes = Just $ \pname ->
 103         "Examples:\n"
 104           ++ "  "
 105           ++ pname
 106           ++ " v2-freeze\n"
 107           ++ "    Freeze the configuration of the current project\n\n"
 108           ++ "  "
 109           ++ pname
 110           ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n"
 111           ++ "    Check what a solution with the given constraints would look like\n"
 112           ++ "  "
 113           ++ pname
 114           ++ " v2-freeze --constraint=\"aeson < 1\"\n"
 115           ++ "    Freeze a solution using the given constraints\n"
 116     , commandDefaultFlags = defaultNixStyleFlags ()
 117     , commandOptions = nixStyleOptions (const [])
 118     }
 119
 120 -- | To a first approximation, the @freeze@ command runs the first phase of
 121 -- the @build@ command where we bring the install plan up to date, and then
 122 -- based on the install plan we write out a @cabal.project.freeze@ config file.
 123 --
 124 -- For more details on how this works, see the module
 125 -- "Distribution.Client.ProjectOrchestration"
 126 freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
 127 freezeAction flags@NixStyleFlags{..} extraArgs globalFlags = do
 128   unless (null extraArgs) $
 129     dieWithException verbosity $
 130       FreezeAction extraArgs
 131
 132   ProjectBaseContext
 133     { distDirLayout
 134     , cabalDirLayout
 135     , projectConfig
 136     , localPackages
 137     , buildSettings
 138     } <-
 139     establishProjectBaseContext verbosity cliConfig OtherCommand
 140
 141   (_, elaboratedPlan, _, totalIndexState, activeRepos) <-
 142     rebuildInstallPlan
 143       verbosity
 144       distDirLayout
 145       cabalDirLayout
 146       projectConfig
 147       localPackages
 148       Nothing
 149
 150   let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos
 151       dryRun =
 152         buildSettingDryRun buildSettings
 153           || buildSettingOnlyDownload buildSettings
 154
 155   if dryRun
 156     then notice verbosity "Freeze file not written due to flag(s)"
 157     else do
 158       writeProjectLocalFreezeConfig distDirLayout freezeConfig
 159       notice verbosity $
 160         "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
 161   where
 162     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
 163     cliConfig =
 164       commandLineFlagsToProjectConfig
 165         globalFlags
 166         flags
 167         mempty -- ClientInstallFlags, not needed here
 168
 169 -- | Given the install plan, produce a config value with constraints that
 170 -- freezes the versions of packages used in the plan.
 171 projectFreezeConfig
 172   :: ElaboratedInstallPlan
 173   -> TotalIndexState
 174   -> ActiveRepos
 175   -> ProjectConfig
 176 projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 =
 177   mempty
 178     { projectConfigShared =
 179         mempty
 180           { projectConfigConstraints =
 181               concat (Map.elems (projectFreezeConstraints elaboratedPlan))
 182           , projectConfigIndexState = Flag totalIndexState
 183           , projectConfigActiveRepos = Flag activeRepos
 184           }
 185     }
 186   where
 187     activeRepos :: ActiveRepos
 188     activeRepos = filterSkippedActiveRepos activeRepos0
 189
 190 -- | Given the install plan, produce solver constraints that will ensure the
 191 -- solver picks the same solution again in future in different environments.
 192 projectFreezeConstraints
 193   :: ElaboratedInstallPlan
 194   -> Map PackageName [(UserConstraint, ConstraintSource)]
 195 projectFreezeConstraints plan =
 196   --
 197   -- TODO: [required eventually] this is currently an underapproximation
 198   -- since the constraints language is not expressive enough to specify the
 199   -- precise solution. See https://github.com/haskell/cabal/issues/3502.
 200   --
 201   -- For the moment we deal with multiple versions in the solution by using
 202   -- constraints that allow either version. Also, we do not include any
 203   -- /version/ constraints for packages that are local to the project (e.g.
 204   -- if the solution has two instances of Cabal, one from the local project
 205   -- and one pulled in as a setup deps then we exclude all constraints on
 206   -- Cabal, not just the constraint for the local instance since any
 207   -- constraint would apply to both instances). We do however keep flag
 208   -- constraints of local packages.
 209   --
 210   deleteLocalPackagesVersionConstraints
 211     (Map.unionWith (++) versionConstraints flagConstraints)
 212   where
 213     versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
 214     versionConstraints =
 215       Map.mapWithKey
 216         ( \p v ->
 217             [
 218               ( UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v)
 219               , ConstraintSourceFreeze
 220               )
 221             ]
 222         )
 223         versionRanges
 224
 225     versionRanges :: Map PackageName VersionRange
 226     versionRanges =
 227       Map.map simplifyVersionRange $
 228         Map.fromListWith unionVersionRanges $
 229           [ (packageName pkg, thisVersion (packageVersion pkg))
 230           | InstallPlan.PreExisting pkg <- InstallPlan.toList plan
 231           ]
 232             ++ [ (packageName pkg, thisVersion (packageVersion pkg))
 233                | InstallPlan.Configured pkg <- InstallPlan.toList plan
 234                ]
 235
 236     flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
 237     flagConstraints =
 238       Map.mapWithKey
 239         ( \p f ->
 240             [
 241               ( UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f)
 242               , ConstraintSourceFreeze
 243               )
 244             ]
 245         )
 246         flagAssignments
 247
 248     flagAssignments :: Map PackageName FlagAssignment
 249     flagAssignments =
 250       Map.fromList
 251         [ (pkgname, flags)
 252         | InstallPlan.Configured elab <- InstallPlan.toList plan
 253         , let flags = elabFlagAssignment elab
 254               pkgname = packageName elab
 255         , not (nullFlagAssignment flags)
 256         ]
 257
 258     -- As described above, remove the version constraints on local packages,
 259     -- but leave any flag constraints.
 260     deleteLocalPackagesVersionConstraints
 261       :: Map PackageName [(UserConstraint, ConstraintSource)]
 262       -> Map PackageName [(UserConstraint, ConstraintSource)]
 263     deleteLocalPackagesVersionConstraints =
 264       Map.mergeWithKey
 265         ( \_pkgname () constraints ->
 266             case filter (not . isVersionConstraint . fst) constraints of
 267               [] -> Nothing
 268               constraints' -> Just constraints'
 269         )
 270         (const Map.empty)
 271         id
 272         localPackages
 273
 274     isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True
 275     isVersionConstraint _ = False
 276
 277     localPackages :: Map PackageName ()
 278     localPackages =
 279       Map.fromList
 280         [ (packageName elab, ())
 281         | InstallPlan.Configured elab <- InstallPlan.toList plan
 282         , elabLocalToProject elab
 283         ]