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