Commit b780cc77 authored by U-CIQDEV\gbazerman's avatar U-CIQDEV\gbazerman Committed by Duncan Coutts
Browse files

Implement HTTPS support using external curl, wget and powershell

Supports both uploading and downloading.
Basic built-in HTTP is still supported.
parent 589cc887
......@@ -5,17 +5,17 @@ module Distribution.Client.BuildReports.Upload
( BuildLog
, BuildReportId
, uploadReports
, postBuildReport
, putBuildLog
) where
{-
import Network.Browser
( BrowserAction, request, setAllowRedirects )
import Network.HTTP
( Header(..), HeaderName(..)
, Request(..), RequestMethod(..), Response(..) )
import Network.TCP (HandleStream)
import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)
-}
import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)
import Control.Monad
( forM_ )
......@@ -24,22 +24,31 @@ import System.FilePath.Posix
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
import Distribution.Text (display)
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils (die)
import Distribution.Client.HttpUtils
type BuildReportId = URI
type BuildLog = String
uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
-> BrowserAction (HandleStream BuildLog) ()
uploadReports uri reports = do
uploadReports :: Verbosity -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
uploadReports verbosity auth uri reports = do
forM_ reports $ \(report, mbBuildLog) -> do
buildId <- postBuildReport uri report
buildId <- postBuildReport verbosity auth uri report
case mbBuildLog of
Just buildLog -> putBuildLog buildId buildLog
Just buildLog -> putBuildLog verbosity auth buildId buildLog
Nothing -> return ()
postBuildReport :: URI -> BuildReport
-> BrowserAction (HandleStream BuildLog) BuildReportId
postBuildReport uri buildReport = do
postBuildReport :: Verbosity -> (String, String) -> URI -> BuildReport -> IO BuildReportId
postBuildReport verbosity auth uri buildReport = do
let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }
transport <- configureTransport verbosity Nothing
res <- postHttp transport fullURI (BuildReport.show buildReport) (Just auth)
case res of
(303, redir) -> return $ undefined redir --TODO parse redir
_ -> die "unrecognized response" -- give response
{-
setAllowRedirects False
(_, response) <- request Request {
rqURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },
......@@ -64,17 +73,18 @@ postBuildReport uri buildReport = do
-> return $ buildId
_ -> error "Unrecognised response from server."
where body = BuildReport.show buildReport
-}
-- TODO force this to be a PUT?
putBuildLog :: BuildReportId -> BuildLog
-> BrowserAction (HandleStream BuildLog) ()
putBuildLog reportId buildLog = do
--FIXME: do something if the request fails
(_, _response) <- request Request {
rqURI = reportId{uriPath = uriPath reportId </> "log"},
rqMethod = PUT,
rqHeaders = [Header HdrContentType ("text/plain"),
Header HdrContentLength (show (length buildLog)),
Header HdrAccept ("text/plain")],
rqBody = buildLog
}
return ()
putBuildLog :: Verbosity -> (String, String)
-> BuildReportId -> BuildLog
-> IO ()
putBuildLog verbosity auth reportId buildLog = do
let fullURI = reportId {uriPath = uriPath reportId </> "log"}
transport <- configureTransport verbosity Nothing
res <- postHttp transport fullURI buildLog (Just auth)
case res of
(200, _) -> return ()
_ -> die "unrecognized response" -- give response
......@@ -219,7 +219,8 @@ instance Monoid SavedConfig where
globalLogsDir = combine globalLogsDir,
globalWorldFile = combine globalWorldFile,
globalRequireSandbox = combine globalRequireSandbox,
globalIgnoreSandbox = combine globalIgnoreSandbox
globalIgnoreSandbox = combine globalIgnoreSandbox,
globalHttpTransport = combine globalHttpTransport
}
where
combine = combine' savedGlobalFlags
......
......@@ -21,6 +21,8 @@ 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(..) )
......@@ -33,7 +35,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag )
( fromFlag, flagToMaybe )
import Distribution.Simple.Utils
( die, notice, debug )
import Distribution.System
......@@ -83,7 +85,9 @@ fetch verbosity packageDBs repos comp platform conf
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
pkgSpecifiers <- resolveUserTargets verbosity
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
pkgSpecifiers <- resolveUserTargets transport verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
......@@ -105,7 +109,7 @@ fetch verbosity packageDBs repos comp platform conf
"The following packages would be fetched:"
: map (display . packageId) pkgs'
else mapM_ (fetchPackage verbosity . packageSource) pkgs'
else mapM_ (fetchPackage transport verbosity . packageSource) pkgs'
where
dryRun = fromFlag (fetchDryRun fetchFlags)
......@@ -181,8 +185,8 @@ checkTarget target = case target of
++ "In the meantime you can use the 'unpack' commands."
_ -> return ()
fetchPackage :: Verbosity -> PackageLocation a -> IO ()
fetchPackage verbosity pkgsrc = case pkgsrc of
fetchPackage :: HttpTransport -> Verbosity -> PackageLocation a -> IO ()
fetchPackage transport verbosity pkgsrc = case pkgsrc of
LocalUnpackedPackage _dir -> return ()
LocalTarballPackage _file -> return ()
......@@ -191,5 +195,5 @@ fetchPackage verbosity pkgsrc = case pkgsrc of
++ "In the meantime you can use the 'unpack' commands."
RepoTarballPackage repo pkgid _ -> do
_ <- fetchRepoTarball verbosity repo pkgid
_ <- fetchRepoTarball transport verbosity repo pkgid
return ()
......@@ -27,7 +27,7 @@ module Distribution.Client.FetchUtils (
import Distribution.Client.Types
import Distribution.Client.HttpUtils
( downloadURI, isOldHackageURI, DownloadResult(..) )
( downloadURI, isOldHackageURI, DownloadResult(..), HttpTransport(..) )
import Distribution.Package
( PackageId, packageName, packageVersion )
......@@ -88,10 +88,11 @@ checkFetched loc = case loc of
-- | Fetch a package if we don't have it already.
--
fetchPackage :: Verbosity
fetchPackage :: HttpTransport
-> Verbosity
-> PackageLocation (Maybe FilePath)
-> IO (PackageLocation FilePath)
fetchPackage verbosity loc = case loc of
fetchPackage transport verbosity loc = case loc of
LocalUnpackedPackage dir ->
return (LocalUnpackedPackage dir)
LocalTarballPackage file ->
......@@ -105,7 +106,7 @@ fetchPackage verbosity loc = case loc of
path <- downloadTarballPackage uri
return (RemoteTarballPackage uri path)
RepoTarballPackage repo pkgid Nothing -> do
local <- fetchRepoTarball verbosity repo pkgid
local <- fetchRepoTarball transport verbosity repo pkgid
return (RepoTarballPackage repo pkgid local)
where
downloadTarballPackage uri = do
......@@ -113,14 +114,14 @@ fetchPackage verbosity loc = case loc of
tmpdir <- getTemporaryDirectory
(path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"
hClose hnd
_ <- downloadURI verbosity uri path
_ <- downloadURI transport verbosity uri path
return path
-- | Fetch a repo package if we don't have it already.
--
fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath
fetchRepoTarball verbosity repo pkgid = do
fetchRepoTarball :: HttpTransport -> Verbosity -> Repo -> PackageId -> IO FilePath
fetchRepoTarball transport verbosity repo pkgid = do
fetched <- doesFileExist (packageFile repo pkgid)
if fetched
then do info verbosity $ display pkgid ++ " has already been downloaded."
......@@ -136,20 +137,20 @@ fetchRepoTarball verbosity repo pkgid = do
dir = packageDir repo pkgid
path = packageFile repo pkgid
createDirectoryIfMissing True dir
_ <- downloadURI verbosity uri path
_ <- downloadURI transport verbosity uri path
return path
-- | Downloads an index file to [config-dir/packages/serv-id].
--
downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
downloadIndex verbosity repo cacheDir = do
downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
downloadIndex transport verbosity repo cacheDir = do
let uri = (remoteRepoURI repo) {
uriPath = uriPath (remoteRepoURI repo)
`FilePath.Posix.combine` "00-index.tar.gz"
}
path = cacheDir </> "00-index" <.> "tar.gz"
createDirectoryIfMissing True cacheDir
downloadURI verbosity uri path
downloadURI transport verbosity uri path
-- ------------------------------------------------------------
......
......@@ -27,6 +27,8 @@ import Distribution.Client.InstallPlan
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )
import Distribution.Client.HttpUtils
( configureTransport )
import Distribution.Client.Sandbox.PackageEnvironment
( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
userPackageEnvironmentFile )
......@@ -42,7 +44,7 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag, fromFlagOrDefault )
( fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.Utils
( die, notice, debug, writeFileAtomic )
import Distribution.System
......@@ -87,7 +89,9 @@ freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
pkgSpecifiers <- resolveUserTargets verbosity
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
pkgSpecifiers <- resolveUserTargets transport verbosity
(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 )
( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.Utils
( notice, die, info, writeFileAtomic )
import Distribution.Verbosity
......@@ -35,6 +35,8 @@ 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 )
......@@ -90,7 +92,9 @@ get verbosity repos globalFlags getFlags userTargets = do
sourcePkgDb <- getSourcePackages verbosity repos
pkgSpecifiers <- resolveUserTargets verbosity
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
pkgSpecifiers <- resolveUserTargets transport verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
......@@ -104,7 +108,7 @@ get verbosity repos globalFlags getFlags userTargets = do
if useFork
then fork pkgs
else unpack pkgs
else unpack transport pkgs
where
resolverParams sourcePkgDb pkgSpecifiers =
......@@ -119,10 +123,10 @@ get verbosity repos globalFlags getFlags userTargets = do
branchers <- findUsableBranchers
mapM_ (forkPackage verbosity branchers prefix kind) pkgs
unpack :: [SourcePackage] -> IO ()
unpack pkgs = do
unpack :: HttpTransport -> [SourcePackage] -> IO ()
unpack transport pkgs = do
forM_ pkgs $ \pkg -> do
location <- fetchPackage verbosity (packageSource pkg)
location <- fetchPackage transport verbosity (packageSource pkg)
let pkgid = packageId pkg
descOverride | usePristine = Nothing
| otherwise = packageDescrOverride pkg
......
......@@ -72,6 +72,8 @@ import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
( Solver(..) )
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils
( configureTransport, HttpTransport (..) )
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
......@@ -228,7 +230,7 @@ install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo
-- TODO: Make InstallContext a proper data type with documented fields.
-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext = ( InstalledPackageIndex, SourcePackageDb
, [UserTarget], [PackageSpecifier SourcePackage] )
, [UserTarget], [PackageSpecifier SourcePackage], HttpTransport )
-- TODO: Make InstallArgs a proper data type with documented fields or just get
-- rid of it completely.
......@@ -255,6 +257,7 @@ makeInstallContext verbosity
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
(userTargets, pkgSpecifiers) <- case mUserTargets of
Nothing ->
......@@ -268,13 +271,13 @@ makeInstallContext verbosity
let userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0
pkgSpecifiers <- resolveUserTargets verbosity
pkgSpecifiers <- resolveUserTargets transport verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
return (userTargets, pkgSpecifiers)
return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers, transport)
-- | Make an install plan given install context and install arguments.
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
......@@ -284,7 +287,7 @@ makeInstallPlan verbosity
_, configFlags, configExFlags, installFlags,
_)
(installedPkgIndex, sourcePkgDb,
_, pkgSpecifiers) = do
_, pkgSpecifiers, _) = do
solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
(compilerInfo comp)
......@@ -300,7 +303,7 @@ processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
processInstallPlan verbosity
args@(_,_, comp, _, _, _, _, _, _, _, installFlags, _)
(installedPkgIndex, sourcePkgDb,
userTargets, pkgSpecifiers) installPlan = do
userTargets, pkgSpecifiers, _) installPlan = do
checkPrintPlan verbosity comp installedPkgIndex installPlan sourcePkgDb
installFlags pkgSpecifiers
......@@ -687,7 +690,7 @@ reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String ->
reportPlanningFailure verbosity
(_, _, comp, platform, _, _, _
,_, configFlags, _, installFlags, _)
(_, sourcePkgDb, _, pkgSpecifiers)
(_, sourcePkgDb, _, pkgSpecifiers, _)
message = do
when reportFailure $ do
......@@ -1015,13 +1018,14 @@ 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 ->
-- Calculate the package key (ToDo: Is this right for source install)
let pkg_key = readyPackageKey comp rpkg in
installReadyPackage platform cinfo configFlags
rpkg $ \configFlags' src pkg pkgoverride ->
fetchSourcePackage verbosity fetchLimit src $ \src' ->
fetchSourcePackage transport verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit
(packageId pkg) src' distPref $ \mpath ->
installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key
......@@ -1217,18 +1221,19 @@ installReadyPackage platform cinfo configFlags
Right (desc, _) -> desc
fetchSourcePackage
:: Verbosity
:: HttpTransport
-> Verbosity
-> JobLimit
-> PackageLocation (Maybe FilePath)
-> (PackageLocation FilePath -> IO BuildResult)
-> IO BuildResult
fetchSourcePackage verbosity fetchLimit src installPkg = do
fetchSourcePackage transport verbosity fetchLimit src installPkg = do
fetched <- checkFetched src
case fetched of
Just src' -> installPkg src'
Nothing -> onFailure DownloadFailed $ do
loc <- withJobLimit fetchLimit $
fetchPackage verbosity src
fetchPackage transport verbosity src
installPkg loc
......
......@@ -30,7 +30,7 @@ import Distribution.Simple.Compiler
import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.Simple.Utils
( equating, comparing, die, notice )
import Distribution.Simple.Setup (fromFlag)
import Distribution.Simple.Setup (fromFlag, flagToMaybe)
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Client.PackageIndex as PackageIndex
......@@ -55,6 +55,8 @@ import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.FetchUtils
( isFetched )
import Distribution.Client.HttpUtils
( configureTransport )
import Data.List
( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )
......@@ -187,7 +189,8 @@ info verbosity packageDBs repos comp conf
(InstalledPackageIndex.allPackages installedPkgIndex)
++ map packageId
(PackageIndex.allPackages sourcePkgIndex)
pkgSpecifiers <- resolveUserTargets verbosity
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
pkgSpecifiers <- resolveUserTargets transport verbosity
(fromFlag $ globalWorldFile globalFlags)
sourcePkgs' userTargets
......
......@@ -126,7 +126,8 @@ data GlobalFlags = GlobalFlags {
globalLogsDir :: Flag FilePath,
globalWorldFile :: Flag FilePath,
globalRequireSandbox :: Flag Bool,
globalIgnoreSandbox :: Flag Bool
globalIgnoreSandbox :: Flag Bool,
globalHttpTransport :: Flag String
}
defaultGlobalFlags :: GlobalFlags
......@@ -141,7 +142,8 @@ defaultGlobalFlags = GlobalFlags {
globalLogsDir = mempty,
globalWorldFile = mempty,
globalRequireSandbox = Flag False,
globalIgnoreSandbox = Flag False
globalIgnoreSandbox = Flag False,
globalHttpTransport = mempty
}
globalCommand :: [Command action] -> CommandUI GlobalFlags
......@@ -260,7 +262,7 @@ globalCommand commands = CommandUI {
commandNotes = Nothing,
commandDefaultFlags = mempty,
commandOptions = \showOrParseArgs ->
(case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)
(case showOrParseArgs of ShowArgs -> take 7; ParseArgs -> id)
[option ['V'] ["version"]
"Print version information"
globalVersion (\v flags -> flags { globalVersion = v })
......@@ -291,6 +293,11 @@ globalCommand commands = CommandUI {
globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
trueArg
,option [] ["http-transport"]
"Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'insecure-http'. (default: 'curl')"
globalConfigFile (\v flags -> flags { globalHttpTransport = v })
(reqArgFlag "HttpTransport")
,option [] ["remote-repo"]
"The name and url for a remote repository"
globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
......@@ -330,7 +337,8 @@ instance Monoid GlobalFlags where
globalLogsDir = mempty,
globalWorldFile = mempty,
globalRequireSandbox = mempty,
globalIgnoreSandbox = mempty
globalIgnoreSandbox = mempty,
globalHttpTransport = mempty
}
mappend a b = GlobalFlags {
globalVersion = combine globalVersion,
......@@ -343,7 +351,8 @@ instance Monoid GlobalFlags where
globalLogsDir = combine globalLogsDir,
globalWorldFile = combine globalWorldFile,
globalRequireSandbox = combine globalRequireSandbox,
globalIgnoreSandbox = combine globalIgnoreSandbox
globalIgnoreSandbox = combine globalIgnoreSandbox,
globalHttpTransport = combine globalHttpTransport
}
where combine field = field a `mappend` field b
......@@ -1953,7 +1962,7 @@ sandboxCommand = CommandUI {
, headLine "init:"
, indentParagraph $ "Initialize a sandbox in the current directory."
++ " An existing package database will not be modified, but settings"
++ " (such as the location of the database) can be modified this way."
++ " (such as the location of the database) can be modified this way."
, headLine "delete:"
, indentParagraph $ "Remove the sandbox; deleting all the packages"
++ " installed inside."
......
......@@ -59,6 +59,7 @@ import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils ( HttpTransport(..) )
import Distribution.Client.Utils ( tryFindPackageDesc )
import Distribution.PackageDescription
......@@ -350,17 +351,18 @@ reportUserTargetProblems problems = do
-- or they can be named packages (with or without version info).
--
resolveUserTargets :: Package pkg
=> Verbosity
=> HttpTransport
-> Verbosity
-> FilePath
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier SourcePackage]
resolveUserTargets verbosity worldFile available userTargets = do
resolveUserTargets transport verbosity worldFile available userTargets = do
-- given the user targets, get a list of fully or partially resolved
-- package references
packageTargets <- mapM (readPackageTarget verbosity)
=<< mapM (fetchPackageTarget verbosity) . concat
=<< mapM (fetchPackageTarget transport verbosity) . concat
=<< mapM (expandUserTarget worldFile) userTargets
-- users are allowed to give package names case-insensitively, so we must
......@@ -446,14 +448,15 @@ localPackageError dir =
-- | Fetch any remote targets so that they can be read.
--
fetchPackageTarget :: Verbosity
fetchPackageTarget :: HttpTransport
-> Verbosity
-> PackageTarget (PackageLocation ())
-> IO (PackageTarget (PackageLocation FilePath))
fetchPackageTarget verbosity target = case target of
fetchPackageTarget transport verbosity target = case target of
PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut)
PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)
PackageTargetLocation location -> do
location' <- fetchPackage verbosity (fmap (const Nothing) location)
location' <- fetchPackage transport verbosity (fmap (const Nothing) location)
return (PackageTargetLocation location')
......
......@@ -17,7 +17,7 @@ module Distribution.Client.Update
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), LocalRepo(..) )
import Distribution.Client.HttpUtils
( DownloadResult(..) )
( DownloadResult(..), HttpTransport(..) )
import Distribution.Client.FetchUtils
( downloadIndex )
import Distribution.Client.IndexUtils
......@@ -36,11 +36,11 @@ import System.FilePath (dropExtension)
import Data.Either (lefts)
-- | 'update' downloads the package list from all known servers
update :: Verbosity -> [Repo] -> IO ()
update verbosity [] =
update :: HttpTransport -> Verbosity -> [Repo] -> IO ()
update _ verbosity [] =
warn verbosity $ "No remote package servers have been specified. Usually "
++ "you would have one specified in the config file."
update verbosity repos = do
update transport verbosity repos = do
jobCtrl <- newParallelJobControl
let remoteRepos = lefts (map repoKind repos)
case remoteRepos of
......@@ -51,14 +51,14 @@ update verbosity repos = do
_ -> notice verbosity . unlines
$ "Downloading the latest package lists from: "
: map (("- " ++) . remoteRepoName) remoteRepos
mapM_ (spawnJob jobCtrl . updateRepo verbosity) repos
mapM_ (spawnJob jobCtrl . updateRepo transport verbosity) repos
mapM_ (\_ -> collectJob jobCtrl) repos
updateRepo :: Verbosity -> Repo -> IO ()
updateRepo verbosity repo = case repoKind repo of
updateRepo :: HttpTransport -> Verbosity -> Repo -> IO ()
updateRepo transport verbosity repo = case repoKind repo of
Right LocalRepo -> return ()
Left remoteRepo -> do
downloadResult <- downloadIndex verbosity remoteRepo (repoLocalDir repo)
downloadResult <- downloadIndex transport verbosity remoteRepo (repoLocalDir repo)
case downloadResult of
FileAlreadyInCache -> return ()
FileDownloaded indexPath -> do
......