-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.FetchUtils
-- Copyright   :  (c) David Himmelstrup 2005
--                    Duncan Coutts 2011
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Functions for fetching packages
-----------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
module Distribution.Client.FetchUtils (

    -- * fetching packages
    fetchPackage,
    isFetched,
    checkFetched,

    -- ** specifically for repo packages
    checkRepoTarballFetched,
    fetchRepoTarball,
    verifyFetchedTarball,

    -- ** fetching packages asynchronously
    asyncFetchPackages,
    waitAsyncFetchPackage,
    AsyncFetchMap,

    -- * fetching other things
    downloadIndex,
  ) where

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

import Distribution.Client.Types
import Distribution.Client.HttpUtils
         ( downloadURI, isOldHackageURI, DownloadResult(..)
         , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )

import Distribution.Package
         ( PackageId, packageName, packageVersion )
import Distribution.Simple.Utils
         ( notice, info, debug, warn, die' )
import Distribution.Verbosity
         ( verboseUnmarkOutput )
import Distribution.Client.GlobalFlags
         ( RepoContext(..) )
import Distribution.Client.Utils
         ( ProgressPhase(..), progressMessage )

import qualified Data.Map as Map
import qualified Control.Exception.Safe as Safe
import Control.Concurrent.Async
import Control.Concurrent.MVar
import System.Directory
         ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory
         , getFileSize )
import System.IO
         ( openTempFile, hClose )
import System.FilePath
         ( (</>), (<.>) )
import qualified System.FilePath.Posix as FilePath.Posix
         ( combine, joinPath )
import Network.URI
         ( URI(uriPath) )

import qualified Hackage.Security.Client as Sec
import qualified Hackage.Security.Util.Path as Sec
import qualified Hackage.Security.Util.Checked as Sec

-- ------------------------------------------------------------
-- * Actually fetch things
-- ------------------------------------------------------------

-- | Returns @True@ if the package has already been fetched
-- or does not need fetching.
--
isFetched :: UnresolvedPkgLoc -> IO Bool
isFetched :: UnresolvedPkgLoc -> IO Bool
isFetched UnresolvedPkgLoc
loc = case UnresolvedPkgLoc
loc of
    LocalUnpackedPackage FilePath
_dir       -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    LocalTarballPackage  FilePath
_file      -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    RemoteTarballPackage URI
_uri Maybe FilePath
local -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a -> Bool
isJust Maybe FilePath
local)
    RepoTarballPackage Repo
repo PackageId
pkgid Maybe FilePath
_ -> FilePath -> IO Bool
doesFileExist (Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid)
    RemoteSourceRepoPackage SourceRepoMaybe
_ Maybe FilePath
local -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a -> Bool
isJust Maybe FilePath
local)


-- | Checks if the package has already been fetched (or does not need
-- fetching) and if so returns evidence in the form of a 'PackageLocation'
-- with a resolved local file location.
--
checkFetched :: UnresolvedPkgLoc
             -> IO (Maybe ResolvedPkgLoc)
checkFetched :: UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
checkFetched UnresolvedPkgLoc
loc = case UnresolvedPkgLoc
loc of
    LocalUnpackedPackage FilePath
dir  ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall local. FilePath -> PackageLocation local
LocalUnpackedPackage FilePath
dir)
    LocalTarballPackage  FilePath
file ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall local. FilePath -> PackageLocation local
LocalTarballPackage  FilePath
file)
    RemoteTarballPackage URI
uri (Just FilePath
file) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall local. URI -> local -> PackageLocation local
RemoteTarballPackage URI
uri FilePath
file)
    RepoTarballPackage Repo
repo PackageId
pkgid (Just FilePath
file) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid FilePath
file)
    RemoteSourceRepoPackage SourceRepoMaybe
repo (Just FilePath
file) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall local. SourceRepoMaybe -> local -> PackageLocation local
RemoteSourceRepoPackage SourceRepoMaybe
repo FilePath
file)

    RemoteTarballPackage     URI
_uri Maybe FilePath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    RemoteSourceRepoPackage SourceRepoMaybe
_repo Maybe FilePath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    RepoTarballPackage Repo
repo PackageId
pkgid Maybe FilePath
Nothing ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid))
           (Repo -> PackageId -> IO (Maybe FilePath)
checkRepoTarballFetched Repo
repo PackageId
pkgid)

-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.
--
checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)
checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)
checkRepoTarballFetched Repo
repo PackageId
pkgid = do
    let file :: FilePath
file = Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
file
    if Bool
exists
      then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just FilePath
file)
      else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

verifyFetchedTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO Bool
verifyFetchedTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO Bool
verifyFetchedTarball Verbosity
verbosity RepoContext
repoCtxt Repo
repo PackageId
pkgid =
   let file :: FilePath
file = Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid
       handleError :: IO Bool -> IO Bool
       handleError :: IO Bool -> IO Bool
handleError IO Bool
act = do
         Either SomeException Bool
res <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try IO Bool
act
         case Either SomeException Bool
res of
           Left SomeException
e -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"Error verifying fetched tarball " forall a. [a] -> [a] -> [a]
++ FilePath
file forall a. [a] -> [a] -> [a]
++ FilePath
", will redownload: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (SomeException
e :: SomeException)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
           Right Bool
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
   in IO Bool -> IO Bool
handleError forall a b. (a -> b) -> a -> b
$ do
        Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
file
        if Bool -> Bool
not Bool
exists
          then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- if the file does not exist, it vacuously passes validation, since it will be downloaded as necessary with what we will then check is a valid hash.
          else case Repo
repo of
            -- a secure repo has hashes we can compare against to confirm this is the correct file.
                RepoSecure{} ->
                 RepoContext
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo RepoContext
repoCtxt Repo
repo forall a b. (a -> b) -> a -> b
$ \Repository down
repoSecure ->
                   forall (down :: * -> *) a.
Repository down -> (IndexCallbacks -> IO a) -> IO a
Sec.withIndex Repository down
repoSecure forall a b. (a -> b) -> a -> b
$ \IndexCallbacks
callbacks ->
                     let warnAndFail :: FilePath -> IO Bool
warnAndFail FilePath
s = Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"Fetched tarball " forall a. [a] -> [a] -> [a]
++ FilePath
file forall a. [a] -> [a] -> [a]
++ FilePath
" does not match server, will redownload: " forall a. [a] -> [a] -> [a]
++ FilePath
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                     -- the do block in parens is due to dealing with the checked exceptions mechanism.
                     in (do Trusted FileInfo
fileInfo <- IndexCallbacks
-> (Throws InvalidPackageException, Throws VerificationError) =>
   PackageId -> IO (Trusted FileInfo)
Sec.indexLookupFileInfo IndexCallbacks
callbacks PackageId
pkgid
                            FileLength
sz <- Int54 -> FileLength
Sec.FileLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Integer
getFileSize FilePath
file
                            if FileLength
sz forall a. Eq a => a -> a -> Bool
/= FileInfo -> FileLength
Sec.fileInfoLength (forall a. Trusted a -> a
Sec.trusted Trusted FileInfo
fileInfo)
                              then FilePath -> IO Bool
warnAndFail FilePath
"file length mismatch"
                              else do
                                Bool
res <- FileInfo -> FileInfo -> Bool
Sec.compareTrustedFileInfo (forall a. Trusted a -> a
Sec.trusted Trusted FileInfo
fileInfo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall root. FsRoot root => Path root -> IO FileInfo
Sec.computeFileInfo (forall a. FilePath -> Path a
Sec.Path FilePath
file :: Sec.Path Sec.Absolute)
                                if Bool
res
                                  then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                                  else FilePath -> IO Bool
warnAndFail FilePath
"file hash mismatch")
                       forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
`Sec.catchChecked` (\(InvalidPackageException
e :: Sec.InvalidPackageException) -> FilePath -> IO Bool
warnAndFail (forall a. Show a => a -> FilePath
show InvalidPackageException
e))
                       forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
`Sec.catchChecked` (\(VerificationError
e :: Sec.VerificationError) -> FilePath -> IO Bool
warnAndFail (forall a. Show a => a -> FilePath
show VerificationError
e))
                Repo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | Fetch a package if we don't have it already.
--
fetchPackage :: Verbosity
             -> RepoContext
             -> UnresolvedPkgLoc
             -> IO ResolvedPkgLoc
fetchPackage :: Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage Verbosity
verbosity RepoContext
repoCtxt UnresolvedPkgLoc
loc = case UnresolvedPkgLoc
loc of
    LocalUnpackedPackage FilePath
dir  ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall local. FilePath -> PackageLocation local
LocalUnpackedPackage FilePath
dir)
    LocalTarballPackage  FilePath
file ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall local. FilePath -> PackageLocation local
LocalTarballPackage  FilePath
file)
    RemoteTarballPackage URI
uri (Just FilePath
file) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall local. URI -> local -> PackageLocation local
RemoteTarballPackage URI
uri FilePath
file)
    RepoTarballPackage Repo
repo PackageId
pkgid (Just FilePath
file) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid FilePath
file)
    RemoteSourceRepoPackage SourceRepoMaybe
repo (Just FilePath
dir) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall local. SourceRepoMaybe -> local -> PackageLocation local
RemoteSourceRepoPackage SourceRepoMaybe
repo FilePath
dir)

    RemoteTarballPackage URI
uri Maybe FilePath
Nothing -> do
      FilePath
path <- URI -> IO FilePath
downloadTarballPackage URI
uri
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall local. URI -> local -> PackageLocation local
RemoteTarballPackage URI
uri FilePath
path)
    RepoTarballPackage Repo
repo PackageId
pkgid Maybe FilePath
Nothing -> do
      FilePath
local <- Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
fetchRepoTarball Verbosity
verbosity RepoContext
repoCtxt Repo
repo PackageId
pkgid
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid FilePath
local)
    RemoteSourceRepoPackage SourceRepoMaybe
_repo Maybe FilePath
Nothing ->
      forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"fetchPackage: source repos not supported"
  where
    downloadTarballPackage :: URI -> IO FilePath
    downloadTarballPackage :: URI -> IO FilePath
downloadTarballPackage URI
uri = do
      HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
      Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps Verbosity
verbosity HttpTransport
transport URI
uri
      Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath
"Downloading " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show URI
uri)
      FilePath
tmpdir <- IO FilePath
getTemporaryDirectory
      (FilePath
path, Handle
hnd) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmpdir FilePath
"cabal-.tar.gz"
      Handle -> IO ()
hClose Handle
hnd
      DownloadResult
_ <- HttpTransport -> Verbosity -> URI -> FilePath -> IO DownloadResult
downloadURI HttpTransport
transport Verbosity
verbosity URI
uri FilePath
path
      forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path


-- | Fetch a repo package if we don't have it already.
--
fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
fetchRepoTarball Verbosity
verbosity' RepoContext
repoCtxt Repo
repo PackageId
pkgid = do
  Bool
fetched <- FilePath -> IO Bool
doesFileExist (Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid)
  if Bool
fetched
    then do Verbosity -> FilePath -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid forall a. [a] -> [a] -> [a]
++ FilePath
" has already been downloaded."
            forall (m :: * -> *) a. Monad m => a -> m a
return (Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid)
    else do Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
ProgressDownloading (forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid)
            FilePath
res <- IO FilePath
downloadRepoPackage
            Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
ProgressDownloaded (forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid)
            forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
res
  where
    -- whether we download or not is non-deterministic
    verbosity :: Verbosity
verbosity = Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity'

    downloadRepoPackage :: IO FilePath
    downloadRepoPackage :: IO FilePath
downloadRepoPackage = case Repo
repo of
      RepoLocalNoIndex{} -> forall (m :: * -> *) a. Monad m => a -> m a
return (Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid)

      RepoRemote{FilePath
RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: Repo -> FilePath
repoLocalDir :: FilePath
repoRemote :: RemoteRepo
..} -> do
        HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
        Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps Verbosity
verbosity HttpTransport
transport RemoteRepo
repoRemote
        let uri :: URI
uri  = RemoteRepo -> PackageId -> URI
packageURI  RemoteRepo
repoRemote PackageId
pkgid
            dir :: FilePath
dir  = Repo -> PackageId -> FilePath
packageDir  Repo
repo       PackageId
pkgid
            path :: FilePath
path = Repo -> PackageId -> FilePath
packageFile Repo
repo       PackageId
pkgid
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
        DownloadResult
_ <- HttpTransport -> Verbosity -> URI -> FilePath -> IO DownloadResult
downloadURI HttpTransport
transport Verbosity
verbosity URI
uri FilePath
path
        forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path

      RepoSecure{} -> RepoContext
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo RepoContext
repoCtxt Repo
repo forall a b. (a -> b) -> a -> b
$ \Repository down
rep -> do
        let dir :: FilePath
dir  = Repo -> PackageId -> FilePath
packageDir  Repo
repo PackageId
pkgid
            path :: FilePath
path = Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
        forall a.
((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO a)
-> IO a
Sec.uncheckClientErrors forall a b. (a -> b) -> a -> b
$ do
          Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"Writing " forall a. [a] -> [a] -> [a]
++ FilePath
path)
          forall (down :: * -> *).
(Throws SomeRemoteError, Throws VerificationError,
 Throws InvalidPackageException) =>
Repository down -> PackageId -> FilePath -> IO ()
Sec.downloadPackage' Repository down
rep PackageId
pkgid FilePath
path
        forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path

-- | Downloads an index file to [config-dir/packages/serv-id] without
-- hackage-security. You probably don't want to call this directly;
-- use 'updateRepo' instead.
--
downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
downloadIndex :: HttpTransport
-> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
downloadIndex HttpTransport
transport Verbosity
verbosity RemoteRepo
remoteRepo FilePath
cacheDir = do
  Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps Verbosity
verbosity HttpTransport
transport RemoteRepo
remoteRepo
  let uri :: URI
uri = (RemoteRepo -> URI
remoteRepoURI RemoteRepo
remoteRepo) {
              uriPath :: FilePath
uriPath = URI -> FilePath
uriPath (RemoteRepo -> URI
remoteRepoURI RemoteRepo
remoteRepo)
                          FilePath -> FilePath -> FilePath
`FilePath.Posix.combine` FilePath
"00-index.tar.gz"
            }
      path :: FilePath
path = FilePath
cacheDir FilePath -> FilePath -> FilePath
</> FilePath
"00-index" FilePath -> FilePath -> FilePath
<.> FilePath
"tar.gz"
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
cacheDir
  HttpTransport -> Verbosity -> URI -> FilePath -> IO DownloadResult
downloadURI HttpTransport
transport Verbosity
verbosity URI
uri FilePath
path


-- ------------------------------------------------------------
-- * Async fetch wrapper utilities
-- ------------------------------------------------------------

type AsyncFetchMap = Map UnresolvedPkgLoc
                         (MVar (Either SomeException ResolvedPkgLoc))

-- | Fork off an async action to download the given packages (by location).
--
-- The downloads are initiated in order, so you can arrange for packages that
-- will likely be needed sooner to be earlier in the list.
--
-- The body action is passed a map from those packages (identified by their
-- location) to a completion var for that package. So the body action should
-- lookup the location and use 'waitAsyncFetchPackage' to get the result.
--
-- Synchronous exceptions raised by the download actions are delivered
-- via 'waitAsyncFetchPackage'.
--
asyncFetchPackages :: Verbosity
                   -> RepoContext
                   -> [UnresolvedPkgLoc]
                   -> (AsyncFetchMap -> IO a)
                   -> IO a
asyncFetchPackages :: forall a.
Verbosity
-> RepoContext
-> [UnresolvedPkgLoc]
-> (AsyncFetchMap -> IO a)
-> IO a
asyncFetchPackages Verbosity
verbosity RepoContext
repoCtxt [UnresolvedPkgLoc]
pkglocs AsyncFetchMap -> IO a
body = do
    --TODO: [nice to have] use parallel downloads?

    [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
asyncDownloadVars <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ do MVar (Either SomeException ResolvedPkgLoc)
v <- forall a. IO (MVar a)
newEmptyMVar
             forall (m :: * -> *) a. Monad m => a -> m a
return (UnresolvedPkgLoc
pkgloc, MVar (Either SomeException ResolvedPkgLoc)
v)
        | UnresolvedPkgLoc
pkgloc <- [UnresolvedPkgLoc]
pkglocs
        ]

    let fetchPackages :: IO ()
        fetchPackages :: IO ()
fetchPackages =
          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
asyncDownloadVars forall a b. (a -> b) -> a -> b
$ \(UnresolvedPkgLoc
pkgloc, MVar (Either SomeException ResolvedPkgLoc)
var) -> do
            -- Suppress marking here, because 'withAsync' means
            -- that we get nondeterministic interleaving.
            -- It is essential that we don't catch async exceptions here,
            -- specifically 'AsyncCancelled' thrown at us from 'concurrently'.
            Either SomeException ResolvedPkgLoc
result <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try forall a b. (a -> b) -> a -> b
$
              Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage (Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity) RepoContext
repoCtxt UnresolvedPkgLoc
pkgloc
            forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException ResolvedPkgLoc)
var Either SomeException ResolvedPkgLoc
result

    (()
_, a
res) <- forall a b. IO a -> IO b -> IO (a, b)
concurrently
        IO ()
fetchPackages
        (AsyncFetchMap -> IO a
body forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
asyncDownloadVars)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res


-- | Expect to find a download in progress in the given 'AsyncFetchMap'
-- and wait on it to finish.
--
-- If the download failed with an exception then this will be thrown.
--
-- Note: This function is supposed to be idempotent, as our install plans
-- can now use the same tarball for many builds, e.g. different
-- components and/or qualified goals, and these all go through the
-- download phase so we end up using 'waitAsyncFetchPackage' twice on
-- the same package. C.f. #4461.
waitAsyncFetchPackage :: Verbosity
                      -> AsyncFetchMap
                      -> UnresolvedPkgLoc
                      -> IO ResolvedPkgLoc
waitAsyncFetchPackage :: Verbosity -> AsyncFetchMap -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
waitAsyncFetchPackage Verbosity
verbosity AsyncFetchMap
downloadMap UnresolvedPkgLoc
srcloc =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnresolvedPkgLoc
srcloc AsyncFetchMap
downloadMap of
      Just MVar (Either SomeException ResolvedPkgLoc)
hnd -> do
        Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Waiting for download of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show UnresolvedPkgLoc
srcloc
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. MVar a -> IO a
readMVar MVar (Either SomeException ResolvedPkgLoc)
hnd
      Maybe (MVar (Either SomeException ResolvedPkgLoc))
Nothing -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"waitAsyncFetchPackage: package not being downloaded"


-- ------------------------------------------------------------
-- * Path utilities
-- ------------------------------------------------------------

-- | Generate the full path to the locally cached copy of
-- the tarball for a given @PackageIdentifier@.
--
packageFile :: Repo -> PackageId -> FilePath
packageFile :: Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid = Repo -> PackageId -> FilePath
packageDir Repo
repo PackageId
pkgid
                     FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid
                     FilePath -> FilePath -> FilePath
<.> FilePath
"tar.gz"

-- | Generate the full path to the directory where the local cached copy of
-- the tarball for a given @PackageIdentifier@ is stored.
--
packageDir :: Repo -> PackageId -> FilePath
packageDir :: Repo -> PackageId -> FilePath
packageDir (RepoLocalNoIndex (LocalRepo RepoName
_ FilePath
dir Bool
_) FilePath
_) PackageId
_pkgid = FilePath
dir
packageDir Repo
repo PackageId
pkgid = Repo -> FilePath
repoLocalDir Repo
repo
                    FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName    PackageId
pkgid)
                    FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> Version
packageVersion PackageId
pkgid)

-- | Generate the URI of the tarball for a given package.
--
packageURI :: RemoteRepo -> PackageId -> URI
packageURI :: RemoteRepo -> PackageId -> URI
packageURI RemoteRepo
repo PackageId
pkgid | URI -> Bool
isOldHackageURI (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) =
  (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) {
    uriPath :: FilePath
uriPath = [FilePath] -> FilePath
FilePath.Posix.joinPath
      [URI -> FilePath
uriPath (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo)
      ,forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName    PackageId
pkgid)
      ,forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> Version
packageVersion PackageId
pkgid)
      ,forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid FilePath -> FilePath -> FilePath
<.> FilePath
"tar.gz"]
  }
packageURI RemoteRepo
repo PackageId
pkgid =
  (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) {
    uriPath :: FilePath
uriPath = [FilePath] -> FilePath
FilePath.Posix.joinPath
      [URI -> FilePath
uriPath (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo)
      ,FilePath
"package"
      ,forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid FilePath -> FilePath -> FilePath
<.> FilePath
"tar.gz"]
  }