Support authentication tokens for uploading to Hackage (haskell#9058)

* Add token authorization for cabal upload Add token flag. If a token is set ignore the username and password. The token is passed to Hackage in the Authorization header. * Add token flag to upload documentation * Add token authentication for cabal report * Update auth token documentation and changelog * Add token flag to config integration tests * Add auth token header to plain-http transport * Add documentation and reduce wildcard usage Use Nothing in pattern matching instead of wildcards. * Add auth token headers to wget and powershell * Fix auth token header for powershell transport Powershell has to have the Authorization token set in the Header dictionary parameter. Some headers (e.g. User-Agent) have to be set as a request parameter. * Fix code formatting to comply with fourmolu
ffaf1 · Sep 15, 2023 · a0d815c · a0d815c
1 parent fa54e31
commit a0d815c
Show file tree

Hide file tree

Showing 13 changed files with 163 additions and 52 deletions.
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Upload.hs b/cabal-install/src/Distribution/Client/BuildReports/Upload.hs
@@ -28,6 +28,7 @@ import Distribution.Client.HttpUtils
 import Distribution.Client.Setup
   ( RepoContext (..)
   )
+import Distribution.Client.Types.Credentials (Auth)
 import Distribution.Simple.Utils (die')
 import System.FilePath.Posix
   ( (</>)
@@ -36,15 +37,15 @@ import System.FilePath.Posix
 type BuildReportId = URI
 type BuildLog = String
 
-uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
+uploadReports :: Verbosity -> RepoContext -> Auth -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
 uploadReports verbosity repoCtxt auth uri reports = do
   for_ reports $ \(report, mbBuildLog) -> do
     buildId <- postBuildReport verbosity repoCtxt auth uri report
     case mbBuildLog of
       Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog
       Nothing -> return ()
 
-postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId
+postBuildReport :: Verbosity -> RepoContext -> Auth -> URI -> BuildReport -> IO BuildReportId
 postBuildReport verbosity repoCtxt auth uri buildReport = do
   let fullURI = uri{uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports"}
   transport <- repoContextGetTransport repoCtxt
@@ -87,7 +88,7 @@ postBuildReport verbosity repoCtxt auth uri buildReport = do
 putBuildLog
   :: Verbosity
   -> RepoContext
-  -> (String, String)
+  -> Auth
   -> BuildReportId
   -> BuildLog
   -> IO ()

diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
@@ -95,7 +95,11 @@ import Distribution.Client.Types
   , isRelaxDeps
   , unRepoName
   )
-import Distribution.Client.Types.Credentials (Password (..), Username (..))
+import Distribution.Client.Types.Credentials
+  ( Password (..)
+  , Token (..)
+  , Username (..)
+  )
 import Distribution.Utils.NubList
   ( NubList
   , fromNubList
@@ -569,6 +573,7 @@ instance Semigroup SavedConfig where
         UploadFlags
           { uploadCandidate = combine uploadCandidate
           , uploadDoc = combine uploadDoc
+          , uploadToken = combine uploadToken
           , uploadUsername = combine uploadUsername
           , uploadPassword = combine uploadPassword
           , uploadPasswordCmd = combine uploadPasswordCmd
@@ -579,7 +584,8 @@ instance Semigroup SavedConfig where
 
       combinedSavedReportFlags =
         ReportFlags
-          { reportUsername = combine reportUsername
+          { reportToken = combine reportToken
+          , reportUsername = combine reportUsername
           , reportPassword = combine reportPassword
           , reportVerbosity = combine reportVerbosity
           }
@@ -1275,7 +1281,7 @@ configFieldDescriptions src =
     ++ toSavedConfig
       liftReportFlag
       (commandOptions reportCommand ParseArgs)
-      ["verbose", "username", "password"]
+      ["verbose", "token", "username", "password"]
       []
     -- FIXME: this is a hack, hiding the user name and password.
     -- But otherwise it masks the upload ones. Either need to
@@ -1340,6 +1346,13 @@ deprecatedFieldDescriptions =
         (optionalFlag parsecFilePath)
         globalCacheDir
         (\d cfg -> cfg{globalCacheDir = d})
+  , liftUploadFlag $
+      simpleFieldParsec
+        "hackage-token"
+        (Disp.text . fromFlagOrDefault "" . fmap unToken)
+        (optionalFlag (fmap Token parsecToken))
+        uploadToken
+        (\d cfg -> cfg{uploadToken = d})
   , liftUploadFlag $
       simpleFieldParsec
         "hackage-username"

diff --git a/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal-install/src/Distribution/Client/HttpUtils.hs
@@ -27,6 +27,7 @@ import Distribution.Client.Types
   ( RemoteRepo (..)
   , unRepoName
   )
+import Distribution.Client.Types.Credentials (Auth)
 import Distribution.Client.Utils
   ( withTempFileName
   )
@@ -353,7 +354,7 @@ data HttpTransport = HttpTransport
       -> String
       -> Maybe Auth
       -> IO (HttpCode, String)
-  -- ^ POST a resource to a URI, with optional auth (username, password)
+  -- ^ POST a resource to a URI, with optional 'Auth'
   -- and return the HTTP status code and any redirect URL.
   , postHttpFile
       :: Verbosity
@@ -362,7 +363,7 @@ data HttpTransport = HttpTransport
       -> Maybe Auth
       -> IO (HttpCode, String)
   -- ^ POST a file resource to a URI using multipart\/form-data encoding,
-  -- with optional auth (username, password) and return the HTTP status
+  -- with optional 'Auth' and return the HTTP status
   -- code and any error string.
   , putHttpFile
       :: Verbosity
@@ -371,8 +372,8 @@ data HttpTransport = HttpTransport
       -> Maybe Auth
       -> [Header]
       -> IO (HttpCode, String)
-  -- ^ PUT a file resource to a URI, with optional auth
-  -- (username, password), extra headers and return the HTTP status code
+  -- ^ PUT a file resource to a URI, with optional 'Auth',
+  -- extra headers and return the HTTP status code
   -- and any error string.
   , transportSupportsHttps :: Bool
   -- ^ Whether this transport supports https or just http.
@@ -387,13 +388,12 @@ data HttpTransport = HttpTransport
 
 type HttpCode = Int
 type ETag = String
-type Auth = (String, String)
 
 noPostYet
   :: Verbosity
   -> URI
   -> String
-  -> Maybe (String, String)
+  -> Maybe Auth
   -> IO (Int, String)
 noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet"
 
@@ -536,12 +536,13 @@ curlTransport prog =
             (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u
             _ -> Nothing
       -- prefer passed in auth to auth derived from uri. If neither exist, then no auth
-      let mbAuthString = case (explicitAuth, uriDerivedAuth) of
-            (Just (uname, passwd), _) -> Just (uname ++ ":" ++ passwd)
-            (Nothing, Just a) -> Just a
+      let mbAuthStringToken = case (explicitAuth, uriDerivedAuth) of
+            (Just (Right token), _) -> Just $ Right token
+            (Just (Left (uname, passwd)), _) -> Just $ Left (uname ++ ":" ++ passwd)
+            (Nothing, Just a) -> Just $ Left a
             (Nothing, Nothing) -> Nothing
-      case mbAuthString of
-        Just up ->
+      case mbAuthStringToken of
+        Just (Left up) ->
           progInvocation
             { progInvokeInput =
                 Just . IODataText . unlines $
@@ -550,6 +551,12 @@ curlTransport prog =
                   ]
             , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
             }
+        Just (Right token) ->
+          progInvocation
+            { progInvokeArgs =
+                ["--header", "Authorization: X-ApiKey " ++ token]
+                  ++ progInvokeArgs progInvocation
+            }
         Nothing -> progInvocation
 
     posthttpfile verbosity uri path auth = do
@@ -702,6 +709,7 @@ wgetTransport prog =
                         ++ "boundary="
                         ++ boundary
                     ]
+                      ++ maybeToList (authTokenHeader auth)
               out <- runWGet verbosity (addUriAuth auth uri) args
               (code, _etag) <- parseOutput verbosity uri out
               withFile responseFile ReadMode $ \hnd -> do
@@ -723,20 +731,24 @@ wgetTransport prog =
                   ++ [ "--header=" ++ show name ++ ": " ++ value
                      | Header name value <- headers
                      ]
+                  ++ maybeToList (authTokenHeader auth)
 
           out <- runWGet verbosity (addUriAuth auth uri) args
           (code, _etag) <- parseOutput verbosity uri out
           withFile responseFile ReadMode $ \hnd -> do
             resp <- hGetContents hnd
             evaluate $ force (code, resp)
 
-    addUriAuth Nothing uri = uri
-    addUriAuth (Just (user, pass)) uri =
+    authTokenHeader (Just (Right token)) = Just $ "--header=Authorization: X-ApiKey " ++ token
+    authTokenHeader _ = Nothing
+
+    addUriAuth (Just (Left (user, pass))) uri =
       uri
         { uriAuthority = Just a{uriUserInfo = user ++ ":" ++ pass ++ "@"}
         }
       where
         a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)
+    addUriAuth _ uri = uri
 
     runWGet verbosity uri args = do
       -- We pass the URI via STDIN because it contains the users' credentials
@@ -918,14 +930,16 @@ powershellTransport prog =
                in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
             name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
 
-    setupAuth auth =
+    setupAuth (Just (Left (uname, passwd))) =
       [ "$request.Credentials = new-object System.Net.NetworkCredential("
-        ++ escape uname
-        ++ ","
-        ++ escape passwd
-        ++ ",\"\");"
-      | (uname, passwd) <- maybeToList auth
+          ++ escape uname
+          ++ ","
+          ++ escape passwd
+          ++ ",\"\");"
       ]
+    setupAuth (Just (Right token)) =
+      ["$request.Headers[\"Authorization\"] = " ++ escape ("X-ApiKey " ++ token)]
+    setupAuth Nothing = []
 
     uploadFileAction method _uri fullPath =
       [ "$request.Method = " ++ show method
@@ -1027,6 +1041,7 @@ plainHttpTransport =
             , Header HdrContentLength (show (LBS8.length body))
             , Header HdrAccept ("text/plain")
             ]
+              ++ maybeToList (authTokenHeader auth)
           req =
             Request
               { rqURI = uri
@@ -1046,7 +1061,8 @@ plainHttpTransport =
               , rqHeaders =
                   Header HdrContentLength (show (LBS8.length body))
                     : Header HdrAccept "text/plain"
-                    : headers
+                    : maybeToList (authTokenHeader auth)
+                    ++ headers
               , rqBody = body
               }
       (_, resp) <- cabalBrowse verbosity auth (request req)
@@ -1076,9 +1092,14 @@ plainHttpTransport =
           setOutHandler (debug verbosity)
           setUserAgent userAgent
           setAllowBasicAuth False
-          setAuthorityGen (\_ _ -> return auth)
+          case auth of
+            Just (Left x) -> setAuthorityGen (\_ _ -> return $ Just x)
+            _ -> setAuthorityGen (\_ _ -> return Nothing)
           act
 
+    authTokenHeader (Just (Right token)) = Just $ Header HdrAuthorization ("X-ApiKey " ++ token)
+    authTokenHeader _ = Nothing
+
     fixupEmptyProxy (Proxy uri _) | null uri = NoProxy
     fixupEmptyProxy p = p
 

diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs
@@ -1118,6 +1118,7 @@ uploadAction uploadFlags extraArgs globalFlags = do
         Upload.uploadDoc
           verbosity
           repoContext
+          (flagToMaybe $ uploadToken uploadFlags')
           (flagToMaybe $ uploadUsername uploadFlags')
           maybe_password
           (fromFlag (uploadCandidate uploadFlags'))
@@ -1126,6 +1127,7 @@ uploadAction uploadFlags extraArgs globalFlags = do
         Upload.upload
           verbosity
           repoContext
+          (flagToMaybe $ uploadToken uploadFlags')
           (flagToMaybe $ uploadUsername uploadFlags')
           maybe_password
           (fromFlag (uploadCandidate uploadFlags'))
@@ -1199,6 +1201,7 @@ reportAction reportFlags extraArgs globalFlags = do
     Upload.report
       verbosity
       repoContext
+      (flagToMaybe $ reportToken reportFlags')
       (flagToMaybe $ reportUsername reportFlags')
       (flagToMaybe $ reportPassword reportFlags')
 

diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs
@@ -93,7 +93,7 @@ import Distribution.Client.Compat.Prelude hiding (get)
 import Prelude ()
 
 import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDeps (..))
-import Distribution.Client.Types.Credentials (Password (..), Username (..))
+import Distribution.Client.Types.Credentials (Password (..), Token (..), Username (..))
 import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..))
 import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
 
@@ -1648,7 +1648,8 @@ runCommand =
 -- ------------------------------------------------------------
 
 data ReportFlags = ReportFlags
-  { reportUsername :: Flag Username
+  { reportToken :: Flag Token
+  , reportUsername :: Flag Username
   , reportPassword :: Flag Password
   , reportVerbosity :: Flag Verbosity
   }
@@ -1657,7 +1658,8 @@ data ReportFlags = ReportFlags
 defaultReportFlags :: ReportFlags
 defaultReportFlags =
   ReportFlags
-    { reportUsername = mempty
+    { reportToken = mempty
+    , reportUsername = mempty
     , reportPassword = mempty
     , reportVerbosity = toFlag normal
     }
@@ -1675,6 +1677,17 @@ reportCommand =
     , commandDefaultFlags = defaultReportFlags
     , commandOptions = \_ ->
         [ optionVerbosity reportVerbosity (\v flags -> flags{reportVerbosity = v})
+        , option
+            ['t']
+            ["token"]
+            "Hackage authentication Token."
+            reportToken
+            (\v flags -> flags{reportToken = v})
+            ( reqArg'
+                "TOKEN"
+                (toFlag . Token)
+                (flagToList . fmap unToken)
+            )
         , option
             ['u']
             ["username"]
@@ -2665,6 +2678,7 @@ data IsCandidate = IsCandidate | IsPublished
 data UploadFlags = UploadFlags
   { uploadCandidate :: Flag IsCandidate
   , uploadDoc :: Flag Bool
+  , uploadToken :: Flag Token
   , uploadUsername :: Flag Username
   , uploadPassword :: Flag Password
   , uploadPasswordCmd :: Flag [String]
@@ -2677,6 +2691,7 @@ defaultUploadFlags =
   UploadFlags
     { uploadCandidate = toFlag IsCandidate
     , uploadDoc = toFlag False
+    , uploadToken = mempty
     , uploadUsername = mempty
     , uploadPassword = mempty
     , uploadPasswordCmd = mempty
@@ -2692,7 +2707,7 @@ uploadCommand =
     , commandNotes = Just $ \_ ->
         "You can store your Hackage login in the ~/.config/cabal/config file\n"
           ++ "(the %APPDATA%\\cabal\\config file on Windows)\n"
-          ++ relevantConfigValuesText ["username", "password", "password-command"]
+          ++ relevantConfigValuesText ["token", "username", "password", "password-command"]
     , commandUsage = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n"
     , commandDefaultFlags = defaultUploadFlags
@@ -2718,6 +2733,17 @@ uploadCommand =
             uploadDoc
             (\v flags -> flags{uploadDoc = v})
             trueArg
+        , option
+            ['t']
+            ["token"]
+            "Hackage authentication token."
+            uploadToken
+            (\v flags -> flags{uploadToken = v})
+            ( reqArg'
+                "TOKEN"
+                (toFlag . Token)
+                (flagToList . fmap unToken)
+            )
         , option
             ['u']
             ["username"]

diff --git a/cabal-install/src/Distribution/Client/Types/Credentials.hs b/cabal-install/src/Distribution/Client/Types/Credentials.hs
@@ -1,9 +1,15 @@
 module Distribution.Client.Types.Credentials
-  ( Username (..)
+  ( Auth
+  , Token (..)
+  , Username (..)
   , Password (..)
   ) where
 
-import Prelude (String)
+import Prelude (Either, String)
 
+-- | Either (username, password) or authentacation token
+type Auth = Either (String, String) String
+
+newtype Token = Token {unToken :: String}
 newtype Username = Username {unUsername :: String}
 newtype Password = Password {unPassword :: String}