diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index 51fae37e3379742a63b2fac9b42fbeb9476dd28f..50a7f41eb47eaf80fd22d92d02cdddf2bf862145 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 @@ -80,10 +80,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 @@ -92,8 +92,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 ec443204b2e4e85544035cefe2d81271acf2e258..3801f336ecab15fcedd84c461cd93678ed48a809 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 @@ -84,17 +77,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 @@ -113,16 +98,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 ByteString) () +handlePackage :: Verbosity -> URI -> Maybe (String, String) -> FilePath -> IO () handlePackage verbosity uri auth path = do req <- mkRequest uri path