never executed always true always false
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : Distribution.Client.Get
4 -- Copyright : (c) Andrea Vezzosi 2008
5 -- Duncan Coutts 2011
6 -- John Millikin 2012
7 -- License : BSD-like
8 --
9 -- Maintainer : cabal-devel@haskell.org
10 -- Stability : provisional
11 -- Portability : portable
12 --
13 -- The 'cabal get' command.
14 -----------------------------------------------------------------------------
15
16 module Distribution.Client.Get (
17 get,
18
19 -- * Cloning 'SourceRepo's
20 -- | Mainly exported for testing purposes
21 clonePackagesFromSourceRepo,
22 ClonePackageException(..),
23 ) where
24
25 import Prelude ()
26 import Distribution.Client.Compat.Prelude hiding (get)
27 import Distribution.Compat.Directory
28 ( listDirectory )
29 import Distribution.Package
30 ( PackageId, packageId, packageName )
31 import Distribution.Simple.Setup
32 ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
33 import Distribution.Simple.Utils
34 ( notice, die', info, writeFileAtomic )
35 import qualified Distribution.PackageDescription as PD
36 import Distribution.Simple.Program
37 ( programName )
38 import Distribution.Types.SourceRepo (RepoKind (..))
39 import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)
40
41 import Distribution.Client.Setup
42 ( GlobalFlags(..), GetFlags(..), RepoContext(..) )
43 import Distribution.Client.Types
44 import Distribution.Client.Targets
45 import Distribution.Client.Dependency
46 import Distribution.Client.VCS
47 import Distribution.Client.FetchUtils
48 import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
49 import Distribution.Client.IndexUtils
50 ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos )
51 import Distribution.Solver.Types.SourcePackage
52
53 import qualified Data.Map as Map
54 import System.Directory
55 ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )
56 import System.FilePath
57 ( (</>), (<.>), addTrailingPathSeparator )
58
59
60 -- | Entry point for the 'cabal get' command.
61 get :: Verbosity
62 -> RepoContext
63 -> GlobalFlags
64 -> GetFlags
65 -> [UserTarget]
66 -> IO ()
67 get verbosity _ _ _ [] =
68 notice verbosity "No packages requested. Nothing to do."
69
70 get verbosity repoCtxt globalFlags getFlags userTargets = do
71 let useSourceRepo = case getSourceRepository getFlags of
72 NoFlag -> False
73 _ -> True
74
75 unless useSourceRepo $
76 traverse_ (checkTarget verbosity) userTargets
77
78 let idxState :: Maybe TotalIndexState
79 idxState = flagToMaybe $ getIndexState getFlags
80
81 activeRepos :: Maybe ActiveRepos
82 activeRepos = flagToMaybe $ getActiveRepos getFlags
83
84 (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
85
86 pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
87 (fromFlag $ globalWorldFile globalFlags)
88 (packageIndex sourcePkgDb)
89 userTargets
90
91 pkgs <- either (die' verbosity . unlines . map show) return $
92 resolveWithoutDependencies
93 (resolverParams sourcePkgDb pkgSpecifiers)
94
95 unless (null prefix) $
96 createDirectoryIfMissing True prefix
97
98 if useSourceRepo
99 then clone pkgs
100 else unpack pkgs
101
102 where
103 resolverParams sourcePkgDb pkgSpecifiers =
104 --TODO: add command-line constraint and preference args for unpack
105 standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
106
107 prefix = fromFlagOrDefault "" (getDestDir getFlags)
108
109 clone :: [UnresolvedSourcePackage] -> IO ()
110 clone = clonePackagesFromSourceRepo verbosity prefix kind
111 . map (\pkg -> (packageId pkg, packageSourceRepos pkg))
112 where
113 kind = fromFlag . getSourceRepository $ getFlags
114 packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]
115 packageSourceRepos = PD.sourceRepos
116 . PD.packageDescription
117 . srcpkgDescription
118
119 unpack :: [UnresolvedSourcePackage] -> IO ()
120 unpack pkgs = do
121 for_ pkgs $ \pkg -> do
122 location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg)
123 let pkgid = packageId pkg
124 descOverride | usePristine = Nothing
125 | otherwise = srcpkgDescrOverride pkg
126 case location of
127 LocalTarballPackage tarballPath ->
128 unpackPackage verbosity prefix pkgid descOverride tarballPath
129
130 RemoteTarballPackage _tarballURL tarballPath ->
131 unpackPackage verbosity prefix pkgid descOverride tarballPath
132
133 RepoTarballPackage _repo _pkgid tarballPath ->
134 unpackPackage verbosity prefix pkgid descOverride tarballPath
135
136 RemoteSourceRepoPackage _repo _ ->
137 die' verbosity $ "The 'get' command does no yet support targets "
138 ++ "that are remote source repositories."
139
140 LocalUnpackedPackage _ ->
141 error "Distribution.Client.Get.unpack: the impossible happened."
142 where
143 usePristine = fromFlagOrDefault False (getPristine getFlags)
144
145 checkTarget :: Verbosity -> UserTarget -> IO ()
146 checkTarget verbosity target = case target of
147 UserTargetLocalDir dir -> die' verbosity (notTarball dir)
148 UserTargetLocalCabalFile file -> die' verbosity (notTarball file)
149 _ -> return ()
150 where
151 notTarball t =
152 "The 'get' command is for tarball packages. "
153 ++ "The target '" ++ t ++ "' is not a tarball."
154
155 -- ------------------------------------------------------------
156 -- * Unpacking the source tarball
157 -- ------------------------------------------------------------
158
159 unpackPackage :: Verbosity -> FilePath -> PackageId
160 -> PackageDescriptionOverride
161 -> FilePath -> IO ()
162 unpackPackage verbosity prefix pkgid descOverride pkgPath = do
163 let pkgdirname = prettyShow pkgid
164 pkgdir = prefix </> pkgdirname
165 pkgdir' = addTrailingPathSeparator pkgdir
166 emptyDirectory directory = null <$> listDirectory directory
167 existsDir <- doesDirectoryExist pkgdir
168 when existsDir $ do
169 isEmpty <- emptyDirectory pkgdir
170 unless isEmpty $
171 die' verbosity $
172 "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking."
173 existsFile <- doesFileExist pkgdir
174 when existsFile $ die' verbosity $
175 "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."
176 notice verbosity $ "Unpacking to " ++ pkgdir'
177 Tar.extractTarGzFile prefix pkgdirname pkgPath
178
179 case descOverride of
180 Nothing -> return ()
181 Just pkgtxt -> do
182 let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"
183 info verbosity $
184 "Updating " ++ descFilePath
185 ++ " with the latest revision from the index."
186 writeFileAtomic descFilePath pkgtxt
187
188
189 -- ------------------------------------------------------------
190 -- * Cloning packages from their declared source repositories
191 -- ------------------------------------------------------------
192
193
194 data ClonePackageException =
195 ClonePackageNoSourceRepos PackageId
196 | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
197 | ClonePackageNoRepoType PackageId PD.SourceRepo
198 | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType
199 | ClonePackageNoRepoLocation PackageId PD.SourceRepo
200 | ClonePackageDestinationExists PackageId FilePath Bool
201 | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode
202 deriving (Show, Eq)
203
204 instance Exception ClonePackageException where
205 displayException (ClonePackageNoSourceRepos pkgid) =
206 "Cannot fetch a source repository for package " ++ prettyShow pkgid
207 ++ ". The package does not specify any source repositories."
208
209 displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =
210 "Cannot fetch a source repository for package " ++ prettyShow pkgid
211 ++ ". The package does not specify a source repository of the requested "
212 ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind
213
214 displayException (ClonePackageNoRepoType pkgid _repo) =
215 "Cannot fetch the source repository for package " ++ prettyShow pkgid
216 ++ ". The package's description specifies a source repository but does "
217 ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
218
219 displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =
220 "Cannot fetch the source repository for package " ++ prettyShow pkgid
221 ++ ". The repository type '" ++ prettyShow repoType
222 ++ "' is not yet supported."
223
224 displayException (ClonePackageNoRepoLocation pkgid _repo) =
225 "Cannot fetch the source repository for package " ++ prettyShow pkgid
226 ++ ". The package's description specifies a source repository but does "
227 ++ "not specify the repository 'location' field (i.e. the URL)."
228
229 displayException (ClonePackageDestinationExists pkgid dest isdir) =
230 "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". "
231 ++ if isdir then "The destination directory " ++ dest ++ " already exists."
232 else "A file " ++ dest ++ " is in the way."
233
234 displayException (ClonePackageFailedWithExitCode
235 pkgid repo vcsprogname exitcode) =
236 "Failed to fetch the source repository for package " ++ prettyShow pkgid
237 ++ ", repository location " ++ srpLocation repo ++ " ("
238 ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
239
240
241 -- | Given a bunch of package ids and their corresponding available
242 -- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into
243 -- new subdirs of the given directory.
244 --
245 clonePackagesFromSourceRepo :: Verbosity
246 -> FilePath -- ^ destination dir prefix
247 -> Maybe RepoKind -- ^ preferred 'RepoKind'
248 -> [(PackageId, [PD.SourceRepo])]
249 -- ^ the packages and their
250 -- available 'SourceRepo's
251 -> IO ()
252 clonePackagesFromSourceRepo verbosity destDirPrefix
253 preferredRepoKind pkgrepos = do
254
255 -- Do a bunch of checks and collect the required info
256 pkgrepos' <- traverse preCloneChecks pkgrepos
257
258 -- Configure the VCS drivers for all the repository types we may need
259 vcss <- configureVCSs verbosity $
260 Map.fromList [ (vcsRepoType vcs, vcs)
261 | (_, _, vcs, _) <- pkgrepos' ]
262
263 -- Now execute all the required commands for each repo
264 sequence_
265 [ cloneSourceRepo verbosity vcs' repo destDir
266 `catch` \exitcode ->
267 throwIO (ClonePackageFailedWithExitCode
268 pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode)
269 | (pkgid, repo, vcs, destDir) <- pkgrepos'
270 , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss
271 ]
272
273 where
274 preCloneChecks :: (PackageId, [PD.SourceRepo])
275 -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)
276 preCloneChecks (pkgid, repos) = do
277 repo <- case selectPackageSourceRepo preferredRepoKind repos of
278 Just repo -> return repo
279 Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)
280 Nothing -> throwIO (ClonePackageNoSourceReposOfKind
281 pkgid preferredRepoKind)
282
283 (repo', vcs) <- case validatePDSourceRepo repo of
284 Right (repo', _, _, vcs) -> return (repo', vcs)
285 Left SourceRepoRepoTypeUnspecified ->
286 throwIO (ClonePackageNoRepoType pkgid repo)
287
288 Left (SourceRepoRepoTypeUnsupported repo' repoType) ->
289 throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)
290
291 Left SourceRepoLocationUnspecified ->
292 throwIO (ClonePackageNoRepoLocation pkgid repo)
293
294 let destDir = destDirPrefix </> prettyShow (packageName pkgid)
295 destDirExists <- doesDirectoryExist destDir
296 destFileExists <- doesFileExist destDir
297 when (destDirExists || destFileExists) $
298 throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)
299
300 return (pkgid, repo', vcs, destDir)
301
302 -------------------------------------------------------------------------------
303 -- Selecting
304 -------------------------------------------------------------------------------
305
306 -- | Pick the 'SourceRepo' to use to get the package sources from.
307 --
308 -- Note that this does /not/ depend on what 'VCS' drivers we are able to
309 -- successfully configure. It is based only on the 'SourceRepo's declared
310 -- in the package, and optionally on a preferred 'RepoKind'.
311 --
312 selectPackageSourceRepo :: Maybe RepoKind
313 -> [PD.SourceRepo]
314 -> Maybe PD.SourceRepo
315 selectPackageSourceRepo preferredRepoKind =
316 listToMaybe
317 -- Sort repositories by kind, from This to Head to Unknown. Repositories
318 -- with equivalent kinds are selected based on the order they appear in
319 -- the Cabal description file.
320 . sortBy (comparing thisFirst)
321 -- If the user has specified the repo kind, filter out the repositories
322 -- they're not interested in.
323 . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)
324 where
325 thisFirst :: PD.SourceRepo -> Int
326 thisFirst r = case PD.repoKind r of
327 RepoThis -> 0
328 RepoHead -> case PD.repoTag r of
329 -- If the type is 'head' but the author specified a tag, they
330 -- probably meant to create a 'this' repository but screwed up.
331 Just _ -> 0
332 Nothing -> 1
333 RepoKindUnknown _ -> 2