From 36e9e6222916f30a6336b6902e977392b3496b41 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Mon, 29 Jun 2015 03:15:11 +0100
Subject: [PATCH] Change the logic for automatically upgrading to HTTPS
The initial patch would always try to use HTTPS, even when the repo
specified to use HTTP. This works for the central community hackage
but obviously does not work in general.
The new logic is that we always follow what is specified for the
remote repo in the config, except for built-in known repos (currently
just the central community hackage) where we mark them as also
supporting https. For upload when uploading to such a marked repo
then we will try https and will complain if the plain-http impl was
selected automatically (but it's ok if selected manually).
This patch also changes things so that for http urls on download, we
stick to the builtin http impl by default, and only use the external
ones if https support is required (i.e. because the repo was
configured to use an https url)
---
cabal-install/Distribution/Client/Config.hs | 6 +-
.../Distribution/Client/FetchUtils.hs | 12 +-
.../Distribution/Client/HttpUtils.hs | 167 +++++++++++++-----
cabal-install/Distribution/Client/Setup.hs | 15 +-
cabal-install/Distribution/Client/Types.hs | 12 +-
cabal-install/Distribution/Client/Upload.hs | 36 ++--
6 files changed, 170 insertions(+), 78 deletions(-)
diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs
index 5a25f41db6..6143c9e05e 100644
--- a/cabal-install/Distribution/Client/Config.hs
+++ b/cabal-install/Distribution/Client/Config.hs
@@ -477,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 "")) "/" "" ""
@@ -499,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/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs
index acf830a51b..7f126dd762 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(..), HttpTransport(..) )
+ ( downloadURI, isOldHackageURI, DownloadResult(..)
+ , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )
import Distribution.Package
( PackageId, packageName, packageVersion )
@@ -110,6 +111,7 @@ fetchPackage transport verbosity loc = case loc of
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"
@@ -133,6 +135,7 @@ fetchRepoTarball transport 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
@@ -143,9 +146,10 @@ fetchRepoTarball transport verbosity repo pkgid = do
-- | Downloads an index file to [config-dir/packages/serv-id].
--
downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
-downloadIndex transport verbosity repo cacheDir = do
- let uri = (remoteRepoURI repo) {
- uriPath = uriPath (remoteRepoURI repo)
+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"
diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs
index 7a5546651b..eaed986f8f 100644
--- a/cabal-install/Distribution/Client/HttpUtils.hs
+++ b/cabal-install/Distribution/Client/HttpUtils.hs
@@ -7,6 +7,9 @@ module Distribution.Client.HttpUtils (
configureTransport,
HttpTransport(..),
downloadURI,
+ transportCheckHttps,
+ remoteRepoCheckHttps,
+ remoteRepoTryUpgradeToHttps,
isOldHackageURI
) where
@@ -27,7 +30,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS
import Data.List
( isPrefixOf, find, intercalate )
import Data.Maybe
- ( catMaybes, listToMaybe, maybeToList )
+ ( listToMaybe, maybeToList )
import qualified Paths_cabal_install (version)
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils
@@ -36,6 +39,8 @@ import Distribution.Simple.Utils
, rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings )
import Distribution.Client.Utils
( readMaybe, withTempFileName )
+import Distribution.Client.Types
+ ( RemoteRepo(..) )
import Distribution.System
( buildOS, buildArch )
import Distribution.Text
@@ -87,17 +92,28 @@ downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do
-- Can we store the hash of the file so we can safely return path when the
-- hash matches to avoid unnecessary computation?
-downloadURI transport verbosity uri path =
- withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> 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
+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
- result <- getHttp transport verbosity uri etag tmpFile
+ 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.
@@ -116,6 +132,63 @@ downloadURI transport verbosity uri path =
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
@@ -145,7 +218,16 @@ data HttpTransport = HttpTransport {
-- with optional auth (username, password) and return the HTTP status
-- code and any error string.
postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth
- -> IO (HttpCode, String)
+ -> 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?
@@ -190,8 +272,8 @@ configureTransport verbosity (Just name) =
Just prog -> snd <$> requireProgram verbosity prog emptyProgramDb
-- ^^ if it fails, it'll fail here
- let Just trans = mkTrans progdb
- return trans
+ let Just transport = mkTrans progdb
+ return transport { transportManuallySelected = True }
Nothing -> die $ "Unknown HTTP transport specified: " ++ name
++ ". The supported transports are "
@@ -209,19 +291,15 @@ configureTransport verbosity Nothing = do
[ prog | (_, Just prog, _, _) <- supportedTransports ]
emptyProgramDb
- let availableHttpsTransports =
- [ mkTrans progdb
- | (_, _, _tls@True, mkTrans) <- supportedTransports ]
+ 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
- case catMaybes availableHttpsTransports of
- (trans:_) -> return trans
- [] -> die $ "Could not find a https transport: fallback to plain"
- ++ "http by running with --http-transport=plain-http"
-
-statusParseFail :: URI -> String -> IO a
-statusParseFail uri r =
- die $ "Failed to download " ++ show uri ++ " : "
- ++ "No Status Code could be parsed from response: " ++ r
+ return transport { transportManuallySelected = False }
------------------------------------------------------------------------------
@@ -230,9 +308,9 @@ statusParseFail uri r =
curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport prog =
- HttpTransport gethttp posthttp posthttpfile
+ HttpTransport gethttp posthttp posthttpfile True False
where
- gethttp verbosity uri' etag destPath = do
+ gethttp verbosity uri etag destPath = do
withTempFile (takeDirectory destPath)
"curl-headers.txt" $ \tmpFile tmpHandle -> do
hClose tmpHandle
@@ -252,12 +330,10 @@ curlTransport prog =
headers <- readFile tmpFile
(code, _err, etag') <- parseResponse uri resp headers
return (code, etag')
- where
- uri = uriToSecure uri'
posthttp = noPostYet
- posthttpfile verbosity uri' path auth = do
+ posthttpfile verbosity uri path auth = do
let args = [ show uri
, "--form", "package=@"++path
, "--write-out", "%{http_code}"
@@ -271,8 +347,6 @@ curlTransport prog =
(programInvocation prog args)
(code, err, _etag) <- parseResponse uri resp ""
return (code, err)
- where
- uri = uriToSecure uri'
-- on success these curl involcations produces an output like "200"
-- and on failure it has the server error response first
@@ -298,9 +372,9 @@ curlTransport prog =
wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport prog =
- HttpTransport gethttp posthttp posthttpfile
+ HttpTransport gethttp posthttp posthttpfile True False
where
- gethttp verbosity uri' etag destPath = do
+ gethttp verbosity uri etag destPath = do
resp <- runWGet verbosity args
(code, _err, etag') <- parseResponse uri resp
return (code, etag')
@@ -315,11 +389,9 @@ wgetTransport prog =
[ ["--header", "If-None-Match: " ++ t]
| t <- maybeToList etag ]
- uri = uriToSecure uri'
-
posthttp = noPostYet
- posthttpfile verbosity uri' path auth =
+ posthttpfile verbosity uri path auth =
withTempFile (takeDirectory path)
(takeFileName path) $ \tmpFile tmpHandle -> do
(body, boundary) <- generateMultipartBody path
@@ -340,8 +412,6 @@ wgetTransport prog =
resp <- runWGet verbosity args
(code, err, _etag) <- parseResponse uri resp
return (code, err)
- where
- uri = uriToSecure uri'
runWGet verbosity args = do
-- wget returns its output on stderr rather than stdout
@@ -378,9 +448,9 @@ wgetTransport prog =
powershellTransport :: ConfiguredProgram -> HttpTransport
powershellTransport prog =
- HttpTransport gethttp posthttp posthttpfile
+ HttpTransport gethttp posthttp posthttpfile True False
where
- gethttp verbosity uri' etag destPath =
+ gethttp verbosity uri etag destPath =
withTempFile (takeDirectory destPath)
"psScript.ps1" $ \tmpFile tmpHandle -> do
hPutStr tmpHandle script
@@ -404,7 +474,6 @@ powershellTransport prog =
, "Write-Host $wc.ResponseHeaders.Item(\"ETag\")"
, "Exit" ]
- uri = uriToSecure uri'
escape x = '"' : x ++ "\"" --TODO write/find real escape.
parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of
@@ -413,7 +482,7 @@ powershellTransport prog =
posthttp = noPostYet
- posthttpfile verbosity uri' path auth =
+ posthttpfile verbosity uri path auth =
withTempFile (takeDirectory path)
(takeFileName path) $ \tmpFile tmpHandle ->
withTempFile (takeDirectory path)
@@ -447,7 +516,6 @@ powershellTransport prog =
, "Write-Host \"200\""
, "Exit" ]
- uri = uriToSecure uri'
escape x = show x
parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of
@@ -461,7 +529,7 @@ powershellTransport prog =
plainHttpTransport :: HttpTransport
plainHttpTransport =
- HttpTransport gethttp posthttp posthttpfile
+ HttpTransport gethttp posthttp posthttpfile False False
where
gethttp verbosity uri etag destPath = do
let req = Request{
@@ -533,9 +601,10 @@ userAgent = concat [ "cabal-install/", display Paths_cabal_install.version
, " (", display buildOS, "; ", display buildArch, ")"
]
-uriToSecure :: URI -> URI
-uriToSecure x | uriScheme x == "http:" = x {uriScheme = "https:"}
- | otherwise = x
+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
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
index a11ddcb7f4..264e139820 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -2263,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/Types.hs b/cabal-install/Distribution/Client/Types.hs
index 2a45e3b3bc..1ac90a1324 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/Upload.hs b/cabal-install/Distribution/Client/Upload.hs
index d0ced9fed0..8555a9f713 100644
--- a/cabal-install/Distribution/Client/Upload.hs
+++ b/cabal-install/Distribution/Client/Upload.hs
@@ -4,9 +4,10 @@
module Distribution.Client.Upload (check, upload, report) where
import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))
-import Distribution.Client.HttpUtils (isOldHackageURI, HttpTransport(..))
+import Distribution.Client.HttpUtils
+ ( isOldHackageURI, HttpTransport(..), remoteRepoTryUpgradeToHttps )
-import Distribution.Simple.Utils (notice, warn, info)
+import Distribution.Simple.Utils (notice, warn, info, die)
import Distribution.Verbosity (Verbosity)
import Distribution.Text (display)
import Distribution.Client.Config
@@ -19,7 +20,7 @@ import Network.URI (URI(uriPath), parseURI)
import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho)
import Control.Exception (bracket)
import System.FilePath ((</>), takeExtension)
-import qualified System.FilePath.Posix as FilePath.Posix (combine)
+import qualified System.FilePath.Posix as FilePath.Posix ((</>))
import System.Directory
import Control.Monad (forM_, when)
@@ -35,17 +36,24 @@ Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/che
upload :: HttpTransport -> Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()
upload transport 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 transport verbosity uploadURI auth path
- where
- targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given
+ 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
--
GitLab