Support authentication tokens for uploading to Hackage

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 ()

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 
+  ( Token (..)
+  , Password (..)
+  , Username (..)
+  )
 import Distribution.Utils.NubList
   ( NubList
   , fromNubList
@@ -568,6 +572,7 @@ instance Semigroup SavedConfig where
         UploadFlags
           { uploadCandidate = combine uploadCandidate
           , uploadDoc = combine uploadDoc
+          , uploadToken = combine uploadToken
           , uploadUsername = combine uploadUsername
           , uploadPassword = combine uploadPassword
           , uploadPasswordCmd = combine uploadPasswordCmd
@@ -1333,6 +1338,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"

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
   )
@@ -118,6 +119,7 @@ import System.IO.Error
   ( isDoesNotExistError
   )
 import System.Random (randomRIO)
+import Data.Either (lefts)
 
 import qualified Crypto.Hash.SHA256 as SHA256
 import qualified Data.ByteString as BS
@@ -386,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"
 
@@ -535,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
-            (Nothing, Nothing) -> Nothing
-      case mbAuthString of
-        Just up ->
+      let mbAuthStringToken = case (explicitAuth, uriDerivedAuth) of
+            (Just (Right token), _) -> Just $ Right token
+            (Just (Left (uname, passwd)), _) -> Just $ Left (uname ++ ":" ++ passwd)
+            (_, Just a) -> Just $ Left a
+            (_, _) -> Nothing
+      case mbAuthStringToken of
+        Just (Left up) ->
           progInvocation
             { progInvokeInput =
                 Just . IODataText . unlines $
@@ -549,6 +551,11 @@ 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
@@ -728,13 +735,13 @@ wgetTransport prog =
             resp <- hGetContents hnd
             evaluate $ force (code, resp)
 
-    addUriAuth Nothing uri = uri
-    addUriAuth (Just (user, pass)) uri =
+    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
@@ -921,7 +928,7 @@ powershellTransport prog =
         ++ ","
         ++ escape passwd
         ++ ",\"\");"
-      | (uname, passwd) <- maybeToList auth
+      | (uname, passwd) <- lefts $ maybeToList auth
       ]
 
     uploadFileAction method _uri fullPath =
@@ -1073,7 +1080,9 @@ 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
 
     fixupEmptyProxy (Proxy uri _) | null uri = NoProxy

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'))

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 (Token (..), Password (..), Username (..))
 import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..))
 import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
 
@@ -2628,6 +2628,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]
@@ -2640,6 +2641,7 @@ defaultUploadFlags =
   UploadFlags
     { uploadCandidate = toFlag IsCandidate
     , uploadDoc = toFlag False
+    , uploadToken = mempty
     , uploadUsername = mempty
     , uploadPassword = mempty
     , uploadPasswordCmd = mempty
@@ -2654,7 +2656,7 @@ uploadCommand =
     , commandDescription = Nothing
     , commandNotes = Just $ \_ ->
         "You can store your Hackage login in the ~/.config/cabal/config file\n"
-          ++ relevantConfigValuesText ["username", "password", "password-command"]
+          ++ relevantConfigValuesText ["token", "username", "password", "password-command"]
     , commandUsage = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n"
     , commandDefaultFlags = defaultUploadFlags
@@ -2680,6 +2682,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"]

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 Data.Either (Either)
 
+type Auth = Either (String, String) String
+
+newtype Token = Token {unToken :: String}
 newtype Username = Username {unUsername :: String}
 newtype Password = Password {unPassword :: String}

cabal-install/src/Distribution/Client/Upload.hs

@@ -11,7 +11,12 @@ import Distribution.Client.Setup
   ( IsCandidate (..)
   , RepoContext (..)
   )
-import Distribution.Client.Types.Credentials (Password (..), Username (..))
+import Distribution.Client.Types.Credentials 
+  ( Auth
+  , Token (..)
+  , Password (..)
+  , Username (..)
+  )
 import Distribution.Client.Types.Repo (RemoteRepo (..), Repo, maybeRepoRemote)
 import Distribution.Client.Types.RepoName (unRepoName)
 
@@ -32,8 +37,6 @@ import qualified System.FilePath.Posix as FilePath.Posix ((</>))
 import System.IO (hFlush, stdout)
 import System.IO.Echo (withoutInputEcho)
 
-type Auth = Maybe (String, String)
-
 -- > stripExtensions ["tar", "gz"] "foo.tar.gz"
 -- Just "foo"
 -- > stripExtensions ["tar", "gz"] "foo.gz.tar"
@@ -48,12 +51,13 @@ stripExtensions exts path = foldM f path (reverse exts)
 upload
   :: Verbosity
   -> RepoContext
+  -> Maybe Token
   -> Maybe Username
   -> Maybe Password
   -> IsCandidate
   -> [FilePath]
   -> IO ()
-upload verbosity repoCtxt mUsername mPassword isCandidate paths = do
+upload verbosity repoCtxt mToken mUsername mPassword isCandidate paths = do
   let repos :: [Repo]
       repos = repoContextRepos repoCtxt
   transport <- repoContextGetTransport repoCtxt
@@ -87,9 +91,7 @@ upload verbosity repoCtxt mUsername mPassword isCandidate paths = do
                       IsPublished -> ""
                   ]
           }
-  Username username <- maybe (promptUsername domain) return mUsername
-  Password password <- maybe (promptPassword domain) return mPassword
-  let auth = Just (username, password)
+  auth <- Just <$> createAuth domain mToken mUsername mPassword
   for_ paths $ \path -> do
     notice verbosity $ "Uploading " ++ path ++ "... "
     case fmap takeFileName (stripExtensions ["tar", "gz"] path) of
@@ -109,12 +111,13 @@ upload verbosity repoCtxt mUsername mPassword isCandidate paths = do
 uploadDoc
   :: Verbosity
   -> RepoContext
+  -> Maybe Token
   -> Maybe Username
   -> Maybe Password
   -> IsCandidate
   -> FilePath
   -> IO ()
-uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do
+uploadDoc verbosity repoCtxt mToken mUsername mPassword isCandidate path = do
   let repos = repoContextRepos repoCtxt
   transport <- repoContextGetTransport repoCtxt
   targetRepo <-
@@ -160,11 +163,10 @@ uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do
         || Unsafe.head reversePkgid /= '-'
     )
     $ die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz"
-  Username username <- maybe (promptUsername domain) return mUsername
-  Password password <- maybe (promptPassword domain) return mPassword
 
-  let auth = Just (username, password)
-      headers =
+  auth <- Just <$> createAuth domain mToken mUsername mPassword
+
+  let headers =
         [ Header HdrContentType "application/x-tar"
         , Header HdrContentEncoding "gzip"
         ]
@@ -247,7 +249,7 @@ report verbosity repoCtxt mUsername mPassword = do
                 BuildReport.uploadReports
                   verbosity
                   repoCtxt
-                  auth
+                  (Left auth)
                   (remoteRepoURI remoteRepo)
                   [(report', Just buildLog)]
                 return ()
@@ -257,7 +259,7 @@ handlePackage
   -> Verbosity
   -> URI
   -> URI
-  -> Auth
+  -> Maybe Auth
   -> IsCandidate
   -> FilePath
   -> IO ()
@@ -294,3 +296,17 @@ handlePackage transport verbosity uri packageUri auth isCandidate path =
 
 formatWarnings :: String -> String
 formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x
+
+createAuth
+  :: String
+  -> Maybe Token
+  -> Maybe Username
+  -> Maybe Password
+  -> IO Auth
+createAuth domain mToken mUsername mPassword = case mToken of
+    Just token -> return $ Right $ unToken token
+    -- Use username and password if no token is provided
+    Nothing -> do
+      Username username <- maybe (promptUsername domain) return mUsername
+      Password password <- maybe (promptPassword domain) return mPassword
+      return $ Left (username, password)

doc/cabal-commands.rst

@@ -1076,6 +1076,10 @@ to Hackage.
     documentation for a published package (and not a candidate), add
     ``--publish``.
 
+.. option:: -t, --token
+
+    Your Hackage authentication token.
+
 .. option:: -u, --username
 
     Your Hackage username.