add support for token auth for Hackage

Author: tek

changelog.md

@@ -19,6 +19,7 @@
 * Add the options `envs.*.ghci{,d}.args` as env-specific extra arguments to those commands, based on env selection.
 * Add the options `ghci{,d}.args` as unconditional extra arguments to those commands.
 * Add the CLI option `--env` to override env selection for commands.
+* Add support for token authentication for Hackage.
 
 # 0.9.0
 

lib/doc/prose.nix

@@ -1650,8 +1650,7 @@ in {
 
       # Default for `publish` is `true` for central Hackage
       "hackage.haskell.org" = {
-        user = "deepspace-mining-corp";
-        password = {
+        token = {
           type = "exec";
           value = "/path/to/password/script";
         };
@@ -1676,8 +1675,8 @@ in {
   }
   ```
 
-  With this config, the app will execute the configured script to obtain the password for central Hackage, and fetch
-  that for `prod` from the given environment variable.
+  With this config, the app will execute the configured script to obtain the auth token for central Hackage, and fetch
+  the password for `prod` from the given environment variable.
   For `staging`, the credentials must be specified as CLI args:
 
   ```

modules/hackage-repo.nix

@@ -48,6 +48,12 @@ in {
       default = null;
     };
 
+    token = util.maybeOption types.str {
+      description = ''
+      Authentication token for uploading.
+      '';
+    };
+
     secure = lib.mkOption {
       description = "Use the newer Cabal client that verifies index signatures via `hackage-security`.";
       type = types.nullOr types.bool;

packages/hix/lib/Hix/Managed/Cabal/Config.hs

@@ -28,9 +28,18 @@ import Hix.Managed.Cabal.Data.ContextHackageRepo (
   ContextHackageLocation (..),
   ContextHackagePassword (..),
   ContextHackageRepo (..),
+  ContextHackageSecret (..),
+  ContextHackageToken (..),
   )
 import qualified Hix.Managed.Cabal.Data.HackageLocation as HackageLocation
-import Hix.Managed.Cabal.Data.HackageLocation (HackageLocation (auth), HackagePassword (HackagePassword), HackageUser)
+import Hix.Managed.Cabal.Data.HackageLocation (
+  HackageAuth (..),
+  HackageLocation (auth),
+  HackagePassword (..),
+  HackageSecret (..),
+  HackageToken (..),
+  HackageUser,
+  )
 import Hix.Managed.Cabal.Data.HackageRepo (HackageName, HackageRepo (..), centralName)
 import Hix.Managed.Cabal.HackageLocation (parseLocation)
 import Hix.Managed.Cabal.HackageRepo (hackageDescription)
@@ -64,18 +73,18 @@ isReinstallableId package = isReinstallable package.name
 isNonReinstallableDep :: MutableDep -> Bool
 isNonReinstallableDep = isNonReinstallable . depName
 
-resolvePasswordEnvVar :: Text -> M HackagePassword
-resolvePasswordEnvVar name =
+resolveSecretEnvVar :: Text -> M HackageSecret
+resolveSecretEnvVar name =
   lookup >>= \case
     [] -> clientError (message "is empty")
-    value -> pure (HackagePassword (toText value))
+    value -> pure (HackageSecret (toText value))
   where
     lookup = noteClient (message "does not exist") =<< tryIOM (lookupEnv (toString name))
 
     message problem = [exon|The specified environment variable #{Color.cyan name} #{problem}|]
 
-resolvePasswordExec :: Text -> M HackagePassword
-resolvePasswordExec spec =
+resolveSecretExec :: Text -> M HackageSecret
+resolveSecretExec spec =
   noteClient (message "is not a valid path") (Path.parseSomeFile (toString spec)) >>= \case
     Abs path -> checkPath path
     Rel rel ->
@@ -93,7 +102,7 @@ resolvePasswordExec spec =
       liftIO (tryIOError (Process.readProcessStdout (Process.proc (toFilePath path) []))) >>= \case
         Right (ExitSuccess, output)
           | LByteString.null output -> failure "printed nothing on stdout"
-          | [pw] <- Text.lines (decodeUtf8 output) -> pure (HackagePassword pw)
+          | [secret] <- Text.lines (decodeUtf8 output) -> pure (HackageSecret secret)
           | otherwise -> failure "printed multiple lines"
         Right (ExitFailure code, _) -> failure [exon|exited with code #{show @_ @Int code}|]
         Left err -> do
@@ -104,40 +113,48 @@ resolvePasswordExec spec =
 
     message problem = [exon|The specified executable #{Color.path spec} #{problem}|]
 
-resolvePassword :: ContextHackagePassword -> M HackagePassword
-resolvePassword =
+resolveSecret :: ContextHackageSecret -> M HackageSecret
+resolveSecret =
   appContextVerbose ctx . \case
-    PasswordUnobscured pw -> pure pw
-    PasswordPlain pw -> pure pw
-    PasswordEnvVar name -> resolvePasswordEnvVar name
-    PasswordExec path -> resolvePasswordExec path
+    SecretUnobscured secret -> pure secret
+    SecretPlain secret -> pure secret
+    SecretEnvVar name -> resolveSecretEnvVar name
+    SecretExec path -> resolveSecretExec path
   where
     ctx = "resolving the password"
 
 withAuth ::
   HackageLocation ->
   Maybe HackageUser ->
   Maybe ContextHackagePassword ->
+  Maybe ContextHackageToken ->
   M HackageLocation
 withAuth location = \cases
-  (Just user) Nothing ->
+  _ (Just _) (Just _) ->
+    bothSorts
+  (Just user) Nothing _ ->
     onlyOne [exon|user (##{user})|] "password"
-  Nothing (Just _) ->
+  Nothing (Just _) Nothing ->
     onlyOne "password" "user"
-  Nothing Nothing ->
+  Nothing Nothing Nothing ->
     pure location
-  (Just user) (Just passwordSpec) -> do
-    password <- resolvePassword passwordSpec
-    pure location {auth = Just (user, password)}
+  (Just user) (Just passwordSpec) Nothing -> do
+    secret <- resolveSecret passwordSpec.secret
+    pure location {auth = Just (HackageAuthPassword {user, password = HackagePassword secret})}
+  Nothing Nothing (Just tokenSpec) -> do
+    secret <- resolveSecret tokenSpec.secret
+    pure location {auth = Just (HackageAuthToken {token = HackageToken secret})}
   where
     onlyOne present absent = clientError [exon|Specified a #{present}, but no #{absent}|]
 
+    bothSorts = clientError "Specified both password and auth token"
+
 validateContextRepo :: ContextHackageRepo -> M HackageRepo
 validateContextRepo ContextHackageRepo {location = location0, ..} = do
   appContextVerbose [exon|validating the Hackage config #{Color.yellow name}|] do
     location1 <- for location0 \ (ContextHackageLocation spec) ->
       eitherClient (first toText (parseLocation (toString spec)))
-    location <- withAuth (fromMaybe HackageLocation.central location1) user password
+    location <- withAuth (fromMaybe HackageLocation.central location1) user password token
     pure HackageRepo {
       name,
       description = fromMaybe (hackageDescription location) description,

packages/hix/lib/Hix/Managed/Cabal/ContextHackageRepo.hs

@@ -14,9 +14,11 @@ import Hix.Managed.Cabal.Data.ContextHackageRepo (
   ContextHackageLocation (..),
   ContextHackagePassword (..),
   ContextHackageRepo (..),
+  ContextHackageSecret (..),
+  ContextHackageToken (..),
   contextHackageRepo,
   )
-import Hix.Managed.Cabal.Data.HackageLocation (HackagePassword (..), HackageUser (..))
+import Hix.Managed.Cabal.Data.HackageLocation (HackageSecret (..), HackageUser (..))
 import Hix.Managed.Cabal.Data.HackageRepo (HackageName, centralName)
 
 update' ::
@@ -57,7 +59,8 @@ fields =
     ("enable", update #enable bool),
     ("location", update #location (text ContextHackageLocation)),
     ("user", update #user (text HackageUser)),
-    ("password", update' True #password (text (PasswordPlain . HackagePassword))),
+    ("password", update' True #password (text (ContextHackagePassword . SecretPlain . HackageSecret))),
+    ("token", update' True #token (text (ContextHackageToken . SecretPlain . HackageSecret))),
     ("secure", update #secure bool),
     ("keys", update #keys (nonEmpty . Text.splitOn "," . toText)),
     ("indexState", update #indexState simpleParsec),

packages/hix/lib/Hix/Managed/Cabal/Data/ContextHackageRepo.hs

@@ -7,7 +7,7 @@ import Text.PrettyPrint
 
 import Hix.Class.EncodeNix (EncodeNix (encodeNix))
 import Hix.Data.NixExpr (Expr (..), ExprAttr (..))
-import Hix.Managed.Cabal.Data.HackageLocation (HackagePassword (HackagePassword), HackageUser)
+import Hix.Managed.Cabal.Data.HackageLocation (HackageSecret (..), HackageUser)
 import Hix.Managed.Cabal.Data.HackageRepo (HackageDescription, HackageIndexState, HackageName)
 import Hix.NixExpr (mkAttrs, single, singleOpt)
 import Hix.Pretty (field, prettyFieldsV, prettyText)
@@ -20,52 +20,62 @@ newtype ContextHackageLocation =
 instance Pretty ContextHackageLocation where
   pretty = prettyText . coerce
 
-data ContextHackagePassword =
+data ContextHackageSecret =
   -- | Password was intended to be printed, most likely in a test.
-  PasswordUnobscured HackagePassword
+  SecretUnobscured HackageSecret
   |
-  PasswordPlain HackagePassword
+  SecretPlain HackageSecret
   |
-  PasswordEnvVar Text
+  SecretEnvVar Text
   |
-  PasswordExec Text
+  SecretExec Text
   deriving stock (Eq, Show)
 
-instance Pretty ContextHackagePassword where
+instance Pretty ContextHackageSecret where
   pretty = \case
-    PasswordUnobscured (HackagePassword pw) -> prettyText pw
-    PasswordPlain _ -> "<password>"
-    PasswordEnvVar var -> prettyText var <+> brackets (text "env-var")
-    PasswordExec exe -> prettyText exe <+> brackets (text "exec")
+    SecretUnobscured (HackageSecret pw) -> prettyText pw
+    SecretPlain _ -> "<password>"
+    SecretEnvVar var -> prettyText var <+> brackets (text "env-var")
+    SecretExec exe -> prettyText exe <+> brackets (text "exec")
 
-instance EncodeNix ContextHackagePassword where
+instance EncodeNix ContextHackageSecret where
   encodeNix = \case
-    PasswordUnobscured (HackagePassword pw) -> ExprString pw
-    PasswordPlain _ -> ExprString "<password>"
-    PasswordEnvVar var -> structured "env-var" var
-    PasswordExec exe -> structured "exec" exe
+    SecretUnobscured (HackageSecret pw) -> ExprString pw
+    SecretPlain _ -> ExprString "<password>"
+    SecretEnvVar var -> structured "env-var" var
+    SecretExec exe -> structured "exec" exe
     where
       structured t value =
         ExprAttrs [
           ExprAttr "type" (ExprString t),
           ExprAttr {name = "value", value = ExprString value}
         ]
 
-instance FromJSON ContextHackagePassword where
+instance FromJSON ContextHackageSecret where
   parseJSON v =
-    withText "ContextHackagePassword" plain v
+    withText "ContextHackageSecret" plain v
     <|>
-    withObject "ContextHackagePassword" typed v
+    withObject "ContextHackageSecret" typed v
     where
       typed o = do
         value <- o .: "value"
         o .: "type" >>= \case
           ("plain" :: Text) -> plain value
-          "env-var" -> pure (PasswordEnvVar value)
-          "exec" -> pure (PasswordExec value)
+          "env-var" -> pure (SecretEnvVar value)
+          "exec" -> pure (SecretExec value)
           t -> fail [exon|Invalid value for Hackage password type: ##{t}|]
 
-      plain = pure . PasswordPlain . HackagePassword
+      plain = pure . SecretPlain . HackageSecret
+
+newtype ContextHackagePassword =
+  ContextHackagePassword { secret :: ContextHackageSecret }
+  deriving stock (Eq, Show, Generic)
+  deriving newtype (Pretty, EncodeNix, FromJSON)
+
+newtype ContextHackageToken =
+  ContextHackageToken { secret :: ContextHackageSecret }
+  deriving stock (Eq, Show, Generic)
+  deriving newtype (Pretty, EncodeNix, FromJSON)
 
 data ContextHackageRepo =
   ContextHackageRepo {
@@ -75,6 +85,7 @@ data ContextHackageRepo =
     location :: Maybe ContextHackageLocation,
     user :: Maybe HackageUser,
     password :: Maybe ContextHackagePassword,
+    token :: Maybe ContextHackageToken,
     secure :: Maybe Bool,
     keys :: Maybe (NonEmpty Text),
     indexState :: Maybe HackageIndexState,
@@ -93,6 +104,7 @@ instance Pretty ContextHackageRepo where
       field "location" location,
       field "user" user,
       field "password" password,
+      field "token" token,
       field "secure" secure,
       field "keys" keys,
       field "indexState" indexState,
@@ -125,6 +137,7 @@ contextHackageRepo name =
     location = Nothing,
     user = Nothing,
     password = Nothing,
+    token = Nothing,
     secure = Nothing,
     keys = Nothing,
     indexState = Nothing,

packages/hix/lib/Hix/Managed/Cabal/Data/HackageLocation.hs

@@ -60,23 +60,39 @@ newtype HackageUser =
 instance Pretty HackageUser where
   pretty = prettyNt
 
-newtype HackagePassword =
-  HackagePassword Text
+newtype HackageSecret =
+  HackageSecret { text :: Text }
   deriving stock (Eq)
   deriving newtype (IsString, Ord, FromJSON)
 
-instance Show HackagePassword where
+instance Show HackageSecret where
   showsPrec d _ = showParen (d > 10) (showString "HackagePassword <password>")
 
-instance Pretty HackagePassword where
+instance Pretty HackageSecret where
   pretty _ = "<password>"
 
+newtype HackagePassword =
+  HackagePassword { secret :: HackageSecret }
+  deriving stock (Eq, Show)
+  deriving newtype (IsString, Ord, FromJSON)
+
+newtype HackageToken =
+  HackageToken { secret :: HackageSecret }
+  deriving stock (Eq, Show)
+  deriving newtype (IsString, Ord, FromJSON)
+
+data HackageAuth =
+  HackageAuthPassword { user :: HackageUser, password :: HackagePassword }
+  |
+  HackageAuthToken { token :: HackageToken }
+  deriving stock (Eq, Show)
+
 data HackageLocation =
   HackageLocation {
     host :: HackageHost,
     tls :: HackageTls,
     port :: Maybe HackagePort,
-    auth :: Maybe (HackageUser, HackagePassword)
+    auth :: Maybe HackageAuth
   }
   deriving stock (Eq, Show, Generic)
 

packages/hix/lib/Hix/Managed/Handlers/HackageClient/Prod.hs

@@ -18,6 +18,7 @@ import Network.HTTP.Client.MultipartFormData (formDataBody, partBS)
 import Network.HTTP.Types (
   Status (statusCode, statusMessage),
   hAccept,
+  hAuthorization,
   hContentType,
   statusIsClientError,
   statusIsServerError,
@@ -31,10 +32,13 @@ import Hix.Http (httpManager)
 import qualified Hix.Log as Log
 import Hix.Managed.Cabal.Data.Config (CabalConfig, HackagePurpose, hackagesFor)
 import Hix.Managed.Cabal.Data.HackageLocation (
+  HackageAuth (..),
   HackageHost (..),
   HackageLocation (..),
-  HackagePassword (HackagePassword),
+  HackagePassword (..),
+  HackageSecret (..),
   HackageTls (..),
+  HackageToken (..),
   HackageUser (..),
   hackageTlsBool,
   )
@@ -101,8 +105,11 @@ nativeRequest location request@HackageRequest {..} = do
       Left fields -> formDataBody [partBS key (encodeUtf8 value) | (key, value) <- toList fields]
 
     addAuth =
-      maybe id \ (HackageUser user, HackagePassword password) ->
-        applyBasicAuth (encodeUtf8 user) (encodeUtf8 password)
+      maybe id \case
+        HackageAuthPassword {user = HackageUser user, password = HackagePassword (HackageSecret password)} ->
+          applyBasicAuth (encodeUtf8 user) (encodeUtf8 password)
+        HackageAuthToken {token = HackageToken (HackageSecret token)} ->
+           \ req -> req {requestHeaders = (hAuthorization, (encodeUtf8 token)) : req.requestHeaders}
 
     addQuery = maybe id \ q -> setQueryString (second Just <$> toList q)
 
@@ -178,8 +185,8 @@ handlersMock manager port = do
         host = "localhost",
         tls = TlsOff,
         port = Just (fromIntegral port),
-        auth = Just ("admin", "admin")
+        auth = Just (HackageAuthPassword {user = "admin", password = "admin"})
       }
     }
-    userRes = res {location = res.location {auth = Just ("test", "test")}}
+    userRes = res {location = res.location {auth = Just (HackageAuthPassword {user = "test", password = "test"})}}
     adminClient = handlersProd res