1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
-----------------------------------------------------------------------------
-- |
-- 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.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.InstallPlan as InstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FetchFlags(..) )
import Distribution.Package
( packageId )
import Distribution.Simple.Compiler
( Compiler(compilerId), PackageDBStack )
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag )
import Distribution.Simple.Utils
( die, notice, debug )
import Distribution.System
( Platform )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import Control.Monad
( filterM )
-- ------------------------------------------------------------
-- * 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:
-- * --updage-dependencies
-- * --constraint and --preference
-- * --only-dependencies, but note it conflicts with --no-deps
-- | Fetch a list of packages and their dependencies.
--
fetch :: Verbosity
-> PackageDBStack
-> [Repo]
-> Compiler
-> Platform
-> ProgramConfiguration
-> GlobalFlags
-> FetchFlags
-> [UserTarget]
-> IO ()
fetch verbosity _ _ _ _ _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
fetch verbosity packageDBs repos comp platform conf
globalFlags fetchFlags userTargets = do
mapM_ checkTarget userTargets
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
pkgSpecifiers <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
pkgs <- planPackages
verbosity comp platform fetchFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs
if null 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 notice verbosity $ "No packages need to be fetched. "
++ "All the requested packages are already local "
++ "or cached locally."
else if dryRun
then notice verbosity $ unlines $
"The following packages would be fetched:"
: map (display . packageId) pkgs'
else mapM_ (fetchPackage verbosity . packageSource) pkgs'
where
dryRun = fromFlag (fetchDryRun fetchFlags)
planPackages :: Verbosity
-> Compiler
-> Platform
-> FetchFlags
-> PackageIndex
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> IO [SourcePackage]
planPackages verbosity comp platform fetchFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
| includeDependencies = do
solver <- chooseSolver verbosity
(fromFlag (fetchSolver fetchFlags)) (compilerId comp)
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
resolveDependencies
platform (compilerId comp)
solver
resolverParams
-- The packages we want to fetch are those packages the 'InstallPlan'
-- that are in the 'InstallPlan.Configured' state.
return
[ pkg
| (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _ _))
<- InstallPlan.toList installPlan ]
| otherwise =
either (die . unlines . map show) return $
resolveWithoutDependencies resolverParams
where
resolverParams =
setMaxBackjumps (if maxBackjumps < 0 then Nothing
else Just maxBackjumps)
. setIndependentGoals independentGoals
. setReorderGoals reorderGoals
. setShadowPkgs shadowPkgs
. setStrongFlags strongFlags
-- 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).
. reinstallTargets
$ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
includeDependencies = fromFlag (fetchDeps fetchFlags)
logMsg message rest = debug verbosity message >> rest
reorderGoals = fromFlag (fetchReorderGoals fetchFlags)
independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)
strongFlags = fromFlag (fetchStrongFlags fetchFlags)
maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags)
checkTarget :: UserTarget -> IO ()
checkTarget target = case target of
UserTargetRemoteTarball _uri
-> die $ "The 'fetch' command does not yet support remote tarballs. "
++ "In the meantime you can use the 'unpack' commands."
_ -> return ()
fetchPackage :: Verbosity -> PackageLocation a -> IO ()
fetchPackage verbosity pkgsrc = case pkgsrc of
LocalUnpackedPackage _dir -> return ()
LocalTarballPackage _file -> return ()
RemoteTarballPackage _uri _ ->
die $ "The 'fetch' command does not yet support remote tarballs. "
++ "In the meantime you can use the 'unpack' commands."
RepoTarballPackage repo pkgid _ -> do
_ <- fetchRepoTarball verbosity repo pkgid
return ()
|
