shomei-jwt (empty) → 0.2.0.0

raw patch · 20 files changed

+2261/−0 lines, 20 filesdep +aesondep +basedep +base64-bytestring

Dependencies added: aeson, base, base64-bytestring, bytestring, containers, crypton, effectful, effectful-core, jose, lens, monad-time, mtl, ram, shomei-core, shomei-jwt, tasty, tasty-hunit, text, time

Files

• CHANGELOG.md +33/−0
• LICENSE +21/−0
• shomei-jwt.cabal +107/−0
• src/Shomei/SigningKey/Jwks/Jwt.hs +38/−0
• src/Shomei/SigningKey/Key/Jwt.hs +118/−0
• src/Shomei/SigningKey/Protection/Jwt.hs +179/−0
• src/Shomei/SigningKey/Rotation/Jwt.hs +58/−0
• src/Shomei/SigningKey/Sign/Jwt.hs +221/−0
• src/Shomei/SigningKey/Verify/Jwt.hs +265/−0
• test/Main.hs +28/−0
• test/Shomei/SigningKey/Interpreter/JwtSpec.hs +30/−0
• test/Shomei/SigningKey/Jwks/JwtSpec.hs +45/−0
• test/Shomei/SigningKey/Key/JwtSpec.hs +52/−0
• test/Shomei/SigningKey/Protection/JwtSpec.hs +186/−0
• test/Shomei/SigningKey/Rotation/JwtSpec.hs +136/−0
• test/Shomei/SigningKey/Sign/IdTokenSpec.hs +140/−0
• test/Shomei/SigningKey/Sign/JwtSpec.hs +213/−0
• test/Shomei/SigningKey/Sign/RsaCustomClaimSpec.hs +100/−0
• test/Shomei/SigningKey/TestSupport.hs +75/−0
• test/Shomei/SigningKey/Verify/JwtSpec.hs +216/−0

@@ -0,0 +1,33 @@+# Changelog for shomei-jwt++All notable changes to `shomei-jwt` are documented here. This package adheres to the+[PVP](https://pvp.haskell.org/) and is versioned independently of the other+Shōmei packages.++## 0.2.0.0 — 2026-08-27++- **Breaking:** requires `shomei-core ^>=0.2.0.0`.+- **Breaking:** `toStoredSigningKey` and `toStoredSigningKeyFor` now return `Either Text+  StoredSigningKey` and refuse keys without a public projection; generated and published JWKs+  explicitly carry their signing `alg`.+- Verification is pinned to ES256/RS256 and selects exactly by `kid`; missing and unknown key IDs,+  malformed list claims, multi-valued audiences, and access-token `typ` mismatches are rejected.+- JWT numeric dates are emitted at whole-second precision, access tokens carry `typ: at+jwt`, and+  configurable clock skew applies to `exp`, `nbf`, and `iat`.+- Key rotation uses the store's atomic active-key replacement operation and keeps retired overlap+  keys trusted while immediately excluding revoked keys.++## 0.1.0.0 — 2026-08-24++Initial release. Interprets Shōmei's signing-key effects with `jose`.++- ES256 and RS256 access-token signing and verification, and OpenID Connect+  ID tokens. RSA signing is pinned to RS256 rather than PSS.+- JWKS publishing over the full publishable key set, with hot reload, so+  relying services can verify tokens offline.+- Key rotation with an overlap window: a retired key keeps verifying+  outstanding tokens until they expire.+- Envelope encryption for signing keys at rest, with decrypt-at-load and+  rewrap.+- An extensible custom-claims bag on `AuthClaims`, plus the `act` actor+  claim for delegated tokens and the reserved `permissions` claim.

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Nadeem Bitar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,107 @@+cabal-version:   3.0+name:            shomei-jwt+version:         0.2.0.0+synopsis:        JWT access-token signing/verification and JWKS publishing+description:+  Interprets Shōmei's signing-key effects with jose. Signs and verifies ES256+  (or, configurably, RS256) access tokens and OpenID Connect ID tokens,+  publishes the JWKS document that relying services fetch to verify those+  tokens offline, and implements key rotation with an overlap window so a+  retired key keeps verifying outstanding tokens until they expire. Depends+  only on shomei-core, so it can be used without Shōmei's HTTP or PostgreSQL+  layers.++homepage:        https://github.com/shinzui/shomei+bug-reports:     https://github.com/shinzui/shomei/issues+license:         MIT+license-file:    LICENSE+author:          Nadeem Bitar+maintainer:      nadeem@gmail.com+copyright:       2026 Nadeem Bitar+category:        Web, Security+tested-with:     GHC ==9.12.4+extra-doc-files: CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/shinzui/shomei.git++common warnings+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++common shared+  default-language:   GHC2024+  default-extensions:+    BlockArguments+    DeriveAnyClass+    DuplicateRecordFields+    MultilineStrings+    OverloadedLabels+    OverloadedRecordDot+    OverloadedStrings+    QualifiedDo+    TemplateHaskell++library+  import:          warnings, shared+  hs-source-dirs:  src+  exposed-modules:+    Shomei.SigningKey.Jwks.Jwt+    Shomei.SigningKey.Key.Jwt+    Shomei.SigningKey.Protection.Jwt+    Shomei.SigningKey.Rotation.Jwt+    Shomei.SigningKey.Sign.Jwt+    Shomei.SigningKey.Verify.Jwt++  build-depends:+    , aeson              >=2.1      && <2.3+    , base               >=4.18     && <5+    , base64-bytestring  >=1.2      && <1.3+    , bytestring         >=0.11     && <0.13+    , containers         >=0.6      && <0.9+    , crypton            >=1.1.0    && <1.2+    , effectful          >=2.5      && <2.8+    , effectful-core     >=2.5      && <2.8+    , jose               >=0.13     && <0.14+    , lens               >=5.2      && <5.4+    , monad-time         >=0.4      && <0.5+    , mtl                >=2.3      && <2.4+    , ram                >=0.22     && <0.23+    , shomei-core        ^>=0.2.0.0+    , text               >=2.0      && <2.2+    , time               >=1.12     && <1.15++test-suite shomei-jwt-test+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  other-modules:+    Shomei.SigningKey.Interpreter.JwtSpec+    Shomei.SigningKey.Jwks.JwtSpec+    Shomei.SigningKey.Key.JwtSpec+    Shomei.SigningKey.Protection.JwtSpec+    Shomei.SigningKey.Rotation.JwtSpec+    Shomei.SigningKey.Sign.IdTokenSpec+    Shomei.SigningKey.Sign.JwtSpec+    Shomei.SigningKey.Sign.RsaCustomClaimSpec+    Shomei.SigningKey.TestSupport+    Shomei.SigningKey.Verify.JwtSpec++  build-depends:+    , aeson        >=2.1      && <2.3+    , base         >=4.18     && <5+    , bytestring   >=0.11     && <0.13+    , containers   >=0.6      && <0.9+    , effectful    >=2.5      && <2.8+    , jose         >=0.13     && <0.14+    , lens         >=5.2      && <5.4+    , ram          >=0.22     && <0.23+    , shomei-core  ^>=0.2.0.0+    , shomei-jwt   ^>=0.2.0.0+    , tasty        >=1.4      && <1.6+    , tasty-hunit  >=0.10     && <0.11+    , text         >=2.0      && <2.2+    , time         >=1.12     && <1.15

@@ -0,0 +1,38 @@+-- | The published JWKS (JSON Web Key Set) document and the 'KeySet' abstraction.+--+-- A JWKS is the public document a downstream verifier fetches: @{"keys":[ ... ]}@+-- containing the *public* projection of each signing key (no private @"d"@). EP-6+-- serves 'jwksDocument' at @GET /.well-known/jwks.json@.+module Shomei.SigningKey.Jwks.Jwt+  ( jwksDocument,+    KeySet (..),+    keySetPublicJwks,+  )+where++import Crypto.JOSE.JWK (JWK, JWKSet (JWKSet), asPublicKey)+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as BSL+import Shomei.Prelude++-- | A live set of signing keys: the current active key plus any retired-but-valid keys.+data KeySet = KeySet+  { activeKey :: !JWK,+    previousKeys :: ![JWK]+  }++-- | All keys in a 'KeySet' (active first), as live JWKs.+keySetAll :: KeySet -> [JWK]+keySetAll ks = ks.activeKey : ks.previousKeys++-- | The public 'JWKSet' a verifier should use (private material stripped).+keySetPublicJwks :: KeySet -> JWKSet+keySetPublicJwks ks = JWKSet (mapMaybe publicOf (keySetAll ks))+  where+    publicOf k = k ^. asPublicKey++-- | Encode a list of keys as a published JWKS document (public material only).+jwksDocument :: [JWK] -> BSL.ByteString+jwksDocument keys = Aeson.encode (JWKSet (mapMaybe publicOf keys))+  where+    publicOf k = k ^. asPublicKey

@@ -0,0 +1,118 @@+-- | Generating ES256 signing keys and converting them to/from the+-- storage-agnostic 'StoredSigningKey' record (MasterPlan IP-4).+--+-- A key's @kid@ is its RFC 7638 JWK thumbprint (the SHA-256 hash of the key's+-- canonical JSON, Base64URL-unpadded), so the same public key always yields the+-- same @kid@ and two distinct keys cannot collide. This module is the only place+-- in Shōmei that converts between the opaque JWK JSON stored in+-- 'StoredSigningKey' and a live @jose@ 'JWK'.+module Shomei.SigningKey.Key.Jwt+  ( generateSigningKey,+    generateSigningKeyFor,+    toStoredSigningKey,+    toStoredSigningKeyFor,+    fromStoredSigningKey,+    keyKid,+    joseAlg,+  )+where++import Crypto.Hash (Digest)+import Crypto.Hash.Algorithms (SHA256)+import Crypto.JOSE.JWA.JWK (Crv (P_256))+import Crypto.JOSE.JWA.JWS qualified as JWS+import Crypto.JOSE.JWK+  ( JWK,+    JWKAlg (JWSAlg),+    KeyMaterialGenParam (ECGenParam, RSAGenParam),+    KeyUse (Sig),+    asPublicKey,+    genJWK,+    jwkAlg,+    jwkKid,+    jwkUse,+    thumbprint,+  )+import Data.Aeson qualified as Aeson+import Data.ByteArray.Encoding (Base (Base64URLUnpadded), convertToBase)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Shomei.Prelude+import Shomei.SigningKey.Domain+  ( SigningAlgorithm (ES256, RS256),+    SigningKeyStatus (KeyActive),+    StoredSigningKey (..),+    signingAlgorithmToText,+  )++-- | Generate a fresh signing key for the requested algorithm, marked for+-- signature use, with its @kid@ set to its RFC 7638 thumbprint (Base64URL,+-- unpadded). @ES256@ → a P-256 EC key; @RS256@ → a 2048-bit RSA key (256 bytes,+-- comfortably above jose's 2040-bit minimum).+generateSigningKeyFor :: SigningAlgorithm -> IO JWK+generateSigningKeyFor alg = do+  k0 <- genJWK (genParam alg)+  let tp = view thumbprint k0 :: Digest SHA256+      kid = Text.decodeUtf8 (convertToBase Base64URLUnpadded tp :: ByteString)+  pure (k0 & jwkUse ?~ Sig & jwkKid ?~ kid & jwkAlg ?~ JWSAlg (joseAlg alg))+  where+    genParam ES256 = ECGenParam P_256+    genParam RS256 = RSAGenParam 256 -- 256 bytes == 2048-bit modulus++-- | Generate a fresh ES256 (P-256) signing key. Back-compat alias defined in+-- terms of 'generateSigningKeyFor'.+generateSigningKey :: IO JWK+generateSigningKey = generateSigningKeyFor ES256++-- | The @kid@ stored on a key (empty if absent — 'generateSigningKey' always sets it).+keyKid :: JWK -> Text+keyKid k = fromMaybe "" (k ^. jwkKid)++joseAlg :: SigningAlgorithm -> JWS.Alg+joseAlg ES256 = JWS.ES256+joseAlg RS256 = JWS.RS256++-- | Convert a live 'JWK' to the storage-agnostic record. Serializes the full+-- key (with the private @"d"@) to 'privateKeyJwk' and the public-only projection+-- to 'publicKeyJwk'.+toStoredSigningKey :: UTCTime -> JWK -> Either Text StoredSigningKey+toStoredSigningKey t k = do+  pub <-+    maybe+      (Left ("key " <> keyKid k <> " has no public projection; refusing to store private material as public"))+      Right+      (k ^. asPublicKey)+  let enc = Text.decodeUtf8 . BSL.toStrict . Aeson.encode+  pure+    StoredSigningKey+      { keyId = keyKid k,+        algorithm = "ES256",+        publicKeyJwk = enc pub,+        privateKeyJwk = enc k,+        status = KeyActive,+        createdAt = t,+        activatedAt = Just t,+        retiredAt = Nothing,+        revokedAt = Nothing+      }++-- | Like 'toStoredSigningKey' but records the actual algorithm of the key. New+-- code that generates RS256 keys uses this; 'toStoredSigningKey' stays the ES256+-- convenience so existing callers are unaffected.+toStoredSigningKeyFor :: SigningAlgorithm -> UTCTime -> JWK -> Either Text StoredSigningKey+toStoredSigningKeyFor alg t k =+  (\stored -> stored {algorithm = signingAlgorithmToText alg}) <$> toStoredSigningKey t k++-- | Parse a stored key's full (private) JWK JSON back into a live 'JWK'.+--+-- __Does not decrypt.__ A row whose private material is encrypted at rest (see+-- "Shomei.SigningKey.Protection.Jwt") will fail to parse here. Production code loading a signer must+-- call 'Shomei.SigningKey.Protection.Jwt.decryptStoredSigningKey', which handles both forms; this+-- function remains for tests and for callers converting an in-memory, unprotected record.+fromStoredSigningKey :: StoredSigningKey -> Either Text JWK+fromStoredSigningKey sk =+  case Aeson.eitherDecodeStrict (Text.encodeUtf8 sk.privateKeyJwk) of+    Left err -> Left (Text.pack err)+    Right k -> Right k

@@ -0,0 +1,179 @@+-- | Envelope encryption of stored signing-key private material (at-rest protection).+--+-- A signing key's private JWK is the most powerful secret in the system: whoever holds it+-- can forge a valid token for any user of any downstream service that trusts Shōmei's JWKS.+-- Stored in plaintext, a database read — or a backup, a dump, a misconfigured replica —+-- hands that power over. Here it is encrypted under a __key-encryption key__ (KEK) that+-- lives outside the database, in the process environment, so forging tokens requires the+-- database /and/ the application environment.+--+-- Format v1, held in the existing @private_key_jwk text@ column (no schema change):+--+-- > "enc:v1:" <> base64url(nonce, 12 bytes) <> ":" <> base64url(ciphertext <> tag)+--+-- Cipher: ChaCha20-Poly1305 (AEAD). The associated data is the key's @kid@, which binds+-- each ciphertext to its row: an attacker with database /write/ access cannot relabel an+-- old compromised key as the active one, because decryption under the new @kid@ fails.+--+-- Operators wanting KMS/HSM-managed keys inject the KEK from their secret manager; that+-- integration sits above Shōmei and is out of scope here.+module Shomei.SigningKey.Protection.Jwt+  ( KeyEncryptionKey,+    keyEncryptionKeyFromBase64,+    KeyDecryptError (..),+    isEncryptedPrivateJwk,+    encryptPrivateJwk,+    decryptPrivateJwk,+    protectStoredSigningKey,+    decryptStoredSigningKey,+    publicJwkFromStored,+  )+where++import Crypto.Cipher.ChaChaPoly1305 qualified as AEAD+import Crypto.Error (CryptoFailable (..))+import Crypto.JOSE.JWK (JWK, JWKAlg (JWSAlg), jwkAlg)+import Crypto.MAC.Poly1305 qualified as Poly1305+import Crypto.Random (getRandomBytes)+import Data.Aeson qualified as Aeson+import Data.Bifunctor (first)+import Data.ByteArray qualified as BA+import Data.ByteArray.Encoding (Base (Base64, Base64URLUnpadded), convertFromBase, convertToBase)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Shomei.Prelude+import Shomei.SigningKey.Domain (StoredSigningKey (..), signingAlgorithmFromText)+import Shomei.SigningKey.Key.Jwt (joseAlg)++-- | The 32-byte key that encrypts stored private keys. Abstract, with no 'Show' and no+-- JSON instances: printing it anywhere would defeat the entire scheme, so make that a type+-- error rather than a code-review question.+newtype KeyEncryptionKey = KeyEncryptionKey BA.ScrubbedBytes++-- | Parse a KEK from base64 text (the value of @SHOMEI_KEY_ENCRYPTION_KEY@). Requires+-- exactly 32 decoded bytes. The 'Left' explains what was wrong and how to make a valid one;+-- callers prefix it with the variable they read.+keyEncryptionKeyFromBase64 :: Text -> Either Text KeyEncryptionKey+keyEncryptionKeyFromBase64 raw =+  case convertFromBase Base64 (TE.encodeUtf8 (Text.strip raw)) :: Either String ByteString of+    Left err -> Left (badKek ("it is not valid base64 (" <> Text.pack err <> ")"))+    Right bs+      | BS.length bs == 32 -> Right (KeyEncryptionKey (BA.convert bs))+      | otherwise -> Left (badKek ("it decodes to " <> tshow (BS.length bs) <> " bytes, not 32"))+  where+    badKek reason =+      "is not a valid key-encryption key: "+        <> reason+        <> ". Generate one with: head -c 32 /dev/urandom | base64"+    tshow = Text.pack . show++-- | Why a stored private key could not be turned back into a live 'JWK'.+data KeyDecryptError+  = -- | The @enc:v1:@ envelope is structurally broken (missing prefix, bad base64, …).+    MalformedEncryptedKey Text+  | -- | Authentication failed. Deliberately one constructor for a wrong KEK, a tampered+    -- ciphertext, and a ciphertext moved to another row: the caller learns only that it+    -- did not authenticate.+    KeyDecryptFailed+  | -- | Decryption succeeded but the recovered bytes are not a JWK.+    KeyJsonInvalid Text+  deriving stock (Eq, Show)++envelopePrefix :: Text+envelopePrefix = "enc:v1:"++-- | Is this stored @private_key_jwk@ an envelope rather than plaintext JWK JSON? Plaintext+-- JWKs are JSON objects, so the prefix is an unambiguous discriminator.+isEncryptedPrivateJwk :: Text -> Bool+isEncryptedPrivateJwk = Text.isPrefixOf envelopePrefix++-- | Encrypt a private JWK JSON string under @kek@, binding it to @kid@.+encryptPrivateJwk :: KeyEncryptionKey -> Text -> Text -> IO Text+encryptPrivateJwk (KeyEncryptionKey kek) kid jwkJson = do+  nonceBytes <- getRandomBytes 12 :: IO ByteString+  case aeadState kek nonceBytes kid of+    CryptoFailed e -> ioError (userError ("shomei: cannot initialize key encryption: " <> show e))+    CryptoPassed st0 -> do+      let (ciphertext, st1) = AEAD.encrypt (TE.encodeUtf8 jwkJson) st0+          tag = BA.convert (AEAD.finalize st1) :: ByteString+      pure (envelopePrefix <> b64 nonceBytes <> ":" <> b64 (ciphertext <> tag))++-- | Recover private JWK JSON from the required encrypted envelope.+decryptPrivateJwk :: KeyEncryptionKey -> Text -> Text -> Either KeyDecryptError Text+decryptPrivateJwk (KeyEncryptionKey kek) kid stored+  | not (isEncryptedPrivateJwk stored) =+      Left (MalformedEncryptedKey "private key is not an enc:v1 envelope")+  | otherwise = do+      (nonceBytes, body) <- parseEnvelope stored+      when (BS.length body < 16) (Left (MalformedEncryptedKey "ciphertext is shorter than its authentication tag"))+      let (ciphertext, tagBytes) = BS.splitAt (BS.length body - 16) body+      st0 <- cryptoOr (MalformedEncryptedKey "bad nonce or key size") (aeadState kek nonceBytes kid)+      expectedTag <- cryptoOr (MalformedEncryptedKey "bad authentication tag") (Poly1305.authTag tagBytes)+      let (plaintext, st1) = AEAD.decrypt ciphertext st0+      -- 'Auth's Eq is constant-time (Data.ByteArray.constEq).+      unless (AEAD.finalize st1 == expectedTag) (Left KeyDecryptFailed)+      first (KeyJsonInvalid . Text.pack . show) (TE.decodeUtf8' plaintext)++-- | Split @enc:v1:\<nonce\>:\<body\>@ into its decoded parts.+parseEnvelope :: Text -> Either KeyDecryptError (ByteString, ByteString)+parseEnvelope stored =+  case Text.splitOn ":" (Text.drop (Text.length envelopePrefix) stored) of+    [nonceB64, bodyB64] -> do+      nonceBytes <- decodeField "nonce" nonceB64+      body <- decodeField "ciphertext" bodyB64+      when (BS.length nonceBytes /= 12) (Left (MalformedEncryptedKey "nonce is not 12 bytes"))+      pure (nonceBytes, body)+    parts ->+      Left (MalformedEncryptedKey ("expected enc:v1:<nonce>:<ciphertext>, found " <> Text.pack (show (length parts)) <> " parts"))+  where+    decodeField what t =+      first+        (\err -> MalformedEncryptedKey (what <> " is not valid base64url (" <> Text.pack err <> ")"))+        (convertFromBase Base64URLUnpadded (TE.encodeUtf8 t) :: Either String ByteString)++-- | The AEAD state for @(kek, nonce, kid-as-AAD)@, shared by encrypt and decrypt so the two+-- can never disagree about the associated data.+aeadState :: BA.ScrubbedBytes -> ByteString -> Text -> CryptoFailable AEAD.State+aeadState kek nonceBytes kid = do+  nonce <- AEAD.nonce12 nonceBytes+  st <- AEAD.initialize kek nonce+  pure (AEAD.finalizeAAD (AEAD.appendAAD (TE.encodeUtf8 kid) st))++cryptoOr :: KeyDecryptError -> CryptoFailable a -> Either KeyDecryptError a+cryptoOr err = \case+  CryptoFailed _ -> Left err+  CryptoPassed a -> Right a++b64 :: ByteString -> Text+b64 bs = TE.decodeUtf8 (convertToBase Base64URLUnpadded bs)++-- | Encrypt a key's private material before it is persisted. Idempotent for an envelope.+--+-- @publicKeyJwk@ is never encrypted — publication and verification must not depend on the+-- KEK.+protectStoredSigningKey :: KeyEncryptionKey -> StoredSigningKey -> IO StoredSigningKey+protectStoredSigningKey kek sk+  | isEncryptedPrivateJwk sk.privateKeyJwk = pure sk+  | otherwise = do+      enc <- encryptPrivateJwk kek sk.keyId sk.privateKeyJwk+      pure sk {privateKeyJwk = enc}++-- | The single stored→live conversion for __private__ key material: decrypt if needed, then+-- parse. Every path that needs a signing key goes through here; nothing else may parse+-- @private_key_jwk@.+decryptStoredSigningKey :: KeyEncryptionKey -> StoredSigningKey -> Either KeyDecryptError JWK+decryptStoredSigningKey kek sk = do+  jwkJson <- decryptPrivateJwk kek sk.keyId sk.privateKeyJwk+  first (KeyJsonInvalid . Text.pack) (Aeson.eitherDecodeStrict (TE.encodeUtf8 jwkJson))++-- | Parse a key's __public__ material. Needs no KEK, by construction: the published JWKS and+-- the verifier key set are built from this, so a missing or wrong KEK can never break+-- verification of outstanding tokens — only signing.+publicJwkFromStored :: StoredSigningKey -> Either Text JWK+publicJwkFromStored sk = do+  jwk <- first Text.pack (Aeson.eitherDecodeStrict (TE.encodeUtf8 sk.publicKeyJwk))+  pure case (jwk ^. jwkAlg, signingAlgorithmFromText sk.algorithm) of+    (Nothing, Right alg) -> jwk & jwkAlg ?~ JWSAlg (joseAlg alg)+    _ -> jwk

@@ -0,0 +1,58 @@+-- | Key rotation and the live published JWKS, written against the+-- 'SigningKeyStore' and 'Clock' port effects only (no IO key storage of its own).+--+-- Rotation is intentionally simple: generate a new active key, insert it, and mark+-- the previously-active key 'KeyRetired'. The published JWKS includes every publishable+-- key ('KeyActive' and 'KeyRetired'), so tokens signed just before rotation keep+-- verifying until they expire (zero-downtime rotation).+module Shomei.SigningKey.Rotation.Jwt+  ( rotateSigningKey,+    currentJwks,+  )+where++import Crypto.JOSE.JWK (JWK)+import Data.ByteString.Lazy qualified as BSL+import Data.Either (rights)+import Data.Text qualified as Text+import Effectful (Eff, IOE, (:>))+import Shomei.Prelude+import Shomei.SigningKey.Domain (SigningAlgorithm)+import Shomei.SigningKey.Jwks.Jwt (jwksDocument)+import Shomei.SigningKey.Key.Jwt (generateSigningKeyFor, toStoredSigningKeyFor)+import Shomei.SigningKey.Protection.Jwt (KeyEncryptionKey, protectStoredSigningKey, publicJwkFromStored)+import Shomei.SigningKey.Store+  ( SigningKeyStore,+    listPublishableSigningKeys,+    replaceActiveSigningKey,+  )+import Shomei.Time.Store (Clock, now)++-- | Generate and encrypt a new active key, then retire whatever was active. Returns the live+-- 'JWK' so the caller can sign with it immediately.+rotateSigningKey ::+  (IOE :> es, SigningKeyStore :> es, Clock :> es) =>+  KeyEncryptionKey ->+  SigningAlgorithm ->+  Eff es JWK+rotateSigningKey kek alg = do+  t <- now+  newJwk <- liftIO (generateSigningKeyFor alg)+  stored <- liftIO (either (ioError . userError . Text.unpack) pure (toStoredSigningKeyFor alg t newJwk))+  protected <- liftIO (protectStoredSigningKey kek stored)+  replaceActiveSigningKey protected t+  pure newJwk++-- | Build the published JWKS from every publishable key: the active key(s) plus the+-- retired-but-still-trusted ones, so tokens signed just before a rotation keep verifying+-- until they expire. @pending@ and @revoked@ keys are excluded by the store's+-- 'listPublishableSigningKeys' contract.+--+-- Reads the __public__ column only, so it needs no key-encryption key and works unchanged+-- against a table whose private material is encrypted at rest.+currentJwks ::+  (SigningKeyStore :> es) =>+  Eff es BSL.ByteString+currentJwks = do+  keys <- listPublishableSigningKeys+  pure (jwksDocument (rights (map publicJwkFromStored keys)))

@@ -0,0 +1,221 @@+-- jose 0.13 deprecates addClaim/unregisteredClaims in favour of payload+-- subtypes; Shōmei deliberately carries sid/scopes/roles/permissions as custom+-- claims, so we silence that one deprecation here (see the EP-4 Decision Log).+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Building a @jose@ 'ClaimsSet' from Shōmei's 'AuthClaims', signing it into an+-- 'AccessToken', and the @effectful@ 'TokenSigner' interpreter.+--+-- The standard claims map directly (@iss@, @sub@, @aud@, @iat@, @exp@); the session+-- id, scopes, roles, and permissions travel as the custom claims @sid@, @scopes@,+-- @roles@, @permissions@. The protected JWS header's @alg@ is chosen from the key+-- material ('algForKey') and the signing key's @kid@ is copied in by hand so a+-- verifier can tell which key to use.+module Shomei.SigningKey.Sign.Jwt+  ( claimsFromAuth,+    claimsFromIdToken,+    wholeSeconds,+    signAccessToken,+    signIdToken,+    runTokenSignerJwt,+  )+where++import Control.Exception (throwIO)+import Crypto.JOSE.Compact (encodeCompact)+import Crypto.JOSE.Error (runJOSE)+import Crypto.JOSE.Header (newHeaderParamProtected)+import Crypto.JOSE.JWA.JWK (KeyMaterial (ECKeyMaterial, RSAKeyMaterial))+import Crypto.JOSE.JWA.JWS (Alg (ES256, RS256))+import Crypto.JOSE.JWK (JWK, jwkMaterial)+import Crypto.JOSE.JWS (newJWSHeaderProtected)+import Crypto.JOSE.JWS qualified as JWS+import Crypto.JWT+  ( Audience (Audience),+    ClaimsSet,+    JWTError,+    NumericDate (NumericDate),+    SignedJWT,+    StringOrURI,+    addClaim,+    claimAud,+    claimExp,+    claimIat,+    claimIss,+    claimSub,+    emptyClaimsSet,+    signClaims,+  )+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy qualified as BSL+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Shomei.Authorization.Claims.Domain (AuthClaims (..))+import Shomei.Authorization.Claims.Domain qualified as Domain+import Shomei.Config (ShomeiConfig)+import Shomei.Id (idText)+import Shomei.OAuth.IdToken.Domain (IdToken (IdToken), IdTokenClaims (..))+import Shomei.Prelude+import Shomei.Session.Token.Domain (AccessToken (AccessToken))+import Shomei.SigningKey.Key.Jwt (keyKid)+import Shomei.SigningKey.Signer (TokenSigner (SignAccessToken, SignIdToken))++issuerText :: Domain.Issuer -> Text+issuerText (Domain.Issuer t) = t++audienceText :: Domain.Audience -> Text+audienceText (Domain.Audience t) = t++-- | Build a 'StringOrURI' in the canonical form jose produces when it parses a+-- claim back from JSON (a scheme-bearing string becomes a URI, otherwise an+-- arbitrary string), so signed and verified values compare equal.+sou :: Text -> StringOrURI+sou = fromString . Text.unpack++-- | Build a @jose@ 'ClaimsSet' from Shōmei's 'AuthClaims'. Standard claims map+-- directly; session id, scopes, roles, and permissions travel as the custom claims+-- @sid@, @scopes@, @roles@, @permissions@.+claimsFromAuth :: AuthClaims -> ClaimsSet+claimsFromAuth ac =+  withActor $+    -- 'addExtra' seeds the custom claims into the base FIRST, then every claim in+    -- 'Domain.reservedClaimKeys' is written through a registered slot or a managed+    -- custom claim (sid/scopes/roles/permissions below, act in 'withActor') and is+    -- applied on top, so a same-named custom key is always overwritten by Shōmei's+    -- value. Combined with 'mkExtraClaims' dropping reserved keys at construction, a+    -- service (or attacker-influenced input) can never forge a standard claim.+    addExtra ac.extraClaims emptyClaimsSet+      & claimIss+      ?~ sou (issuerText ac.issuer)+      & claimSub+      ?~ sou (idText ac.subject)+      & claimAud+      ?~ Audience [sou (audienceText ac.audience)]+      & claimIat+      ?~ NumericDate (wholeSeconds ac.issuedAt)+      & claimExp+      ?~ NumericDate (wholeSeconds ac.expiresAt)+      & addClaim "sid" (Aeson.String (idText ac.sessionId))+      & addClaim "scopes" (Aeson.toJSON (Set.toList ac.scopes))+      & addClaim "roles" (Aeson.toJSON (Set.toList ac.roles))+      & addClaim "permissions" (Aeson.toJSON (Set.toList ac.permissions))+      & addClaim "auth_time" (Aeson.toJSON (NumericDate (wholeSeconds ac.authTime)))+  where+    addExtra obj cs = KeyMap.foldrWithKey (\k v -> addClaim (Key.toText k) v) cs obj+    -- Add the @act@ claim only for delegated tokens, leaving ordinary tokens+    -- byte-identical to before this field existed.+    withActor cs = case ac.actor of+      Just uid -> cs & addClaim "act" (Aeson.String (idText uid))+      Nothing -> cs++-- | The JWS algorithm to sign with for a given key, chosen directly from the key+-- material so the header can never disagree with the key. Crucially we pick 'RS256'+-- (RSASSA-PKCS1-v1_5) for RSA keys — NOT the RSASSA-PSS variant @jose@'s+-- @bestJWSAlg@/@makeJWSHeader@ would prefer (PS512), which existing JWT consumers and+-- downstream verifiers reject. Our generators only ever produce EC or RSA keys.+algForKey :: JWK -> Alg+algForKey jwk = case view jwkMaterial jwk of+  RSAKeyMaterial _ -> RS256+  ECKeyMaterial _ -> ES256+  _ -> ES256++-- | Sign an 'AuthClaims' into an 'AccessToken' using the given (active, private)+-- key. The protected header's @alg@ is pinned by 'algForKey' (RS256 for RSA, ES256+-- for EC) rather than negotiated by @makeJWSHeader@, and the key's @kid@ is copied+-- into the header by hand so a verifier can select the right key.+signAccessToken :: JWK -> AuthClaims -> IO (Either JWTError AccessToken)+signAccessToken jwk ac = do+  let hdr =+        newJWSHeaderProtected (algForKey jwk)+          & JWS.kid+          ?~ newHeaderParamProtected (keyKid jwk)+          & JWS.typ+          ?~ newHeaderParamProtected "at+jwt"+  result <- runJOSE @JWTError $ do+    signed <- signClaims jwk hdr (claimsFromAuth ac)+    pure (encodeCompact (signed :: SignedJWT))+  pure $ case result of+    Left e -> Left e+    Right wire -> Right (AccessToken (Text.decodeUtf8 (BSL.toStrict wire)))++-- | Build a @jose@ 'ClaimsSet' for an OIDC ID token (OIDC Core §2), mirroring 'claimsFromAuth'.+--+-- Deliberately narrow. @aud@ is the @client_id@, not the API audience, so the token cannot be+-- replayed at a resource server; and there is no @sid@, no @scopes@, no @roles@, and no+-- @permissions@, because an ID token is a statement about an authentication, not a bearer+-- credential.+--+-- @auth_time@ is a JSON /number/ of Unix seconds, as OIDC Core requires — not an RFC 3339 string,+-- which is what @toJSON \@UTCTime@ would produce and what a relying party would reject.+claimsFromIdToken :: IdTokenClaims -> ClaimsSet+claimsFromIdToken idc =+  withNonce $+    emptyClaimsSet+      & claimIss+      ?~ sou (issuerText idc.issuer)+      & claimSub+      ?~ sou (idText idc.subject)+      & claimAud+      ?~ Audience [sou idc.audience]+      & claimIat+      ?~ NumericDate (wholeSeconds idc.issuedAt)+      & claimExp+      ?~ NumericDate (wholeSeconds idc.expiresAt)+      & addClaim "auth_time" (Aeson.Number (fromIntegral (unixSeconds idc.authTime)))+  where+    unixSeconds :: UTCTime -> Integer+    unixSeconds = floor . utcTimeToPOSIXSeconds++    -- Present only when the authorize request sent one, so a client that sent no nonce does not+    -- receive a null it must then decide how to interpret.+    withNonce cs = case idc.nonce of+      Just n -> cs & addClaim "nonce" (Aeson.String n)+      Nothing -> cs++-- | Sign an 'IdTokenClaims' with the same active key, @alg@ and @kid@ as 'signAccessToken', so the+-- ID token verifies against the very JWKS document this deployment already publishes.+signIdToken :: JWK -> IdTokenClaims -> IO (Either JWTError IdToken)+signIdToken jwk idc = do+  let hdr =+        newJWSHeaderProtected (algForKey jwk)+          & JWS.kid+          ?~ newHeaderParamProtected (keyKid jwk)+          & JWS.typ+          ?~ newHeaderParamProtected "JWT"+  result <- runJOSE @JWTError $ do+    signed <- signClaims jwk hdr (claimsFromIdToken idc)+    pure (encodeCompact (signed :: SignedJWT))+  pure $ case result of+    Left e -> Left e+    Right wire -> Right (IdToken (Text.decodeUtf8 (BSL.toStrict wire)))++-- | Interpret the 'TokenSigner' effect by signing with a fixed active private key.+runTokenSignerJwt ::+  (IOE :> es) =>+  JWK ->+  ShomeiConfig ->+  Eff (TokenSigner : es) a ->+  Eff es a+runTokenSignerJwt jwk _cfg = interpret_ \case+  SignAccessToken ac -> do+    r <- liftIO (signAccessToken jwk ac)+    case r of+      Right tok -> pure tok+      Left e -> liftIO (throwIO (userError ("token signing failed: " <> show e)))+  SignIdToken idc -> do+    r <- liftIO (signIdToken jwk idc)+    case r of+      Right tok -> pure tok+      Left e -> liftIO (throwIO (userError ("id token signing failed: " <> show e)))++-- | JWT NumericDate values are whole Unix seconds. Truncating at the issuer+-- avoids making successful verification depend on sub-second clock ordering.+wholeSeconds :: UTCTime -> UTCTime+wholeSeconds = posixSecondsToUTCTime . fromInteger . floor . utcTimeToPOSIXSeconds

@@ -0,0 +1,265 @@+-- jose 0.13 deprecates addClaim/unregisteredClaims in favour of payload+-- subtypes; Shōmei deliberately reads sid/scopes/roles/permissions as custom+-- claims, so we silence that one deprecation here (see the EP-4 Decision Log).+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Verifying a compact JWT back into Shōmei's 'AuthClaims', the @effectful@+-- 'TokenVerifier' interpreter, and the jose-error → 'TokenError' mapping.+--+-- 'verifyToken' is the EP-4 ↔ EP-5 contract: EP-5's Servant @Authenticated@+-- combinator runs inside an @AuthHandler@ (plain 'IO', not @effectful@), so it+-- calls this ordinary-'IO' verifier directly. The @effectful@ interpreter+-- 'runTokenVerifierJwt' is implemented on top of the same 'verifyToken'.+module Shomei.SigningKey.Verify.Jwt+  ( VerifierSettings (..),+    verifierSettingsFromConfig,+    KidSelectingKeys (..),+    checkStringOrUri,+    verifyTokenWith,+    verifyToken,+    runTokenVerifierJwt,+    jwtErrorToTokenError,+  )+where++import Crypto.JOSE.Compact (decodeCompact)+import Crypto.JOSE.Error (Error (..), runJOSE)+import Crypto.JOSE.Header (HasKid (kid), HasTyp (typ), param)+import Crypto.JOSE.JWA.JWS (Alg (ES256, RS256))+import Crypto.JOSE.JWK (JWKSet (JWKSet), jwkKid)+import Crypto.JOSE.JWK.Store (VerificationKeyStore (getVerificationKeys))+import Crypto.JOSE.JWS (header, signatures, validationSettingsAlgorithms)+import Crypto.JWT+  ( Audience (Audience),+    ClaimsSet,+    JWTError (..),+    NumericDate (NumericDate),+    SignedJWT,+    StringOrURI,+    allowedSkew,+    claimAud,+    claimExp,+    claimIat,+    claimIss,+    claimSub,+    defaultJWTValidationSettings,+    issuerPredicate,+    stringOrUri,+    unregisteredClaims,+    verifyClaims,+  )+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseEither)+import Data.ByteString.Lazy qualified as BSL+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (NominalDiffTime)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Shomei.Authorization.Claims.Domain (AuthClaims (..))+import Shomei.Authorization.Claims.Domain qualified as Domain+import Shomei.Config (ShomeiConfig (..), SigningKeyConfig (..))+import Shomei.Error (TokenError (..))+import Shomei.Id (parseId)+import Shomei.Prelude+import Shomei.Session.Token.Domain (AccessToken (AccessToken))+import Shomei.SigningKey.Verifier (TokenVerifier (VerifyAccessToken))++issuerText :: Domain.Issuer -> Text+issuerText (Domain.Issuer t) = t++audienceText :: Domain.Audience -> Text+audienceText (Domain.Audience t) = t++-- | Verification policy separated from the server's larger configuration so+-- downstream hosts can choose strict token-type enforcement independently.+data VerifierSettings = VerifierSettings+  { issuer :: !Domain.Issuer,+    audience :: !Domain.Audience,+    allowedClockSkew :: !NominalDiffTime,+    requireTokenType :: !Bool+  }+  deriving stock (Eq, Show)++verifierSettingsFromConfig :: ShomeiConfig -> VerifierSettings+verifierSettingsFromConfig cfg =+  VerifierSettings+    { issuer = cfg.issuer,+      audience = cfg.audience,+      allowedClockSkew = fromIntegral cfg.signingKeyConfig.allowedClockSkewSeconds,+      requireTokenType = False+    }++-- | A verification key store that returns only the key named by the protected+-- @kid@ header. Missing and unknown identifiers deliberately return no keys.+newtype KidSelectingKeys = KidSelectingKeys JWKSet++instance (Applicative m, HasKid h) => VerificationKeyStore m (h p) payload KidSelectingKeys where+  getVerificationKeys hdr _payload (KidSelectingKeys (JWKSet keys)) =+    pure case preview (kid . _Just . param) hdr of+      Just wanted -> filter ((== Just wanted) . view jwkKid) keys+      Nothing -> []++-- | Validate the RFC 7519 StringOrURI shape without using its partial+-- 'IsString' instance.+checkStringOrUri :: Text -> Either Text ()+checkStringOrUri value = case preview stringOrUri value of+  Just (_ :: StringOrURI) -> Right ()+  Nothing -> Left "contains ':' but is not a valid URI (RFC 7519 StringOrURI)"++-- | Verify with explicit policy. The protected @kid@ chooses exactly one public+-- key and the accepted JWS algorithms are pinned to Shōmei's ES256/RS256 set.+verifyTokenWith :: VerifierSettings -> JWKSet -> Text -> IO (Either TokenError AuthClaims)+verifyTokenWith verifierSettings jwks raw = do+  let bytes = BSL.fromStrict (Text.encodeUtf8 raw)+      matches wanted = maybe (const False) (==) (preview stringOrUri wanted)+      settings =+        defaultJWTValidationSettings (matches (audienceText verifierSettings.audience))+          & issuerPredicate+          .~ matches (issuerText verifierSettings.issuer)+          & allowedSkew+          .~ verifierSettings.allowedClockSkew+          & validationSettingsAlgorithms+          .~ Set.fromList [ES256, RS256]+  decoded <- runJOSE @JWTError do+    signed <- decodeCompact bytes+    pure (signed :: SignedJWT)+  case decoded of+    Left err -> pure (Left (jwtErrorToTokenError err))+    Right signed -> do+      let headerKid = signed ^? signatures . header . kid . _Just . param+          headerType = signed ^? signatures . header . typ . _Just . param+      result <- runJOSE @JWTError (verifyClaims settings (KidSelectingKeys jwks) signed)+      pure case result of+        Left (JWSError NoUsableKeys) -> Left (TokenKeyNotFound headerKid)+        Left err -> Left (jwtErrorToTokenError err)+        Right claims -> checkTokenType verifierSettings headerType *> claimsToAuth claims++-- | THE core/Servant contract. Existing callers receive the hardened verifier+-- through the unchanged public function.+verifyToken :: JWKSet -> ShomeiConfig -> Text -> IO (Either TokenError AuthClaims)+verifyToken jwks cfg = verifyTokenWith (verifierSettingsFromConfig cfg) jwks++-- | Interpret the 'TokenVerifier' effect over a fixed public 'JWKSet'.+runTokenVerifierJwt ::+  (IOE :> es) =>+  JWKSet ->+  ShomeiConfig ->+  Eff (TokenVerifier : es) a ->+  Eff es a+runTokenVerifierJwt jwks cfg = interpret_ \case+  VerifyAccessToken (AccessToken raw) -> liftIO (verifyToken jwks cfg raw)++-- | Map jose's 'JWTError' into the core's transport-agnostic 'TokenError'.+jwtErrorToTokenError :: JWTError -> TokenError+jwtErrorToTokenError = \case+  JWTExpired -> TokenExpired+  JWTNotYetValid -> TokenOtherError "token not yet valid"+  JWTNotInIssuer -> TokenIssuerInvalid+  JWTNotInAudience -> TokenAudienceInvalid+  JWTIssuedAtFuture -> TokenOtherError "iat in the future"+  JWTClaimsSetDecodeError _ -> TokenMalformed+  JWSError e -> jwsErrorToTokenError e++-- | Map the inner JWS 'Error' (wrapped by 'JWSError') into a 'TokenError'.+jwsErrorToTokenError :: Error -> TokenError+jwsErrorToTokenError = \case+  CompactDecodeError _ -> TokenMalformed+  JSONDecodeError _ -> TokenMalformed+  AlgorithmNotImplemented -> TokenSignatureInvalid+  AlgorithmMismatch _ -> TokenSignatureInvalid+  KeyMismatch _ -> TokenSignatureInvalid+  JWSInvalidSignature -> TokenSignatureInvalid+  JWSNoValidSignatures -> TokenSignatureInvalid+  JWSNoSignatures -> TokenSignatureInvalid+  NoUsableKeys -> TokenKeyNotFound Nothing+  other -> TokenOtherError (Text.pack (show other))++checkTokenType :: VerifierSettings -> Maybe Text -> Either TokenError ()+checkTokenType settings = \case+  Nothing+    | settings.requireTokenType -> Left (TokenOtherError "missing typ header")+    | otherwise -> Right ()+  Just tokenType+    | Text.toCaseFold tokenType `elem` ["at+jwt", "application/at+jwt"] -> Right ()+    | otherwise -> Left (TokenOtherError ("typ " <> tokenType <> " is not at+jwt"))++-- | Decode a verified jose 'ClaimsSet' back into Shōmei's 'AuthClaims'.+claimsToAuth :: ClaimsSet -> Either TokenError AuthClaims+claimsToAuth cs = do+  subTxt <- note "missing sub" (cs ^. claimSub >>= soText)+  subj <- mapLeft (const TokenMalformed) (parseId subTxt)+  sidTxt <- note "missing sid" (lookupString "sid")+  sess <- mapLeft (const TokenMalformed) (parseId sidTxt)+  issTxt <- note "missing iss" (cs ^. claimIss >>= soText)+  audTxt <- exactAudience (cs ^. claimAud)+  issuedAt' <- note "missing iat" (dateOf (cs ^. claimIat))+  expiresAt' <- note "missing exp" (dateOf (cs ^. claimExp))+  authTime' <- case Map.lookup "auth_time" claims of+    Nothing -> Right issuedAt'+    Just value -> case parseEither Aeson.parseJSON value of+      Left _ -> Left TokenMalformed+      Right (NumericDate t) -> Right t+  scopeValues <- lookupStringList "scopes"+  roleValues <- lookupStringList "roles"+  permissionValues <- lookupStringList "permissions"+  let scs = Set.fromList (map Domain.Scope scopeValues)+      rls = Set.fromList (map Domain.Role roleValues)+      perms = Set.fromList (map Domain.Permission permissionValues)+      -- The custom claims Shōmei manages itself; everything else in the+      -- unregistered map is the consuming service's extra bag, returned verbatim.+      -- (The registered iss/sub/aud/iat/exp claims are never in this map.)+      managed = Domain.reservedClaimKeys+      extra =+        KeyMap.fromList+          [ (Key.fromText k, v)+          | (k, v) <- Map.toList claims,+            k `notElem` managed+          ]+  -- The @act@ claim is present only on delegated (impersonation) tokens. Absent+  -- → 'Nothing'; present but unparseable → a malformed token.+  actor' <- case lookupString "act" of+    Nothing -> Right Nothing+    Just actTxt -> Just <$> mapLeft (const TokenMalformed) (parseId actTxt)+  pure+    AuthClaims+      { subject = subj,+        sessionId = sess,+        issuer = Domain.Issuer issTxt,+        audience = Domain.Audience audTxt,+        issuedAt = issuedAt',+        expiresAt = expiresAt',+        authTime = authTime',+        scopes = scs,+        roles = rls,+        permissions = perms,+        actor = actor',+        extraClaims = extra+      }+  where+    note msg = maybe (Left (TokenOtherError msg)) Right+    mapLeft f = either (Left . f) Right+    -- jose serialises a StringOrURI (whether arbitrary string or URI) as a JSON+    -- string, so toJSON recovers the original text for both forms.+    soText :: StringOrURI -> Maybe Text+    soText s = case Aeson.toJSON s of+      Aeson.String t -> Just t+      _ -> Nothing+    dateOf = fmap (\(NumericDate t) -> t)+    exactAudience = \case+      Nothing -> Left (TokenOtherError "missing aud")+      Just (Audience [singleAudience]) -> maybe (Left TokenAudienceInvalid) Right (soText singleAudience)+      Just _ -> Left TokenAudienceInvalid+    claims :: Map Text Aeson.Value+    claims = cs ^. unregisteredClaims+    lookupString k = case Map.lookup k claims of+      Just (Aeson.String s) -> Just s+      _ -> Nothing+    lookupStringList k = case Map.lookup k claims of+      Just v -> mapLeft (const TokenMalformed) (parseEither Aeson.parseJSON v)+      Nothing -> Right []

@@ -0,0 +1,28 @@+module Main (main) where++import Shomei.SigningKey.Interpreter.JwtSpec qualified as InterpreterSpec+import Shomei.SigningKey.Jwks.JwtSpec qualified as JwksSpec+import Shomei.SigningKey.Key.JwtSpec qualified as KeySpec+import Shomei.SigningKey.Protection.JwtSpec qualified as KeyProtectionSpec+import Shomei.SigningKey.Rotation.JwtSpec qualified as RotationSpec+import Shomei.SigningKey.Sign.IdTokenSpec qualified as IdTokenSpec+import Shomei.SigningKey.Sign.JwtSpec qualified as SignVerifySpec+import Shomei.SigningKey.Sign.RsaCustomClaimSpec qualified as RsaCustomClaimSpec+import Shomei.SigningKey.Verify.JwtSpec qualified as VerifySpec+import Test.Tasty (defaultMain, testGroup)++main :: IO ()+main =+  defaultMain $+    testGroup+      "shomei-jwt"+      [ KeySpec.tests,+        KeyProtectionSpec.tests,+        SignVerifySpec.tests,+        IdTokenSpec.tests,+        JwksSpec.tests,+        InterpreterSpec.tests,+        RotationSpec.tests,+        RsaCustomClaimSpec.tests,+        VerifySpec.tests+      ]

@@ -0,0 +1,30 @@+-- | Scenario (h): the @effectful@ interpreters. Inside an 'Eff' computation,+-- 'runTokenSignerJwt' mints a token and 'runTokenVerifierJwt' verifies it; the+-- recovered claims equal the originals.+module Shomei.SigningKey.Interpreter.JwtSpec (tests) where++import Data.Time (getCurrentTime)+import Effectful (runEff)+import Shomei.SigningKey.Key.Jwt (generateSigningKey)+import Shomei.SigningKey.Sign.Jwt (runTokenSignerJwt)+import Shomei.SigningKey.Signer (signAccessToken)+import Shomei.SigningKey.TestSupport (coreFields, mkClaims, publicJwks, testConfig)+import Shomei.SigningKey.Verifier (verifyAccessToken)+import Shomei.SigningKey.Verify.Jwt (runTokenVerifierJwt)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Interpreter"+    [ testCase "sign-then-verify in Eff round-trips" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        tok <- runEff (runTokenSignerJwt jwk testConfig (signAccessToken ac))+        res <- runEff (runTokenVerifierJwt (publicJwks jwk []) testConfig (verifyAccessToken tok))+        case res of+          Right ac' -> coreFields ac' @?= coreFields ac+          Left e -> assertFailure ("verify failed: " <> show e)+    ]

@@ -0,0 +1,45 @@+-- | Scenario (g), JWKS-shape half: 'jwksDocument' for two keys is valid JSON+-- with a top-level @"keys"@ array of two objects carrying the correct @kid@s and+-- no private @"d"@ field. The kid-selection half (sign with A, verify against+-- {A, B}) lives in 'Shomei.SigningKey.Sign.JwtSpec' because it needs the signer.+module Shomei.SigningKey.Jwks.JwtSpec (tests) where++import Data.Aeson (Value (Array, Object, String))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Lazy (ByteString)+import Data.Foldable (toList)+import Data.List (sort)+import Data.Text (Text)+import Shomei.SigningKey.Jwks.Jwt (jwksDocument)+import Shomei.SigningKey.Key.Jwt (generateSigningKey, keyKid)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Jwks"+    [ testCase "publishes public-only JWKS with the right kids" $ do+        a <- generateSigningKey+        b <- generateSigningKey+        objs <- keysArray (jwksDocument [a, b])+        length objs @?= 2+        assertBool "no private d field" (not (any (KM.member (Key.fromText "d")) objs))+        sort (kidsOf objs) @?= sort [keyKid a, keyKid b]+    ]++-- | Decode a JWKS document and return the objects in its @"keys"@ array.+keysArray :: ByteString -> IO [KM.KeyMap Value]+keysArray doc =+  case Aeson.decode doc of+    Just (Object top) ->+      case KM.lookup (Key.fromText "keys") top of+        Just (Array arr) -> pure [o | Object o <- toList arr]+        _ -> assertFailure "JWKS has no \"keys\" array" >> pure []+    _ -> assertFailure "JWKS is not a JSON object" >> pure []++-- | Extract the @"kid"@ string of each key object.+kidsOf :: [KM.KeyMap Value] -> [Text]+kidsOf objs = [k | o <- objs, Just (String k) <- [KM.lookup (Key.fromText "kid") o]]

@@ -0,0 +1,52 @@+-- | Scenario (a): a generated ES256 key round-trips through 'StoredSigningKey'+-- without losing its @kid@.+module Shomei.SigningKey.Key.JwtSpec (tests) where++import Crypto.JOSE.JWK (fromOctets)+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as BSL+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (getCurrentTime)+import Shomei.SigningKey.Domain (SigningAlgorithm (RS256), StoredSigningKey (..))+import Shomei.SigningKey.Jwks.Jwt (jwksDocument)+import Shomei.SigningKey.Key.Jwt+  ( fromStoredSigningKey,+    generateSigningKey,+    generateSigningKeyFor,+    keyKid,+    toStoredSigningKey,+    toStoredSigningKeyFor,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Key"+    [ testCase "round-trips a key with stable kid" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        stored <- either (assertFailure . Text.unpack) pure (toStoredSigningKey t jwk)+        assertBool "kid is non-empty" (not (Text.null stored.keyId))+        case fromStoredSigningKey stored of+          Left err -> assertFailure ("decode failed: " <> Text.unpack err)+          Right jwk' -> keyKid jwk' @?= stored.keyId,+      testCase "generates an RS256 key recorded as RS256 with a kid and an RSA JWKS" $ do+        jwk <- generateSigningKeyFor RS256+        t <- getCurrentTime+        sk <- either (assertFailure . Text.unpack) pure (toStoredSigningKeyFor RS256 t jwk)+        sk.algorithm @?= "RS256"+        assertBool "kid is non-empty" (not (Text.null sk.keyId))+        let doc = jwksDocument [jwk]+        assertBool+          "JWKS contains an RSA key"+          ("\"kty\":\"RSA\"" `Text.isInfixOf` Text.decodeUtf8 (BSL.toStrict doc)),+      testCase "refuses a key with no public projection" $ do+        t <- getCurrentTime+        let symmetric = fromOctets (BS8.pack "not-a-public-key")+        case toStoredSigningKey t symmetric of+          Left reason -> assertBool "error names the public-material boundary" ("refusing to store private material as public" `Text.isInfixOf` reason)+          Right _ -> assertFailure "a symmetric key must not be copied into public_key_jwk"+    ]

@@ -0,0 +1,186 @@+-- | Envelope encryption of stored private signing keys. The properties that matter:+-- a round trip recovers the key; a wrong KEK, a tampered ciphertext, or a ciphertext moved+-- to another row's @kid@ all fail authentication indistinguishably; unencrypted rows are+-- rejected; and independent encryptions use fresh nonces.+module Shomei.SigningKey.Protection.JwtSpec (tests) where++import Data.ByteArray.Encoding (Base (Base64), convertToBase)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Time (UTCTime (..), fromGregorian, getCurrentTime)+import Effectful (runEff)+import Shomei.SigningKey.Domain (SigningAlgorithm (ES256, RS256), StoredSigningKey (..))+import Shomei.SigningKey.Key.Jwt (generateSigningKeyFor, toStoredSigningKeyFor)+import Shomei.SigningKey.Protection.Jwt+  ( KeyDecryptError (..),+    KeyEncryptionKey,+    decryptPrivateJwk,+    decryptStoredSigningKey,+    encryptPrivateJwk,+    isEncryptedPrivateJwk,+    keyEncryptionKeyFromBase64,+    protectStoredSigningKey,+    publicJwkFromStored,+  )+import Shomei.SigningKey.Sign.Jwt (runTokenSignerJwt)+import Shomei.SigningKey.Signer (signAccessToken)+import Shomei.SigningKey.TestSupport (coreFields, mkClaims, publicJwks, testConfig)+import Shomei.SigningKey.Verifier (verifyAccessToken)+import Shomei.SigningKey.Verify.Jwt (runTokenVerifierJwt)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "KeyProtection"+    [ testGroup "KEK parsing" kekParsing,+      testGroup "envelope" envelope,+      testGroup "stored keys" storedKeys+    ]++kekParsing :: [TestTree]+kekParsing =+  [ testCase "accepts 32 base64 bytes" do+      either (assertFailure . Text.unpack) (const (pure ())) (keyEncryptionKeyFromBase64 (kekText 32)),+    testCase "rejects a 31-byte key and says how to make one" do+      case keyEncryptionKeyFromBase64 (kekText 31) of+        Right _ -> assertFailure "a 31-byte KEK must be rejected"+        Left err -> do+          assertBool ("names the length: " <> Text.unpack err) ("31 bytes" `Text.isInfixOf` err)+          assertBool "gives the generation recipe" ("/dev/urandom" `Text.isInfixOf` err),+    testCase "rejects non-base64" do+      case keyEncryptionKeyFromBase64 "not base64 !!!" of+        Right _ -> assertFailure "invalid base64 must be rejected"+        Left err -> assertBool ("names base64: " <> Text.unpack err) ("base64" `Text.isInfixOf` err),+    testCase "tolerates surrounding whitespace (a trailing newline from `| base64`)" do+      either (assertFailure . Text.unpack) (const (pure ())) (keyEncryptionKeyFromBase64 (kekText 32 <> "\n"))+  ]++envelope :: [TestTree]+envelope =+  [ testCase "round-trips" do+      kek <- testKek 1+      enc <- encryptPrivateJwk kek "kid-a" plaintextJwk+      assertBool "is tagged as encrypted" (isEncryptedPrivateJwk enc)+      decryptPrivateJwk kek "kid-a" enc @?= Right plaintextJwk,+    testCase "unencrypted private material is rejected" do+      kek <- testKek 1+      assertBool "plaintext is not tagged" (not (isEncryptedPrivateJwk plaintextJwk))+      case decryptPrivateJwk kek "kid-a" plaintextJwk of+        Left (MalformedEncryptedKey _) -> pure ()+        other -> assertFailure ("expected MalformedEncryptedKey, got " <> show other),+    testCase "the wrong KEK fails authentication" do+      kek <- testKek 1+      other <- testKek 2+      enc <- encryptPrivateJwk kek "kid-a" plaintextJwk+      decryptPrivateJwk other "kid-a" enc @?= Left KeyDecryptFailed,+    testCase "a flipped ciphertext byte fails authentication" do+      kek <- testKek 1+      enc <- encryptPrivateJwk kek "kid-a" plaintextJwk+      decryptPrivateJwk kek "kid-a" (tamper enc) @?= Left KeyDecryptFailed,+    testCase "a ciphertext moved to another row's kid fails (the AAD binding)" do+      -- This is what stops an attacker with write access from relabeling an old,+      -- compromised key as the active one.+      kek <- testKek 1+      enc <- encryptPrivateJwk kek "kid-a" plaintextJwk+      decryptPrivateJwk kek "kid-b" enc @?= Left KeyDecryptFailed,+    testCase "a structurally broken envelope is distinguished from a failed tag" do+      kek <- testKek 1+      case decryptPrivateJwk kek "kid-a" "enc:v1:nope" of+        Left (MalformedEncryptedKey _) -> pure ()+        other -> assertFailure ("expected MalformedEncryptedKey, got " <> show other),+    testCase "a short nonce is rejected" do+      kek <- testKek 1+      case decryptPrivateJwk kek "kid-a" "enc:v1:AAAA:AAAAAAAAAAAAAAAAAAAAAA" of+        Left (MalformedEncryptedKey msg) -> assertBool ("names the nonce: " <> Text.unpack msg) ("nonce" `Text.isInfixOf` msg)+        other -> assertFailure ("expected MalformedEncryptedKey, got " <> show other),+    testCase "encrypting the same plaintext twice yields different ciphertexts (fresh nonce)" do+      kek <- testKek 1+      a <- encryptPrivateJwk kek "kid-a" plaintextJwk+      b <- encryptPrivateJwk kek "kid-a" plaintextJwk+      assertBool "nonces must not repeat" (a /= b)+      decryptPrivateJwk kek "kid-a" a @?= Right plaintextJwk+      decryptPrivateJwk kek "kid-a" b @?= Right plaintextJwk+  ]++storedKeys :: [TestTree]+storedKeys =+  [ testCase "protect → decrypt → sign → verify round-trips an ES256 key" (protectAndUse ES256),+    testCase "protect → decrypt → sign → verify round-trips an RS256 key" (protectAndUse RS256),+    testCase "protecting is idempotent: an encrypted row is returned unchanged" do+      kek <- testKek 1+      stored <- storedKeyFor ES256+      once <- protectStoredSigningKey kek stored+      twice <- protectStoredSigningKey kek once+      -- Not merely "still decrypts": the bytes must be identical, or a re-run of the+      -- backfill would rewrite every row (and burn a nonce) for nothing.+      twice.privateKeyJwk @?= once.privateKeyJwk,+    testCase "the public column is never encrypted, and parses without a KEK" do+      kek <- testKek 1+      stored <- storedKeyFor ES256+      protected <- protectStoredSigningKey kek stored+      protected.publicKeyJwk @?= stored.publicKeyJwk+      assertBool "private material is encrypted" (isEncryptedPrivateJwk protected.privateKeyJwk)+      case publicJwkFromStored protected of+        Right _ -> pure ()+        Left err -> assertFailure ("public key must parse with no KEK: " <> Text.unpack err),+    testCase "decryptStoredSigningKey reports a decryptable-but-invalid payload distinctly" do+      kek <- testKek 1+      stored <- storedKeyFor ES256+      enc <- encryptPrivateJwk kek stored.keyId "not json at all"+      case decryptStoredSigningKey kek stored {privateKeyJwk = enc} of+        Left (KeyJsonInvalid _) -> pure ()+        other -> assertFailure ("expected KeyJsonInvalid, got " <> show (() <$ other))+  ]++-- | Generate a key, store it, encrypt it, recover it, and prove the recovered key still+-- signs a token that verifies against the published public key.+protectAndUse :: SigningAlgorithm -> IO ()+protectAndUse alg = do+  kek <- testKek 1+  stored <- storedKeyFor alg+  protected <- protectStoredSigningKey kek stored+  assertBool "private material is encrypted at rest" (isEncryptedPrivateJwk protected.privateKeyJwk)+  signer <- case decryptStoredSigningKey kek protected of+    Right jwk -> pure jwk+    Left err -> assertFailure ("decrypt failed: " <> show err)+  pub <- either (assertFailure . Text.unpack) pure (publicJwkFromStored protected)+  -- Claims are minted against the real clock: the verifier checks expiry, so a fixed epoch+  -- would make this test start failing an hour into the day it was written.+  now <- getCurrentTime+  claims <- mkClaims testConfig now+  tok <- runEff (runTokenSignerJwt signer testConfig (signAccessToken claims))+  result <- runEff (runTokenVerifierJwt (publicJwks pub []) testConfig (verifyAccessToken tok))+  case result of+    Right recovered -> coreFields recovered @?= coreFields claims+    Left e -> assertFailure ("a token signed with the decrypted key must verify: " <> show e)++storedKeyFor :: SigningAlgorithm -> IO StoredSigningKey+storedKeyFor alg = do+  jwk <- generateSigningKeyFor alg+  either (assertFailure . Text.unpack) pure (toStoredSigningKeyFor alg epoch jwk)++epoch :: UTCTime+epoch = UTCTime (fromGregorian 2026 7 8) 0++-- | A deterministic, distinct KEK per seed byte.+testKek :: Int -> IO KeyEncryptionKey+testKek seed = either (assertFailure . Text.unpack) pure (keyEncryptionKeyFromBase64 (kekTextFrom (toEnum (0x40 + seed))))++kekText :: Int -> Text+kekText n = TE.decodeUtf8 (convertToBase Base64 (BS.replicate n 0x2a))++kekTextFrom :: Char -> Text+kekTextFrom c = TE.decodeUtf8 (convertToBase Base64 (BS8.replicate 32 c))++-- | A JWK-shaped plaintext; the envelope does not care that it is well-formed.+plaintextJwk :: Text+plaintextJwk = "{\"kty\":\"EC\",\"crv\":\"P-256\",\"d\":\"private-scalar\"}"++-- | Flip the last character of the base64url ciphertext.+tamper :: Text -> Text+tamper enc = Text.init enc <> if Text.last enc == 'A' then "B" else "A"

@@ -0,0 +1,136 @@+-- | The signing-key lifecycle over the in-memory store: publication filters lifecycle+-- states, rotation replaces the active key atomically, and revocation removes trust.+module Shomei.SigningKey.Rotation.JwtSpec (tests) where++import Crypto.JOSE.JWK (JWKSet)+import Data.Aeson (Value (Array, Object, String))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.ByteArray.Encoding (Base (Base64), convertToBase)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy (ByteString)+import Data.Foldable (toList, traverse_)+import Data.IORef (newIORef, readIORef)+import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (UTCTime (..), fromGregorian, getCurrentTime)+import Effectful (runEff)+import Shomei.Error (TokenError (TokenKeyNotFound))+import Shomei.Session.Token.Domain (AccessToken (AccessToken))+import Shomei.SigningKey.Domain (SigningAlgorithm (ES256), SigningKeyStatus (..), StoredSigningKey (..))+import Shomei.SigningKey.Key.Jwt (generateSigningKey, keyKid, toStoredSigningKey)+import Shomei.SigningKey.Protection.Jwt (KeyEncryptionKey, keyEncryptionKeyFromBase64)+import Shomei.SigningKey.Rotation.Jwt (currentJwks, rotateSigningKey)+import Shomei.SigningKey.Sign.Jwt (signAccessToken)+import Shomei.SigningKey.Store (insertSigningKey, updateSigningKeyStatus)+import Shomei.SigningKey.TestSupport (mkClaims, testConfig)+import Shomei.SigningKey.Verify.Jwt (verifyToken)+import Shomei.Test.InMemory (World (..), emptyWorld, runClock, runSigningKeyStore)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Rotation"+    [ testCase "currentJwks publishes active + retired, not pending or revoked" $ do+        activeK <- generateSigningKey+        retiredK <- generateSigningKey+        pendingK <- generateSigningKey+        revokedK <- generateSigningKey+        stored <-+          either (assertFailure . show) pure $+            traverse+              (\(k, st) -> (\sk -> sk {status = st}) <$> toStoredSigningKey epoch k)+              [ (activeK, KeyActive),+                (retiredK, KeyRetired),+                (pendingK, KeyPending),+                (revokedK, KeyRevoked)+              ]+        ref <- newIORef (emptyWorld epoch)+        doc <- runEff . runSigningKeyStore ref $ do+          traverse_ insertSigningKey stored+          currentJwks+        published <- kidsOf doc+        sort published @?= sort [keyKid activeK, keyKid retiredK]+        assertAbsent "pending" (keyKid pendingK) published+        assertAbsent "revoked" (keyKid revokedK) published,+      testCase "rotation leaves one active key and publishes alg on both overlap keys" $ do+        oldJwk <- generateSigningKey+        old <- either (assertFailure . show) pure (toStoredSigningKey epoch oldJwk)+        kek <- testKek+        ref <- newIORef (emptyWorld epoch)+        newJwk <-+          runEff . runClock ref . runSigningKeyStore ref $ do+            insertSigningKey old+            rotateSigningKey kek ES256+        world <- readIORef ref+        let rows = Map.elems world.signingKeys+            activeRows = filter ((== KeyActive) . (.status)) rows+        fmap (.keyId) activeRows @?= [keyKid newJwk]+        oldAfter <- maybe (assertFailure "old key disappeared during rotation") pure (Map.lookup old.keyId world.signingKeys)+        newAfter <- maybe (assertFailure "new key was not stored during rotation") pure (Map.lookup (keyKid newJwk) world.signingKeys)+        oldAfter.status @?= KeyRetired+        oldAfter.retiredAt @?= Just epoch+        newAfter.activatedAt @?= Just epoch+        doc <- runEff . runSigningKeyStore ref $ currentJwks+        published <- kidsOf doc+        sort published @?= sort [old.keyId, keyKid newJwk]+        algs <- algsOf doc+        assertBool "every published overlap key has ES256 alg" (length algs == 2 && all (== "ES256") algs),+      testCase "revoking a key removes it from the verifier set" $ do+        jwk <- generateSigningKey+        stored <- either (assertFailure . show) pure (toStoredSigningKey epoch jwk)+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        AccessToken wire <- signAccessToken jwk claims >>= either (assertFailure . show) pure+        ref <- newIORef (emptyWorld epoch)+        before <- runEff . runSigningKeyStore ref $ do+          insertSigningKey stored+          currentJwks+        beforeSet <- decodeJwkSet before+        verifyToken beforeSet testConfig wire >>= either (assertFailure . show) (const (pure ()))+        after <- runEff . runSigningKeyStore ref $ do+          updateSigningKeyStatus stored.keyId KeyRevoked epoch+          currentJwks+        afterSet <- decodeJwkSet after+        rejected <- verifyToken afterSet testConfig wire+        rejected @?= Left (TokenKeyNotFound (Just stored.keyId))+    ]+  where+    epoch = UTCTime (fromGregorian 2026 8 27) 0+    assertAbsent label kid published+      | kid `elem` published = assertFailure (label <> " key " <> show kid <> " must not be published")+      | otherwise = pure ()++kidsOf :: ByteString -> IO [Text]+kidsOf doc =+  case Aeson.decode doc of+    Just (Object top) ->+      case KM.lookup (Key.fromText "keys") top of+        Just (Array arr) ->+          pure [kid | Object o <- toList arr, Just (String kid) <- [KM.lookup (Key.fromText "kid") o]]+        _ -> assertFailure "JWKS has no \"keys\" array" >> pure []+    _ -> assertFailure "JWKS is not a JSON object" >> pure []++algsOf :: ByteString -> IO [Text]+algsOf doc =+  case Aeson.decode doc of+    Just (Object top) ->+      case KM.lookup (Key.fromText "keys") top of+        Just (Array arr) ->+          pure [alg | Object o <- toList arr, Just (String alg) <- [KM.lookup (Key.fromText "alg") o]]+        _ -> assertFailure "JWKS has no \"keys\" array" >> pure []+    _ -> assertFailure "JWKS is not a JSON object" >> pure []++decodeJwkSet :: ByteString -> IO JWKSet+decodeJwkSet = maybe (assertFailure "JWKS did not decode as JWKSet") pure . Aeson.decode++testKek :: IO KeyEncryptionKey+testKek =+  either (assertFailure . Text.unpack) pure $+    keyEncryptionKeyFromBase64 (Text.decodeUtf8 (convertToBase Base64 (BS.replicate 32 0x2a)))

@@ -0,0 +1,140 @@+-- | EP-5: the OIDC ID token is signed by the same key machinery as the access token, and carries+-- exactly the claims OIDC Core §2 defines — no more.+--+-- An ID token a relying party cannot verify is worthless, so 'verifiesAgainstJwks' checks the real+-- signature against the real public JWK rather than merely decoding the payload. An ID token a+-- resource server /would/ accept as a bearer credential is dangerous, so 'notABearerCredential'+-- pins that the access-token verifier refuses it.+module Shomei.SigningKey.Sign.IdTokenSpec (tests) where++import Crypto.JOSE.Compact (decodeCompact)+import Crypto.JOSE.Error (runJOSE)+import Crypto.JOSE.JWK (JWK)+import Crypto.JWT (JWTError, SignedJWT, defaultJWTValidationSettings, verifyClaims)+import Data.Aeson (Object, Value (Number, String))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteArray.Encoding (Base (Base64URLUnpadded), convertFromBase)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as LBS+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (addUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Shomei.Authorization.Claims.Domain (Issuer (..))+import Shomei.Error (TokenError (..))+import Shomei.Id (genUserId, idText)+import Shomei.OAuth.IdToken.Domain (IdToken (IdToken), IdTokenClaims (..))+import Shomei.SigningKey.Key.Jwt (generateSigningKey, keyKid)+import Shomei.SigningKey.Sign.Jwt (signIdToken)+import Shomei.SigningKey.TestSupport (publicJwks, testConfig, testIssuer)+import Shomei.SigningKey.Verify.Jwt (verifyToken)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "IdToken"+    [ testCase "signs an ID token that verifies against the published public key, with the access-token kid" verifiesAgainstJwks,+      testCase "carries iss/sub/aud/iat/exp/nonce/auth_time and nothing else" carriesExactlyTheOidcClaims,+      testCase "omits nonce entirely when the authorize request sent none" omitsAbsentNonce,+      testCase "auth_time is a number of Unix seconds, not an RFC 3339 string" authTimeIsANumber,+      testCase "an ID token is not a bearer credential: the access-token verifier refuses it" notABearerCredential+    ]++issuerText :: Issuer -> Text+issuerText (Issuer t) = t++-- | Sign an ID token for a user who authenticated an hour ago (so @auth_time@ and @iat@ differ),+-- returning the token, the claims, and the decoded JWS payload.+signWith :: JWK -> Maybe Text -> IO (IdToken, IdTokenClaims, Object)+signWith jwk nonce = do+  t <- getCurrentTime+  uid <- genUserId+  let idc =+        IdTokenClaims+          { issuer = testIssuer,+            subject = uid,+            audience = "oauthclient_01",+            issuedAt = t,+            expiresAt = addUTCTime 900 t,+            nonce,+            authTime = addUTCTime (-3600) t+          }+  r <- signIdToken jwk idc+  case r of+    Left e -> assertFailure ("id token signing failed: " <> show e)+    Right tok@(IdToken wire) -> do+      payload <- decodeSegment 1 wire+      pure (tok, idc, payload)++verifiesAgainstJwks :: Assertion+verifiesAgainstJwks = do+  jwk <- generateSigningKey+  (IdToken wire, _, _) <- signWith jwk (Just "n-0S6")+  -- Same key material and same kid as an access token: this is what makes the ID token checkable+  -- against the JWKS document the deployment already serves, with no new key work.+  header <- decodeSegment 0 wire+  KeyMap.lookup "kid" header @?= Just (String (keyKid jwk))+  KeyMap.lookup "typ" header @?= Just (String "JWT")+  result <-+    runJOSE @JWTError do+      jwt <- decodeCompact (LBS.fromStrict (Text.encodeUtf8 wire))+      verifyClaims (defaultJWTValidationSettings (const True)) jwk (jwt :: SignedJWT)+  case result of+    Left e -> assertFailure ("the id_token failed signature verification: " <> show e)+    Right _ -> pure ()++carriesExactlyTheOidcClaims :: Assertion+carriesExactlyTheOidcClaims = do+  jwk <- generateSigningKey+  (_, idc, payload) <- signWith jwk (Just "n-0S6")+  KeyMap.lookup "iss" payload @?= Just (String (issuerText idc.issuer))+  KeyMap.lookup "sub" payload @?= Just (String (idText idc.subject))+  KeyMap.lookup "aud" payload @?= Just (String idc.audience)+  KeyMap.lookup "nonce" payload @?= Just (String "n-0S6")+  assertBool "iat is present" (KeyMap.member "iat" payload)+  assertBool "exp is present" (KeyMap.member "exp" payload)+  assertBool "auth_time is present" (KeyMap.member "auth_time" payload)+  -- An ID token is a statement about an authentication, not a credential: no session id, no+  -- scopes, no roles.+  assertBool "no sid" (not (KeyMap.member "sid" payload))+  assertBool "no scopes" (not (KeyMap.member "scopes" payload))+  assertBool "no roles" (not (KeyMap.member "roles" payload))++omitsAbsentNonce :: Assertion+omitsAbsentNonce = do+  jwk <- generateSigningKey+  (_, _, payload) <- signWith jwk Nothing+  assertBool "nonce is absent, not null" (not (KeyMap.member "nonce" payload))++authTimeIsANumber :: Assertion+authTimeIsANumber = do+  jwk <- generateSigningKey+  (_, idc, payload) <- signWith jwk (Just "n")+  case KeyMap.lookup "auth_time" payload of+    Just (Number n) -> (round n :: Integer) @?= floor (utcTimeToPOSIXSeconds idc.authTime)+    other -> assertFailure ("auth_time must be a JSON number, got " <> show other)++notABearerCredential :: Assertion+notABearerCredential = do+  jwk <- generateSigningKey+  (IdToken wire, _, _) <- signWith jwk Nothing+  -- Its aud is the client_id, not the API audience, so the access-token verifier rejects it. This+  -- is what stops a client replaying an ID token at a resource server.+  res <- verifyToken (publicJwks jwk []) testConfig wire+  case res of+    Left TokenAudienceInvalid -> pure ()+    Left other -> assertFailure ("expected TokenAudienceInvalid, got " <> show other)+    Right _ -> assertFailure "an ID token must never verify as an access token"++-- | Decode segment @n@ (0 = header, 1 = payload) of a compact JWS as a JSON object.+decodeSegment :: Int -> Text -> IO Object+decodeSegment n wire = do+  let seg = Text.encodeUtf8 (Text.splitOn "." wire !! n)+  raw <-+    either (assertFailure . ("segment base64url decode failed: " <>)) pure $+      (convertFromBase Base64URLUnpadded seg :: Either String ByteString)+  maybe (assertFailure "segment is not a JSON object") pure (Aeson.decodeStrict raw)

@@ -0,0 +1,213 @@+-- | Scenarios (b)–(f) and the kid-selection half of (g): a full sign/verify+-- round trip, and rejection of tampered, expired, wrong-audience, and wrong-issuer+-- tokens, plus key selection out of a multi-key JWKSet.+module Shomei.SigningKey.Sign.JwtSpec (tests) where++import Crypto.JOSE.JWK (JWK)+import Data.Aeson (Object, Value (String))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteArray.Encoding (Base (Base64URLUnpadded), convertFromBase)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (addUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), mkExtraClaims)+import Shomei.Config (defaultShomeiConfig)+import Shomei.Error (TokenError (..))+import Shomei.Id (genUserId, idText)+import Shomei.Session.Token.Domain (AccessToken (AccessToken))+import Shomei.SigningKey.Domain (SigningAlgorithm (RS256))+import Shomei.SigningKey.Key.Jwt (generateSigningKey, generateSigningKeyFor, keyKid)+import Shomei.SigningKey.Sign.Jwt (signAccessToken)+import Shomei.SigningKey.TestSupport (coreFields, mkClaims, mkClaimsWith, publicJwks, testAudience, testConfig, testIssuer)+import Shomei.SigningKey.Verify.Jwt (verifyToken)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "SignVerify"+    [ testCase "round-trips all claims" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        assertClaims ac res,+      testCase "rejects a tampered token" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig (tamper wire)+        res @?= Left TokenSignatureInvalid,+      testCase "rejects an expired token" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaimsWith testConfig (addUTCTime (-3600) t) (addUTCTime (-1800) t)+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        res @?= Left TokenExpired,+      testCase "rejects a wrong audience" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        let cfgWrong = defaultShomeiConfig testIssuer (Audience "other-audience")+        res <- verifyToken (publicJwks jwk []) cfgWrong wire+        res @?= Left TokenAudienceInvalid,+      testCase "rejects a wrong issuer" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        let cfgWrong = defaultShomeiConfig (Issuer "https://evil.test") testAudience+        res <- verifyToken (publicJwks jwk []) cfgWrong wire+        res @?= Left TokenIssuerInvalid,+      testCase "selects the signing key by kid" $ do+        a <- generateSigningKey+        b <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail a ac+        res <- verifyToken (publicJwks a [b]) testConfig wire+        assertClaims ac res,+      testCase "round-trips the act (actor) claim on a delegated token" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        op <- genUserId+        base <- mkClaims testConfig t+        let ac = base {actor = Just op}+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> ac'.actor @?= Just op+          Left e -> assertFailure ("verify failed: " <> show e),+      testCase "omits the act claim when actor is Nothing" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> ac'.actor @?= Nothing+          Left e -> assertFailure ("verify failed: " <> show e),+      testCase "an RS256 key signs a token whose header alg is RS256" $ do+        jwk <- generateSigningKeyFor RS256+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        hdr <- decodeHeader wire+        KeyMap.lookup "alg" hdr @?= Just (String "RS256")+        KeyMap.lookup "kid" hdr @?= Just (String (keyKid jwk)),+      testCase "an RS256 token verifies via the RSA public JWKS" $ do+        jwk <- generateSigningKeyFor RS256+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        assertClaims ac res,+      testCase "an ES256 key still signs with header alg ES256" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        hdr <- decodeHeader wire+        KeyMap.lookup "alg" hdr @?= Just (String "ES256"),+      testCase "custom extra claims round-trip through sign/verify" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        base <- mkClaims testConfig t+        let extra =+              mkExtraClaims+                ( KeyMap.fromList+                    [ ("impersonated", Aeson.Bool False),+                      ("userId", String "u-123"),+                      ("userInfo", Aeson.object ["userRole" Aeson..= String "agent"])+                    ]+                )+            ac = base {extraClaims = extra}+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> ac'.extraClaims @?= extra+          Left e -> assertFailure ("verify failed: " <> show e),+      testCase "a custom sub in the extra bag cannot forge the subject" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        base <- mkClaims testConfig t+        let ac = base {extraClaims = mkExtraClaims (KeyMap.fromList [("sub", String "attacker")])}+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> idText ac'.subject @?= idText base.subject+          Left e -> assertFailure ("verify failed: " <> show e),+      testCase "a custom auth_time in the extra bag cannot forge credential freshness" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        base <- mkClaims testConfig t+        let expectedAuthTime = addUTCTime (-120) t+            ac = base {authTime = expectedAuthTime, extraClaims = KeyMap.fromList [("auth_time", Aeson.Number 0)]}+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> do+            floor (utcTimeToPOSIXSeconds ac'.authTime) @?= (floor (utcTimeToPOSIXSeconds expectedAuthTime) :: Integer)+            assertBool "auth_time must not appear in extraClaims" (KeyMap.lookup "auth_time" ac'.extraClaims == Nothing)+          Left e -> assertFailure ("verify failed: " <> show e),+      -- The @permissions@ claim (EP-9) is managed like @roles@/@scopes@: the verify side reads it+      -- into the typed field and MUST strip it from the extra bag, or a consumer reading+      -- @extraClaims@ would see a duplicate it could mistake for a host claim.+      testCase "the permissions claim round-trips and never leaks into the extra bag" $ do+        jwk <- generateSigningKey+        t <- getCurrentTime+        ac <- mkClaims testConfig t+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> do+            ac'.permissions @?= ac.permissions+            assertBool "permissions must not appear in extraClaims" (KeyMap.lookup "permissions" ac'.extraClaims == Nothing)+          Left e -> assertFailure ("verify failed: " <> show e)+    ]++-- | Decode the protected-header segment of a compact JWS (the part before the+-- first @.@): base64url-decode it (unpadded) and parse the JSON object.+decodeHeader :: Text -> IO Object+decodeHeader wire = do+  let seg = Text.encodeUtf8 (Text.takeWhile (/= '.') wire)+  raw <-+    either (assertFailure . ("header base64url decode failed: " <>)) pure $+      (convertFromBase Base64URLUnpadded seg :: Either String ByteString)+  maybe (assertFailure "header is not a JSON object") pure (Aeson.decodeStrict raw)++-- | Sign claims, failing the test if signing errors; returns the compact token text.+signOrFail :: JWK -> AuthClaims -> IO Text+signOrFail jwk ac = do+  r <- signAccessToken jwk ac+  case r of+    Right (AccessToken w) -> pure w+    Left e -> assertFailure ("sign failed: " <> show e)++-- | Assert a verification result holds the expected (stable) claim fields.+assertClaims :: AuthClaims -> Either TokenError AuthClaims -> Assertion+assertClaims expected = \case+  Right ac' -> coreFields ac' @?= coreFields expected+  Left e -> assertFailure ("verify failed: " <> show e)++-- | Flip one character in the signature (last) segment of a compact JWS, so the+-- header and payload still decode but the signature no longer verifies. (jose+-- decodes the payload before checking the signature, so corrupting the payload+-- would surface as a malformed token rather than a bad signature.)+tamper :: Text -> Text+tamper w = case reverse (Text.splitOn "." w) of+  (sig : leading) -> Text.intercalate "." (reverse (flip1 sig : leading))+  [] -> w+  where+    flip1 s = case Text.uncons s of+      Just (c, cs) -> Text.cons (if c == 'A' then 'B' else 'A') cs+      Nothing -> s

@@ -0,0 +1,100 @@+-- | SH-24 acceptance: an RS256 token carrying a custom claim round-trips through+-- the public JWKS verify path, the compact token's header/payload contents are proven+-- by decoding it, reserved keys cannot be forged via the extra bag, and the config+-- selector maps the algorithm text to the closed enum.+module Shomei.SigningKey.Sign.RsaCustomClaimSpec (tests) where++import Crypto.JOSE.JWK (JWK)+import Data.Aeson (Object, Value (Bool, String), object, (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteArray.Encoding (Base (Base64URLUnpadded), convertFromBase)+import Data.ByteString (ByteString)+import Data.Either (isLeft)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (getCurrentTime)+import Shomei.Authorization.Claims.Domain (AuthClaims (..), mkExtraClaims)+import Shomei.Config (ShomeiConfig (..), SigningKeyConfig (..), configSigningAlgorithm)+import Shomei.Id (idText)+import Shomei.Session.Token.Domain (AccessToken (AccessToken))+import Shomei.SigningKey.Domain (SigningAlgorithm (RS256))+import Shomei.SigningKey.Key.Jwt (generateSigningKeyFor, keyKid)+import Shomei.SigningKey.Sign.Jwt (signAccessToken)+import Shomei.SigningKey.TestSupport (mkClaims, publicJwks, testConfig)+import Shomei.SigningKey.Verify.Jwt (verifyToken)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "RsaCustomClaim"+    [ testCase "RS256 token with a custom claim round-trips via JWKS" $ do+        jwk <- generateSigningKeyFor RS256+        t <- getCurrentTime+        base <- mkClaims testConfig t+        let bag =+              mkExtraClaims+                ( KeyMap.fromList+                    [ ("userId", String "u-123"),+                      ("impersonated", Bool False),+                      ("userInfo", object ["userRole" .= String "agent", "username" .= String "alice"])+                    ]+                )+            ac = base {extraClaims = bag}+        wire <- signOrFail jwk ac+        -- Prove the compact header says alg=RS256 with the right kid.+        hdr <- decodeSegment 0 wire+        KeyMap.lookup "alg" hdr @?= Just (String "RS256")+        KeyMap.lookup "kid" hdr @?= Just (String (keyKid jwk))+        -- Prove the payload carries the custom claim AND the standard claims.+        payload <- decodeSegment 1 wire+        KeyMap.lookup "userId" payload @?= Just (String "u-123")+        assertBool "sub present in payload" (KeyMap.member "sub" payload)+        assertBool "sid present in payload" (KeyMap.member "sid" payload)+        -- Verify through the public JWKS path; the custom bag is preserved.+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> do+            ac'.extraClaims @?= bag+            idText ac'.subject @?= idText base.subject+          Left e -> assertFailure ("verify failed: " <> show e),+      testCase "reserved keys cannot be forged via the extra bag" $ do+        jwk <- generateSigningKeyFor RS256+        t <- getCurrentTime+        base <- mkClaims testConfig t+        let ac = base {extraClaims = mkExtraClaims (KeyMap.fromList [("sub", String "attacker")])}+        wire <- signOrFail jwk ac+        res <- verifyToken (publicJwks jwk []) testConfig wire+        case res of+          Right ac' -> idText ac'.subject @?= idText base.subject+          Left e -> assertFailure ("verify failed: " <> show e),+      testCase "configSigningAlgorithm parses RS256 and rejects unknown text" $ do+        let rs = testConfig {signingKeyConfig = SigningKeyConfig {algorithm = "RS256", refreshIntervalSeconds = 60, allowedClockSkewSeconds = 30}}+            bad = testConfig {signingKeyConfig = SigningKeyConfig {algorithm = "nope", refreshIntervalSeconds = 60, allowedClockSkewSeconds = 30}}+        configSigningAlgorithm rs @?= Right RS256+        assertBool "unknown signing algorithms must be a boot error" (isLeft (configSigningAlgorithm bad))+    ]++-- | Sign claims, failing the test if signing errors; returns the compact token text.+signOrFail :: JWK -> AuthClaims -> IO Text+signOrFail jwk ac = do+  r <- signAccessToken jwk ac+  case r of+    Right (AccessToken w) -> pure w+    Left e -> assertFailure ("sign failed: " <> show e)++-- | Decode the @n@th dot-separated segment of a compact JWS: base64url-decode it+-- (unpadded) and parse the JSON object (segment 0 = header, 1 = payload).+decodeSegment :: Int -> Text -> IO Object+decodeSegment n wire = do+  let segs = Text.splitOn "." wire+  seg <- case drop n segs of+    (s : _) -> pure (Text.encodeUtf8 s)+    [] -> assertFailure ("no segment " <> show n <> " in token")+  raw <-+    either (assertFailure . ("base64url decode failed: " <>)) pure $+      (convertFromBase Base64URLUnpadded seg :: Either String ByteString)+  maybe (assertFailure "segment is not a JSON object") pure (Aeson.decodeStrict raw)

@@ -0,0 +1,75 @@+-- | Shared fixtures for the sign/verify/interpreter specs.+module Shomei.SigningKey.TestSupport+  ( testIssuer,+    testAudience,+    testConfig,+    mkClaims,+    mkClaimsWith,+    publicJwks,+    coreFields,+  )+where++import Crypto.JOSE.JWK (JWK, JWKSet)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Time (UTCTime, addUTCTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Permission (..), Role (..), Scope (..))+import Shomei.Config (ShomeiConfig (..), defaultShomeiConfig)+import Shomei.Id (genSessionId, genUserId, idText)+import Shomei.SigningKey.Jwks.Jwt (KeySet (..), keySetPublicJwks)++testIssuer :: Issuer+testIssuer = Issuer "https://shomei.test"++testAudience :: Audience+testAudience = Audience "shomei-clients"++testConfig :: ShomeiConfig+testConfig = defaultShomeiConfig testIssuer testAudience++-- | Build claims valid from @t@ for one hour, with two scopes and one role.+mkClaims :: ShomeiConfig -> UTCTime -> IO AuthClaims+mkClaims cfg t = mkClaimsWith cfg t (addUTCTime 3600 t)++-- | Build claims with explicit @issuedAt@ and @expiresAt@ (used by the expiry test).+mkClaimsWith :: ShomeiConfig -> UTCTime -> UTCTime -> IO AuthClaims+mkClaimsWith cfg iat expd = do+  uid <- genUserId+  sid <- genSessionId+  pure+    AuthClaims+      { subject = uid,+        sessionId = sid,+        issuer = cfg.issuer,+        audience = cfg.audience,+        issuedAt = iat,+        expiresAt = expd,+        authTime = iat,+        scopes = Set.fromList [Scope "read", Scope "write"],+        roles = Set.fromList [Role "user"],+        permissions = Set.fromList [Permission "projects:write", Permission "billing:read"],+        actor = Nothing,+        extraClaims = mempty+      }++-- | The public 'JWKSet' for an active key plus any additional keys.+publicJwks :: JWK -> [JWK] -> JWKSet+publicJwks active others = keySetPublicJwks (KeySet active others)++-- | The claim fields that must survive a sign/verify round trip (timestamps are+-- excluded because JWT numeric dates are truncated to whole seconds). Identifiers+-- are compared by their rendered text form.+coreFields :: AuthClaims -> (Text, Text, Issuer, Audience, Set Scope, Set Role, Set Permission, Integer)+coreFields ac =+  ( idText ac.subject,+    idText ac.sessionId,+    ac.issuer,+    ac.audience,+    ac.scopes,+    ac.roles,+    ac.permissions,+    floor (utcTimeToPOSIXSeconds ac.authTime)+  )

@@ -0,0 +1,216 @@+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Regression tests for the verifier's trust boundary.+module Shomei.SigningKey.Verify.JwtSpec (tests) where++import Control.Lens ((%~), (&), (.~), (?~), (^.))+import Crypto.JOSE.Compact (encodeCompact)+import Crypto.JOSE.Error (runJOSE)+import Crypto.JOSE.Header (newHeaderParamProtected)+import Crypto.JOSE.JWA.JWS (Alg (ES256, HS256, RS256))+import Crypto.JOSE.JWK (JWK, asPublicKey, fromOctets)+import Crypto.JOSE.JWS (newJWSHeaderProtected)+import Crypto.JOSE.JWS qualified as JWS+import Crypto.JWT+  ( Audience (Audience),+    ClaimsSet,+    JWTError,+    SignedJWT,+    StringOrURI,+    addClaim,+    claimAud,+    signClaims,+    unregisteredClaims,+  )+import Data.Aeson (Object, Result (Error, Success), Value (Number, String))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteArray.Encoding (Base (Base64URLUnpadded), convertFromBase, convertToBase)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.String (fromString)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (addUTCTime, getCurrentTime)+import Shomei.Authorization.Claims.Domain (AuthClaims (..), mkExtraClaims)+import Shomei.Error (TokenError (..))+import Shomei.Session.Token.Domain (AccessToken (AccessToken))+import Shomei.SigningKey.Domain qualified as Domain+import Shomei.SigningKey.Key.Jwt (generateSigningKey, generateSigningKeyFor, keyKid)+import Shomei.SigningKey.Sign.Jwt (claimsFromAuth, signAccessToken)+import Shomei.SigningKey.TestSupport (mkClaims, mkClaimsWith, publicJwks, testConfig)+import Shomei.SigningKey.Verify.Jwt (verifyToken)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Verify"+    [ testCase "accepts an iat within the configured 30-second skew" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaimsWith testConfig (addUTCTime 10 now) (addUTCTime 3600 now)+        wire <- signAccessOrFail jwk claims+        result <- verifyToken (publicJwks jwk []) testConfig wire+        case result of+          Right _ -> pure ()+          Left err -> assertFailure ("expected the token to verify, got " <> show err),+      testCase "rejects an iat beyond the configured skew" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaimsWith testConfig (addUTCTime 120 now) (addUTCTime 3600 now)+        wire <- signAccessOrFail jwk claims+        result <- verifyToken (publicJwks jwk []) testConfig wire+        result @?= Left (TokenOtherError "iat in the future"),+      testCase "rejects a string-valued roles claim as malformed" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signClaimsOrFail jwk (claimsFromAuth claims & addClaim "roles" (String "admin"))+        result <- verifyToken (publicJwks jwk []) testConfig wire+        result @?= Left TokenMalformed,+      testCase "rejects a multi-element audience even when one value matches" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        let audienceValues = [sou "shomei-clients", sou "other"]+        wire <- signClaimsOrFail jwk (claimsFromAuth claims & claimAud ?~ Audience audienceValues)+        result <- verifyToken (publicJwks jwk []) testConfig wire+        result @?= Left TokenAudienceInvalid,+      testCase "mints integral iat and exp values" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signAccessOrFail jwk claims+        payload <- decodeSegment 1 wire+        assertIntegralNumber "iat" payload+        assertIntegralNumber "exp" payload+        assertIntegralNumber "auth_time" payload,+      testCase "a legacy access token without auth_time falls back to iat" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        let legacyClaims = claimsFromAuth claims & unregisteredClaims %~ Map.delete "auth_time"+        wire <- signClaimsOrFail jwk legacyClaims+        result <- verifyToken (publicJwks jwk []) testConfig wire+        case result of+          Right verified -> verified.authTime @?= verified.issuedAt+          Left err -> assertFailure ("expected the legacy token to verify, got " <> show err),+      testCase "drops nbf and jti from the extension claim bag" $ do+        let extras = mkExtraClaims (KeyMap.fromList [("nbf", Number 1), ("jti", String "forged")])+        assertBool "nbf must be reserved" (not (KeyMap.member "nbf" extras))+        assertBool "jti must be reserved" (not (KeyMap.member "jti" extras)),+      testCase "reports an unknown kid without trying other keys" $ do+        signingKey <- generateSigningKey+        publishedKey <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signAccessOrFail signingKey claims+        result <- verifyToken (publicJwks publishedKey []) testConfig wire+        result @?= Left (TokenKeyNotFound (Just (keyKid signingKey))),+      testCase "reports a missing kid even when the signature key is published" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signClaimsWithHeaderOrFail jwk ES256 Nothing (Just "at+jwt") (claimsFromAuth claims)+        result <- verifyToken (publicJwks jwk []) testConfig wire+        result @?= Left (TokenKeyNotFound Nothing),+      testCase "rejects typ JWT on an access token" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signClaimsWithHeaderOrFail jwk ES256 (Just (keyKid jwk)) (Just "JWT") (claimsFromAuth claims)+        result <- verifyToken (publicJwks jwk []) testConfig wire+        result @?= Left (TokenOtherError "typ JWT is not at+jwt"),+      testCase "temporarily accepts an access token with no typ" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signClaimsWithHeaderOrFail jwk ES256 (Just (keyKid jwk)) Nothing (claimsFromAuth claims)+        result <- verifyToken (publicJwks jwk []) testConfig wire+        case result of+          Right _ -> pure ()+          Left err -> assertFailure ("expected the typ-less compatibility token to verify, got " <> show err),+      testCase "mints access-token typ at+jwt" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signAccessOrFail jwk claims+        header <- decodeSegment 0 wire+        KeyMap.lookup "typ" header @?= Just (String "at+jwt"),+      testCase "rejects alg none" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        realWire <- signAccessOrFail jwk claims+        let payload = Text.splitOn "." realWire !! 1+            header = Aeson.object ["alg" Aeson..= String "none", "kid" Aeson..= String (keyKid jwk)]+            headerSegment = Text.decodeUtf8 (convertToBase Base64URLUnpadded (BSL.toStrict (Aeson.encode header)) :: ByteString)+            wire = Text.intercalate "." [headerSegment, payload, ""]+        result <- verifyToken (publicJwks jwk []) testConfig wire+        result @?= Left TokenSignatureInvalid,+      testCase "rejects HS256 signed with public-key bytes" $ do+        jwk <- generateSigningKey+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        let publicKey = fromMaybe jwk (jwk ^. asPublicKey)+            hmacKey = fromOctets (BSL.toStrict (Aeson.encode publicKey))+        wire <- signClaimsWithHeaderOrFail hmacKey HS256 (Just (keyKid jwk)) (Just "at+jwt") (claimsFromAuth claims)+        result <- verifyToken (publicJwks jwk []) testConfig wire+        result @?= Left TokenSignatureInvalid,+      testCase "rejects RS256 under an EC kid" $ do+        ecKey <- generateSigningKey+        rsaKey <- generateSigningKeyFor Domain.RS256+        now <- getCurrentTime+        claims <- mkClaims testConfig now+        wire <- signClaimsWithHeaderOrFail rsaKey RS256 (Just (keyKid ecKey)) (Just "at+jwt") (claimsFromAuth claims)+        result <- verifyToken (publicJwks ecKey []) testConfig wire+        result @?= Left TokenSignatureInvalid+    ]++sou :: Text -> StringOrURI+sou = fromString . Text.unpack++signAccessOrFail :: JWK -> AuthClaims -> IO Text+signAccessOrFail jwk claims = do+  result <- signAccessToken jwk claims+  case result of+    Left err -> assertFailure ("signing failed: " <> show err)+    Right (AccessToken wire) -> pure wire++signClaimsOrFail :: JWK -> ClaimsSet -> IO Text+signClaimsOrFail jwk = signClaimsWithHeaderOrFail jwk ES256 (Just (keyKid jwk)) Nothing++signClaimsWithHeaderOrFail :: JWK -> Alg -> Maybe Text -> Maybe Text -> ClaimsSet -> IO Text+signClaimsWithHeaderOrFail jwk algorithm headerKid headerType claims = do+  let header =+        newJWSHeaderProtected algorithm+          & JWS.kid+            .~ fmap newHeaderParamProtected headerKid+          & JWS.typ+            .~ fmap newHeaderParamProtected headerType+  result <- runJOSE @JWTError do+    signed <- signClaims jwk header claims+    pure (encodeCompact (signed :: SignedJWT))+  case result of+    Left err -> assertFailure ("signing claims failed: " <> show err)+    Right wire -> pure (Text.decodeUtf8 (BSL.toStrict wire))++decodeSegment :: Int -> Text -> IO Object+decodeSegment index wire = do+  let segment = Text.encodeUtf8 (Text.splitOn "." wire !! index)+  raw <-+    either (assertFailure . ("segment base64url decode failed: " <>)) pure $+      (convertFromBase Base64URLUnpadded segment :: Either String ByteString)+  maybe (assertFailure "segment is not a JSON object") pure (Aeson.decodeStrict raw)++assertIntegralNumber :: Text -> Object -> IO ()+assertIntegralNumber name payload = case KeyMap.lookup (fromString (Text.unpack name)) payload of+  Just value@(Number _) -> case Aeson.fromJSON value :: Result Integer of+    Success _ -> pure ()+    Error err -> assertFailure (Text.unpack name <> " is not integral: " <> err)+  other -> assertFailure (Text.unpack name <> " must be a JSON number, got " <> show other)