From f3bf60402911d8bf7d0c7497e30039fdf6b20d0a Mon Sep 17 00:00:00 2001
From: Fraser Tweedale <frase@frase.id.au>
Date: Thu, 22 Aug 2024 16:06:42 +1000
Subject: [PATCH] cabal-install: update curl transport to support Basic
 authentication (#10089)

* cabal-install: extract url scheme checks

Extract a bunch of string equality checks for the URI scheme to
top-level functions.

* cabal-install: refactor and document transport checks

"They're the same picture".  Thus, refactor the *transport supports
https* checks.

* cabal-install: allow Basic authentication in curl transport

Allow the curl transport to use Basic authentication, if and only if
the url scheme is HTTPS (i.e. TLS will be used).  Retain the
existing behaviour (force Digest scheme) for insecure requests.

This change is required to support upcoming hackage-server changes.
The wget transport already supports Basic authentication.

---------

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
---
 .../src/Distribution/Client/HttpUtils.hs      | 45 ++++++++++++++-----
 changelog.d/pr-10089                          | 12 +++++
 2 files changed, 45 insertions(+), 12 deletions(-)
 create mode 100644 changelog.d/pr-10089

diff --git a/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal-install/src/Distribution/Client/HttpUtils.hs
index cad511ef9f8..956241ab307 100644
--- a/cabal-install/src/Distribution/Client/HttpUtils.hs
+++ b/cabal-install/src/Distribution/Client/HttpUtils.hs
@@ -192,7 +192,7 @@ downloadURI transport verbosity uri path = do
   -- Only use the external http transports if we actually have to
   -- (or have been told to do so)
   let transport'
-        | uriScheme uri == "http:"
+        | isHttpURI uri
         , not (transportManuallySelected transport) =
             plainHttpTransport
         | otherwise =
@@ -251,20 +251,35 @@ downloadURI transport verbosity uri path = do
 -- Utilities for repo url management
 --
 
+-- | If the remote repo is accessed over HTTPS, ensure that the transport
+-- supports HTTPS.
 remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
-remoteRepoCheckHttps verbosity transport repo
-  | uriScheme (remoteRepoURI repo) == "https:"
-  , not (transportSupportsHttps transport) =
-      dieWithException verbosity $ RemoteRepoCheckHttps (unRepoName (remoteRepoName repo)) requiresHttpsErrorMessage
-  | otherwise = return ()
+remoteRepoCheckHttps verbosity transport repo =
+  transportCheckHttpsWithError verbosity transport (remoteRepoURI repo) $
+    RemoteRepoCheckHttps (unRepoName (remoteRepoName repo)) requiresHttpsErrorMessage
 
+-- | If the URI scheme is HTTPS, ensure the transport supports HTTPS.
 transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
-transportCheckHttps verbosity transport uri
-  | uriScheme uri == "https:"
+transportCheckHttps verbosity transport uri =
+  transportCheckHttpsWithError verbosity transport uri $
+    TransportCheckHttps uri requiresHttpsErrorMessage
+
+-- | If the URI scheme is HTTPS, ensure the transport supports HTTPS.
+-- If not, fail with the given error.
+transportCheckHttpsWithError
+  :: Verbosity -> HttpTransport -> URI -> CabalInstallException -> IO ()
+transportCheckHttpsWithError verbosity transport uri err
+  | isHttpsURI uri
   , not (transportSupportsHttps transport) =
-      dieWithException verbosity $ TransportCheckHttps uri requiresHttpsErrorMessage
+      dieWithException verbosity err
   | otherwise = return ()
 
+isHttpsURI :: URI -> Bool
+isHttpsURI uri = uriScheme uri == "https:"
+
+isHttpURI :: URI -> Bool
+isHttpURI uri = uriScheme uri == "http:"
+
 requiresHttpsErrorMessage :: String
 requiresHttpsErrorMessage =
   "requires HTTPS however the built-in HTTP implementation "
@@ -280,12 +295,12 @@ requiresHttpsErrorMessage =
 remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
 remoteRepoTryUpgradeToHttps verbosity transport repo
   | remoteRepoShouldTryHttps repo
-  , uriScheme (remoteRepoURI repo) == "http:"
+  , isHttpURI (remoteRepoURI repo)
   , not (transportSupportsHttps transport)
   , not (transportManuallySelected transport) =
       dieWithException verbosity $ TryUpgradeToHttps [name | (name, _, True, _) <- supportedTransports]
   | remoteRepoShouldTryHttps repo
-  , uriScheme (remoteRepoURI repo) == "http:"
+  , isHttpURI (remoteRepoURI repo)
   , transportSupportsHttps transport =
       return
         repo
@@ -505,12 +520,18 @@ curlTransport prog =
             (Just (Left (uname, passwd)), _) -> Just $ Left (uname ++ ":" ++ passwd)
             (Nothing, Just a) -> Just $ Left a
             (Nothing, Nothing) -> Nothing
+      let authnSchemeArg
+            -- When using TLS, we can accept Basic authentication.  Let curl
+            -- decide based on the scheme(s) offered by the server.
+            | isHttpsURI uri = "--anyauth"
+            -- When not using TLS, force Digest scheme
+            | otherwise = "--digest"
       case mbAuthStringToken of
         Just (Left up) ->
           progInvocation
             { progInvokeInput =
                 Just . IODataText . unlines $
-                  [ "--digest"
+                  [ authnSchemeArg
                   , "--user " ++ up
                   ]
             , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
diff --git a/changelog.d/pr-10089 b/changelog.d/pr-10089
new file mode 100644
index 00000000000..ed322194e21
--- /dev/null
+++ b/changelog.d/pr-10089
@@ -0,0 +1,12 @@
+synopsis: `curl` transport now supports Basic authentication
+packages: cabal-install
+prs: #10089
+
+description: {
+
+- The `curl` HTTP transport previously only supported the HTTP Digest
+  authentication scheme.  Basic authentication is now supported
+  when using HTTPS; Curl will use the scheme offered by the server.
+  The `wget` transport already supports HTTPS.
+
+}