-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- 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
module Distribution.Client.FetchUtils
  ( -- * fetching packages
    fetchPackage
  , isFetched
  , checkFetched

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

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

    -- * fetching other things
  , downloadIndex
  ) where

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

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

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

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

import Control.Monad (forM)
import Distribution.Client.Errors
import qualified Hackage.Security.Client as Sec
import qualified Hackage.Security.Util.Checked as Sec
import qualified Hackage.Security.Util.Path 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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  LocalTarballPackage FilePath
_file -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  RemoteTarballPackage URI
_uri Maybe FilePath
local -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> Bool
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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> Bool
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 ->
    Maybe ResolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a. a -> Maybe a
Just (ResolvedPkgLoc -> Maybe ResolvedPkgLoc)
-> ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ResolvedPkgLoc
forall local. FilePath -> PackageLocation local
LocalUnpackedPackage FilePath
dir)
  LocalTarballPackage FilePath
file ->
    Maybe ResolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a. a -> Maybe a
Just (ResolvedPkgLoc -> Maybe ResolvedPkgLoc)
-> ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ResolvedPkgLoc
forall local. FilePath -> PackageLocation local
LocalTarballPackage FilePath
file)
  RemoteTarballPackage URI
uri (Just FilePath
file) ->
    Maybe ResolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a. a -> Maybe a
Just (ResolvedPkgLoc -> Maybe ResolvedPkgLoc)
-> ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a b. (a -> b) -> a -> b
$ URI -> FilePath -> ResolvedPkgLoc
forall local. URI -> local -> PackageLocation local
RemoteTarballPackage URI
uri FilePath
file)
  RepoTarballPackage Repo
repo PackageId
pkgid (Just FilePath
file) ->
    Maybe ResolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a. a -> Maybe a
Just (ResolvedPkgLoc -> Maybe ResolvedPkgLoc)
-> ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a b. (a -> b) -> a -> b
$ Repo -> PackageId -> FilePath -> ResolvedPkgLoc
forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid FilePath
file)
  RemoteSourceRepoPackage SourceRepoMaybe
repo (Just FilePath
file) ->
    Maybe ResolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a. a -> Maybe a
Just (ResolvedPkgLoc -> Maybe ResolvedPkgLoc)
-> ResolvedPkgLoc -> Maybe ResolvedPkgLoc
forall a b. (a -> b) -> a -> b
$ SourceRepoMaybe -> FilePath -> ResolvedPkgLoc
forall local. SourceRepoMaybe -> local -> PackageLocation local
RemoteSourceRepoPackage SourceRepoMaybe
repo FilePath
file)
  RemoteTarballPackage URI
_uri Maybe FilePath
Nothing -> Maybe ResolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ResolvedPkgLoc
forall a. Maybe a
Nothing
  RemoteSourceRepoPackage SourceRepoMaybe
_repo Maybe FilePath
Nothing -> Maybe ResolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ResolvedPkgLoc
forall a. Maybe a
Nothing
  RepoTarballPackage Repo
repo PackageId
pkgid Maybe FilePath
Nothing ->
    (Maybe FilePath -> Maybe ResolvedPkgLoc)
-> IO (Maybe FilePath) -> IO (Maybe ResolvedPkgLoc)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ((FilePath -> ResolvedPkgLoc)
-> Maybe FilePath -> Maybe ResolvedPkgLoc
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Repo -> PackageId -> FilePath -> ResolvedPkgLoc
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 Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)
    else Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing

verifyFetchedTarballs
  :: Verbosity
  -> RepoContext
  -> Repo
  -> [PackageId]
  -> IO
      ( [ Either
            (Repo, PackageId) -- Verified
            (Repo, PackageId) -- unverified)
        ]
      )
verifyFetchedTarballs :: Verbosity
-> RepoContext
-> Repo
-> [PackageId]
-> IO [Either (Repo, PackageId) (Repo, PackageId)]
verifyFetchedTarballs Verbosity
verbosity RepoContext
repoCtxt Repo
repo [PackageId]
pkgids =
  -- Establish the context once per repo (see #10110), this codepath is important
  -- to be fast as it can happen when no other building happens.
  let establishContext :: (Maybe IndexCallbacks -> IO a) -> IO a
establishContext Maybe IndexCallbacks -> IO a
k =
        case Repo
repo of
          RepoSecure{} ->
            RepoContext
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo RepoContext
repoCtxt Repo
repo ((forall (down :: * -> *). Repository down -> IO a) -> IO a)
-> (forall (down :: * -> *). Repository down -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Repository down
repoSecure ->
              Repository down -> (IndexCallbacks -> IO a) -> IO a
forall (down :: * -> *) a.
Repository down -> (IndexCallbacks -> IO a) -> IO a
Sec.withIndex Repository down
repoSecure ((IndexCallbacks -> IO a) -> IO a)
-> (IndexCallbacks -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \IndexCallbacks
callbacks -> Maybe IndexCallbacks -> IO a
k (IndexCallbacks -> Maybe IndexCallbacks
forall a. a -> Maybe a
Just IndexCallbacks
callbacks)
          Repo
_ -> Maybe IndexCallbacks -> IO a
k Maybe IndexCallbacks
forall a. Maybe a
Nothing
   in do
        (Maybe IndexCallbacks
 -> IO [Either (Repo, PackageId) (Repo, PackageId)])
-> IO [Either (Repo, PackageId) (Repo, PackageId)]
forall {a}. (Maybe IndexCallbacks -> IO a) -> IO a
establishContext ((Maybe IndexCallbacks
  -> IO [Either (Repo, PackageId) (Repo, PackageId)])
 -> IO [Either (Repo, PackageId) (Repo, PackageId)])
-> (Maybe IndexCallbacks
    -> IO [Either (Repo, PackageId) (Repo, PackageId)])
-> IO [Either (Repo, PackageId) (Repo, PackageId)]
forall a b. (a -> b) -> a -> b
$ \Maybe IndexCallbacks
mCallbacks ->
          [PackageId]
-> (PackageId -> IO (Either (Repo, PackageId) (Repo, PackageId)))
-> IO [Either (Repo, PackageId) (Repo, PackageId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PackageId]
pkgids ((PackageId -> IO (Either (Repo, PackageId) (Repo, PackageId)))
 -> IO [Either (Repo, PackageId) (Repo, PackageId)])
-> (PackageId -> IO (Either (Repo, PackageId) (Repo, PackageId)))
-> IO [Either (Repo, PackageId) (Repo, PackageId)]
forall a b. (a -> b) -> a -> b
$ \PackageId
pkgid -> do
            let file :: FilePath
file = Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid
            Bool
res <- Verbosity
-> FilePath -> Maybe IndexCallbacks -> PackageId -> IO Bool
verifyFetchedTarball Verbosity
verbosity FilePath
file Maybe IndexCallbacks
mCallbacks PackageId
pkgid
            Either (Repo, PackageId) (Repo, PackageId)
-> IO (Either (Repo, PackageId) (Repo, PackageId))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Repo, PackageId) (Repo, PackageId)
 -> IO (Either (Repo, PackageId) (Repo, PackageId)))
-> Either (Repo, PackageId) (Repo, PackageId)
-> IO (Either (Repo, PackageId) (Repo, PackageId))
forall a b. (a -> b) -> a -> b
$ if Bool
res then (Repo, PackageId) -> Either (Repo, PackageId) (Repo, PackageId)
forall a b. a -> Either a b
Left (Repo
repo, PackageId
pkgid) else (Repo, PackageId) -> Either (Repo, PackageId) (Repo, PackageId)
forall a b. b -> Either a b
Right (Repo
repo, PackageId
pkgid)

verifyFetchedTarball :: Verbosity -> FilePath -> Maybe Sec.IndexCallbacks -> PackageId -> IO Bool
verifyFetchedTarball :: Verbosity
-> FilePath -> Maybe IndexCallbacks -> PackageId -> IO Bool
verifyFetchedTarball Verbosity
verbosity FilePath
file Maybe IndexCallbacks
mCallbacks PackageId
pkgid =
  let
    handleError :: IO Bool -> IO Bool
    handleError :: IO Bool -> IO Bool
handleError IO Bool
act = do
      Either SomeException Bool
res <- IO Bool -> IO (Either SomeException Bool)
forall (m :: * -> *) e a.
(HasCallStack, 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 " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", will redownload: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show (SomeException
e :: SomeException)) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Right Bool
b -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
   in
    IO Bool -> IO Bool
handleError (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
      Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
file
      if Bool -> Bool
not Bool
exists
        then Bool -> IO Bool
forall a. a -> IO a
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 Maybe IndexCallbacks
mCallbacks of
          -- a secure repo has hashes we can compare against to confirm this is the correct file.
          Just IndexCallbacks
callbacks ->
            let warnAndFail :: FilePath -> IO Bool
warnAndFail FilePath
s = Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"Fetched tarball " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" does not match server, will redownload: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
             in -- the do block in parens is due to dealing with the checked exceptions mechanism.
                ( 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 (Int54 -> FileLength)
-> (Integer -> Int54) -> Integer -> FileLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int54
forall a. Num a => Integer -> a
fromInteger (Integer -> FileLength) -> IO Integer -> IO FileLength
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Integer
getFileSize FilePath
file
                    if FileLength
sz FileLength -> FileLength -> Bool
forall a. Eq a => a -> a -> Bool
/= FileInfo -> FileLength
Sec.fileInfoLength (Trusted FileInfo -> FileInfo
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 (Trusted FileInfo -> FileInfo
forall a. Trusted a -> a
Sec.trusted Trusted FileInfo
fileInfo) (FileInfo -> Bool) -> IO FileInfo -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Absolute -> IO FileInfo
forall root. FsRoot root => Path root -> IO FileInfo
Sec.computeFileInfo (FilePath -> Path Absolute
forall a. FilePath -> Path a
Sec.Path FilePath
file :: Sec.Path Sec.Absolute)
                        if Bool
res
                          then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                          else FilePath -> IO Bool
warnAndFail FilePath
"file hash mismatch"
                )
                  (Throws InvalidPackageException => IO Bool)
-> (InvalidPackageException -> IO Bool) -> IO Bool
forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
`Sec.catchChecked` (\(InvalidPackageException
e :: Sec.InvalidPackageException) -> FilePath -> IO Bool
warnAndFail (InvalidPackageException -> FilePath
forall a. Show a => a -> FilePath
show InvalidPackageException
e))
                  (Throws VerificationError => IO Bool)
-> (VerificationError -> IO Bool) -> IO Bool
forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
`Sec.catchChecked` (\(VerificationError
e :: Sec.VerificationError) -> FilePath -> IO Bool
warnAndFail (VerificationError -> FilePath
forall a. Show a => a -> FilePath
show VerificationError
e))
          Maybe IndexCallbacks
_ -> Bool -> IO Bool
forall a. a -> IO a
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 ->
    ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ResolvedPkgLoc
forall local. FilePath -> PackageLocation local
LocalUnpackedPackage FilePath
dir)
  LocalTarballPackage FilePath
file ->
    ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ResolvedPkgLoc
forall local. FilePath -> PackageLocation local
LocalTarballPackage FilePath
file)
  RemoteTarballPackage URI
uri (Just FilePath
file) ->
    ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> FilePath -> ResolvedPkgLoc
forall local. URI -> local -> PackageLocation local
RemoteTarballPackage URI
uri FilePath
file)
  RepoTarballPackage Repo
repo PackageId
pkgid (Just FilePath
file) ->
    ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Repo -> PackageId -> FilePath -> ResolvedPkgLoc
forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid FilePath
file)
  RemoteSourceRepoPackage SourceRepoMaybe
repo (Just FilePath
dir) ->
    ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceRepoMaybe -> FilePath -> ResolvedPkgLoc
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
    ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> FilePath -> ResolvedPkgLoc
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
    ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Repo -> PackageId -> FilePath -> ResolvedPkgLoc
forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid FilePath
local)
  RemoteSourceRepoPackage SourceRepoMaybe
_repo Maybe FilePath
Nothing ->
    Verbosity -> CabalInstallException -> IO ResolvedPkgLoc
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
FetchPackageErr
  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 " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ URI -> FilePath
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
      FilePath -> IO FilePath
forall a. a -> IO a
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 (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" has already been downloaded."
      FilePath -> IO FilePath
forall a. a -> IO a
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 (PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid)
      FilePath
res <- IO FilePath
downloadRepoPackage
      Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
ProgressDownloaded (PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid)
      FilePath -> IO FilePath
forall a. a -> IO a
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{} -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Repo -> PackageId -> FilePath
packageFile Repo
repo PackageId
pkgid)
      RepoRemote{FilePath
RemoteRepo
repoRemote :: RemoteRepo
repoLocalDir :: FilePath
repoLocalDir :: Repo -> FilePath
repoRemote :: Repo -> 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
        FilePath -> IO FilePath
forall a. a -> IO a
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 {down :: * -> *}. Repository down -> IO FilePath)
 -> IO FilePath)
-> (forall {down :: * -> *}. Repository down -> IO FilePath)
-> IO FilePath
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
        ((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO ())
-> IO ()
forall a.
((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO a)
-> IO a
Sec.uncheckClientErrors (((Throws VerificationError, Throws SomeRemoteError,
   Throws InvalidPackageException) =>
  IO ())
 -> IO ())
-> ((Throws VerificationError, Throws SomeRemoteError,
     Throws InvalidPackageException) =>
    IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"Writing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path)
          Repository down -> PackageId -> FilePath -> IO ()
forall (down :: * -> *).
(Throws SomeRemoteError, Throws VerificationError,
 Throws InvalidPackageException) =>
Repository down -> PackageId -> FilePath -> IO ()
Sec.downloadPackage' Repository down
rep PackageId
pkgid FilePath
path
        FilePath -> IO FilePath
forall a. a -> IO a
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 =
              uriPath (remoteRepoURI remoteRepo)
                `FilePath.Posix.combine` "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 <-
    [IO (UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
-> IO
     [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
      [ do
        MVar (Either SomeException ResolvedPkgLoc)
v <- IO (MVar (Either SomeException ResolvedPkgLoc))
forall a. IO (MVar a)
newEmptyMVar
        (UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))
-> IO
     (UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))
forall a. a -> IO a
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 =
        [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
-> ((UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))
    -> IO ())
-> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
asyncDownloadVars (((UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))
  -> IO ())
 -> IO ())
-> ((UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))
    -> IO ())
-> IO ()
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 <-
            IO ResolvedPkgLoc -> IO (Either SomeException ResolvedPkgLoc)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try (IO ResolvedPkgLoc -> IO (Either SomeException ResolvedPkgLoc))
-> IO ResolvedPkgLoc -> IO (Either SomeException ResolvedPkgLoc)
forall a b. (a -> b) -> a -> b
$
              Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage (Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity) RepoContext
repoCtxt UnresolvedPkgLoc
pkgloc
          MVar (Either SomeException ResolvedPkgLoc)
-> Either SomeException ResolvedPkgLoc -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException ResolvedPkgLoc)
var Either SomeException ResolvedPkgLoc
result

  (()
_, a
res) <-
    IO () -> IO a -> IO ((), a)
forall a b. IO a -> IO b -> IO (a, b)
concurrently
      IO ()
fetchPackages
      (AsyncFetchMap -> IO a
body (AsyncFetchMap -> IO a) -> AsyncFetchMap -> IO a
forall a b. (a -> b) -> a -> b
$ [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
-> AsyncFetchMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UnresolvedPkgLoc, MVar (Either SomeException ResolvedPkgLoc))]
asyncDownloadVars)
  a -> IO a
forall a. a -> IO a
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 UnresolvedPkgLoc
-> AsyncFetchMap
-> Maybe (MVar (Either SomeException ResolvedPkgLoc))
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 (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Waiting for download of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnresolvedPkgLoc -> FilePath
forall a. Show a => a -> FilePath
show UnresolvedPkgLoc
srcloc
      (SomeException -> IO ResolvedPkgLoc)
-> (ResolvedPkgLoc -> IO ResolvedPkgLoc)
-> Either SomeException ResolvedPkgLoc
-> IO ResolvedPkgLoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO ResolvedPkgLoc
forall e a. Exception e => e -> IO a
throwIO ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException ResolvedPkgLoc -> IO ResolvedPkgLoc)
-> IO (Either SomeException ResolvedPkgLoc) -> IO ResolvedPkgLoc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar (Either SomeException ResolvedPkgLoc)
-> IO (Either SomeException ResolvedPkgLoc)
forall a. MVar a -> IO a
readMVar MVar (Either SomeException ResolvedPkgLoc)
hnd
    Maybe (MVar (Either SomeException ResolvedPkgLoc))
Nothing -> FilePath -> IO ResolvedPkgLoc
forall a. FilePath -> IO a
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
</> PackageId -> 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
</> PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgid)
    FilePath -> FilePath -> FilePath
</> Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageId -> Version
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.Posix.joinPath
              [ uriPath (remoteRepoURI repo)
              , prettyShow (packageName pkgid)
              , prettyShow (packageVersion pkgid)
              , prettyShow pkgid <.> "tar.gz"
              ]
        }
packageURI RemoteRepo
repo PackageId
pkgid =
  (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo)
    { uriPath =
        FilePath.Posix.joinPath
          [ uriPath (remoteRepoURI repo)
          , "package"
          , prettyShow pkgid <.> "tar.gz"
          ]
    }