never executed always true always false
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : Distribution.Client.FetchUtils
4 -- Copyright : (c) David Himmelstrup 2005
5 -- Duncan Coutts 2011
6 -- License : BSD-like
7 --
8 -- Maintainer : cabal-devel@gmail.com
9 -- Stability : provisional
10 -- Portability : portable
11 --
12 -- Functions for fetching packages
13 -----------------------------------------------------------------------------
14 {-# LANGUAGE RecordWildCards #-}
15 module Distribution.Client.FetchUtils (
16
17 -- * fetching packages
18 fetchPackage,
19 isFetched,
20 checkFetched,
21
22 -- ** specifically for repo packages
23 checkRepoTarballFetched,
24 fetchRepoTarball,
25
26 -- ** fetching packages asynchronously
27 asyncFetchPackages,
28 waitAsyncFetchPackage,
29 AsyncFetchMap,
30
31 -- * fetching other things
32 downloadIndex,
33 ) where
34
35 import Distribution.Client.Compat.Prelude
36 import Prelude ()
37
38 import Distribution.Client.Types
39 import Distribution.Client.HttpUtils
40 ( downloadURI, isOldHackageURI, DownloadResult(..)
41 , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )
42
43 import Distribution.Package
44 ( PackageId, packageName, packageVersion )
45 import Distribution.Simple.Utils
46 ( notice, info, debug, die' )
47 import Distribution.Verbosity
48 ( verboseUnmarkOutput )
49 import Distribution.Client.GlobalFlags
50 ( RepoContext(..) )
51 import Distribution.Client.Utils
52 ( ProgressPhase(..), progressMessage )
53
54 import qualified Data.Map as Map
55 import Control.Exception
56 import Control.Concurrent.Async
57 import Control.Concurrent.MVar
58 import System.Directory
59 ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
60 import System.IO
61 ( openTempFile, hClose )
62 import System.FilePath
63 ( (</>), (<.>) )
64 import qualified System.FilePath.Posix as FilePath.Posix
65 ( combine, joinPath )
66 import Network.URI
67 ( URI(uriPath) )
68
69 import qualified Hackage.Security.Client as Sec
70
71 -- ------------------------------------------------------------
72 -- * Actually fetch things
73 -- ------------------------------------------------------------
74
75 -- | Returns @True@ if the package has already been fetched
76 -- or does not need fetching.
77 --
78 isFetched :: UnresolvedPkgLoc -> IO Bool
79 isFetched loc = case loc of
80 LocalUnpackedPackage _dir -> return True
81 LocalTarballPackage _file -> return True
82 RemoteTarballPackage _uri local -> return (isJust local)
83 RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)
84 RemoteSourceRepoPackage _ local -> return (isJust local)
85
86
87 -- | Checks if the package has already been fetched (or does not need
88 -- fetching) and if so returns evidence in the form of a 'PackageLocation'
89 -- with a resolved local file location.
90 --
91 checkFetched :: UnresolvedPkgLoc
92 -> IO (Maybe ResolvedPkgLoc)
93 checkFetched loc = case loc of
94 LocalUnpackedPackage dir ->
95 return (Just $ LocalUnpackedPackage dir)
96 LocalTarballPackage file ->
97 return (Just $ LocalTarballPackage file)
98 RemoteTarballPackage uri (Just file) ->
99 return (Just $ RemoteTarballPackage uri file)
100 RepoTarballPackage repo pkgid (Just file) ->
101 return (Just $ RepoTarballPackage repo pkgid file)
102 RemoteSourceRepoPackage repo (Just file) ->
103 return (Just $ RemoteSourceRepoPackage repo file)
104
105 RemoteTarballPackage _uri Nothing -> return Nothing
106 RemoteSourceRepoPackage _repo Nothing -> return Nothing
107 RepoTarballPackage repo pkgid Nothing ->
108 fmap (fmap (RepoTarballPackage repo pkgid))
109 (checkRepoTarballFetched repo pkgid)
110
111 -- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.
112 --
113 checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)
114 checkRepoTarballFetched repo pkgid = do
115 let file = packageFile repo pkgid
116 exists <- doesFileExist file
117 if exists
118 then return (Just file)
119 else return Nothing
120
121
122 -- | Fetch a package if we don't have it already.
123 --
124 fetchPackage :: Verbosity
125 -> RepoContext
126 -> UnresolvedPkgLoc
127 -> IO ResolvedPkgLoc
128 fetchPackage verbosity repoCtxt loc = case loc of
129 LocalUnpackedPackage dir ->
130 return (LocalUnpackedPackage dir)
131 LocalTarballPackage file ->
132 return (LocalTarballPackage file)
133 RemoteTarballPackage uri (Just file) ->
134 return (RemoteTarballPackage uri file)
135 RepoTarballPackage repo pkgid (Just file) ->
136 return (RepoTarballPackage repo pkgid file)
137 RemoteSourceRepoPackage repo (Just dir) ->
138 return (RemoteSourceRepoPackage repo dir)
139
140 RemoteTarballPackage uri Nothing -> do
141 path <- downloadTarballPackage uri
142 return (RemoteTarballPackage uri path)
143 RepoTarballPackage repo pkgid Nothing -> do
144 local <- fetchRepoTarball verbosity repoCtxt repo pkgid
145 return (RepoTarballPackage repo pkgid local)
146 RemoteSourceRepoPackage _repo Nothing ->
147 die' verbosity "fetchPackage: source repos not supported"
148 where
149 downloadTarballPackage uri = do
150 transport <- repoContextGetTransport repoCtxt
151 transportCheckHttps verbosity transport uri
152 notice verbosity ("Downloading " ++ show uri)
153 tmpdir <- getTemporaryDirectory
154 (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"
155 hClose hnd
156 _ <- downloadURI transport verbosity uri path
157 return path
158
159
160 -- | Fetch a repo package if we don't have it already.
161 --
162 fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
163 fetchRepoTarball verbosity' repoCtxt repo pkgid = do
164 fetched <- doesFileExist (packageFile repo pkgid)
165 if fetched
166 then do info verbosity $ prettyShow pkgid ++ " has already been downloaded."
167 return (packageFile repo pkgid)
168 else do progressMessage verbosity ProgressDownloading (prettyShow pkgid)
169 res <- downloadRepoPackage
170 progressMessage verbosity ProgressDownloaded (prettyShow pkgid)
171 return res
172 where
173 -- whether we download or not is non-deterministic
174 verbosity = verboseUnmarkOutput verbosity'
175
176 downloadRepoPackage = case repo of
177 RepoLocalNoIndex{} -> return (packageFile repo pkgid)
178
179 RepoRemote{..} -> do
180 transport <- repoContextGetTransport repoCtxt
181 remoteRepoCheckHttps verbosity transport repoRemote
182 let uri = packageURI repoRemote pkgid
183 dir = packageDir repo pkgid
184 path = packageFile repo pkgid
185 createDirectoryIfMissing True dir
186 _ <- downloadURI transport verbosity uri path
187 return path
188
189 RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do
190 let dir = packageDir repo pkgid
191 path = packageFile repo pkgid
192 createDirectoryIfMissing True dir
193 Sec.uncheckClientErrors $ do
194 info verbosity ("Writing " ++ path)
195 Sec.downloadPackage' rep pkgid path
196 return path
197
198 -- | Downloads an index file to [config-dir/packages/serv-id] without
199 -- hackage-security. You probably don't want to call this directly;
200 -- use 'updateRepo' instead.
201 --
202 downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
203 downloadIndex transport verbosity remoteRepo cacheDir = do
204 remoteRepoCheckHttps verbosity transport remoteRepo
205 let uri = (remoteRepoURI remoteRepo) {
206 uriPath = uriPath (remoteRepoURI remoteRepo)
207 `FilePath.Posix.combine` "00-index.tar.gz"
208 }
209 path = cacheDir </> "00-index" <.> "tar.gz"
210 createDirectoryIfMissing True cacheDir
211 downloadURI transport verbosity uri path
212
213
214 -- ------------------------------------------------------------
215 -- * Async fetch wrapper utilities
216 -- ------------------------------------------------------------
217
218 type AsyncFetchMap = Map UnresolvedPkgLoc
219 (MVar (Either SomeException ResolvedPkgLoc))
220
221 -- | Fork off an async action to download the given packages (by location).
222 --
223 -- The downloads are initiated in order, so you can arrange for packages that
224 -- will likely be needed sooner to be earlier in the list.
225 --
226 -- The body action is passed a map from those packages (identified by their
227 -- location) to a completion var for that package. So the body action should
228 -- lookup the location and use 'asyncFetchPackage' to get the result.
229 --
230 asyncFetchPackages :: Verbosity
231 -> RepoContext
232 -> [UnresolvedPkgLoc]
233 -> (AsyncFetchMap -> IO a)
234 -> IO a
235 asyncFetchPackages verbosity repoCtxt pkglocs body = do
236 --TODO: [nice to have] use parallel downloads?
237
238 asyncDownloadVars <- sequenceA
239 [ do v <- newEmptyMVar
240 return (pkgloc, v)
241 | pkgloc <- pkglocs
242 ]
243
244 let fetchPackages :: IO ()
245 fetchPackages =
246 for_ asyncDownloadVars $ \(pkgloc, var) -> do
247 -- Suppress marking here, because 'withAsync' means
248 -- that we get nondeterministic interleaving
249 result <- try $ fetchPackage (verboseUnmarkOutput verbosity)
250 repoCtxt pkgloc
251 putMVar var result
252
253 withAsync fetchPackages $ \_ ->
254 body (Map.fromList asyncDownloadVars)
255
256
257 -- | Expect to find a download in progress in the given 'AsyncFetchMap'
258 -- and wait on it to finish.
259 --
260 -- If the download failed with an exception then this will be thrown.
261 --
262 -- Note: This function is supposed to be idempotent, as our install plans
263 -- can now use the same tarball for many builds, e.g. different
264 -- components and/or qualified goals, and these all go through the
265 -- download phase so we end up using 'waitAsyncFetchPackage' twice on
266 -- the same package. C.f. #4461.
267 waitAsyncFetchPackage :: Verbosity
268 -> AsyncFetchMap
269 -> UnresolvedPkgLoc
270 -> IO ResolvedPkgLoc
271 waitAsyncFetchPackage verbosity downloadMap srcloc =
272 case Map.lookup srcloc downloadMap of
273 Just hnd -> do
274 debug verbosity $ "Waiting for download of " ++ show srcloc
275 either throwIO return =<< readMVar hnd
276 Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"
277
278
279 -- ------------------------------------------------------------
280 -- * Path utilities
281 -- ------------------------------------------------------------
282
283 -- | Generate the full path to the locally cached copy of
284 -- the tarball for a given @PackageIdentifer@.
285 --
286 packageFile :: Repo -> PackageId -> FilePath
287 packageFile repo pkgid = packageDir repo pkgid
288 </> prettyShow pkgid
289 <.> "tar.gz"
290
291 -- | Generate the full path to the directory where the local cached copy of
292 -- the tarball for a given @PackageIdentifer@ is stored.
293 --
294 packageDir :: Repo -> PackageId -> FilePath
295 packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir
296 packageDir repo pkgid = repoLocalDir repo
297 </> prettyShow (packageName pkgid)
298 </> prettyShow (packageVersion pkgid)
299
300 -- | Generate the URI of the tarball for a given package.
301 --
302 packageURI :: RemoteRepo -> PackageId -> URI
303 packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =
304 (remoteRepoURI repo) {
305 uriPath = FilePath.Posix.joinPath
306 [uriPath (remoteRepoURI repo)
307 ,prettyShow (packageName pkgid)
308 ,prettyShow (packageVersion pkgid)
309 ,prettyShow pkgid <.> "tar.gz"]
310 }
311 packageURI repo pkgid =
312 (remoteRepoURI repo) {
313 uriPath = FilePath.Posix.joinPath
314 [uriPath (remoteRepoURI repo)
315 ,"package"
316 ,prettyShow pkgid <.> "tar.gz"]
317 }