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

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