Force cabal upload to always use digest auth and never basic auth.

(cherry picked from commit 3d1e7dbd)

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

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