Fix handling of HashJWTs so they're still compatible with old UCM versions

Author: ChrisPenner

app/Env.hs

@@ -91,8 +91,14 @@ withEnv action = do
   let acceptedAudiences = Set.singleton apiOrigin
   let legacyKey = JWT.KeyDescription {JWT.key = hs256Key, JWT.alg = JWT.HS256}
   let signingKey = JWT.KeyDescription {JWT.key = edDSAKey, JWT.alg = JWT.Ed25519}
-  let rotatedKeys = Set.empty
-  jwtSettings <- case JWT.defaultJWTSettings signingKey (Just legacyKey) rotatedKeys acceptedAudiences apiOrigin of
+  hashJWTJWK <- case JWT.keyDescToJWK legacyKey of
+    Left err -> throwIO err
+    Right (_thumbprint, jwk) -> pure jwk
+  -- I explicitly add the legacy key to the validation keys, so that the thumbprinted
+  -- version of the key is used for validation, which is needed for HashJWTs which are signed
+  -- with a 'kid'.
+  let validationKeys = Set.fromList [legacyKey]
+  jwtSettings <- case JWT.defaultJWTSettings signingKey (Just legacyKey) validationKeys acceptedAudiences apiOrigin of
     Left cryptoError -> throwIO cryptoError
     Right settings -> pure settings
   let cookieSettings = Cookies.defaultCookieSettings Deployment.onLocal (Just (realToFrac cookieSessionTTL))

share-auth/src/Share/JWT.hs

@@ -10,7 +10,9 @@ module Share.JWT
     ServantAuth.ToJWT (..),
     ServantAuth.FromJWT (..),
     signJWT,
+    signJWTWithJWK,
     verifyJWT,
+    keyDescToJWK,
 
     -- * Additional Helpers
     textToSignedJWT,
@@ -97,7 +99,8 @@ newtype KeyThumbprint = KeyThumbprint Text
 
 data KeyMap = KeyMap
   { byKeyId :: (Map KeyThumbprint JWT.JWK),
-    -- | The key from before the introduction of key ids. This will be used to verify legacy tokens, but can eventually be removed.
+    -- | The key from before the introduction of key ids.
+    -- This will be used to verify legacy tokens, but is also used to sign HashJWTs on share.
     legacyKey :: Maybe JWT.JWK
   }
   deriving (Show) via (Censored KeyMap)
@@ -134,11 +137,11 @@ defaultJWTSettings ::
   -- E.g. https://api.unison-lang.org
   URI ->
   Either CryptoError JWTSettings
-defaultJWTSettings signingKey legacyKey oldValidKeys acceptedAudiences issuer = toEither do
-  sjwk@(_, signingJWK) <- toJWK signingKey
-  verificationJWKs <- (sjwk :) <$> traverse toJWK (Set.toList oldValidKeys)
+defaultJWTSettings signingKey legacyKey oldValidKeys acceptedAudiences issuer = do
+  sjwk@(_, signingJWK) <- keyDescToJWK signingKey
+  verificationJWKs <- (sjwk :) <$> traverse keyDescToJWK (Set.toList oldValidKeys)
   let byKeyId = Map.fromList verificationJWKs
-  legacyKey <- traverse toJWK legacyKey <&> fmap snd
+  legacyKey <- traverse keyDescToJWK legacyKey <&> fmap snd
   pure $
     JWTSettings
       { signingJWK,
@@ -148,31 +151,33 @@ defaultJWTSettings signingKey legacyKey oldValidKeys acceptedAudiences issuer =
         acceptedAudiences,
         issuer
       }
+
+-- | Converts a 'KeyDescription' to a 'JWK' and a 'KeyThumbprint'.
+keyDescToJWK :: KeyDescription -> Either CryptoError (KeyThumbprint, JWK.JWK)
+keyDescToJWK (KeyDescription {key, alg}) = cryptoFailableToEither $ do
+  case alg of
+    HS256 -> do
+      let jwk =
+            JWK.fromOctets key
+              & JWK.jwkUse .~ Just JWK.Sig
+              & JWK.jwkAlg .~ Just (JWK.JWSAlg JWS.HS256)
+      let thumbprint = jwkThumbprint jwk
+      pure (KeyThumbprint thumbprint, jwk & JWK.jwkKid .~ Just thumbprint)
+    Ed25519 -> do
+      privKey <- Ed25519.secretKey key
+      let pubKey = Ed25519.toPublic privKey
+      let jwk =
+            (JWT.Ed25519Key pubKey (Just privKey))
+              & JWT.OKPKeyMaterial
+              & JWK.fromKeyMaterial
+              & JWK.jwkUse .~ Just JWK.Sig
+              & JWK.jwkAlg .~ Just (JWK.JWSAlg JWS.EdDSA)
+      let thumbprint = jwkThumbprint jwk
+      pure (KeyThumbprint thumbprint, jwk & JWK.jwkKid .~ Just thumbprint)
   where
-    toEither :: CryptoFailable a -> Either CryptoError a
-    toEither (CryptoFailed err) = Left err
-    toEither (CryptoPassed a) = Right a
-    toJWK :: KeyDescription -> CryptoFailable (KeyThumbprint, JWK.JWK)
-    toJWK (KeyDescription {key, alg}) =
-      case alg of
-        HS256 -> do
-          let jwk =
-                JWK.fromOctets key
-                  & JWK.jwkUse .~ Just JWK.Sig
-                  & JWK.jwkAlg .~ Just (JWK.JWSAlg JWS.HS256)
-          let thumbprint = jwkThumbprint jwk
-          pure (KeyThumbprint thumbprint, jwk & JWK.jwkKid .~ Just thumbprint)
-        Ed25519 -> do
-          privKey <- Ed25519.secretKey key
-          let pubKey = Ed25519.toPublic privKey
-          let jwk =
-                (JWT.Ed25519Key pubKey (Just privKey))
-                  & JWT.OKPKeyMaterial
-                  & JWK.fromKeyMaterial
-                  & JWK.jwkUse .~ Just JWK.Sig
-                  & JWK.jwkAlg .~ Just (JWK.JWSAlg JWS.EdDSA)
-          let thumbprint = jwkThumbprint jwk
-          pure (KeyThumbprint thumbprint, jwk & JWK.jwkKid .~ Just thumbprint)
+    cryptoFailableToEither :: CryptoFailable a -> Either CryptoError a
+    cryptoFailableToEither (CryptoFailed err) = Left err
+    cryptoFailableToEither (CryptoPassed a) = Right a
 
     jwkThumbprint :: JWK.JWK -> Text
     jwkThumbprint jwk =
@@ -216,10 +221,15 @@ textToSignedJWT jwtText = JWT.decodeCompact (TL.encodeUtf8 . TL.fromStrict $ jwt
 
 -- | Signs and encodes a JWT using the given 'JWTSettings'.
 signJWT :: forall m v. (MonadIO m, ServantAuth.ToJWT v) => JWTSettings -> v -> m (Either JWT.JWTError JWT.SignedJWT)
-signJWT JWTSettings {signingJWK} v = runExceptT $ do
+signJWT JWTSettings {signingJWK} v = signJWTWithJWK signingJWK v
+
+-- | Signs and encodes a JWT using the given JWK, you should typically use 'signJWT' instead
+-- unless you have a specific reason to use a different JWK.
+signJWTWithJWK :: forall m v. (MonadIO m, ServantAuth.ToJWT v) => JWK.JWK -> v -> m (Either JWT.JWTError JWT.SignedJWT)
+signJWTWithJWK jwk v = runExceptT $ do
   let claimsSet = ServantAuth.encodeJWT v
-  jwtHeader <- mapExceptT liftIO (JWT.makeJWSHeader signingJWK)
-  mapExceptT liftIO (JWT.signClaims signingJWK jwtHeader claimsSet)
+  jwtHeader <- mapExceptT liftIO (JWT.makeJWSHeader jwk)
+  mapExceptT liftIO (JWT.signClaims jwk jwtHeader claimsSet)
 
 -- | Decodes a JWT and verifies the following:
 -- * algorithm (except for legacy tokens)

src/Share/Env.hs

@@ -3,6 +3,7 @@ module Share.Env
   )
 where
 
+import Crypto.JOSE.JWK qualified as JWK
 import Database.Redis qualified as R
 import Hasql.Pool qualified as Hasql
 import Network.URI (URI)
@@ -34,6 +35,7 @@ data Env ctx = Env
     githubClientID :: Text,
     githubClientSecret :: Text,
     jwtSettings :: JWT.JWTSettings,
+    hashJWTJWK :: JWK.JWK,
     cookieSettings :: Cookies.CookieSettings,
     sessionCookieKey :: Text,
     sandboxedRuntime :: Runtime Symbol,

src/Share/Web/Authentication/HashJWT.hs

@@ -10,7 +10,7 @@ import Unison.Share.API.Hash (HashJWTClaims)
 
 signHashJWT :: HashJWTClaims -> WebApp SignedJWT
 signHashJWT claims = do
-  jSettings <- asks Env.jwtSettings
-  JWT.signJWT jSettings claims >>= \case
+  hashJWTJWK <- asks Env.hashJWTJWK
+  JWT.signJWTWithJWK hashJWTJWK claims >>= \case
     Left err -> respondError (InternalServerError "jwt:signing-error" err)
     Right a -> pure a

transcripts/share-apis/releases/project-release-ucm-create.json

@@ -1,12 +1,12 @@
 {
   "body": {
     "payload": {
-      "branch-head": "eyJhbGciOiJIUzI1NiJ9.eyJoIjoic2c2MGJ2am85MWZzb283cGtoOWdlamJuMHFnYzk1dnJhODdhcDZsNWQzNXJpMGxrYXVkbDdiczEyZDcxc2YzZmg2cDIzdGVlbXVvcjdtazFpOW41NjdtNTBpYmFrY2doamVjNWFqZyIsInQiOiJoaiIsInUiOiJVLWQzMmY0ZGRmLTI0MjMtNGYxMC1hNGRlLTQ2NTkzOTk1MTM1NCJ9.Cy7vswarIBxyh-HzT7bckfZu6CVzTCm2F3kMLBiHf0s",
+      "branch-head": "eyJhbGciOiJIUzI1NiIsImtpZCI6IkxCVkJwSlZBZ2hJVHctbll1VlMxZUw3RjFyaWp5VXNqcV9Xd2QzNWJkYXcifQ.eyJoIjoic2c2MGJ2am85MWZzb283cGtoOWdlamJuMHFnYzk1dnJhODdhcDZsNWQzNXJpMGxrYXVkbDdiczEyZDcxc2YzZmg2cDIzdGVlbXVvcjdtazFpOW41NjdtNTBpYmFrY2doamVjNWFqZyIsInQiOiJoaiIsInUiOiJVLWQzMmY0ZGRmLTI0MjMtNGYxMC1hNGRlLTQ2NTkzOTk1MTM1NCJ9.X-GqvqfKSn4im2wDpQq3Zj3Rli4ge4SmmPuNgtvZL0A",
       "branch-id": "R-<UUID>",
       "branch-name": "releases/4.5.6",
       "project-id": "P-<UUID>",
       "project-name": "@test/publictestproject",
-      "squashed-branch-head": "eyJhbGciOiJIUzI1NiJ9.eyJoIjoic2c2MGJ2am85MWZzb283cGtoOWdlamJuMHFnYzk1dnJhODdhcDZsNWQzNXJpMGxrYXVkbDdiczEyZDcxc2YzZmg2cDIzdGVlbXVvcjdtazFpOW41NjdtNTBpYmFrY2doamVjNWFqZyIsInQiOiJoaiIsInUiOiJVLWQzMmY0ZGRmLTI0MjMtNGYxMC1hNGRlLTQ2NTkzOTk1MTM1NCJ9.Cy7vswarIBxyh-HzT7bckfZu6CVzTCm2F3kMLBiHf0s"
+      "squashed-branch-head": "eyJhbGciOiJIUzI1NiIsImtpZCI6IkxCVkJwSlZBZ2hJVHctbll1VlMxZUw3RjFyaWp5VXNqcV9Xd2QzNWJkYXcifQ.eyJoIjoic2c2MGJ2am85MWZzb283cGtoOWdlamJuMHFnYzk1dnJhODdhcDZsNWQzNXJpMGxrYXVkbDdiczEyZDcxc2YzZmg2cDIzdGVlbXVvcjdtazFpOW41NjdtNTBpYmFrY2doamVjNWFqZyIsInQiOiJoaiIsInUiOiJVLWQzMmY0ZGRmLTI0MjMtNGYxMC1hNGRlLTQ2NTkzOTk1MTM1NCJ9.X-GqvqfKSn4im2wDpQq3Zj3Rli4ge4SmmPuNgtvZL0A"
     },
     "type": "success"
   },