From 3d1e7dbd9e7c7209cf38f8fef036a7dd49b6734c 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
---
.../Distribution/Client/HttpUtils.hs | 12 +++++-----
cabal-install/Distribution/Client/Upload.hs | 22 +++++--------------
2 files changed, 11 insertions(+), 23 deletions(-)
diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs
index cd7cf637b1..8e8e7dc4ab 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.Exception
@@ -84,10 +84,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
@@ -100,8 +100,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 ec443204b2..109b0a07a7 100644
--- a/cabal-install/Distribution/Client/Upload.hs
+++ b/cabal-install/Distribution/Client/Upload.hs
@@ -18,12 +18,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)
@@ -53,12 +51,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
@@ -89,12 +82,7 @@ report verbosity repos mUsername mPassword = do
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
@@ -120,9 +108,9 @@ 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 ByteString) ()
+handlePackage :: Verbosity -> URI -> Maybe (String, String)
-> FilePath -> IO ()
handlePackage verbosity uri auth path =
do req <- mkRequest uri path
--
GitLab