diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/shomei-jwt.cabal b/shomei-jwt.cabal new file mode 100644 --- /dev/null +++ b/shomei-jwt.cabal @@ -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 diff --git a/src/Shomei/SigningKey/Jwks/Jwt.hs b/src/Shomei/SigningKey/Jwks/Jwt.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Jwks/Jwt.hs @@ -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 diff --git a/src/Shomei/SigningKey/Key/Jwt.hs b/src/Shomei/SigningKey/Key/Jwt.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Key/Jwt.hs @@ -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 diff --git a/src/Shomei/SigningKey/Protection/Jwt.hs b/src/Shomei/SigningKey/Protection/Jwt.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Protection/Jwt.hs @@ -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:\:\@ 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::, 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 diff --git a/src/Shomei/SigningKey/Rotation/Jwt.hs b/src/Shomei/SigningKey/Rotation/Jwt.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Rotation/Jwt.hs @@ -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))) diff --git a/src/Shomei/SigningKey/Sign/Jwt.hs b/src/Shomei/SigningKey/Sign/Jwt.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Sign/Jwt.hs @@ -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 diff --git a/src/Shomei/SigningKey/Verify/Jwt.hs b/src/Shomei/SigningKey/Verify/Jwt.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Verify/Jwt.hs @@ -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 [] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Shomei/SigningKey/Interpreter/JwtSpec.hs b/test/Shomei/SigningKey/Interpreter/JwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Interpreter/JwtSpec.hs @@ -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) + ] diff --git a/test/Shomei/SigningKey/Jwks/JwtSpec.hs b/test/Shomei/SigningKey/Jwks/JwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Jwks/JwtSpec.hs @@ -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]] diff --git a/test/Shomei/SigningKey/Key/JwtSpec.hs b/test/Shomei/SigningKey/Key/JwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Key/JwtSpec.hs @@ -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" + ] diff --git a/test/Shomei/SigningKey/Protection/JwtSpec.hs b/test/Shomei/SigningKey/Protection/JwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Protection/JwtSpec.hs @@ -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" diff --git a/test/Shomei/SigningKey/Rotation/JwtSpec.hs b/test/Shomei/SigningKey/Rotation/JwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Rotation/JwtSpec.hs @@ -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))) diff --git a/test/Shomei/SigningKey/Sign/IdTokenSpec.hs b/test/Shomei/SigningKey/Sign/IdTokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Sign/IdTokenSpec.hs @@ -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) diff --git a/test/Shomei/SigningKey/Sign/JwtSpec.hs b/test/Shomei/SigningKey/Sign/JwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Sign/JwtSpec.hs @@ -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 diff --git a/test/Shomei/SigningKey/Sign/RsaCustomClaimSpec.hs b/test/Shomei/SigningKey/Sign/RsaCustomClaimSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Sign/RsaCustomClaimSpec.hs @@ -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) diff --git a/test/Shomei/SigningKey/TestSupport.hs b/test/Shomei/SigningKey/TestSupport.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/TestSupport.hs @@ -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) + ) diff --git a/test/Shomei/SigningKey/Verify/JwtSpec.hs b/test/Shomei/SigningKey/Verify/JwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/SigningKey/Verify/JwtSpec.hs @@ -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)