Commit ba5c55c4 authored by Edsko de Vries's avatar Edsko de Vries

Introduce RepoContext

The RepoContext encapsulates the list of repositories, as well as some
associated state. In particular, it also encapsulates the HttpTransport, which
will be initialized on demand and cached thereafter.  This is important for two
reasons:

* For the hackage-security integration: in order to be able to use cabal's own
  HttpTransport API for the secure repo, we need to have access to that
  transport when we initialize the repo, but as things stood that was not
  possible (cabal was initializing repos ahead of time but the transport on
  demand).

* For the integration with the nix-local-branch it is important that the Repo
  type remains Serializable. By passing RepoContext rather than a list of
  Repos, we can leave RepoSecure serializable and separately maintain a mapping
  from cabal's Repo type to hackage-security's (stateful) Repository type.
parent 71609ec1
......@@ -27,22 +27,24 @@ import Distribution.Text (display)
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils (die)
import Distribution.Client.HttpUtils
import Distribution.Client.Setup
( RepoContext(..) )
type BuildReportId = URI
type BuildLog = String
uploadReports :: Verbosity -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
uploadReports verbosity auth uri reports = do
uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
uploadReports verbosity repoCtxt auth uri reports = do
forM_ reports $ \(report, mbBuildLog) -> do
buildId <- postBuildReport verbosity auth uri report
buildId <- postBuildReport verbosity repoCtxt auth uri report
case mbBuildLog of
Just buildLog -> putBuildLog verbosity auth buildId buildLog
Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog
Nothing -> return ()
postBuildReport :: Verbosity -> (String, String) -> URI -> BuildReport -> IO BuildReportId
postBuildReport verbosity auth uri buildReport = do
postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId
postBuildReport verbosity repoCtxt auth uri buildReport = do
let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }
transport <- configureTransport verbosity Nothing
transport <- repoContextGetTransport repoCtxt
res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth)
case res of
(303, redir) -> return $ undefined redir --TODO parse redir
......@@ -78,12 +80,12 @@ postBuildReport verbosity auth uri buildReport = do
-- TODO force this to be a PUT?
putBuildLog :: Verbosity -> (String, String)
putBuildLog :: Verbosity -> RepoContext -> (String, String)
-> BuildReportId -> BuildLog
-> IO ()
putBuildLog verbosity auth reportId buildLog = do
putBuildLog verbosity repoCtxt auth reportId buildLog = do
let fullURI = reportId {uriPath = uriPath reportId </> "log"}
transport <- configureTransport verbosity Nothing
transport <- repoContextGetTransport repoCtxt
res <- postHttp transport verbosity fullURI buildLog (Just auth)
case res of
(200, _) -> return ()
......
......@@ -28,7 +28,8 @@ import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName )
import Distribution.Client.Setup
( ConfigExFlags(..), configureCommand, filterConfigureFlags )
( ConfigExFlags(..), configureCommand, filterConfigureFlags
, RepoContext(..) )
import Distribution.Client.Types as Source
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
......@@ -93,7 +94,7 @@ chooseCabalVersion configExFlags maybeVersion =
-- | Configure the package found in the local directory
configure :: Verbosity
-> PackageDBStack
-> [Repo]
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
......@@ -101,11 +102,11 @@ configure :: Verbosity
-> ConfigExFlags
-> [String]
-> IO ()
configure verbosity packageDBs repos comp platform conf
configure verbosity packageDBs repoCtxt comp platform conf
configFlags configExFlags extraArgs = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
sourcePkgDb <- getSourcePackages verbosity repoCtxt
checkConfigExFlags verbosity installedPkgIndex
(packageIndex sourcePkgDb) configExFlags
......
......@@ -21,11 +21,9 @@ import Distribution.Client.FetchUtils hiding (fetchPackage)
import Distribution.Client.Dependency
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.HttpUtils
( configureTransport, HttpTransport(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FetchFlags(..) )
( GlobalFlags(..), FetchFlags(..), RepoContext(..) )
import Distribution.Package
( packageId )
......@@ -35,7 +33,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag, flagToMaybe )
( fromFlag )
import Distribution.Simple.Utils
( die, notice, debug )
import Distribution.System
......@@ -66,7 +64,7 @@ import Control.Monad
--
fetch :: Verbosity
-> PackageDBStack
-> [Repo]
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
......@@ -77,17 +75,15 @@ fetch :: Verbosity
fetch verbosity _ _ _ _ _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
fetch verbosity packageDBs repos comp platform conf
fetch verbosity packageDBs repoCtxt comp platform conf
globalFlags fetchFlags userTargets = do
mapM_ checkTarget userTargets
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
sourcePkgDb <- getSourcePackages verbosity repoCtxt
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
pkgSpecifiers <- resolveUserTargets verbosity transport
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
......@@ -109,7 +105,7 @@ fetch verbosity packageDBs repos comp platform conf
"The following packages would be fetched:"
: map (display . packageId) pkgs'
else mapM_ (fetchPackage transport verbosity . packageSource) pkgs'
else mapM_ (fetchPackage verbosity repoCtxt . packageSource) pkgs'
where
dryRun = fromFlag (fetchDryRun fetchFlags)
......@@ -185,8 +181,8 @@ checkTarget target = case target of
++ "In the meantime you can use the 'unpack' commands."
_ -> return ()
fetchPackage :: HttpTransport -> Verbosity -> PackageLocation a -> IO ()
fetchPackage transport verbosity pkgsrc = case pkgsrc of
fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of
LocalUnpackedPackage _dir -> return ()
LocalTarballPackage _file -> return ()
......@@ -195,5 +191,5 @@ fetchPackage transport verbosity pkgsrc = case pkgsrc of
++ "In the meantime you can use the 'unpack' commands."
RepoTarballPackage repo pkgid _ -> do
_ <- fetchRepoTarball transport verbosity repo pkgid
_ <- fetchRepoTarball verbosity repoCtxt repo pkgid
return ()
......@@ -39,6 +39,8 @@ import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import Distribution.Client.GlobalFlags
( RepoContext(..) )
import Data.Maybe
import System.Directory
......@@ -90,11 +92,11 @@ checkFetched loc = case loc of
-- | Fetch a package if we don't have it already.
--
fetchPackage :: HttpTransport
-> Verbosity
fetchPackage :: Verbosity
-> RepoContext
-> PackageLocation (Maybe FilePath)
-> IO (PackageLocation FilePath)
fetchPackage transport verbosity loc = case loc of
fetchPackage verbosity repoCtxt loc = case loc of
LocalUnpackedPackage dir ->
return (LocalUnpackedPackage dir)
LocalTarballPackage file ->
......@@ -108,10 +110,11 @@ fetchPackage transport verbosity loc = case loc of
path <- downloadTarballPackage uri
return (RemoteTarballPackage uri path)
RepoTarballPackage repo pkgid Nothing -> do
local <- fetchRepoTarball transport verbosity repo pkgid
local <- fetchRepoTarball verbosity repoCtxt repo pkgid
return (RepoTarballPackage repo pkgid local)
where
downloadTarballPackage uri = do
transport <- repoContextGetTransport repoCtxt
transportCheckHttps transport uri
notice verbosity ("Downloading " ++ show uri)
tmpdir <- getTemporaryDirectory
......@@ -123,8 +126,8 @@ fetchPackage transport verbosity loc = case loc of
-- | Fetch a repo package if we don't have it already.
--
fetchRepoTarball :: HttpTransport -> Verbosity -> Repo -> PackageId -> IO FilePath
fetchRepoTarball transport verbosity repo pkgid = do
fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
fetchRepoTarball verbosity repoCtxt repo pkgid = do
fetched <- doesFileExist (packageFile repo pkgid)
if fetched
then do info verbosity $ display pkgid ++ " has already been downloaded."
......@@ -136,6 +139,7 @@ fetchRepoTarball transport verbosity repo pkgid = do
RepoLocal{..} -> return (packageFile repo pkgid)
RepoRemote{..} -> do
transport <- repoContextGetTransport repoCtxt
remoteRepoCheckHttps transport repoRemote
let uri = packageURI repoRemote pkgid
dir = packageDir repo pkgid
......
......@@ -28,9 +28,8 @@ import Distribution.Client.InstallPlan
( InstallPlan, PlanPackage )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )
import Distribution.Client.HttpUtils
( configureTransport )
( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)
, RepoContext(..) )
import Distribution.Client.Sandbox.PackageEnvironment
( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
userPackageEnvironmentFile )
......@@ -76,7 +75,7 @@ import Distribution.Version
--
freeze :: Verbosity
-> PackageDBStack
-> [Repo]
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
......@@ -84,16 +83,13 @@ freeze :: Verbosity
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
sourcePkgDb <- getSourcePackages verbosity repoCtxt
transport <- configureTransport verbosity
(flagToMaybe (globalHttpTransport globalFlags))
pkgSpecifiers <- resolveUserTargets verbosity transport
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
[UserTargetLocalDir "."]
......
......@@ -21,7 +21,7 @@ module Distribution.Client.Get (
import Distribution.Package
( PackageId, packageId, packageName )
import Distribution.Simple.Setup
( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
( Flag(..), fromFlag, fromFlagOrDefault )
import Distribution.Simple.Utils
( notice, die, info, writeFileAtomic )
import Distribution.Verbosity
......@@ -30,13 +30,11 @@ import Distribution.Text(display)
import qualified Distribution.PackageDescription as PD
import Distribution.Client.Setup
( GlobalFlags(..), GetFlags(..) )
( GlobalFlags(..), GetFlags(..), RepoContext(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils
( configureTransport, HttpTransport(..) )
import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages )
......@@ -74,7 +72,7 @@ import System.Process
-- | Entry point for the 'cabal get' command.
get :: Verbosity
-> [Repo]
-> RepoContext
-> GlobalFlags
-> GetFlags
-> [UserTarget]
......@@ -82,7 +80,7 @@ get :: Verbosity
get verbosity _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
get verbosity repos globalFlags getFlags userTargets = do
get verbosity repoCtxt globalFlags getFlags userTargets = do
let useFork = case (getSourceRepository getFlags) of
NoFlag -> False
_ -> True
......@@ -90,11 +88,9 @@ get verbosity repos globalFlags getFlags userTargets = do
unless useFork $
mapM_ checkTarget userTargets
sourcePkgDb <- getSourcePackages verbosity repos
sourcePkgDb <- getSourcePackages verbosity repoCtxt
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
pkgSpecifiers <- resolveUserTargets verbosity transport
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
......@@ -108,7 +104,7 @@ get verbosity repos globalFlags getFlags userTargets = do
if useFork
then fork pkgs
else unpack transport pkgs
else unpack pkgs
where
resolverParams sourcePkgDb pkgSpecifiers =
......@@ -123,10 +119,10 @@ get verbosity repos globalFlags getFlags userTargets = do
branchers <- findUsableBranchers
mapM_ (forkPackage verbosity branchers prefix kind) pkgs
unpack :: HttpTransport -> [SourcePackage] -> IO ()
unpack transport pkgs = do
unpack :: [SourcePackage] -> IO ()
unpack pkgs = do
forM_ pkgs $ \pkg -> do
location <- fetchPackage transport verbosity (packageSource pkg)
location <- fetchPackage verbosity repoCtxt (packageSource pkg)
let pkgid = packageId pkg
descOverride | usePristine = Nothing
| otherwise = packageDescrOverride pkg
......
......@@ -2,14 +2,25 @@
module Distribution.Client.GlobalFlags (
GlobalFlags(..)
, defaultGlobalFlags
, RepoContext(..)
, withRepoContext
) where
import Distribution.Client.Types
( RemoteRepo(..) )
( Repo(..), RemoteRepo(..) )
import Distribution.Simple.Setup
( Flag(..) )
( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Utils.NubList
( NubList )
( NubList, fromNubList )
import Distribution.Client.HttpUtils
( HttpTransport, configureTransport )
import Distribution.Verbosity
( Verbosity )
import Control.Concurrent
( MVar, newMVar, modifyMVar )
import System.FilePath
( (</>) )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
......@@ -90,3 +101,56 @@ instance Monoid GlobalFlags where
globalHttpTransport = combine globalHttpTransport
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Repo context
-- ------------------------------------------------------------
-- | Access to repositories
data RepoContext = RepoContext {
-- | All user-specified repositories
repoContextRepos :: [Repo]
-- | Get the HTTP transport
--
-- The transport will be initialized on the first call to this function.
--
-- NOTE: It is important that we don't eagerly initialize the transport.
-- Initializing the transport is not free, and especially in contexts where
-- we don't know a-priori whether or not we need the transport (for instance
-- when using cabal in "nix mode") incurring the overhead of transport
-- initialization on _every_ invocation (eg @cabal build@) is undesirable.
, repoContextGetTransport :: IO HttpTransport
-- | Should we ignore expiry times (when checking security)?
, repoContextIgnoreExpiry :: Bool
}
withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext verbosity globalFlags callback = do
transportRef <- newMVar Nothing
callback RepoContext {
repoContextRepos = remoteRepos ++ localRepos
, repoContextGetTransport = getTransport transportRef
, repoContextIgnoreExpiry = fromFlagOrDefault False
(globalIgnoreExpiry globalFlags)
}
where
remoteRepos =
[ RepoRemote remote cacheDir
| remote <- fromNubList $ globalRemoteRepos globalFlags
, let cacheDir = fromFlag (globalCacheDir globalFlags)
</> remoteRepoName remote ]
localRepos =
[ RepoLocal local
| local <- fromNubList $ globalLocalRepos globalFlags ]
getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport
getTransport transportRef =
modifyMVar transportRef $ \mTransport -> do
transport <- case mTransport of
Just tr -> return tr
Nothing -> configureTransport
verbosity
(flagToMaybe (globalHttpTransport globalFlags))
return (Just transport, transport)
......@@ -59,6 +59,8 @@ import Distribution.Verbosity
( Verbosity, normal, lessVerbose )
import Distribution.Simple.Utils
( die, warn, info, fromUTF8, ignoreBOM )
import Distribution.Client.Setup
( RepoContext(..) )
import Data.Char (isAlphaNum)
import Data.Maybe (mapMaybe, catMaybes, maybeToList)
......@@ -108,17 +110,17 @@ getInstalledPackages verbosity comp packageDbs conf =
-- 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb
getSourcePackages verbosity [] = do
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages verbosity repoCtxt | null (repoContextRepos repoCtxt) = do
warn verbosity $ "No remote package servers have been specified. Usually "
++ "you would have one specified in the config file."
return SourcePackageDb {
packageIndex = mempty,
packagePreferences = mempty
}
getSourcePackages verbosity repos = do
getSourcePackages verbosity repoCtxt = do
info verbosity "Reading available packages..."
pkgss <- mapM (\r -> readRepoIndex verbosity r) repos
pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt)
let (pkgs, prefs) = mconcat pkgss
prefs' = Map.fromListWith intersectVersionRanges
[ (name, range) | Dependency name range <- prefs ]
......@@ -143,13 +145,13 @@ readCacheStrict verbosity index mkPkg = do
--
-- This is a higher level wrapper used internally in cabal-install.
--
readRepoIndex :: Verbosity -> Repo
readRepoIndex :: Verbosity -> RepoContext -> Repo
-> IO (PackageIndex SourcePackage, [Dependency])
readRepoIndex verbosity repo =
readRepoIndex verbosity repoCtxt repo =
handleNotFound $ do
warnIfIndexIsOld =<< getIndexFileAge repo
updateRepoIndexCache verbosity (RepoIndex repo)
readPackageIndexCacheFile mkAvailablePackage (RepoIndex repo)
updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
readPackageIndexCacheFile mkAvailablePackage (RepoIndex repoCtxt repo)
where
mkAvailablePackage pkgEntry =
......@@ -356,19 +358,19 @@ lazySequence = unsafeInterleaveIO . go
-- | Which index do we mean?
data Index =
-- | The main index for the specified repository
RepoIndex Repo
RepoIndex RepoContext Repo
-- | A sandbox-local repository
-- Argument is the location of the index file
| SandboxIndex FilePath
indexFile :: Index -> FilePath
indexFile (RepoIndex repo) = repoLocalDir repo </> "00-index.tar"
indexFile (SandboxIndex index) = index
indexFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.tar"
indexFile (SandboxIndex index) = index
cacheFile :: Index -> FilePath
cacheFile (RepoIndex repo) = repoLocalDir repo </> "00-index.cache"
cacheFile (SandboxIndex index) = index `replaceExtension` "cache"
cacheFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.cache"
cacheFile (SandboxIndex index) = index `replaceExtension` "cache"
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
......
......@@ -98,19 +98,21 @@ import Distribution.Client.PackageIndex
import Distribution.Client.IndexUtils
( getSourcePackages )
import Distribution.Client.Types
( SourcePackageDb(..), Repo )
( SourcePackageDb(..) )
import Distribution.Client.Setup
( RepoContext(..) )
initCabal :: Verbosity
-> PackageDBStack
-> [Repo]
-> RepoContext
-> Compiler
-> ProgramConfiguration
-> InitFlags
-> IO ()
initCabal verbosity packageDBs repos comp conf initFlags = do
initCabal verbosity packageDBs repoCtxt comp conf initFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
sourcePkgDb <- getSourcePackages verbosity repoCtxt
hSetBuffering stdout NoBuffering
......
......@@ -73,14 +73,14 @@ import Distribution.Client.Dependency.Types
( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) )
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils
( configureTransport, HttpTransport (..) )
( HttpTransport (..) )
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup
( GlobalFlags(..)
( GlobalFlags(..), RepoContext(..)
, ConfigFlags(..), configureCommand, filterConfigureFlags
, ConfigExFlags(..), InstallFlags(..) )
import Distribution.Client.Config
......@@ -186,7 +186,7 @@ import Distribution.Simple.BuildPaths ( exeExtension )
install
:: Verbosity
-> PackageDBStack
-> [Repo]
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
......@@ -239,7 +239,7 @@ type InstallContext = ( InstalledPackageIndex, SourcePackageDb
-- rid of it completely.
-- | Initial arguments given to 'install' or 'makeInstallContext'.
type InstallArgs = ( PackageDBStack
, [Repo]
, RepoContext
, Compiler
, Platform
, ProgramConfiguration
......@@ -255,15 +255,14 @@ type InstallArgs = ( PackageDBStack
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
-> IO InstallContext
makeInstallContext verbosity
(packageDBs, repos, comp, _, conf,_,_,
(packageDBs, repoCtxt, comp, _, conf,_,_,
globalFlags, _, configExFlags, _, _) mUserTargets = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
sourcePkgDb <- getSourcePackages verbosity repoCtxt
checkConfigExFlags verbosity installedPkgIndex
(packageIndex sourcePkgDb) configExFlags
transport <- configureTransport verbosity
(flagToMaybe (globalHttpTransport globalFlags))
transport <- repoContextGetTransport repoCtxt
(userTargets, pkgSpecifiers) <- case mUserTargets of
Nothing ->
......@@ -277,7 +276,7 @@ makeInstallContext verbosity
let userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0
pkgSpecifiers <- resolveUserTargets verbosity transport
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
......@@ -1034,7 +1033,7 @@ performInstallations :: Verbosity
-> InstallPlan
-> IO InstallPlan
performInstallations verbosity
(packageDBs, _, comp, platform, conf, useSandbox, _,
(packageDBs, repoCtxt, comp, platform, conf, useSandbox, _,
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
installedPkgIndex installPlan = do
......@@ -1051,13 +1050,10 @@ performInstallations verbosity
installLock <- newLock -- serialise installation
cacheLock <- newLock -- serialise access to setup exe cache
transport <- configureTransport verbosity
(flagToMaybe (globalHttpTransport globalFlags))
executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg ->
installReadyPackage platform cinfo configFlags
rpkg $ \configFlags' src pkg pkgoverride ->
fetchSourcePackage transport verbosity fetchLimit src $ \src' ->
fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit
(packageId pkg) src' distPref $ \mpath ->
installUnpackedPackage verbosity buildLimit installLock numJobs
......@@ -1265,19 +1261,19 @@ installReadyPackage platform cinfo configFlags
Right (desc, _) -> desc
fetchSourcePackage
:: HttpTransport
-> Verbosity
:: Verbosity
-> RepoContext
-> JobLimit
-> PackageLocation (Maybe FilePath)
-> (PackageLocation FilePath -> IO BuildResult)
-> IO BuildResult
fetchSourcePackage transport verbosity fetchLimit src installPkg = do
fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do
fetched <- checkFetched src
case fetched of
Just src' -> installPkg src'
Nothing -> onFailure DownloadFailed $ do
loc <- withJobLimit fetchLimit $
fetchPackage transport verbosity src
fetchPackage verbosity repoCtxt src
installPkg loc