diff --git a/cabal-install/Distribution/Client/BuildReports/Upload.hs b/cabal-install/Distribution/Client/BuildReports/Upload.hs index c367f17396c433e598a5f13498863eabbd60c1e2..9da6d9fb5e3633d9c6faa4a185fe9f3bc6331c96 100644 --- a/cabal-install/Distribution/Client/BuildReports/Upload.hs +++ b/cabal-install/Distribution/Client/BuildReports/Upload.hs @@ -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 verbosity 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 verbosity fullURI buildLog (Just auth) + case res of + (200, _) -> return () + _ -> die "unrecognized response" -- give response diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 6e8d336d273fad143893512a1a7152a1eda90b63..6143c9e05e1b5dd851494d05ae2a2725d50a570a 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -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 @@ -476,7 +477,7 @@ defaultUserInstall = True -- global installs on Windows but that no longer works on Windows Vista or 7. defaultRemoteRepo :: RemoteRepo -defaultRemoteRepo = RemoteRepo name uri () +defaultRemoteRepo = RemoteRepo name uri () False where name = "hackage.haskell.org" uri = URI "http:" (Just (URIAuth "" name "")) "/" "" "" @@ -498,8 +499,10 @@ defaultRemoteRepo = RemoteRepo name uri () -- addInfoForKnownRepos :: RemoteRepo -> RemoteRepo addInfoForKnownRepos repo@RemoteRepo{ remoteRepoName = "hackage.haskell.org" } = - repo + repo { --remoteRepoRootKeys --TODO: when this list is empty, fill in known crypto credentials + remoteRepoShouldTryHttps = True + } addInfoForKnownRepos other = other -- diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs index a04a21f33308e10b9769731c532073e13fc349a5..cb863525c589cf1ed45464b7501fb03c12b68c05 100644 --- a/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal-install/Distribution/Client/Fetch.hs @@ -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 () diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs index 97920bbc30d378aaa4d45839bcbf2d950bedf4f4..7f126dd762014c0dd22e8c6cd385b1cde81f1d78 100644 --- a/cabal-install/Distribution/Client/FetchUtils.hs +++ b/cabal-install/Distribution/Client/FetchUtils.hs @@ -27,7 +27,8 @@ module Distribution.Client.FetchUtils ( import Distribution.Client.Types import Distribution.Client.HttpUtils - ( downloadURI, isOldHackageURI, DownloadResult(..) ) + ( downloadURI, isOldHackageURI, DownloadResult(..) + , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps ) import Distribution.Package ( PackageId, packageName, packageVersion ) @@ -88,10 +89,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,22 +107,23 @@ 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 + transportCheckHttps transport uri notice verbosity ("Downloading " ++ show uri) 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." @@ -132,24 +135,26 @@ fetchRepoTarball verbosity repo pkgid = do Right LocalRepo -> return (packageFile repo pkgid) Left remoteRepo -> do + remoteRepoCheckHttps transport remoteRepo let uri = packageURI remoteRepo pkgid 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 - let uri = (remoteRepoURI repo) { - uriPath = uriPath (remoteRepoURI repo) +downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult +downloadIndex transport verbosity remoteRepo cacheDir = do + remoteRepoCheckHttps transport remoteRepo + let uri = (remoteRepoURI remoteRepo) { + uriPath = uriPath (remoteRepoURI remoteRepo) `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 -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 8c1b9a18af97a9959d00167169e9abff2e8cdb59..98ec58cc73aa06cc8e46454b0f89ea9babfeca6a 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -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 "."] diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs index 1c288ad960723d63374188e942401aaf5aadbdc6..8fc36ea3cb1af11a97553afc27f2fb8394c7aed0 100644 --- a/cabal-install/Distribution/Client/Get.hs +++ b/cabal-install/Distribution/Client/Get.hs @@ -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 diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index 8e8e7dc4ab2c2e76134e766cf11504e874502f6e..6afc760e9d8c553f7dd9442db85f71b6bfe85116 100644 --- a/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal-install/Distribution/Client/HttpUtils.hs @@ -1,12 +1,15 @@ +{-# LANGUAGE CPP, BangPatterns #-} ----------------------------------------------------------------------------- -- | Separate module for HTTP actions, using a proxy server if one exists ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils ( DownloadResult(..), + configureTransport, + HttpTransport(..), downloadURI, - getHTTP, - cabalBrowse, - proxy, + transportCheckHttps, + remoteRepoCheckHttps, + remoteRepoTryUpgradeToHttps, isOldHackageURI ) where @@ -17,151 +20,665 @@ import Network.HTTP.Proxy ( Proxy(..), fetchProxy) import Network.URI ( URI (..), URIAuth (..) ) import Network.Browser - ( BrowserAction, browse, setAllowBasicAuth, setAuthorityGen - , setOutHandler, setErrHandler, setProxy, request) -import Network.Stream - ( Result, ConnError(..) ) -import Control.Exception - ( handleJust ) + ( browse, setOutHandler, setErrHandler, setProxy + , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import qualified Control.Exception as Exception import Control.Monad - ( liftM, guard ) -import qualified Data.ByteString.Lazy.Char8 as ByteString -import Data.ByteString.Lazy (ByteString) - + ( when, guard ) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.List + ( isPrefixOf, find, intercalate ) +import Data.Maybe + ( listToMaybe, maybeToList ) import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, info, warn, debug, notice - , copyFileVerbose, writeFileAtomic ) + ( die, info, warn, debug, notice, writeFileAtomic + , copyFileVerbose, withTempFile + , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings ) +import Distribution.Client.Utils + ( readMaybe, withTempFileName ) +import Distribution.Client.Types + ( RemoteRepo(..) ) import Distribution.System ( buildOS, buildArch ) import Distribution.Text ( display ) -import Data.Char ( isSpace ) +import Data.Char + ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix ( splitDirectories ) import System.FilePath ( (<.>) ) import System.Directory - ( doesFileExist ) + ( doesFileExist, renameFile ) import System.IO.Error ( isDoesNotExistError ) +import Distribution.Simple.Program + ( Program, simpleProgram, ConfiguredProgram, programPath + , ProgramInvocation(..), programInvocation + , getProgramInvocationOutput ) +import Distribution.Simple.Program.Db + ( ProgramDb, emptyProgramDb, addKnownPrograms + , configureAllKnownPrograms + , requireProgram, lookupProgram ) +import Distribution.Simple.Program.Run + ( IOEncoding(..), getEffectiveEnvironment ) +import Numeric (showHex) +import System.Directory (canonicalizePath) +import System.IO (hClose, hPutStr) +import System.FilePath (takeFileName, takeDirectory) +import System.Random (randomRIO) +import System.Exit (ExitCode(..)) -data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath deriving (Eq) --- Trim -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace +------------------------------------------------------------------------------ +-- Downloading a URI, given an HttpTransport +-- --- |Get the local proxy settings ---TODO: print info message when we're using a proxy based on verbosity -proxy :: Verbosity -> IO Proxy -proxy _verbosity = do - p <- fetchProxy True - -- Handle empty proxy strings - return $ case p of - Proxy uri auth -> - let uri' = trim uri in - if uri' == "" then NoProxy else Proxy uri' auth - _ -> p - -mkRequest :: URI - -> Maybe String -- ^ Optional etag to be set in the If-None-Match HTTP header. - -> Request ByteString -mkRequest uri etag = Request{ rqURI = uri - , rqMethod = GET - , rqHeaders = Header HdrUserAgent userAgent : ifNoneMatchHdr - , rqBody = ByteString.empty } - where userAgent = concat [ "cabal-install/", display Paths_cabal_install.version - , " (", display buildOS, "; ", display buildArch, ")" - ] - ifNoneMatchHdr = maybe [] (\t -> [Header HdrIfNoneMatch t]) etag - --- |Carry out a GET request, using the local proxy settings -getHTTP :: Verbosity - -> URI - -> Maybe String -- ^ Optional etag to check if we already have the latest file. - -> IO (Result (Response ByteString)) -getHTTP verbosity uri etag = liftM (\(_, resp) -> Right resp) $ - cabalBrowse verbosity Nothing (request (mkRequest uri etag)) - -cabalBrowse :: Verbosity - -> Maybe (String, String) - -> BrowserAction s a - -> IO a -cabalBrowse verbosity auth act = do - p <- proxy verbosity - handleJust - (guard . isDoesNotExistError) - (const . die $ "Couldn't establish HTTP connection. " - ++ "Possible cause: HTTP proxy server is down.") $ - browse $ do - setProxy p - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - setAllowBasicAuth False - setAuthorityGen (\_ _ -> return auth) - act - -downloadURI :: Verbosity +data DownloadResult = FileAlreadyInCache + | FileDownloaded FilePath + deriving (Eq) + +downloadURI :: HttpTransport + -> Verbosity -> URI -- ^ What to download -> FilePath -- ^ Where to put it -> IO DownloadResult -downloadURI verbosity uri path | uriScheme uri == "file:" = do +downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do copyFileVerbose verbosity (uriPath uri) path return (FileDownloaded path) -- Can we store the hash of the file so we can safely return path when the -- hash matches to avoid unnecessary computation? -downloadURI verbosity uri path = do - let etagPath = path <.> "etag" - targetExists <- doesFileExist path - etagPathExists <- doesFileExist etagPath - -- In rare cases the target file doesn't exist, but the etag does. - etag <- if targetExists && etagPathExists - then liftM Just $ readFile etagPath - else return Nothing - - result <- getHTTP verbosity uri etag - let result' = case result of - Left err -> Left err - Right rsp -> case rspCode rsp of - (2,0,0) -> Right rsp - (3,0,4) -> Right rsp - (a,b,c) -> Left err - where - err = ErrorMisc $ "Error HTTP code: " - ++ concatMap show [a,b,c] - - -- Only write the etag if we get a 200 response code. - -- A 304 still sends us an etag header. - case result' of - Left _ -> return () - Right rsp -> case rspCode rsp of - (2,0,0) -> case lookupHeader HdrETag (rspHeaders rsp) of - Nothing -> return () - Just newEtag -> writeFile etagPath newEtag - (_,_,_) -> return () - - case result' of - Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err - Right rsp -> case rspCode rsp of - (2,0,0) -> do - info verbosity ("Downloaded to " ++ path) - writeFileAtomic path $ rspBody rsp - return (FileDownloaded path) - (3,0,4) -> do - notice verbosity "Skipping download: Local and remote files match." - return FileAlreadyInCache - (_,_,_) -> return (FileDownloaded path) - --FIXME: check the content-length header matches the body length. - --TODO: stream the download into the file rather than buffering the whole - -- thing in memory. - --- Utility function for legacy support. + +downloadURI transport verbosity uri path = do + + let etagPath = path <.> "etag" + targetExists <- doesFileExist path + etagPathExists <- doesFileExist etagPath + -- In rare cases the target file doesn't exist, but the etag does. + etag <- if targetExists && etagPathExists + then Just <$> readFile etagPath + else return Nothing + + -- Only use the external http transports if we actually have to + -- (or have been told to do so) + let transport' + | uriScheme uri == "http:" + , not (transportManuallySelected transport) + = plainHttpTransport + + | otherwise + = transport + + withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do + result <- getHttp transport' verbosity uri etag tmpFile + + -- Only write the etag if we get a 200 response code. + -- A 304 still sends us an etag header. + case result of + (200, Just newEtag) -> writeFile etagPath newEtag + _ -> return () + + case fst result of + 200 -> do + info verbosity ("Downloaded to " ++ path) + renameFile tmpFile path + return (FileDownloaded path) + 304 -> do + notice verbosity "Skipping download: local and remote files match." + return FileAlreadyInCache + errCode -> die $ "Failed to download " ++ show uri + ++ " : HTTP code " ++ show errCode + +------------------------------------------------------------------------------ +-- Utilities for repo url management +-- + +remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO () +remoteRepoCheckHttps transport repo + | uriScheme (remoteRepoURI repo) == "https:" + , not (transportSupportsHttps transport) + = die $ "The remote repository '" ++ remoteRepoName repo + ++ "' specifies a URL that " ++ requiresHttpsErrorMessage + | otherwise = return () + +transportCheckHttps :: HttpTransport -> URI -> IO () +transportCheckHttps transport uri + | uriScheme uri == "https:" + , not (transportSupportsHttps transport) + = die $ "The URL " ++ show uri + ++ " " ++ requiresHttpsErrorMessage + | otherwise = return () + +requiresHttpsErrorMessage :: String +requiresHttpsErrorMessage = + "requires HTTPS however the built-in HTTP implementation " + ++ "does not support HTTPS. The transport implementations with HTTPS " + ++ "support are " ++ intercalate ", " + [ name | (name, _, True, _ ) <- supportedTransports ] + ++ ". One of these will be selected automatically if the corresponding " + ++ "external program is available, or one can be selected specifically " + ++ "with the global flag --http-transport=" + +remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo +remoteRepoTryUpgradeToHttps transport repo + | remoteRepoShouldTryHttps repo + , uriScheme (remoteRepoURI repo) == "http:" + , not (transportSupportsHttps transport) + , not (transportManuallySelected transport) + = die $ "The builtin HTTP implementation does not support HTTPS, but using " + ++ "HTTPS for authenticated uploads is recommended. " + ++ "The transport implementations with HTTPS support are " + ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] + ++ "but they require the corresponding external program to be " + ++ "available. You can either make one available or use plain HTTP by " + ++ "using the global flag --http-transport=plain-http (or putting the " + ++ "equivalent in the config file). With plain HTTP, your password " + ++ "is sent using HTTP digest authentication so it cannot be easily " + ++ "intercepted, but it is not as secure as using HTTPS." + + | remoteRepoShouldTryHttps repo + , uriScheme (remoteRepoURI repo) == "http:" + , transportSupportsHttps transport + = return repo { + remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" } + } + + | otherwise + = return repo + +-- | Utility function for legacy support. isOldHackageURI :: URI -> Bool isOldHackageURI uri = case uriAuthority uri of Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"] _ -> False + + +------------------------------------------------------------------------------ +-- Setting up a HttpTransport +-- + +data HttpTransport = HttpTransport { + -- | GET a URI, with an optional ETag (to do a conditional fetch), + -- write the resource to the given file and return the HTTP status code, + -- and optional ETag. + getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath + -> IO (HttpCode, Maybe ETag), + + -- | POST a resource to a URI, with optional auth (username, password) + -- and return the HTTP status code and any redirect URL. + postHttp :: Verbosity -> URI -> String -> Maybe Auth + -> IO (HttpCode, String), + + -- | POST a file resource to a URI using multipart\/form-data encoding, + -- with optional auth (username, password) and return the HTTP status + -- code and any error string. + postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth + -> IO (HttpCode, String), + + -- | Whether this transport supports https or just http. + transportSupportsHttps :: Bool, + + -- | Whether this transport implementation was specifically chosen by + -- the user via configuration, or whether it was automatically selected. + -- Strictly speaking this is not a property of the transport itself but + -- about how it was chosen. Nevertheless it's convenient to keep here. + transportManuallySelected :: Bool + } + --TODO: why does postHttp return a redirect, but postHttpFile return errors? + +type HttpCode = Int +type ETag = String +type Auth = (String, String) + +noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) + -> IO (Int, String) +noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet" + +supportedTransports :: [(String, Maybe Program, Bool, + ProgramDb -> Maybe HttpTransport)] +supportedTransports = + [ let prog = simpleProgram "curl" in + ( "curl", Just prog, True + , \db -> curlTransport <$> lookupProgram prog db ) + + , let prog = simpleProgram "wget" in + ( "wget", Just prog, True + , \db -> wgetTransport <$> lookupProgram prog db ) + + , let prog = simpleProgram "powershell" in + ( "powershell", Just prog, True + , \db -> powershellTransport <$> lookupProgram prog db ) + + , ( "plain-http", Nothing, False + , \_ -> Just plainHttpTransport ) + ] + +configureTransport :: Verbosity -> Maybe String -> IO HttpTransport + +configureTransport verbosity (Just name) = + -- the user secifically selected a transport by name so we'll try and + -- configure that one + + case find (\(name',_,_,_) -> name' == name) supportedTransports of + Just (_, mprog, _tls, mkTrans) -> do + + progdb <- case mprog of + Nothing -> return emptyProgramDb + Just prog -> snd <$> requireProgram verbosity prog emptyProgramDb + -- ^^ if it fails, it'll fail here + + let Just transport = mkTrans progdb + return transport { transportManuallySelected = True } + + Nothing -> die $ "Unknown HTTP transport specified: " ++ name + ++ ". The supported transports are " + ++ intercalate ", " + [ name' | (name', _, _, _ ) <- supportedTransports ] + +configureTransport verbosity Nothing = do + -- the user hasn't selected a transport, so we'll pick the first one we + -- can configure successfully, provided that it supports tls + + -- for all the transports except plain-http we need to try and find + -- their external executable + progdb <- configureAllKnownPrograms verbosity $ + addKnownPrograms + [ prog | (_, Just prog, _, _) <- supportedTransports ] + emptyProgramDb + + let availableTransports = + [ (name, transport) + | (name, _, _, mkTrans) <- supportedTransports + , transport <- maybeToList (mkTrans progdb) ] + -- there's always one because the plain one is last and never fails + let (name, transport) = head availableTransports + debug verbosity $ "Selected http transport implementation: " ++ name + + return transport { transportManuallySelected = False } + + +------------------------------------------------------------------------------ +-- The HttpTransports based on external programs +-- + +curlTransport :: ConfiguredProgram -> HttpTransport +curlTransport prog = + HttpTransport gethttp posthttp posthttpfile True False + where + gethttp verbosity uri etag destPath = do + withTempFile (takeDirectory destPath) + "curl-headers.txt" $ \tmpFile tmpHandle -> do + hClose tmpHandle + let args = [ show uri + , "--output", destPath + , "--location" + , "--write-out", "%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--dump-header", tmpFile ] + ++ concat + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag ] + + resp <- getProgramInvocationOutput verbosity + (programInvocation prog args) + headers <- readFile tmpFile + (code, _err, etag') <- parseResponse uri resp headers + return (code, etag') + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = do + let args = [ show uri + , "--form", "package=@"++path + , "--write-out", "%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--header", "Accept: text/plain" ] + ++ concat + [ ["--digest", "--user", uname ++ ":" ++ passwd] + | (uname,passwd) <- maybeToList auth ] + resp <- getProgramInvocationOutput verbosity + (programInvocation prog args) + (code, err, _etag) <- parseResponse uri resp "" + return (code, err) + + -- on success these curl involcations produces an output like "200" + -- and on failure it has the server error response first + parseResponse uri resp headers = + let codeerr = + case reverse (lines resp) of + (codeLine:rerrLines) -> + case readMaybe (trim codeLine) of + Just i -> let errstr = unlines (reverse rerrLines) + in Just (i, errstr) + Nothing -> Nothing + [] -> Nothing + + mb_etag :: Maybe ETag + mb_etag = listToMaybe $ reverse + [ etag + | ["ETag:", etag] <- map words (lines headers) ] + + in case codeerr of + Just (i, err) -> return (i, err, mb_etag) + _ -> statusParseFail uri resp + + +wgetTransport :: ConfiguredProgram -> HttpTransport +wgetTransport prog = + HttpTransport gethttp posthttp posthttpfile True False + where + gethttp verbosity uri etag destPath = do + resp <- runWGet verbosity args + (code, _err, etag') <- parseResponse uri resp + return (code, etag') + where + args = [ show uri + , "--output-document=" ++ destPath + , "--user-agent=" ++ userAgent + , "--tries=5" + , "--timeout=15" + , "--server-response" ] + ++ concat + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag ] + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = + withTempFile (takeDirectory path) + (takeFileName path) $ \tmpFile tmpHandle -> do + (body, boundary) <- generateMultipartBody path + BS.hPut tmpHandle body + BS.writeFile "wget.in" body + hClose tmpHandle + let args = [ show uri + , "--post-file=" ++ tmpFile + , "--user-agent=" ++ userAgent + , "--server-response" + , "--header=Content-type: multipart/form-data; " ++ + "boundary=" ++ boundary ] + ++ concat + [ [ "--http-user=" ++ uname + , "--http-password=" ++ passwd ] + | (uname,passwd) <- maybeToList auth ] + + resp <- runWGet verbosity args + (code, err, _etag) <- parseResponse uri resp + return (code, err) + + runWGet verbosity args = do + -- wget returns its output on stderr rather than stdout + (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity + (programInvocation prog args) + -- wget returns exit code 8 for server "errors" like "304 not modified" + if exitCode == ExitSuccess || exitCode == ExitFailure 8 + then return resp + else die $ "'" ++ programPath prog + ++ "' exited with an error:\n" ++ resp + + -- With the --server-response flag, wget produces output with the full + -- http server response with all headers, we want to find a line like + -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple + -- requests due to redirects. + -- + -- Unfortunately wget apparently cannot be persuaded to give us the body + -- of error responses, so we just return the human readable status message + -- like "Forbidden" etc. + parseResponse uri resp = + let codeerr = listToMaybe + [ (code, unwords err) + | (protocol:codestr:err) <- map words (reverse (lines resp)) + , "HTTP/" `isPrefixOf` protocol + , code <- maybeToList (readMaybe codestr) ] + mb_etag :: Maybe ETag + mb_etag = listToMaybe + [ etag + | ["ETag:", etag] <- map words (reverse (lines resp)) ] + in case codeerr of + Just (i, err) -> return (i, err, mb_etag) + _ -> statusParseFail uri resp + + +powershellTransport :: ConfiguredProgram -> HttpTransport +powershellTransport prog = + HttpTransport gethttp posthttp posthttpfile True False + where + gethttp verbosity uri etag destPath = + withTempFile (takeDirectory destPath) + "psScript.ps1" $ \tmpFile tmpHandle -> do + hPutStr tmpHandle script + hClose tmpHandle + let args = ["-InputFormat", "None", "-File", tmpFile] + resp <- getProgramInvocationOutput verbosity + (programInvocation prog args) + parseResponse resp + where + script = + concatMap (++";\n") $ + [ "$wc = new-object system.net.webclient" + , "$wc.Headers.Add(\"user-agent\","++escape userAgent++")"] + ++ [ "$wc.Headers.Add(\"If-None-Match\"," ++ t ++ ")" + | t <- maybeToList etag ] + ++ [ "Try {" + , "$wc.DownloadFile("++ escape (show uri) ++ + "," ++ escape destPath ++ ")" + , "} Catch {Write-Error $_; Exit(5);}" + , "Write-Host \"200\"" + , "Write-Host $wc.ResponseHeaders.Item(\"ETag\")" + , "Exit" ] + + escape x = '"' : x ++ "\"" --TODO write/find real escape. + + parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of + Just i -> return (i, Nothing) -- TODO extract real etag + Nothing -> statusParseFail uri x + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = + withTempFile (takeDirectory path) + (takeFileName path) $ \tmpFile tmpHandle -> + withTempFile (takeDirectory path) + "psScript.ps1" $ \tmpScriptFile tmpScriptHandle -> do + (body, boundary) <- generateMultipartBody path + BS.hPut tmpHandle body + hClose tmpHandle + + fullPath <- canonicalizePath tmpFile + hPutStr tmpScriptHandle (script fullPath boundary) + hClose tmpScriptHandle + let args = ["-InputFormat", "None", "-File", tmpScriptFile] + resp <- getProgramInvocationOutput verbosity + (programInvocation prog args) + parseResponse resp + where + script fullPath boundary = + concatMap (++";\n") $ + [ "$wc = new-object system.net.webclient" + , "$wc.Headers.Add(\"user-agent\","++escape userAgent++")" + , "$wc.Headers.Add(\"Content-type\"," ++ + "\"multipart/form-data; " ++ + "boundary="++boundary++"\")" ] + ++ [ "$wc.Credentials = new-object System.Net.NetworkCredential(" + ++ escape uname ++ "," ++ escape passwd ++ ",\"\")" + | (uname,passwd) <- maybeToList auth ] + ++ [ "Try {" + , "$bytes = [System.IO.File]::ReadAllBytes("++escape fullPath++")" + , "$wc.UploadData("++ escape (show uri) ++ ",$bytes)" + , "} Catch {Write-Error $_; Exit(1);}" + , "Write-Host \"200\"" + , "Exit" ] + + escape x = show x + + parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of + Just i -> return (i, x) -- TODO extract real etag + Nothing -> statusParseFail uri x + + +------------------------------------------------------------------------------ +-- The builtin plain HttpTransport +-- + +plainHttpTransport :: HttpTransport +plainHttpTransport = + HttpTransport gethttp posthttp posthttpfile False False + where + gethttp verbosity uri etag destPath = do + let req = Request{ + rqURI = uri, + rqMethod = GET, + rqHeaders = [ Header HdrIfNoneMatch t + | t <- maybeToList etag ], + rqBody = BS.empty + } + (_, resp) <- cabalBrowse verbosity Nothing (request req) + let code = convertRspCode (rspCode resp) + etag' = lookupHeader HdrETag (rspHeaders resp) + when (code==200) $ + writeFileAtomic destPath $ rspBody resp + return (code, etag') + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = do + (body, boundary) <- generateMultipartBody path + let headers = [ Header HdrContentType + ("multipart/form-data; boundary="++boundary) + , Header HdrContentLength (show (BS.length body)) + , Header HdrAccept ("text/plain") + ] + req = Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = headers, + rqBody = body + } + (_, resp) <- cabalBrowse verbosity auth (request req) + return (convertRspCode (rspCode resp), rspErrorString resp) + + convertRspCode (a,b,c) = a*100 + b*10 + c + + rspErrorString resp = + case lookupHeader HdrContentType (rspHeaders resp) of + Just contenttype + | takeWhile (/= ';') contenttype == "text/plain" + -> BS.unpack (rspBody resp) + _ -> rspReason resp + + cabalBrowse verbosity auth act = do + p <- fixupEmptyProxy <$> fetchProxy True + Exception.handleJust + (guard . isDoesNotExistError) + (const . die $ "Couldn't establish HTTP connection. " + ++ "Possible cause: HTTP proxy server is down.") $ + browse $ do + setProxy p + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + setUserAgent userAgent + setAllowBasicAuth False + setAuthorityGen (\_ _ -> return auth) + act + + fixupEmptyProxy (Proxy uri _) | null uri = NoProxy + fixupEmptyProxy p = p + + +------------------------------------------------------------------------------ +-- Common stuff used by multiple transport impls +-- + +userAgent :: String +userAgent = concat [ "cabal-install/", display Paths_cabal_install.version + , " (", display buildOS, "; ", display buildArch, ")" + ] + +statusParseFail :: URI -> String -> IO a +statusParseFail uri r = + die $ "Failed to download " ++ show uri ++ " : " + ++ "No Status Code could be parsed from response: " ++ r + +-- Trim +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + + +------------------------------------------------------------------------------ +-- Multipart stuff partially taken from cgi package. +-- + +generateMultipartBody :: FilePath -> IO (BS.ByteString, String) +generateMultipartBody path = do + content <- BS.readFile path + boundary <- genBoundary + let !body = formatBody content (BS.pack boundary) + return (body, boundary) + where + formatBody content boundary = + BS.concat $ + [ crlf, dd, boundary, crlf ] + ++ [ BS.pack (show header) | header <- headers ] + ++ [ crlf + , content + , crlf, dd, boundary, dd, crlf ] + + headers = + [ Header (HdrCustom "Content-disposition") + ("form-data; name=package; " ++ + "filename=\"" ++ takeFileName path ++ "\"") + , Header HdrContentType "application/x-gzip" + ] + + crlf = BS.pack "\r\n" + dd = BS.pack "--" + +genBoundary :: IO String +genBoundary = do + i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" + +------------------------------------------------------------------------------ +-- Compat utils + +-- TODO: This is only here temporarily so we can release without also requiring +-- the latest Cabal lib. The function is also included in Cabal now. + +getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation + -> IO (String, String, ExitCode) +getProgramInvocationOutputAndErrors verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envOverrides, + progInvokeCwd = mcwd, + progInvokeInput = minputStr, + progInvokeOutputEncoding = encoding + } = do + let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False + decode | utf8 = fromUTF8 . normaliseLineEndings + | otherwise = id + menv <- getEffectiveEnvironment envOverrides + (output, errors, exitCode) <- rawSystemStdInOut verbosity + path args + mcwd menv + input utf8 + return (decode output, decode errors, exitCode) + where + input = + case minputStr of + Nothing -> Nothing + Just inputStr -> Just $ + case encoding of + IOEncodingText -> (inputStr, False) + IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index c1c53c26fe3015277be32d0a19d062cd810b6c4d..c8cef42e59829324162cd3fff95f5f28bae0822a 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -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 diff --git a/cabal-install/Distribution/Client/List.hs b/cabal-install/Distribution/Client/List.hs index dbcd3f9fc051644213584c8ff058e46c1f3e4247..3ce3dd253335c1d7fd89bce666fb68b60a0eba6b 100644 --- a/cabal-install/Distribution/Client/List.hs +++ b/cabal-install/Distribution/Client/List.hs @@ -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 diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 319fef6a3b5d509189a516b1c04c342503a52cbe..264e13982075d238e306a61da144e27587258d8a 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -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 'plain-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." @@ -2254,14 +2263,15 @@ readRepo = readPToMaybe parseRepo parseRepo :: Parse.ReadP r RemoteRepo parseRepo = do - name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") - _ <- Parse.char ':' + name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") + _ <- Parse.char ':' uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") - uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) - return $ RemoteRepo { - remoteRepoName = name, - remoteRepoURI = uri, - remoteRepoRootKeys = () + uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) + return RemoteRepo { + remoteRepoName = name, + remoteRepoURI = uri, + remoteRepoRootKeys = (), + remoteRepoShouldTryHttps = False } -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index c5a5c676a572912bcf1e2718ad1a4fd69d3f7a9a..dbc5731198d98bb3bd454915ea603a56fdb437e7 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -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 @@ -264,7 +265,7 @@ readUserTarget targetstr = uriScheme = scheme, uriAuthority = Just URIAuth { uriRegName = host } } - | scheme /= "http:" -> + | scheme /= "http:" && scheme /= "https:" -> Just (Left (UserTargetUnexpectedUriScheme targetstr)) | null host -> @@ -331,7 +332,7 @@ reportUserTargetProblems problems = do $ unlines [ "URL target not supported '" ++ name ++ "'." | name <- target ] - ++ "Only 'http://' URLs are supported." + ++ "Only 'http://' and 'https://' URLs are supported." case [ target | UserTargetUnrecognisedUri target <- problems ] of [] -> return () @@ -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') diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index 2a45e3b3bc560d658c50736c23a693038765ee18..1ac90a1324158b8456d79205ae7e97fd1f3fd588 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -239,7 +239,15 @@ data RemoteRepo = RemoteRepo { remoteRepoName :: String, remoteRepoURI :: URI, - remoteRepoRootKeys :: () + remoteRepoRootKeys :: (), + + -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a + -- special case we may know a repo supports both and want to try HTTPS + -- if we can, but still allow falling back to HTTP. + -- + -- This field is not currently stored in the config file, but is filled + -- in automagically for known repos. + remoteRepoShouldTryHttps :: Bool } -- FIXME: discuss this type some more. @@ -248,7 +256,7 @@ data RemoteRepo = -- | Construct a partial 'RemoteRepo' value to fold the field parser list over. emptyRemoteRepo :: String -> RemoteRepo -emptyRemoteRepo name = RemoteRepo name nullURI () +emptyRemoteRepo name = RemoteRepo name nullURI () False data Repo = Repo { repoKind :: Either RemoteRepo LocalRepo, diff --git a/cabal-install/Distribution/Client/Update.hs b/cabal-install/Distribution/Client/Update.hs index 50e35e1ea44d2f33abb7e429221dc27f7b248a21..069488320c248455a3188ad0cc147969edfa87df 100644 --- a/cabal-install/Distribution/Client/Update.hs +++ b/cabal-install/Distribution/Client/Update.hs @@ -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 diff --git a/cabal-install/Distribution/Client/Upload.hs b/cabal-install/Distribution/Client/Upload.hs index 3801f336ecab15fcedd84c461cd93678ed48a809..8555a9f713ef3df8e257a258b3aac83c549be6fd 100644 --- a/cabal-install/Distribution/Client/Upload.hs +++ b/cabal-install/Distribution/Client/Upload.hs @@ -3,13 +3,11 @@ 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(..), remoteRepoTryUpgradeToHttps ) -import Distribution.Simple.Utils (debug, notice, warn, info) +import Distribution.Simple.Utils (notice, warn, info, die) import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config @@ -17,23 +15,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) -import Data.Char (intToDigit) -import Numeric (showHex) import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho) import Control.Exception (bracket) -import System.Random (randomRIO) -import System.FilePath ((</>), takeExtension, takeFileName) -import qualified System.FilePath.Posix as FilePath.Posix (combine) +import System.FilePath ((</>), takeExtension) +import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory import Control.Monad (forM_, when) +type Auth = Maybe (String, String) --FIXME: how do we find this path for an arbitrary hackage server? -- is it always at some fixed location relative to the server root? @@ -43,20 +34,26 @@ Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scri checkURI :: URI Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" - -upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO () -upload verbosity repos mUsername mPassword paths = do - let uploadURI = if isOldHackageURI targetRepoURI - then legacyUploadURI - else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} - Username username <- maybe promptUsername return mUsername - Password password <- maybe promptPassword return mPassword - let auth = Just (username, password) - flip mapM_ paths $ \path -> do - notice verbosity $ "Uploading " ++ path ++ "... " - handlePackage verbosity uploadURI auth path - where - targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given +upload :: HttpTransport -> Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO () +upload transport verbosity repos mUsername mPassword paths = do + targetRepo <- + case [ remoteRepo | Left remoteRepo <- map repoKind repos ] of + [] -> die $ "Cannot upload. No remote repositories are configured." + rs -> remoteRepoTryUpgradeToHttps transport (last rs) + let targetRepoURI = remoteRepoURI targetRepo + uploadURI + | isOldHackageURI targetRepoURI + = legacyUploadURI + | otherwise + = targetRepoURI { + uriPath = uriPath targetRepoURI FilePath.Posix.</> "upload" + } + Username username <- maybe promptUsername return mUsername + Password password <- maybe promptPassword return mPassword + let auth = Just (username,password) + flip mapM_ paths $ \path -> do + notice verbosity $ "Uploading " ++ path ++ "... " + handlePackage transport verbosity uploadURI auth path promptUsername :: IO Username promptUsername = do @@ -79,7 +76,7 @@ report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO () report verbosity repos mUsername mPassword = do Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword - let auth = Just (username, password) + let auth = (username,password) forM_ repos $ \repo -> case repoKind repo of Left remoteRepo -> do dotCabal <- defaultCabalDir @@ -95,79 +92,23 @@ report verbosity repos mUsername mPassword = do Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME Right report' -> do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') - cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] + BuildReport.uploadReports verbosity auth (remoteRepoURI remoteRepo) [(report', Just buildLog)] return () Right{} -> return () -check :: Verbosity -> [FilePath] -> IO () -check verbosity paths = do +check :: HttpTransport -> Verbosity -> [FilePath] -> IO () +check transport verbosity paths = do flip mapM_ paths $ \path -> do notice verbosity $ "Checking " ++ path ++ "... " - handlePackage verbosity checkURI Nothing path + handlePackage transport verbosity checkURI Nothing path -handlePackage :: Verbosity -> URI -> Maybe (String, String) +handlePackage :: HttpTransport -> Verbosity -> URI -> Auth -> FilePath -> IO () -handlePackage verbosity uri auth path = - do req <- mkRequest uri path - debug verbosity $ "\n" ++ show req - (_,resp) <- cabalBrowse verbosity auth $ request req - debug verbosity $ show resp - case rspCode resp of - (2,0,0) -> do notice verbosity "Ok" - (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": " - ++ map intToDigit [x,y,z] ++ " " - ++ rspReason resp - case findHeader HdrContentType resp of - Just contenttype - | takeWhile (/= ';') contenttype == "text/plain" - -> notice verbosity $ B.unpack $ rspBody resp - _ -> debug verbosity $ B.unpack $ rspBody resp - -mkRequest :: URI -> FilePath -> IO (Request ByteString) -mkRequest uri path = - do pkg <- readBinaryFile path - boundary <- genBoundary - let body = printMultiPart (B.pack boundary) (mkFormData path pkg) - return $ Request { - rqURI = uri, - rqMethod = POST, - rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), - Header HdrContentLength (show (B.length body)), - Header HdrAccept ("text/plain")], - rqBody = body - } - -readBinaryFile :: FilePath -> IO ByteString -readBinaryFile = B.readFile - -genBoundary :: IO String -genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer - return $ showHex i "" - -mkFormData :: FilePath -> ByteString -> [BodyPart] -mkFormData path pkg = - -- yes, web browsers are that stupid (re quoting) - [BodyPart [Header hdrContentDisposition $ - "form-data; name=package; filename=\""++takeFileName path++"\"", - Header HdrContentType "application/x-gzip"] - pkg] - -hdrContentDisposition :: HeaderName -hdrContentDisposition = HdrCustom "Content-disposition" - --- * Multipart, partly stolen from the cgi package. - -data BodyPart = BodyPart [Header] ByteString - -printMultiPart :: ByteString -> [BodyPart] -> ByteString -printMultiPart boundary xs = - B.concat $ map (printBodyPart boundary) xs ++ [crlf, dd, boundary, dd, crlf] - -printBodyPart :: ByteString -> BodyPart -> ByteString -printBodyPart boundary (BodyPart hs c) = B.concat $ [crlf, dd, boundary, crlf] ++ map (B.pack . show) hs ++ [crlf, c] - -crlf :: ByteString -crlf = B.pack "\r\n" - -dd :: ByteString -dd = B.pack "--" +handlePackage transport verbosity uri auth path = + do resp <- postHttpFile transport verbosity uri path auth + case resp of + (200,_) -> do notice verbosity "Ok" + (code,err) -> do notice verbosity $ "Error uploading " ++ path ++ ": " + ++ "http code " ++ show code ++ "\n" + ++ err + diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs index 60703efe32db41c4fb1095d85d5d8410a7b5f336..901540d893029644862bf88a189d5c7ebf1a1ea1 100644 --- a/cabal-install/Distribution/Client/Utils.hs +++ b/cabal-install/Distribution/Client/Utils.hs @@ -2,8 +2,10 @@ module Distribution.Client.Utils ( MergeResult(..) , mergeBy, duplicates, duplicatesBy + , readMaybe , inDir, determineNumJobs, numberOfProcessors , removeExistingFile + , withTempFileName , makeAbsoluteToCwd, filePathToByteString , byteStringToFilePath, tryCanonicalizePath , canonicalizePathNoThrow @@ -24,20 +26,24 @@ import Data.Bits ( (.|.), shiftL, shiftR ) import Data.Char ( ord, chr ) +#if MIN_VERSION_base(4,6,0) +import Text.Read + ( readMaybe ) +#endif import Data.List ( isPrefixOf, sortBy, groupBy ) import Data.Word ( Word8, Word32) import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception - ( finally ) + ( finally, bracket ) import System.Directory ( canonicalizePath, doesFileExist, getCurrentDirectory , removeFile, setCurrentDirectory ) import System.FilePath ( (</>), isAbsolute ) import System.IO - ( Handle + ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0) , hGetEncoding, hSetEncoding #endif @@ -87,6 +93,14 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp moreThanOne (_:_:_) = True moreThanOne _ = False +#if !MIN_VERSION_base(4,6,0) +-- | An implementation of readMaybe, for compatability with older base versions. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing +#endif + -- | Like 'removeFile', but does not throw an exception when the file does not -- exist. removeExistingFile :: FilePath -> IO () @@ -95,6 +109,19 @@ removeExistingFile path = do when exists $ removeFile path +-- | A variant of 'withTempFile' that only gives us the file name, and while +-- it will clean up the file afterwards, it's lenient if the file is +-- moved\/deleted. +-- +withTempFileName :: FilePath + -> String + -> (FilePath -> IO a) -> IO a +withTempFileName tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, _) -> removeExistingFile name) + (\(name, h) -> hClose h >> action name) + -- | Executes the action in the specified directory. inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index 8f9ca52b49b1eade5b5bf4f63b8f7b63b7e64c16..4da0e0e823ebc474b7ed2d5823429e187f47b254 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -75,6 +75,7 @@ import Distribution.Client.Check as Check (check) --import Distribution.Client.Clean (clean) import Distribution.Client.Upload as Upload (upload, check, report) import Distribution.Client.Run (run, splitRunArgs) +import Distribution.Client.HttpUtils (configureTransport) import Distribution.Client.SrcDist (sdist) import Distribution.Client.Get (get) import Distribution.Client.Sandbox (sandboxInit @@ -920,7 +921,8 @@ updateAction verbosityFlag extraArgs globalFlags = do (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let globalFlags' = savedGlobalFlags config `mappend` globalFlags - update verbosity (globalRepos globalFlags') + transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags')) + update transport verbosity (globalRepos globalFlags') upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () @@ -983,9 +985,11 @@ uploadAction uploadFlags extraArgs globalFlags = do getProgramInvocationOutput verbosity (simpleProgramInvocation xs xss) _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' + transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags')) if fromFlag (uploadCheck uploadFlags') - then Upload.check verbosity tarfiles - else upload verbosity + then Upload.check transport verbosity tarfiles + else upload transport + verbosity (globalRepos globalFlags') (flagToMaybe $ uploadUsername uploadFlags') maybe_password diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index babfc0a52c5217644859c971ec3f092a73321e0f..c42e1c1a316316a839aa65f9eed33f71c3ca30be 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -135,7 +135,7 @@ executable cabal Cabal >= 1.23 && < 1.24, containers >= 0.1 && < 0.6, filepath >= 1.0 && < 1.5, - HTTP >= 4000.2.5 && < 4000.3, + HTTP >= 4000.1.5 && < 4000.3, mtl >= 2.0 && < 3, pretty >= 1 && < 1.2, random >= 1 && < 1.2, @@ -201,7 +201,7 @@ Test-Suite unit-tests time, HTTP, zlib, - + random, tasty, tasty-hunit, tasty-quickcheck, diff --git a/cabal-install/changelog b/cabal-install/changelog index 4f15213e8529050ec6d36b0d5599a37d635ec022..83b0945bc93837849d9efefe599342582921764f 100644 --- a/cabal-install/changelog +++ b/cabal-install/changelog @@ -11,6 +11,12 @@ * New 'cabal install' option: '--offline' (#2578). * Accept 'builddir' field in cabal.config (#2484) * Read 'builddir' option from 'CABAL_BUILDDIR' environment variable + * Remote repos may now be configured to use https URLs + * Install target URLs can now use https + e.g. cabal install https://example.com/foo-1.0.tar.gz + * Automatically use https for cabal upload for the main + hackage.haskell.org (other repos will use whatever they are + configured to use) 1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015 * New command: user-config (#2159).