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

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
......
......@@ -3,13 +3,10 @@
module Distribution.Client.Upload (check, upload, report) where
import qualified Data.ByteString.Lazy.Char8 as B (concat, length, pack, readFile, unpack)
import Data.ByteString.Lazy.Char8 (ByteString)
import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))
import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse)
import Distribution.Client.HttpUtils (isOldHackageURI, HttpTransport(..))
import Distribution.Simple.Utils (debug, notice, warn, info)
import Distribution.Simple.Utils (notice, warn, info)
import Distribution.Verbosity (Verbosity)
import Distribution.Text (display)
import Distribution.Client.Config
......@@ -17,23 +14,16 @@ import Distribution.Client.Config
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import qualified Distribution.Client.BuildReports.Upload as BuildReport
import Network.Browser
( request )
import Network.HTTP
( Header(..), HeaderName(..), findHeader
, Request(..), RequestMethod(..), Response(..) )
import Network.URI (URI(uriPath), parseURI)