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