------------------------------------------------------------------------------- |
-- Module      :  Distribution.Client.Fetch
-- Copyright   :  (c) David Himmelstrup 2005
--                    Duncan Coutts 2011
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- The cabal fetch command
-----------------------------------------------------------------------------
module Distribution.Client.Fetch (
    fetch,
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.FetchUtils hiding (fetchPackage)
import Distribution.Client.Dependency
import Distribution.Client.IndexUtils as IndexUtils
         ( getSourcePackages, getInstalledPackages )
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Setup
         ( GlobalFlags(..), FetchFlags(..), RepoContext(..) )

import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb )
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage

import Distribution.Package
         ( packageId )
import Distribution.Simple.Compiler
         ( Compiler, compilerInfo, PackageDBStack )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
         ( ProgramDb )
import Distribution.Simple.Setup
         ( fromFlag, fromFlagOrDefault )
import Distribution.Simple.Utils
         ( die', notice, debug )
import Distribution.System
         ( Platform )

-- ------------------------------------------------------------
-- * The fetch command
-- ------------------------------------------------------------

--TODO:
-- * add fetch -o support
-- * support tarball URLs via ad-hoc download cache (or in -o mode?)
-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied
-- * Port various flags from install:
--   * --upgrade-dependencies
--   * --constraint and --preference
--   * --only-dependencies, but note it conflicts with --no-deps


-- | Fetch a list of packages and their dependencies.
--
fetch :: Verbosity
      -> PackageDBStack
      -> RepoContext
      -> Compiler
      -> Platform
      -> ProgramDb
      -> GlobalFlags
      -> FetchFlags
      -> [UserTarget]
      -> IO ()
fetch :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FetchFlags
-> [UserTarget]
-> IO ()
fetch Verbosity
verbosity PackageDBStack
_ RepoContext
_ Compiler
_ Platform
_ ProgramDb
_ GlobalFlags
_ FetchFlags
_ [] =
    Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"No packages requested. Nothing to do."

fetch Verbosity
verbosity PackageDBStack
packageDBs RepoContext
repoCtxt Compiler
comp Platform
platform ProgramDb
progdb
      GlobalFlags
_ FetchFlags
fetchFlags [UserTarget]
userTargets = do

    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> UserTarget -> IO ()
checkTarget Verbosity
verbosity) [UserTarget]
userTargets

    InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
packageDBs ProgramDb
progdb
    SourcePackageDb
sourcePkgDb       <- Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages    Verbosity
verbosity RepoContext
repoCtxt
    PkgConfigDb
pkgConfigDb       <- Verbosity -> ProgramDb -> IO PkgConfigDb
readPkgConfigDb      Verbosity
verbosity ProgramDb
progdb

    [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers <- forall pkg.
Package pkg =>
Verbosity
-> RepoContext
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets Verbosity
verbosity RepoContext
repoCtxt
                       (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb)
                       [UserTarget]
userTargets

    [UnresolvedSourcePackage]
pkgs  <- Verbosity
-> Compiler
-> Platform
-> FetchFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [UnresolvedSourcePackage]
planPackages
               Verbosity
verbosity Compiler
comp Platform
platform FetchFlags
fetchFlags
               InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers

    [UnresolvedSourcePackage]
pkgs' <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedPkgLoc -> IO Bool
isFetched forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. SourcePackage loc -> loc
srcpkgSource) [UnresolvedSourcePackage]
pkgs
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnresolvedSourcePackage]
pkgs'
      --TODO: when we add support for remote tarballs then this message
      -- will need to be changed because for remote tarballs we fetch them
      -- at the earlier phase.
      then Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"No packages need to be fetched. "
                           forall a. [a] -> [a] -> [a]
++ String
"All the requested packages are already local "
                           forall a. [a] -> [a] -> [a]
++ String
"or cached locally."
      else if Bool
dryRun
             then Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
                     String
"The following packages would be fetched:"
                   forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) [UnresolvedSourcePackage]
pkgs'

             else forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a. Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage Verbosity
verbosity RepoContext
repoCtxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. SourcePackage loc -> loc
srcpkgSource) [UnresolvedSourcePackage]
pkgs'

  where
    dryRun :: Bool
dryRun = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag Bool
fetchDryRun FetchFlags
fetchFlags)

planPackages :: Verbosity
             -> Compiler
             -> Platform
             -> FetchFlags
             -> InstalledPackageIndex
             -> SourcePackageDb
             -> PkgConfigDb
             -> [PackageSpecifier UnresolvedSourcePackage]
             -> IO [UnresolvedSourcePackage]
planPackages :: Verbosity
-> Compiler
-> Platform
-> FetchFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [UnresolvedSourcePackage]
planPackages Verbosity
verbosity Compiler
comp Platform
platform FetchFlags
fetchFlags
             InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers

  | Bool
includeDependencies = do
      Solver
solver <- Verbosity -> PreSolver -> CompilerInfo -> IO Solver
chooseSolver Verbosity
verbosity
                (forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag PreSolver
fetchSolver FetchFlags
fetchFlags)) (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
      Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Resolving dependencies..."
      SolverInstallPlan
installPlan <- forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress forall {b}. String -> IO b -> IO b
logMsg (forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                       Platform
-> CompilerInfo
-> PkgConfigDb
-> Solver
-> DepResolverParams
-> Progress String String SolverInstallPlan
resolveDependencies
                         Platform
platform (Compiler -> CompilerInfo
compilerInfo Compiler
comp) PkgConfigDb
pkgConfigDb
                         Solver
solver
                         DepResolverParams
resolverParams

      -- The packages we want to fetch are those packages the 'InstallPlan'
      -- that are in the 'InstallPlan.Configured' state.
      forall (m :: * -> *) a. Monad m => a -> m a
return
        [ forall loc. SolverPackage loc -> SourcePackage loc
solverPkgSource SolverPackage UnresolvedPkgLoc
cpkg
        | (SolverInstallPlan.Configured SolverPackage UnresolvedPkgLoc
cpkg)
            <- SolverInstallPlan -> [ResolverPackage UnresolvedPkgLoc]
SolverInstallPlan.toList SolverInstallPlan
installPlan ]

  | Bool
otherwise =
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        DepResolverParams
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
resolveWithoutDependencies DepResolverParams
resolverParams

  where
    resolverParams :: DepResolverParams
    resolverParams :: DepResolverParams
resolverParams =

        Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps (if Int
maxBackjumps forall a. Ord a => a -> a -> Bool
< Int
0 then forall a. Maybe a
Nothing
                                             else forall a. a -> Maybe a
Just Int
maxBackjumps)

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals IndependentGoals
independentGoals

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals ReorderGoals
reorderGoals

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts CountConflicts
countConflicts

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts FineGrainedConflicts
fineGrainedConflicts

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet MinimizeConflictSet
minimizeConflictSet

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs ShadowPkgs
shadowPkgs

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags StrongFlags
strongFlags

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls AllowBootLibInstalls
allowBootLibInstalls

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained OnlyConstrained
onlyConstrained

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity Verbosity
verbosity

      forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
          [ let pc :: PackageConstraint
pc = ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint
                     (PackageName -> ConstraintScope
scopeToplevel forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier UnresolvedSourcePackage
pkgSpecifier)
                     ([OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza]
stanzas)
            in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceConfigFlagOrTarget
          | PackageSpecifier UnresolvedSourcePackage
pkgSpecifier <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers ]

        -- Reinstall the targets given on the command line so that the dep
        -- resolver will decide that they need fetching, even if they're
        -- already installed. Since we want to get the source packages of
        -- things we might have installed (but not have the sources for).
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepResolverParams -> DepResolverParams
reinstallTargets

      forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers

    includeDependencies :: Bool
includeDependencies = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag Bool
fetchDeps FetchFlags
fetchFlags)
    logMsg :: String -> IO b -> IO b
logMsg String
message IO b
rest = Verbosity -> String -> IO ()
debug Verbosity
verbosity String
message forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
rest

    stanzas :: [OptionalStanza]
stanzas           = [ OptionalStanza
TestStanzas | Bool
testsEnabled ]
                     forall a. [a] -> [a] -> [a]
++ [ OptionalStanza
BenchStanzas | Bool
benchmarksEnabled ]
    testsEnabled :: Bool
testsEnabled      = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ FetchFlags -> Flag Bool
fetchTests FetchFlags
fetchFlags
    benchmarksEnabled :: Bool
benchmarksEnabled = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ FetchFlags -> Flag Bool
fetchBenchmarks FetchFlags
fetchFlags

    reorderGoals :: ReorderGoals
reorderGoals     = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag ReorderGoals
fetchReorderGoals     FetchFlags
fetchFlags)
    countConflicts :: CountConflicts
countConflicts   = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag CountConflicts
fetchCountConflicts   FetchFlags
fetchFlags)
    fineGrainedConflicts :: FineGrainedConflicts
fineGrainedConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag FineGrainedConflicts
fetchFineGrainedConflicts FetchFlags
fetchFlags)
    minimizeConflictSet :: MinimizeConflictSet
minimizeConflictSet = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag MinimizeConflictSet
fetchMinimizeConflictSet FetchFlags
fetchFlags)
    independentGoals :: IndependentGoals
independentGoals = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag IndependentGoals
fetchIndependentGoals FetchFlags
fetchFlags)
    shadowPkgs :: ShadowPkgs
shadowPkgs       = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag ShadowPkgs
fetchShadowPkgs       FetchFlags
fetchFlags)
    strongFlags :: StrongFlags
strongFlags      = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag StrongFlags
fetchStrongFlags      FetchFlags
fetchFlags)
    maxBackjumps :: Int
maxBackjumps     = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag Int
fetchMaxBackjumps     FetchFlags
fetchFlags)
    allowBootLibInstalls :: AllowBootLibInstalls
allowBootLibInstalls = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag AllowBootLibInstalls
fetchAllowBootLibInstalls FetchFlags
fetchFlags)
    onlyConstrained :: OnlyConstrained
onlyConstrained  = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag OnlyConstrained
fetchOnlyConstrained  FetchFlags
fetchFlags)


checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget Verbosity
verbosity UserTarget
target = case UserTarget
target of
    UserTargetRemoteTarball URI
_uri
      -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The 'fetch' command does not yet support remote tarballs. "
            forall a. [a] -> [a] -> [a]
++ String
"In the meantime you can use the 'unpack' commands."
    UserTarget
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage :: forall a. Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage Verbosity
verbosity RepoContext
repoCtxt PackageLocation a
pkgsrc = case PackageLocation a
pkgsrc of
    LocalUnpackedPackage String
_dir  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    LocalTarballPackage  String
_file -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    RemoteTarballPackage URI
_uri a
_ ->
      forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The 'fetch' command does not yet support remote tarballs. "
         forall a. [a] -> [a] -> [a]
++ String
"In the meantime you can use the 'unpack' commands."

    RemoteSourceRepoPackage SourceRepoMaybe
_repo a
_ ->
      forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The 'fetch' command does not yet support remote "
         forall a. [a] -> [a] -> [a]
++ String
"source repositories."

    RepoTarballPackage Repo
repo PackageIdentifier
pkgid a
_ -> do
      String
_ <- Verbosity -> RepoContext -> Repo -> PackageIdentifier -> IO String
fetchRepoTarball Verbosity
verbosity RepoContext
repoCtxt Repo
repo PackageIdentifier
pkgid
      forall (m :: * -> *) a. Monad m => a -> m a
return ()