From 0863b4687832368250e18083552407060503b5cd Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Tue, 28 Apr 2015 15:21:11 +0100
Subject: [PATCH] Force cabal upload to always use digest auth and never basic
auth.
(cherry picked from commit 3d1e7dbd9e7c7209cf38f8fef036a7dd49b6734c)
---
.../Distribution/Client/HttpUtils.hs | 12 ++++-----
cabal-install/Distribution/Client/Upload.hs | 27 ++++---------------
2 files changed, 11 insertions(+), 28 deletions(-)
diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs
index 8396079546..f062b13291 100644
--- a/cabal-install/Distribution/Client/HttpUtils.hs
+++ b/cabal-install/Distribution/Client/HttpUtils.hs
@@ -17,8 +17,8 @@ import Network.HTTP.Proxy ( Proxy(..), fetchProxy)
import Network.URI
( URI (..), URIAuth (..) )
import Network.Browser
- ( BrowserAction, browse
- , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request)
+ ( BrowserAction, browse, setAllowBasicAuth, setAuthorityGen
+ , setOutHandler, setErrHandler, setProxy, request)
import Network.Stream
( Result, ConnError(..) )
import Control.Monad
@@ -76,10 +76,10 @@ getHTTP :: Verbosity
-> 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 (return ()) (request (mkRequest uri etag))
+ cabalBrowse verbosity Nothing (request (mkRequest uri etag))
cabalBrowse :: Verbosity
- -> BrowserAction s ()
+ -> Maybe (String, String)
-> BrowserAction s a
-> IO a
cabalBrowse verbosity auth act = do
@@ -88,8 +88,8 @@ cabalBrowse verbosity auth act = do
setProxy p
setErrHandler (warn verbosity . ("http error: "++))
setOutHandler (debug verbosity)
- auth
- setAuthorityGen (\_ _ -> return Nothing)
+ setAllowBasicAuth False
+ setAuthorityGen (\_ _ -> return auth)
act
downloadURI :: Verbosity
diff --git a/cabal-install/Distribution/Client/Upload.hs b/cabal-install/Distribution/Client/Upload.hs
index 75a6696006..2638a8bca9 100644
--- a/cabal-install/Distribution/Client/Upload.hs
+++ b/cabal-install/Distribution/Client/Upload.hs
@@ -15,12 +15,10 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import qualified Distribution.Client.BuildReports.Upload as BuildReport
import Network.Browser
- ( BrowserAction, request
- , Authority(..), addAuthority )
+ ( request )
import Network.HTTP
( Header(..), HeaderName(..), findHeader
, Request(..), RequestMethod(..), Response(..) )
-import Network.TCP (HandleStream)
import Network.URI (URI(uriPath), parseURI)
import Data.Char (intToDigit)
@@ -51,12 +49,7 @@ upload verbosity repos mUsername mPassword paths = do
else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}
Username username <- maybe promptUsername return mUsername
Password password <- maybe promptPassword return mPassword
- let auth = addAuthority AuthBasic {
- auRealm = "Hackage",
- auUsername = username,
- auPassword = password,
- auSite = uploadURI
- }
+ let auth = Just (username, password)
flip mapM_ paths $ \path -> do
notice verbosity $ "Uploading " ++ path ++ "... "
handlePackage verbosity uploadURI auth path
@@ -82,17 +75,9 @@ promptPassword = do
report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()
report verbosity repos mUsername mPassword = do
- let uploadURI = if isOldHackageURI targetRepoURI
- then legacyUploadURI
- else targetRepoURI{uriPath = ""}
Username username <- maybe promptUsername return mUsername
Password password <- maybe promptPassword return mPassword
- let auth = addAuthority AuthBasic {
- auRealm = "Hackage",
- auUsername = username,
- auPassword = password,
- auSite = uploadURI
- }
+ let auth = Just (username, password)
forM_ repos $ \repo -> case repoKind repo of
Left remoteRepo
-> do dotCabal <- defaultCabalDir
@@ -111,16 +96,14 @@ report verbosity repos mUsername mPassword = do
cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]
return ()
Right{} -> return ()
- where
- targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given
check :: Verbosity -> [FilePath] -> IO ()
check verbosity paths = do
flip mapM_ paths $ \path -> do
notice verbosity $ "Checking " ++ path ++ "... "
- handlePackage verbosity checkURI (return ()) path
+ handlePackage verbosity checkURI Nothing path
-handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()
+handlePackage :: Verbosity -> URI -> Maybe (String, String)
-> FilePath -> IO ()
handlePackage verbosity uri auth path =
do req <- mkRequest uri path
--
GitLab