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

   1 ------------------------------------------------------------------------------- |
   2 -- Module      :  Distribution.Client.Fetch
   3 -- Copyright   :  (c) David Himmelstrup 2005
   4 --                    Duncan Coutts 2011
   5 -- License     :  BSD-like
   6 --
   7 -- Maintainer  :  cabal-devel@gmail.com
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- The cabal fetch command
  12 -----------------------------------------------------------------------------
  13 module Distribution.Client.Fetch
  14   ( fetch
  15   ) where
  16
  17 import Distribution.Client.Compat.Prelude
  18 import Prelude ()
  19
  20 import Distribution.Client.Dependency
  21 import Distribution.Client.FetchUtils hiding (fetchPackage)
  22 import Distribution.Client.IndexUtils as IndexUtils
  23   ( getInstalledPackages
  24   , getSourcePackages
  25   )
  26 import Distribution.Client.Setup
  27   ( FetchFlags (..)
  28   , GlobalFlags (..)
  29   , RepoContext (..)
  30   )
  31 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
  32 import Distribution.Client.Targets
  33 import Distribution.Client.Types
  34
  35 import Distribution.Solver.Types.ConstraintSource
  36 import Distribution.Solver.Types.LabeledPackageConstraint
  37 import Distribution.Solver.Types.OptionalStanza
  38 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb)
  39 import Distribution.Solver.Types.SolverPackage
  40 import Distribution.Solver.Types.SourcePackage
  41
  42 import Distribution.Client.Errors
  43 import Distribution.Package
  44   ( packageId
  45   )
  46 import Distribution.Simple.Compiler
  47   ( Compiler
  48   , PackageDBStack
  49   , compilerInfo
  50   )
  51 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
  52 import Distribution.Simple.Program
  53   ( ProgramDb
  54   )
  55 import Distribution.Simple.Setup
  56   ( fromFlag
  57   , fromFlagOrDefault
  58   )
  59 import Distribution.Simple.Utils
  60   ( debug
  61   , dieWithException
  62   , notice
  63   )
  64 import Distribution.System
  65   ( Platform
  66   )
  67
  68 -- ------------------------------------------------------------
  69
  70 -- * The fetch command
  71
  72 -- ------------------------------------------------------------
  73
  74 -- TODO:
  75
  76 -- * add fetch -o support
  77
  78 -- * support tarball URLs via ad-hoc download cache (or in -o mode?)
  79
  80 -- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied
  81
  82 -- * Port various flags from install:
  83
  84 --   * --upgrade-dependencies
  85 --   * --constraint and --preference
  86 --   * --only-dependencies, but note it conflicts with --no-deps
  87
  88 -- | Fetch a list of packages and their dependencies.
  89 fetch
  90   :: Verbosity
  91   -> PackageDBStack
  92   -> RepoContext
  93   -> Compiler
  94   -> Platform
  95   -> ProgramDb
  96   -> GlobalFlags
  97   -> FetchFlags
  98   -> [UserTarget]
  99   -> IO ()
 100 fetch verbosity _ _ _ _ _ _ _ [] =
 101   notice verbosity "No packages requested. Nothing to do."
 102 fetch
 103   verbosity
 104   packageDBs
 105   repoCtxt
 106   comp
 107   platform
 108   progdb
 109   _
 110   fetchFlags
 111   userTargets = do
 112     traverse_ (checkTarget verbosity) userTargets
 113
 114     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
 115     sourcePkgDb <- getSourcePackages verbosity repoCtxt
 116     pkgConfigDb <- readPkgConfigDb verbosity progdb
 117
 118     pkgSpecifiers <-
 119       resolveUserTargets
 120         verbosity
 121         repoCtxt
 122         (packageIndex sourcePkgDb)
 123         userTargets
 124
 125     pkgs <-
 126       planPackages
 127         verbosity
 128         comp
 129         platform
 130         fetchFlags
 131         installedPkgIndex
 132         sourcePkgDb
 133         pkgConfigDb
 134         pkgSpecifiers
 135
 136     pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs
 137     if null pkgs'
 138       then -- TODO: when we add support for remote tarballs then this message
 139       -- will need to be changed because for remote tarballs we fetch them
 140       -- at the earlier phase.
 141
 142         notice verbosity $
 143           "No packages need to be fetched. "
 144             ++ "All the requested packages are already local "
 145             ++ "or cached locally."
 146       else
 147         if dryRun
 148           then
 149             notice verbosity $
 150               unlines $
 151                 "The following packages would be fetched:"
 152                   : map (prettyShow . packageId) pkgs'
 153           else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs'
 154     where
 155       dryRun = fromFlag (fetchDryRun fetchFlags)
 156
 157 planPackages
 158   :: Verbosity
 159   -> Compiler
 160   -> Platform
 161   -> FetchFlags
 162   -> InstalledPackageIndex
 163   -> SourcePackageDb
 164   -> PkgConfigDb
 165   -> [PackageSpecifier UnresolvedSourcePackage]
 166   -> IO [UnresolvedSourcePackage]
 167 planPackages
 168   verbosity
 169   comp
 170   platform
 171   fetchFlags
 172   installedPkgIndex
 173   sourcePkgDb
 174   pkgConfigDb
 175   pkgSpecifiers
 176     | includeDependencies = do
 177         notice verbosity "Resolving dependencies..."
 178         installPlan <-
 179           foldProgress logMsg (dieWithException verbosity . PlanPackages . show) return $
 180             resolveDependencies
 181               platform
 182               (compilerInfo comp)
 183               pkgConfigDb
 184               resolverParams
 185
 186         -- The packages we want to fetch are those packages the 'InstallPlan'
 187         -- that are in the 'InstallPlan.Configured' state.
 188         return
 189           [ solverPkgSource cpkg
 190           | (SolverInstallPlan.Configured cpkg) <-
 191               SolverInstallPlan.toList installPlan
 192           ]
 193     | otherwise =
 194         either (dieWithException verbosity . PlanPackages . unlines . map show) return $
 195           resolveWithoutDependencies resolverParams
 196     where
 197       resolverParams :: DepResolverParams
 198       resolverParams =
 199         setMaxBackjumps
 200           ( if maxBackjumps < 0
 201               then Nothing
 202               else Just maxBackjumps
 203           )
 204           . setIndependentGoals independentGoals
 205           . setReorderGoals reorderGoals
 206           . setCountConflicts countConflicts
 207           . setFineGrainedConflicts fineGrainedConflicts
 208           . setMinimizeConflictSet minimizeConflictSet
 209           . setShadowPkgs shadowPkgs
 210           . setStrongFlags strongFlags
 211           . setAllowBootLibInstalls allowBootLibInstalls
 212           . setOnlyConstrained onlyConstrained
 213           . setSolverVerbosity verbosity
 214           . addConstraints
 215             [ let pc =
 216                     PackageConstraint
 217                       (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
 218                       (PackagePropertyStanzas stanzas)
 219                in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
 220             | pkgSpecifier <- pkgSpecifiers
 221             ]
 222           -- Reinstall the targets given on the command line so that the dep
 223           -- resolver will decide that they need fetching, even if they're
 224           -- already installed. Since we want to get the source packages of
 225           -- things we might have installed (but not have the sources for).
 226           . reinstallTargets
 227           $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
 228
 229       includeDependencies = fromFlag (fetchDeps fetchFlags)
 230       logMsg message rest = debug verbosity message >> rest
 231
 232       stanzas =
 233         [TestStanzas | testsEnabled]
 234           ++ [BenchStanzas | benchmarksEnabled]
 235       testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags
 236       benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags
 237
 238       reorderGoals = fromFlag (fetchReorderGoals fetchFlags)
 239       countConflicts = fromFlag (fetchCountConflicts fetchFlags)
 240       fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags)
 241       minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags)
 242       independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
 243       shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)
 244       strongFlags = fromFlag (fetchStrongFlags fetchFlags)
 245       maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags)
 246       allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags)
 247       onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags)
 248
 249 checkTarget :: Verbosity -> UserTarget -> IO ()
 250 checkTarget verbosity target = case target of
 251   UserTargetRemoteTarball _uri ->
 252     dieWithException verbosity CheckTarget
 253   _ -> return ()
 254
 255 fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()
 256 fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of
 257   LocalUnpackedPackage _dir -> return ()
 258   LocalTarballPackage _file -> return ()
 259   RemoteTarballPackage _uri _ ->
 260     dieWithException verbosity CheckTarget
 261   RemoteSourceRepoPackage _repo _ ->
 262     dieWithException verbosity FetchPackage
 263   RepoTarballPackage repo pkgid _ -> do
 264     _ <- fetchRepoTarball verbosity repoCtxt repo pkgid
 265     return ()