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

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RecordWildCards #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -----------------------------------------------------------------------------
   8
   9 -- |
  10 -- Module      :  Distribution.Client.CmdOutdated
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- Implementation of the 'outdated' command. Checks for outdated
  15 -- dependencies in the package description file or freeze file.
  16 module Distribution.Client.CmdOutdated
  17   ( outdatedCommand
  18   , outdatedAction
  19   , ListOutdatedSettings (..)
  20   , listOutdated
  21   )
  22 where
  23
  24 import Distribution.Client.Compat.Prelude
  25 import Distribution.Compat.Lens
  26   ( _1
  27   , _2
  28   )
  29 import Prelude ()
  30
  31 import Distribution.Client.Config
  32   ( SavedConfig
  33       ( savedConfigureExFlags
  34       , savedConfigureFlags
  35       , savedGlobalFlags
  36       )
  37   )
  38 import Distribution.Client.DistDirLayout
  39   ( DistDirLayout (distProjectFile, distProjectRootDirectory)
  40   , defaultDistDirLayout
  41   )
  42 import Distribution.Client.IndexUtils as IndexUtils
  43 import Distribution.Client.ProjectConfig
  44 import Distribution.Client.ProjectConfig.Legacy
  45   ( instantiateProjectConfigSkeletonWithCompiler
  46   )
  47 import Distribution.Client.ProjectFlags
  48   ( ProjectFlags (..)
  49   , defaultProjectFlags
  50   , projectFlagsOptions
  51   , removeIgnoreProjectOption
  52   )
  53 import Distribution.Client.RebuildMonad
  54   ( runRebuild
  55   )
  56 import Distribution.Client.Sandbox
  57   ( loadConfigOrSandboxConfig
  58   )
  59 import Distribution.Client.Sandbox.PackageEnvironment
  60   ( loadUserConfig
  61   )
  62 import Distribution.Client.Setup
  63 import Distribution.Client.Targets
  64   ( UserConstraint
  65   , userToPackageConstraint
  66   )
  67 import Distribution.Client.Types.SourcePackageDb as SourcePackageDb
  68 import Distribution.Solver.Types.PackageConstraint
  69   ( packageConstraintToDependency
  70   )
  71 import Distribution.Utils.Generic
  72   ( safeLast
  73   , wrapText
  74   )
  75
  76 import Distribution.Client.HttpUtils
  77 import qualified Distribution.Compat.CharParsing as P
  78 import Distribution.Package
  79   ( PackageName
  80   , packageVersion
  81   )
  82 import Distribution.PackageDescription
  83   ( allBuildDepends
  84   )
  85 import Distribution.PackageDescription.Configuration
  86   ( finalizePD
  87   )
  88 import Distribution.ReadE
  89   ( parsecToReadE
  90   )
  91 import Distribution.Simple.Command
  92   ( CommandUI (..)
  93   , OptionField
  94   , ShowOrParseArgs
  95   , liftOptionL
  96   , optArg
  97   , option
  98   , reqArg
  99   )
 100 import Distribution.Simple.Compiler
 101   ( Compiler
 102   , compilerInfo
 103   )
 104 import Distribution.Simple.Flag
 105   ( Flag (..)
 106   , flagToMaybe
 107   , fromFlagOrDefault
 108   , toFlag
 109   )
 110 import Distribution.Simple.PackageDescription
 111   ( readGenericPackageDescription
 112   )
 113 import Distribution.Simple.Setup
 114   ( optionVerbosity
 115   , trueArg
 116   )
 117 import Distribution.Simple.Utils
 118   ( debug
 119   , dieWithException
 120   , notice
 121   , tryFindPackageDesc
 122   )
 123 import Distribution.System
 124   ( Platform (..)
 125   )
 126 import Distribution.Types.ComponentRequestedSpec
 127   ( ComponentRequestedSpec (..)
 128   )
 129 import Distribution.Types.Dependency
 130   ( Dependency (..)
 131   )
 132 import Distribution.Types.DependencySatisfaction
 133   ( DependencySatisfaction (..)
 134   )
 135 import Distribution.Types.PackageVersionConstraint
 136   ( PackageVersionConstraint (..)
 137   , simplifyPackageVersionConstraint
 138   )
 139 import Distribution.Utils.NubList
 140   ( fromNubList
 141   )
 142 import Distribution.Verbosity
 143   ( normal
 144   , silent
 145   )
 146 import Distribution.Version
 147   ( LowerBound (..)
 148   , UpperBound (..)
 149   , Version
 150   , VersionInterval (..)
 151   , VersionRange
 152   , asVersionIntervals
 153   , majorBoundVersion
 154   )
 155
 156 import qualified Data.Set as S
 157 import Distribution.Client.Errors
 158 import Distribution.Utils.Path (relativeSymbolicPath)
 159 import System.Directory
 160   ( doesFileExist
 161   , getCurrentDirectory
 162   )
 163
 164 -------------------------------------------------------------------------------
 165 -- Command
 166 -------------------------------------------------------------------------------
 167
 168 outdatedCommand :: CommandUI (ProjectFlags, OutdatedFlags)
 169 outdatedCommand =
 170   CommandUI
 171     { commandName = "outdated"
 172     , commandSynopsis = "Check for outdated dependencies."
 173     , commandDescription = Just $ \_ ->
 174         wrapText $
 175           "Checks for outdated dependencies in the package description file "
 176             ++ "or freeze file"
 177     , commandNotes = Nothing
 178     , commandUsage = \pname ->
 179         "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n"
 180     , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags)
 181     , commandOptions = \showOrParseArgs ->
 182         map
 183           (liftOptionL _1)
 184           (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs))
 185           ++ map (liftOptionL _2) (outdatedOptions showOrParseArgs)
 186     }
 187
 188 -------------------------------------------------------------------------------
 189 -- Flags
 190 -------------------------------------------------------------------------------
 191
 192 data IgnoreMajorVersionBumps
 193   = IgnoreMajorVersionBumpsNone
 194   | IgnoreMajorVersionBumpsAll
 195   | IgnoreMajorVersionBumpsSome [PackageName]
 196
 197 instance Monoid IgnoreMajorVersionBumps where
 198   mempty = IgnoreMajorVersionBumpsNone
 199   mappend = (<>)
 200
 201 instance Semigroup IgnoreMajorVersionBumps where
 202   IgnoreMajorVersionBumpsNone <> r = r
 203   l@IgnoreMajorVersionBumpsAll <> _ = l
 204   l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l
 205   (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r
 206   (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) =
 207     IgnoreMajorVersionBumpsSome (a ++ b)
 208
 209 data OutdatedFlags = OutdatedFlags
 210   { outdatedVerbosity :: Flag Verbosity
 211   , outdatedFreezeFile :: Flag Bool
 212   , outdatedNewFreezeFile :: Flag Bool
 213   , outdatedSimpleOutput :: Flag Bool
 214   , outdatedExitCode :: Flag Bool
 215   , outdatedQuiet :: Flag Bool
 216   , outdatedIgnore :: [PackageName]
 217   , outdatedMinor :: Maybe IgnoreMajorVersionBumps
 218   }
 219
 220 defaultOutdatedFlags :: OutdatedFlags
 221 defaultOutdatedFlags =
 222   OutdatedFlags
 223     { outdatedVerbosity = toFlag normal
 224     , outdatedFreezeFile = mempty
 225     , outdatedNewFreezeFile = mempty
 226     , outdatedSimpleOutput = mempty
 227     , outdatedExitCode = mempty
 228     , outdatedQuiet = mempty
 229     , outdatedIgnore = mempty
 230     , outdatedMinor = mempty
 231     }
 232
 233 outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags]
 234 outdatedOptions _showOrParseArgs =
 235   [ optionVerbosity
 236       outdatedVerbosity
 237       (\v flags -> flags{outdatedVerbosity = v})
 238   , option
 239       []
 240       ["freeze-file", "v1-freeze-file"]
 241       "Act on the freeze file"
 242       outdatedFreezeFile
 243       (\v flags -> flags{outdatedFreezeFile = v})
 244       trueArg
 245   , option
 246       []
 247       ["v2-freeze-file", "new-freeze-file"]
 248       "Act on the new-style freeze file (default: cabal.project.freeze)"
 249       outdatedNewFreezeFile
 250       (\v flags -> flags{outdatedNewFreezeFile = v})
 251       trueArg
 252   , option
 253       []
 254       ["simple-output"]
 255       "Only print names of outdated dependencies, one per line"
 256       outdatedSimpleOutput
 257       (\v flags -> flags{outdatedSimpleOutput = v})
 258       trueArg
 259   , option
 260       []
 261       ["exit-code"]
 262       "Exit with non-zero when there are outdated dependencies"
 263       outdatedExitCode
 264       (\v flags -> flags{outdatedExitCode = v})
 265       trueArg
 266   , option
 267       ['q']
 268       ["quiet"]
 269       "Don't print any output. Implies '--exit-code' and '-v0'"
 270       outdatedQuiet
 271       (\v flags -> flags{outdatedQuiet = v})
 272       trueArg
 273   , option
 274       []
 275       ["ignore"]
 276       "Packages to ignore"
 277       outdatedIgnore
 278       (\v flags -> flags{outdatedIgnore = v})
 279       (reqArg "PKGS" pkgNameListParser (map prettyShow))
 280   , option
 281       []
 282       ["minor"]
 283       "Ignore major version bumps for these packages"
 284       outdatedMinor
 285       (\v flags -> flags{outdatedMinor = v})
 286       ( optArg
 287           "PKGS"
 288           ignoreMajorVersionBumpsParser
 289           ("", Just IgnoreMajorVersionBumpsAll)
 290           ignoreMajorVersionBumpsPrinter
 291       )
 292   ]
 293   where
 294     ignoreMajorVersionBumpsPrinter
 295       :: Maybe IgnoreMajorVersionBumps
 296       -> [Maybe String]
 297     ignoreMajorVersionBumpsPrinter Nothing = []
 298     ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone) = []
 299     ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]
 300     ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =
 301       map (Just . prettyShow) pkgs
 302
 303     ignoreMajorVersionBumpsParser =
 304       (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser
 305
 306     pkgNameListParser =
 307       parsecToReadE
 308         ("Couldn't parse the list of package names: " ++)
 309         (fmap toList (P.sepByNonEmpty parsec (P.char ',')))
 310
 311 -------------------------------------------------------------------------------
 312 -- Action
 313 -------------------------------------------------------------------------------
 314
 315 -- | Entry point for the 'outdated' command.
 316 outdatedAction :: (ProjectFlags, OutdatedFlags) -> [String] -> GlobalFlags -> IO ()
 317 outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..}) _targetStrings globalFlags = do
 318   config <- loadConfigOrSandboxConfig verbosity globalFlags
 319   let globalFlags' = savedGlobalFlags config `mappend` globalFlags
 320       configFlags = savedConfigureFlags config
 321   withRepoContext verbosity globalFlags' $ \repoContext -> do
 322     when (not newFreezeFile && (isJust mprojectDir || isJust mprojectFile)) $
 323       dieWithException verbosity OutdatedAction
 324
 325     sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
 326     (comp, platform, _progdb) <- configCompilerAux' configFlags
 327     deps <-
 328       if freezeFile
 329         then depsFromFreezeFile verbosity
 330         else
 331           if newFreezeFile
 332             then do
 333               httpTransport <-
 334                 configureTransport
 335                   verbosity
 336                   (fromNubList . globalProgPathExtra $ globalFlags)
 337                   (flagToMaybe . globalHttpTransport $ globalFlags)
 338               depsFromNewFreezeFile verbosity httpTransport comp platform mprojectDir mprojectFile
 339             else do
 340               depsFromPkgDesc verbosity comp platform
 341     debug verbosity $
 342       "Dependencies loaded: "
 343         ++ intercalate ", " (map prettyShow deps)
 344     let outdatedDeps =
 345           listOutdated
 346             deps
 347             sourcePkgDb
 348             (ListOutdatedSettings ignorePred minorPred)
 349     when (not quiet) $
 350       showResult verbosity outdatedDeps simpleOutput
 351     if exitCode && (not . null $ outdatedDeps)
 352       then exitFailure
 353       else return ()
 354   where
 355     verbosity =
 356       if quiet
 357         then silent
 358         else fromFlagOrDefault normal outdatedVerbosity
 359     freezeFile = fromFlagOrDefault False outdatedFreezeFile
 360     newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile
 361     mprojectDir = flagToMaybe flagProjectDir
 362     mprojectFile = flagToMaybe flagProjectFile
 363     simpleOutput = fromFlagOrDefault False outdatedSimpleOutput
 364     quiet = fromFlagOrDefault False outdatedQuiet
 365     exitCode = fromFlagOrDefault quiet outdatedExitCode
 366     ignorePred =
 367       let ignoreSet = S.fromList outdatedIgnore
 368        in \pkgname -> pkgname `S.member` ignoreSet
 369     minorPred = case outdatedMinor of
 370       Nothing -> const False
 371       Just IgnoreMajorVersionBumpsNone -> const False
 372       Just IgnoreMajorVersionBumpsAll -> const True
 373       Just (IgnoreMajorVersionBumpsSome pkgs) ->
 374         let minorSet = S.fromList pkgs
 375          in \pkgname -> pkgname `S.member` minorSet
 376
 377 -- | Print either the list of all outdated dependencies, or a message
 378 -- that there are none.
 379 showResult :: Verbosity -> [(PackageVersionConstraint, Version)] -> Bool -> IO ()
 380 showResult verbosity outdatedDeps simpleOutput =
 381   if not . null $ outdatedDeps
 382     then do
 383       when (not simpleOutput) $
 384         notice verbosity "Outdated dependencies:"
 385       for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->
 386         let outdatedDep =
 387               if simpleOutput
 388                 then prettyShow pn
 389                 else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"
 390          in notice verbosity outdatedDep
 391     else notice verbosity "All dependencies are up to date."
 392
 393 -- | Convert a list of 'UserConstraint's to a 'Dependency' list.
 394 userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint]
 395 userConstraintsToDependencies ucnstrs =
 396   mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs
 397
 398 -- | Read the list of dependencies from the freeze file.
 399 depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint]
 400 depsFromFreezeFile verbosity = do
 401   cwd <- getCurrentDirectory
 402   userConfig <- loadUserConfig verbosity cwd Nothing
 403   let ucnstrs =
 404         map fst . configExConstraints . savedConfigureExFlags $
 405           userConfig
 406       deps = userConstraintsToDependencies ucnstrs
 407   debug verbosity "Reading the list of dependencies from the freeze file"
 408   return deps
 409
 410 -- | Read the list of dependencies from the new-style freeze file.
 411 depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> Maybe FilePath -> IO [PackageVersionConstraint]
 412 depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectDir mprojectFile = do
 413   projectRoot <-
 414     either throwIO return
 415       =<< findProjectRoot verbosity mprojectDir mprojectFile
 416   let distDirLayout =
 417         defaultDistDirLayout
 418           projectRoot
 419           {- TODO: Support dist dir override -} Nothing
 420           Nothing
 421   projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do
 422     pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout
 423     pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs
 424   let ucnstrs =
 425         map fst . projectConfigConstraints . projectConfigShared $
 426           projectConfig
 427       deps = userConstraintsToDependencies ucnstrs
 428       freezeFile = distProjectFile distDirLayout "freeze"
 429   freezeFileExists <- doesFileExist freezeFile
 430
 431   unless freezeFileExists $
 432     dieWithException verbosity $
 433       FreezeFileExistsErr freezeFile
 434
 435   debug verbosity $
 436     "Reading the list of dependencies from the new-style freeze file " ++ freezeFile
 437   return deps
 438
 439 -- | Read the list of dependencies from the package description.
 440 depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint]
 441 depsFromPkgDesc verbosity comp platform = do
 442   path <- tryFindPackageDesc verbosity Nothing
 443   gpd <- readGenericPackageDescription verbosity Nothing (relativeSymbolicPath path)
 444   let cinfo = compilerInfo comp
 445       epd =
 446         finalizePD
 447           mempty
 448           (ComponentRequestedSpec True True)
 449           (const Satisfied)
 450           platform
 451           cinfo
 452           []
 453           gpd
 454   case epd of
 455     Left _ -> dieWithException verbosity FinalizePDFailed
 456     Right (pd, _) -> do
 457       let bd = allBuildDepends pd
 458       debug
 459         verbosity
 460         "Reading the list of dependencies from the package description"
 461       return $ map toPVC bd
 462   where
 463     toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr
 464
 465 -- | Various knobs for customising the behaviour of 'listOutdated'.
 466 data ListOutdatedSettings = ListOutdatedSettings
 467   { listOutdatedIgnorePred :: PackageName -> Bool
 468   -- ^ Should this package be ignored?
 469   , listOutdatedMinorPred :: PackageName -> Bool
 470   -- ^ Should major version bumps be ignored for this package?
 471   }
 472
 473 -- | Find all outdated dependencies.
 474 listOutdated
 475   :: [PackageVersionConstraint]
 476   -> SourcePackageDb
 477   -> ListOutdatedSettings
 478   -> [(PackageVersionConstraint, Version)]
 479 listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) =
 480   mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps
 481   where
 482     isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version)
 483     isOutdated dep@(PackageVersionConstraint pname vr)
 484       | ignorePred pname = Nothing
 485       | otherwise =
 486           let this = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr
 487               latest = lookupLatest dep
 488            in (\v -> (dep, v)) `fmap` isOutdated' this latest
 489
 490     isOutdated' :: [Version] -> [Version] -> Maybe Version
 491     isOutdated' [] _ = Nothing
 492     isOutdated' _ [] = Nothing
 493     isOutdated' this latest =
 494       let this' = maximum this
 495           latest' = maximum latest
 496        in if this' < latest' then Just latest' else Nothing
 497
 498     lookupLatest :: PackageVersionConstraint -> [Version]
 499     lookupLatest (PackageVersionConstraint pname vr)
 500       | minorPred pname =
 501           map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname (relaxMinor vr)
 502       | otherwise =
 503           map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname
 504
 505     relaxMinor :: VersionRange -> VersionRange
 506     relaxMinor vr =
 507       let vis = asVersionIntervals vr
 508        in maybe vr relax (safeLast vis)
 509       where
 510         relax (VersionInterval (LowerBound v0 _) upper) =
 511           case upper of
 512             NoUpperBound -> vr
 513             UpperBound _v1 _ -> majorBoundVersion v0