{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | SD-JWT verification: Verifying SD-JWT presentations.
--
-- This module provides functions for verifying SD-JWT presentations on the verifier side.
-- It handles signature verification, disclosure validation, and payload processing.
module SDJWT.Internal.Verification
  ( -- * Public API
    verifySDJWT
  , verifyKeyBinding
    -- * Internal/Test-only functions
    -- These functions are exported primarily for testing purposes.
    -- Most users should use 'verifySDJWT' instead.
  , verifySDJWTSignature
  , verifySDJWTWithoutSignature
  , verifyDisclosures
  , processPayload
  , extractHashAlgorithm
  , parsePayloadFromJWT
  , extractRegularClaims
  , extractDigestsFromPayload
  ) where

import SDJWT.Internal.Types (HashAlgorithm(..), Digest(..), EncodedDisclosure(..), SDJWTPayload(..), SDJWTPresentation(..), ProcessedSDJWTPayload(..), SDJWTError(..), KeyBindingInfo(..))
import SDJWT.Internal.Digest (extractDigestsFromValue, computeDigest, computeDigestText, parseHashAlgorithm, defaultHashAlgorithm)
import SDJWT.Internal.Disclosure (decodeDisclosure, getDisclosureValue, getDisclosureClaimName)
import SDJWT.Internal.Utils (base64urlDecode)
import SDJWT.Internal.KeyBinding (verifyKeyBindingJWT)
import SDJWT.Internal.JWT (verifyJWT, JWKLike)
import SDJWT.Internal.Monad (SDJWTIO, runSDJWTIO)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe (mapMaybe)
import Data.Either (partitionEithers)
import Control.Monad (when)
import Data.Text.Encoding (decodeUtf8)

-- | Complete SD-JWT verification.
--
-- This function performs all verification steps:
--
-- 1. Parses the presentation
-- 2. Verifies issuer signature (required)
-- 3. Validates standard JWT claims (if present): @exp@ (expiration time), @nbf@ (not before), etc.
-- 4. Extracts hash algorithm
-- 5. Verifies disclosures match digests
-- 6. Verifies key binding (if present)
-- 7. Processes payload to reconstruct claims
--
-- Returns the processed payload with all claims (both regular non-selectively-disclosable
-- claims and disclosed selectively-disclosable claims). If a KB-JWT was present and verified,
-- the 'keyBindingInfo' field will contain the holder's public key extracted from the
-- @cnf@ claim, allowing the verifier to use it for subsequent operations.
--
-- == Standard JWT Claims Validation
--
-- Standard JWT claims (RFC 7519) included in the issuer-signed JWT are automatically validated:
--
-- - @exp@ (expiration time): Token is rejected if expired
-- - @nbf@ (not before): Token is rejected if not yet valid
-- - Other standard claims are preserved but not validated by this library
--
-- For testing or debugging purposes where signature verification should be skipped,
-- use 'verifySDJWTWithoutSignature' instead.
verifySDJWT
  :: JWKLike jwk => jwk  -- ^ Issuer public key (Text or jose JWK object)
  -> SDJWTPresentation
  -> Maybe T.Text  -- ^ Required typ header value (Nothing = allow any/none, Just "sd-jwt" = require exactly "sd-jwt")
  -> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWT :: forall jwk.
JWKLike jwk =>
jwk
-> SDJWTPresentation
-> Maybe Text
-> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWT jwk
issuerKey SDJWTPresentation
presentation Maybe Text
requiredTyp = do
  -- Verify issuer signature (required)
  Either SDJWTError ()
verifyResult <- jwk -> SDJWTPresentation -> Maybe Text -> IO (Either SDJWTError ())
forall jwk.
JWKLike jwk =>
jwk -> SDJWTPresentation -> Maybe Text -> IO (Either SDJWTError ())
verifySDJWTSignature jwk
issuerKey SDJWTPresentation
presentation Maybe Text
requiredTyp
  case Either SDJWTError ()
verifyResult of
    Left SDJWTError
err -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ProcessedSDJWTPayload
forall a b. a -> Either a b
Left SDJWTError
err)
    Right () -> SDJWTPresentation -> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWTAfterSignature SDJWTPresentation
presentation

-- | SD-JWT verification without signature verification.
--
-- This function performs verification steps 3-6 of 'verifySDJWT' but skips
-- signature verification. This is useful for testing or debugging, but should
-- NOT be used in production as it does not verify the authenticity of the JWT.
--
-- WARNING: This function does not verify the issuer signature. Only use this
-- function when signature verification is not required (e.g., in tests or
-- when verifying locally-generated JWTs).
verifySDJWTWithoutSignature
  :: SDJWTPresentation
  -> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWTWithoutSignature :: SDJWTPresentation -> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWTWithoutSignature = SDJWTPresentation -> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWTAfterSignature

-- | Continue SD-JWT verification after signature verification (if performed).
verifySDJWTAfterSignature
  :: SDJWTPresentation
  -> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWTAfterSignature :: SDJWTPresentation -> IO (Either SDJWTError ProcessedSDJWTPayload)
verifySDJWTAfterSignature SDJWTPresentation
presentation = do
  -- Extract hash algorithm from payload
  Either SDJWTError HashAlgorithm
hashAlg <- case SDJWTPresentation -> Either SDJWTError HashAlgorithm
extractHashAlgorithmFromPresentation SDJWTPresentation
presentation of
    Left SDJWTError
err -> Either SDJWTError HashAlgorithm
-> IO (Either SDJWTError HashAlgorithm)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError HashAlgorithm
forall a b. a -> Either a b
Left SDJWTError
err)
    Right HashAlgorithm
alg -> Either SDJWTError HashAlgorithm
-> IO (Either SDJWTError HashAlgorithm)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HashAlgorithm -> Either SDJWTError HashAlgorithm
forall a b. b -> Either a b
Right HashAlgorithm
alg)
  
  case Either SDJWTError HashAlgorithm
hashAlg of
    Left SDJWTError
err -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ProcessedSDJWTPayload
forall a b. a -> Either a b
Left SDJWTError
err)
    Right HashAlgorithm
alg -> do
      -- Verify disclosures match digests
      case HashAlgorithm -> SDJWTPresentation -> Either SDJWTError ()
verifyDisclosures HashAlgorithm
alg SDJWTPresentation
presentation of
        Left SDJWTError
err -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ProcessedSDJWTPayload
forall a b. a -> Either a b
Left SDJWTError
err)
        Right () -> do
          -- Verify key binding if present
          case SDJWTPresentation -> Maybe Text
keyBindingJWT SDJWTPresentation
presentation of
            Just Text
kbJWT -> do
              -- Extract holder public key from cnf claim in SD-JWT payload
              Either SDJWTError KeyBindingInfo
holderKeyResult <- SDJWTPresentation -> IO (Either SDJWTError KeyBindingInfo)
extractHolderKeyFromPayload SDJWTPresentation
presentation
              case Either SDJWTError KeyBindingInfo
holderKeyResult of
                Left SDJWTError
err -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ProcessedSDJWTPayload
forall a b. a -> Either a b
Left SDJWTError
err)
                Right KeyBindingInfo
kbInfo -> do
                  -- Verify KB-JWT using holder's public key from cnf claim
                  -- kbPublicKey is compatible with JWKLike (Text implements JWKLike)
                  Either SDJWTError ()
kbVerifyResult <- HashAlgorithm
-> Text -> Text -> SDJWTPresentation -> IO (Either SDJWTError ())
forall jwk.
JWKLike jwk =>
HashAlgorithm
-> jwk -> Text -> SDJWTPresentation -> IO (Either SDJWTError ())
verifyKeyBindingJWT HashAlgorithm
alg (KeyBindingInfo -> Text
kbPublicKey KeyBindingInfo
kbInfo) Text
kbJWT SDJWTPresentation
presentation
                  case Either SDJWTError ()
kbVerifyResult of
                    Left SDJWTError
err -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ProcessedSDJWTPayload
forall a b. a -> Either a b
Left SDJWTError
err)
                    Right () -> do
                      -- Process payload to reconstruct claims, including key binding info
                      case HashAlgorithm
-> SDJWTPresentation
-> Maybe KeyBindingInfo
-> Either SDJWTError ProcessedSDJWTPayload
processPayloadFromPresentation HashAlgorithm
alg SDJWTPresentation
presentation (KeyBindingInfo -> Maybe KeyBindingInfo
forall a. a -> Maybe a
Just KeyBindingInfo
kbInfo) of
                        Left SDJWTError
err -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ProcessedSDJWTPayload
forall a b. a -> Either a b
Left SDJWTError
err)
                        Right ProcessedSDJWTPayload
processed -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessedSDJWTPayload -> Either SDJWTError ProcessedSDJWTPayload
forall a b. b -> Either a b
Right ProcessedSDJWTPayload
processed)
            Maybe Text
Nothing -> do
              -- Process payload to reconstruct claims (no key binding)
              case HashAlgorithm
-> SDJWTPresentation
-> Maybe KeyBindingInfo
-> Either SDJWTError ProcessedSDJWTPayload
processPayloadFromPresentation HashAlgorithm
alg SDJWTPresentation
presentation Maybe KeyBindingInfo
forall a. Maybe a
Nothing of
                Left SDJWTError
err -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ProcessedSDJWTPayload
forall a b. a -> Either a b
Left SDJWTError
err)
                Right ProcessedSDJWTPayload
processed -> Either SDJWTError ProcessedSDJWTPayload
-> IO (Either SDJWTError ProcessedSDJWTPayload)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessedSDJWTPayload -> Either SDJWTError ProcessedSDJWTPayload
forall a b. b -> Either a b
Right ProcessedSDJWTPayload
processed)

-- | Verify SD-JWT issuer signature.
--
-- Verifies the signature on the issuer-signed JWT using the issuer's public key.
verifySDJWTSignature
  :: JWKLike jwk => jwk  -- ^ Issuer public key (Text or jose JWK object)
  -> SDJWTPresentation  -- ^ SD-JWT presentation to verify
  -> Maybe T.Text  -- ^ Required typ header value (Nothing = allow any typ or none, Just typValue = require typ to be exactly that value)
  -> IO (Either SDJWTError ())
verifySDJWTSignature :: forall jwk.
JWKLike jwk =>
jwk -> SDJWTPresentation -> Maybe Text -> IO (Either SDJWTError ())
verifySDJWTSignature jwk
issuerKey SDJWTPresentation
presentation Maybe Text
requiredTyp = do
  -- Verify JWT signature using verifyJWT
  Either SDJWTError Value
verifiedPayloadResult <- jwk -> Text -> Maybe Text -> IO (Either SDJWTError Value)
forall jwk.
JWKLike jwk =>
jwk -> Text -> Maybe Text -> IO (Either SDJWTError Value)
verifyJWT jwk
issuerKey (SDJWTPresentation -> Text
presentationJWT SDJWTPresentation
presentation) Maybe Text
requiredTyp
  case Either SDJWTError Value
verifiedPayloadResult of
    Left SDJWTError
err -> Either SDJWTError () -> IO (Either SDJWTError ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError ()
forall a b. a -> Either a b
Left SDJWTError
err)
    Right Value
_ -> Either SDJWTError () -> IO (Either SDJWTError ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either SDJWTError ()
forall a b. b -> Either a b
Right ())

-- | Verify key binding in a presentation.
--
-- Verifies the Key Binding JWT if present in the presentation.
-- This includes verifying the KB-JWT signature and sd_hash.
verifyKeyBinding
  :: JWKLike jwk => HashAlgorithm
  -> jwk  -- ^ Holder public key (Text or jose JWK object)
  -> SDJWTPresentation
  -> IO (Either SDJWTError ())
verifyKeyBinding :: forall jwk.
JWKLike jwk =>
HashAlgorithm
-> jwk -> SDJWTPresentation -> IO (Either SDJWTError ())
verifyKeyBinding HashAlgorithm
hashAlg jwk
holderKey SDJWTPresentation
presentation = do
  case SDJWTPresentation -> Maybe Text
keyBindingJWT SDJWTPresentation
presentation of
    Maybe Text
Nothing -> Either SDJWTError () -> IO (Either SDJWTError ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either SDJWTError ()
forall a b. b -> Either a b
Right ())  -- No key binding, verification passes
    Just Text
kbJWT -> HashAlgorithm
-> jwk -> Text -> SDJWTPresentation -> IO (Either SDJWTError ())
forall jwk.
JWKLike jwk =>
HashAlgorithm
-> jwk -> Text -> SDJWTPresentation -> IO (Either SDJWTError ())
verifyKeyBindingJWT HashAlgorithm
hashAlg jwk
holderKey Text
kbJWT SDJWTPresentation
presentation

-- | Verify that all disclosures match digests in the payload.
--
-- This function:
--
-- 1. Computes digest for each disclosure
-- 2. Verifies each digest exists in the payload's _sd array
-- 3. Checks for duplicate disclosures
verifyDisclosures
  :: HashAlgorithm
  -> SDJWTPresentation
  -> Either SDJWTError ()
verifyDisclosures :: HashAlgorithm -> SDJWTPresentation -> Either SDJWTError ()
verifyDisclosures HashAlgorithm
hashAlg SDJWTPresentation
presentation = do
  -- Parse payload from JWT
  SDJWTPayload
sdPayload <- Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT (SDJWTPresentation -> Text
presentationJWT SDJWTPresentation
presentation)
  
  -- Get all digests from payload
  [Digest]
payloadDigests <- SDJWTPayload -> Either SDJWTError [Digest]
extractDigestsFromPayload SDJWTPayload
sdPayload
  
  -- Get all digests from recursive disclosures (disclosures that contain _sd arrays)
  -- For Section 6.3 recursive disclosures, child digests are in the parent disclosure's _sd array
  [Digest]
recursiveDisclosureDigests <- [EncodedDisclosure] -> Either SDJWTError [Digest]
extractDigestsFromRecursiveDisclosures (SDJWTPresentation -> [EncodedDisclosure]
selectedDisclosures SDJWTPresentation
presentation)
  
  -- Combine all valid digests (payload + recursive disclosures)
  let allValidDigests :: Set Text
allValidDigests = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ((Digest -> Text) -> [Digest] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Digest -> Text
unDigest ([Digest]
payloadDigests [Digest] -> [Digest] -> [Digest]
forall a. [a] -> [a] -> [a]
++ [Digest]
recursiveDisclosureDigests))
  
  -- Compute digests for all disclosures
  let disclosureTexts :: [Text]
disclosureTexts = (EncodedDisclosure -> Text) -> [EncodedDisclosure] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg) (SDJWTPresentation -> [EncodedDisclosure]
selectedDisclosures SDJWTPresentation
presentation)
  let disclosureSet :: Set Text
disclosureSet = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
disclosureTexts
  
  -- Check for duplicates (compare by text representation)
  if Set Text -> Int
forall a. Set a -> Int
Set.size Set Text
disclosureSet Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
disclosureTexts
    then SDJWTError -> Either SDJWTError ()
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError ())
-> SDJWTError -> Either SDJWTError ()
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
DuplicateDisclosure Text
"Duplicate disclosures found"
    else () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  
  -- Verify each disclosure digest exists in payload or recursive disclosures
  let missingDigests :: [Text]
missingDigests = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
allValidDigests) [Text]
disclosureTexts
  
  case [Text]
missingDigests of
    [] -> () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Text
missing:[Text]
_) -> SDJWTError -> Either SDJWTError ()
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError ())
-> SDJWTError -> Either SDJWTError ()
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
MissingDisclosure (Text -> SDJWTError) -> Text -> SDJWTError
forall a b. (a -> b) -> a -> b
$ Text
"Disclosure digest not found in payload: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
missing

-- | Process SD-JWT payload by replacing digests with disclosure values.
--
-- This function reconstructs the full claims set by:
--
-- 1. Starting with regular (non-selectively disclosable) claims
-- 2. Replacing digests in _sd arrays with actual claim values from disclosures
processPayload
  :: HashAlgorithm
  -> SDJWTPayload
  -> [EncodedDisclosure]
  -> Maybe KeyBindingInfo  -- ^ Key binding info if KB-JWT was present and verified
  -> Either SDJWTError ProcessedSDJWTPayload
processPayload :: HashAlgorithm
-> SDJWTPayload
-> [EncodedDisclosure]
-> Maybe KeyBindingInfo
-> Either SDJWTError ProcessedSDJWTPayload
processPayload HashAlgorithm
hashAlg SDJWTPayload
sdPayload [EncodedDisclosure]
sdDisclosures Maybe KeyBindingInfo
mbKeyBindingInfo = do
  -- Start with regular claims (non-selectively disclosable)
  Object
regularClaims <- Value -> Either SDJWTError Object
extractRegularClaims (SDJWTPayload -> Value
payloadValue SDJWTPayload
sdPayload)
  
  -- Process disclosures to create maps of digests to claim values
  (Map Text (Text, Value)
objectDisclosureMap, Map Text Value
arrayDisclosureMap) <- HashAlgorithm
-> [EncodedDisclosure]
-> Either SDJWTError (Map Text (Text, Value), Map Text Value)
buildDisclosureMap HashAlgorithm
hashAlg [EncodedDisclosure]
sdDisclosures
  
  -- Replace digests in _sd arrays with actual values and process arrays
  Object
finalClaims <- Object
-> Map Text (Text, Value)
-> Map Text Value
-> Either SDJWTError Object
replaceDigestsWithValues Object
regularClaims Map Text (Text, Value)
objectDisclosureMap Map Text Value
arrayDisclosureMap
  
  ProcessedSDJWTPayload -> Either SDJWTError ProcessedSDJWTPayload
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessedSDJWTPayload -> Either SDJWTError ProcessedSDJWTPayload)
-> ProcessedSDJWTPayload -> Either SDJWTError ProcessedSDJWTPayload
forall a b. (a -> b) -> a -> b
$ ProcessedSDJWTPayload { processedClaims :: Object
processedClaims = Object
finalClaims, keyBindingInfo :: Maybe KeyBindingInfo
keyBindingInfo = Maybe KeyBindingInfo
mbKeyBindingInfo }

-- | Extract hash algorithm from presentation.
--
-- Parses the JWT payload and extracts the _sd_alg claim, defaulting to SHA-256.
extractHashAlgorithm
  :: SDJWTPresentation
  -> Either SDJWTError HashAlgorithm
extractHashAlgorithm :: SDJWTPresentation -> Either SDJWTError HashAlgorithm
extractHashAlgorithm = SDJWTPresentation -> Either SDJWTError HashAlgorithm
extractHashAlgorithmFromPresentation

-- Helper functions

-- | Extract hash algorithm from presentation payload.
extractHashAlgorithmFromPresentation
  :: SDJWTPresentation
  -> Either SDJWTError HashAlgorithm
extractHashAlgorithmFromPresentation :: SDJWTPresentation -> Either SDJWTError HashAlgorithm
extractHashAlgorithmFromPresentation SDJWTPresentation
presentation =
  (SDJWTPayload -> HashAlgorithm)
-> Either SDJWTError SDJWTPayload
-> Either SDJWTError HashAlgorithm
forall a b. (a -> b) -> Either SDJWTError a -> Either SDJWTError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HashAlgorithm
-> (HashAlgorithm -> HashAlgorithm)
-> Maybe HashAlgorithm
-> HashAlgorithm
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HashAlgorithm
defaultHashAlgorithm HashAlgorithm -> HashAlgorithm
forall a. a -> a
id (Maybe HashAlgorithm -> HashAlgorithm)
-> (SDJWTPayload -> Maybe HashAlgorithm)
-> SDJWTPayload
-> HashAlgorithm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDJWTPayload -> Maybe HashAlgorithm
sdAlg) (Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT (SDJWTPresentation -> Text
presentationJWT SDJWTPresentation
presentation))

-- | Extract holder public key from cnf claim in SD-JWT payload.
--
-- The cnf claim (RFC 7800) contains the holder's public key, typically
-- in the format: {"cnf": {"jwk": {...}}}
-- This function extracts the JWK and returns it as a KeyBindingInfo.
extractHolderKeyFromPayload
  :: SDJWTPresentation
  -> IO (Either SDJWTError KeyBindingInfo)
extractHolderKeyFromPayload :: SDJWTPresentation -> IO (Either SDJWTError KeyBindingInfo)
extractHolderKeyFromPayload SDJWTPresentation
presentation =
  case Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT (SDJWTPresentation -> Text
presentationJWT SDJWTPresentation
presentation) of
    Left SDJWTError
err -> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. a -> Either a b
Left SDJWTError
err)
    Right SDJWTPayload
payload -> do
      -- Extract cnf claim from payload
      case SDJWTPayload -> Value
payloadValue SDJWTPayload
payload of
        Aeson.Object Object
obj ->
          case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"cnf" Object
obj of
            Just (Aeson.Object Object
cnfObj) ->
              -- Extract jwk from cnf object (RFC 7800 jwk confirmation method)
              case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"jwk" Object
cnfObj of
                Just Value
jwkValue -> do
                  -- Encode JWK as JSON string
                  let jwkJson :: ByteString
jwkJson = Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
jwkValue
                  Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError KeyBindingInfo
 -> IO (Either SDJWTError KeyBindingInfo))
-> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a b. (a -> b) -> a -> b
$ KeyBindingInfo -> Either SDJWTError KeyBindingInfo
forall a b. b -> Either a b
Right (KeyBindingInfo -> Either SDJWTError KeyBindingInfo)
-> KeyBindingInfo -> Either SDJWTError KeyBindingInfo
forall a b. (a -> b) -> a -> b
$ Text -> KeyBindingInfo
KeyBindingInfo (Text -> KeyBindingInfo) -> Text -> KeyBindingInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
jwkJson
                Maybe Value
Nothing -> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError KeyBindingInfo
 -> IO (Either SDJWTError KeyBindingInfo))
-> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a b. (a -> b) -> a -> b
$ SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError KeyBindingInfo)
-> SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidKeyBinding Text
"Missing jwk in cnf claim"
            Just Value
_ -> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError KeyBindingInfo
 -> IO (Either SDJWTError KeyBindingInfo))
-> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a b. (a -> b) -> a -> b
$ SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError KeyBindingInfo)
-> SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidKeyBinding Text
"cnf claim is not an object"
            Maybe Value
Nothing -> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError KeyBindingInfo
 -> IO (Either SDJWTError KeyBindingInfo))
-> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a b. (a -> b) -> a -> b
$ SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError KeyBindingInfo)
-> SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidKeyBinding Text
"Missing cnf claim in SD-JWT payload"
        Value
_ -> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError KeyBindingInfo
 -> IO (Either SDJWTError KeyBindingInfo))
-> Either SDJWTError KeyBindingInfo
-> IO (Either SDJWTError KeyBindingInfo)
forall a b. (a -> b) -> a -> b
$ SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError KeyBindingInfo)
-> SDJWTError -> Either SDJWTError KeyBindingInfo
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidKeyBinding Text
"SD-JWT payload is not an object"

-- | Parse payload from JWT.
--
-- | Parse JWT payload from a JWT string (advanced/internal use).
--
-- Extracts and decodes the JWT payload (middle part) from a JWT string.
-- This function properly decodes the base64url-encoded payload and parses it as JSON.
--
-- This function is exported for advanced use cases and internal library use.
-- Most users should use 'verifySDJWT' or 'verifySDJWTWithoutSignature' instead,
-- which handle payload parsing internally.
--
-- This function is used internally by:
--
-- * 'SDJWT.Presentation' - To parse payloads when selecting disclosures
-- * 'verifyDisclosures' - To extract digests from payloads
-- * 'extractHashAlgorithm' - To extract hash algorithm from payloads
--
-- == Advanced/Internal Use
--
-- This function is primarily used internally by other modules (e.g., 'SDJWT.Internal.Presentation').
-- Most users should use higher-level functions like 'verifySDJWT' instead.
-- Only use this function directly if you need fine-grained control over JWT parsing.
--
parsePayloadFromJWT :: T.Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT :: Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT Text
jwt =
  -- Split JWT into parts (header.payload.signature)
  let parts :: [Text]
parts = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
jwt
  in case [Text]
parts of
    (Text
_header : Text
payloadPart : [Text]
_signature) -> do
      -- Decode base64url payload
      ByteString
payloadBytes <- (Text -> Either SDJWTError ByteString)
-> (ByteString -> Either SDJWTError ByteString)
-> Either Text ByteString
-> Either SDJWTError ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> SDJWTError -> Either SDJWTError ByteString
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError ByteString)
-> SDJWTError -> Either SDJWTError ByteString
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
JSONParseError (Text -> SDJWTError) -> Text -> SDJWTError
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode JWT payload: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err) ByteString -> Either SDJWTError ByteString
forall a b. b -> Either a b
Right (Text -> Either Text ByteString
base64urlDecode Text
payloadPart)
      -- Parse JSON payload
      Value
payloadJson <- (String -> Either SDJWTError Value)
-> (Value -> Either SDJWTError Value)
-> Either String Value
-> Either SDJWTError Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
err -> SDJWTError -> Either SDJWTError Value
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError Value)
-> SDJWTError -> Either SDJWTError Value
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
JSONParseError (Text -> SDJWTError) -> Text -> SDJWTError
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse JWT payload: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err) Value -> Either SDJWTError Value
forall a b. b -> Either a b
Right (ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
payloadBytes)
      -- Extract hash algorithm from payload
      let hashAlg :: Maybe HashAlgorithm
hashAlg = Value -> Maybe HashAlgorithm
extractHashAlgorithmFromPayload Value
payloadJson
      SDJWTPayload -> Either SDJWTError SDJWTPayload
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTPayload -> Either SDJWTError SDJWTPayload)
-> SDJWTPayload -> Either SDJWTError SDJWTPayload
forall a b. (a -> b) -> a -> b
$ SDJWTPayload
        { sdAlg :: Maybe HashAlgorithm
sdAlg = Maybe HashAlgorithm
hashAlg
        , payloadValue :: Value
payloadValue = Value
payloadJson
        }
    [Text]
_ -> SDJWTError -> Either SDJWTError SDJWTPayload
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError SDJWTPayload)
-> SDJWTError -> Either SDJWTError SDJWTPayload
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidSignature Text
"Invalid JWT format: expected header.payload.signature"
  
  where
    -- Extract hash algorithm from payload JSON
    extractHashAlgorithmFromPayload :: Aeson.Value -> Maybe HashAlgorithm
    extractHashAlgorithmFromPayload :: Value -> Maybe HashAlgorithm
extractHashAlgorithmFromPayload (Aeson.Object Object
obj) =
      case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"_sd_alg" Object
obj of
        Just (Aeson.String Text
algText) -> Text -> Maybe HashAlgorithm
parseHashAlgorithm Text
algText
        Maybe Value
_ -> Maybe HashAlgorithm
forall a. Maybe a
Nothing
    extractHashAlgorithmFromPayload Value
_ = Maybe HashAlgorithm
forall a. Maybe a
Nothing

-- | Extract digests from payload's _sd array and arrays with ellipsis objects.
extractDigestsFromPayload :: SDJWTPayload -> Either SDJWTError [Digest]
extractDigestsFromPayload :: SDJWTPayload -> Either SDJWTError [Digest]
extractDigestsFromPayload SDJWTPayload
sdPayload = Value -> Either SDJWTError [Digest]
extractDigestsFromValue (SDJWTPayload -> Value
payloadValue SDJWTPayload
sdPayload)

-- | Extract digests from recursive disclosures (disclosures that contain _sd arrays).
-- For Section 6.3 recursive disclosures, child digests are in the parent disclosure's _sd array.
extractDigestsFromRecursiveDisclosures
  :: [EncodedDisclosure]
  -> Either SDJWTError [Digest]
extractDigestsFromRecursiveDisclosures :: [EncodedDisclosure] -> Either SDJWTError [Digest]
extractDigestsFromRecursiveDisclosures [EncodedDisclosure]
disclosures =
  ([[Digest]] -> [Digest])
-> Either SDJWTError [[Digest]] -> Either SDJWTError [Digest]
forall a b. (a -> b) -> Either SDJWTError a -> Either SDJWTError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Digest]] -> [Digest]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Either SDJWTError [[Digest]] -> Either SDJWTError [Digest])
-> Either SDJWTError [[Digest]] -> Either SDJWTError [Digest]
forall a b. (a -> b) -> a -> b
$ (EncodedDisclosure -> Either SDJWTError [Digest])
-> [EncodedDisclosure] -> Either SDJWTError [[Digest]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\EncodedDisclosure
encDisclosure ->
    case EncodedDisclosure -> Either SDJWTError Disclosure
decodeDisclosure EncodedDisclosure
encDisclosure of
      Left SDJWTError
_ -> [Digest] -> Either SDJWTError [Digest]
forall a b. b -> Either a b
Right []  -- Skip invalid disclosures
      Right Disclosure
decoded ->
        let claimValue :: Value
claimValue = Disclosure -> Value
getDisclosureValue Disclosure
decoded
        -- Extract digests from _sd arrays in disclosure values
        in Value -> Either SDJWTError [Digest]
extractDigestsFromValue Value
claimValue
    ) [EncodedDisclosure]
disclosures

-- | Extract regular (non-selectively disclosable) claims from payload.
--
-- JWT payloads must be JSON objects (RFC 7519), so this function only accepts
-- Aeson.Object values. Returns an error if given a non-object value.
extractRegularClaims :: Aeson.Value -> Either SDJWTError Aeson.Object
extractRegularClaims :: Value -> Either SDJWTError Object
extractRegularClaims (Aeson.Object Object
obj) =
  Object -> Either SDJWTError Object
forall a b. b -> Either a b
Right (Object -> Either SDJWTError Object)
-> Object -> Either SDJWTError Object
forall a b. (a -> b) -> a -> b
$ (Key -> Value -> Bool) -> Object -> Object
forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filterWithKey (\Key
k Value
_ ->
    let keyText :: Text
keyText = Key -> Text
Key.toText Key
k
    in Text
keyText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"_sd" Bool -> Bool -> Bool
&& Text
keyText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"_sd_alg" Bool -> Bool -> Bool
&& Text
keyText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"cnf"
  ) Object
obj
extractRegularClaims Value
_ = SDJWTError -> Either SDJWTError Object
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError Object)
-> SDJWTError -> Either SDJWTError Object
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
JSONParseError Text
"JWT payload must be a JSON object"

-- | Build maps from digests to disclosure values.
-- Returns two maps:
--
-- 1. Object disclosures: digest -> (claimName, claimValue)
-- 2. Array disclosures: digest -> value
buildDisclosureMap
  :: HashAlgorithm
  -> [EncodedDisclosure]
  -> Either SDJWTError (Map.Map T.Text (T.Text, Aeson.Value), Map.Map T.Text Aeson.Value)
buildDisclosureMap :: HashAlgorithm
-> [EncodedDisclosure]
-> Either SDJWTError (Map Text (Text, Value), Map Text Value)
buildDisclosureMap HashAlgorithm
hashAlg [EncodedDisclosure]
sdDisclosures =
  -- Process each disclosure and separate into object and array disclosures
  ([Either (Text, (Text, Value)) (Text, Value)]
 -> (Map Text (Text, Value), Map Text Value))
-> Either SDJWTError [Either (Text, (Text, Value)) (Text, Value)]
-> Either SDJWTError (Map Text (Text, Value), Map Text Value)
forall a b. (a -> b) -> Either SDJWTError a -> Either SDJWTError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Either (Text, (Text, Value)) (Text, Value)]
disclosureResults ->
    -- Partition into object and array results
    let ([(Text, (Text, Value))]
objectResults, [(Text, Value)]
arrayResults) = [Either (Text, (Text, Value)) (Text, Value)]
-> ([(Text, (Text, Value))], [(Text, Value)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (Text, (Text, Value)) (Text, Value)]
disclosureResults
    in ([(Text, (Text, Value))] -> Map Text (Text, Value)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, (Text, Value))]
objectResults, [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Value)]
arrayResults)
  ) (Either SDJWTError [Either (Text, (Text, Value)) (Text, Value)]
 -> Either SDJWTError (Map Text (Text, Value), Map Text Value))
-> Either SDJWTError [Either (Text, (Text, Value)) (Text, Value)]
-> Either SDJWTError (Map Text (Text, Value), Map Text Value)
forall a b. (a -> b) -> a -> b
$ (EncodedDisclosure
 -> Either SDJWTError (Either (Text, (Text, Value)) (Text, Value)))
-> [EncodedDisclosure]
-> Either SDJWTError [Either (Text, (Text, Value)) (Text, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\EncodedDisclosure
encDisclosure ->
    EncodedDisclosure -> Either SDJWTError Disclosure
decodeDisclosure EncodedDisclosure
encDisclosure Either SDJWTError Disclosure
-> (Disclosure
    -> Either SDJWTError (Either (Text, (Text, Value)) (Text, Value)))
-> Either SDJWTError (Either (Text, (Text, Value)) (Text, Value))
forall a b.
Either SDJWTError a
-> (a -> Either SDJWTError b) -> Either SDJWTError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Disclosure
decodedDisclosure ->
      let digestText :: Text
digestText = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure
          claimName :: Maybe Text
claimName = Disclosure -> Maybe Text
getDisclosureClaimName Disclosure
decodedDisclosure
          claimValue :: Value
claimValue = Disclosure -> Value
getDisclosureValue Disclosure
decodedDisclosure
      in Either (Text, (Text, Value)) (Text, Value)
-> Either SDJWTError (Either (Text, (Text, Value)) (Text, Value))
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Text, (Text, Value)) (Text, Value)
 -> Either SDJWTError (Either (Text, (Text, Value)) (Text, Value)))
-> Either (Text, (Text, Value)) (Text, Value)
-> Either SDJWTError (Either (Text, (Text, Value)) (Text, Value))
forall a b. (a -> b) -> a -> b
$ case Maybe Text
claimName of
           Just Text
name -> (Text, (Text, Value)) -> Either (Text, (Text, Value)) (Text, Value)
forall a b. a -> Either a b
Left (Text
digestText, (Text
name, Value
claimValue))  -- Object disclosure
           Maybe Text
Nothing -> (Text, Value) -> Either (Text, (Text, Value)) (Text, Value)
forall a b. b -> Either a b
Right (Text
digestText, Value
claimValue)  -- Array disclosure
    ) [EncodedDisclosure]
sdDisclosures

-- | Replace digests in payload with actual claim values.
-- This function:
--
-- 1. Processes object claims (replaces digests in _sd arrays with values, recursively)
-- 2. Recursively processes arrays to replace {"...": "<digest>"} objects with values
replaceDigestsWithValues
  :: Aeson.Object
  -> Map.Map T.Text (T.Text, Aeson.Value)  -- Object disclosures: digest -> (claimName, claimValue)
  -> Map.Map T.Text Aeson.Value  -- Array disclosures: digest -> value
  -> Either SDJWTError Aeson.Object
replaceDigestsWithValues :: Object
-> Map Text (Text, Value)
-> Map Text Value
-> Either SDJWTError Object
replaceDigestsWithValues Object
regularClaims Map Text (Text, Value)
objectDisclosureMap Map Text Value
arrayDisclosureMap = do
  -- Process object claims: replace digests in _sd arrays with values (including nested _sd arrays)
  let disclosedClaims :: Object
disclosedClaims = [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Object) -> [(Key, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ ((Text, Value) -> (Key, Value))
-> [(Text, Value)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
claimName, Value
claimValue) -> (Text -> Key
Key.fromText Text
claimName, Value
claimValue)) (Map Text (Text, Value) -> [(Text, Value)]
forall k a. Map k a -> [a]
Map.elems Map Text (Text, Value)
objectDisclosureMap)
      objectClaims :: Object
objectClaims = Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
KeyMap.union Object
disclosedClaims Object
regularClaims
  -- Process arrays recursively to replace {"...": "<digest>"} objects
  -- Also process nested _sd arrays recursively
  -- Note: Array disclosure values may contain _sd arrays (for nested selective disclosure),
  -- so we need to process _sd arrays in those values too
  Object
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError Object
processArraysInClaimsWithSD (Object -> Map Text (Text, Value) -> Object
processSDArraysInClaims Object
objectClaims Map Text (Text, Value)
objectDisclosureMap) Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap

-- | Recursively process _sd arrays in claims to replace digests with values.
processSDArraysInClaims
  :: Aeson.Object
  -> Map.Map T.Text (T.Text, Aeson.Value)  -- Object disclosures: digest -> (claimName, claimValue)
  -> Aeson.Object
processSDArraysInClaims :: Object -> Map Text (Text, Value) -> Object
processSDArraysInClaims Object
claims Map Text (Text, Value)
objectDisclosureMap =
  (Value -> Value) -> Object -> Object
forall a b. (a -> b) -> KeyMap a -> KeyMap b
KeyMap.map (\Value
value -> Value -> Map Text (Text, Value) -> Value
processSDArraysInValue Value
value Map Text (Text, Value)
objectDisclosureMap) Object
claims

-- | Recursively process a JSON value to replace digests in _sd arrays with values.
processSDArraysInValue
  :: Aeson.Value
  -> Map.Map T.Text (T.Text, Aeson.Value)  -- Object disclosures: digest -> (claimName, claimValue)
  -> Aeson.Value
processSDArraysInValue :: Value -> Map Text (Text, Value) -> Value
processSDArraysInValue (Aeson.Object Object
obj) Map Text (Text, Value)
objectDisclosureMap =
  -- Check if this object has an _sd array
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"_sd" Object
obj of
    Just (Aeson.Array Array
arr) ->
      -- Extract claims from _sd array digests
      let disclosedClaims :: [(Text, Value)]
disclosedClaims = (Value -> Maybe (Text, Value)) -> [Value] -> [(Text, Value)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Value
el -> case Value
el of
            Aeson.String Text
digest -> 
              -- Look up the claim name and value for this digest
              Text -> Map Text (Text, Value) -> Maybe (Text, Value)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
digest Map Text (Text, Value)
objectDisclosureMap
            Value
_ -> Maybe (Text, Value)
forall a. Maybe a
Nothing  -- Not a string digest, skip
            ) (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
arr)
      
      -- Build new object: remove _sd and _sd_alg (metadata fields), add disclosed claims, keep other fields
          objWithoutSD :: Object
objWithoutSD = Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"_sd_alg" (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"_sd" Object
obj
          objWithDisclosedClaims :: Object
objWithDisclosedClaims = (Object -> (Text, Value) -> Object)
-> Object -> [(Text, Value)] -> Object
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Object
acc (Text
claimName, Value
claimValue) ->
                Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert (Text -> Key
Key.fromText Text
claimName) Value
claimValue Object
acc) Object
objWithoutSD [(Text, Value)]
disclosedClaims
      -- Recursively process nested objects (including the newly added claims)
          processedObj :: Object
processedObj = (Value -> Value) -> Object -> Object
forall a b. (a -> b) -> KeyMap a -> KeyMap b
KeyMap.map (\Value
value -> Value -> Map Text (Text, Value) -> Value
processSDArraysInValue Value
value Map Text (Text, Value)
objectDisclosureMap) Object
objWithDisclosedClaims
      in Object -> Value
Aeson.Object Object
processedObj
    Maybe Value
_ ->
      -- _sd doesn't exist or is not an array, just recursively process nested objects
      Object -> Value
Aeson.Object ((Value -> Value) -> Object -> Object
forall a b. (a -> b) -> KeyMap a -> KeyMap b
KeyMap.map (\Value
value -> Value -> Map Text (Text, Value) -> Value
processSDArraysInValue Value
value Map Text (Text, Value)
objectDisclosureMap) Object
obj)
processSDArraysInValue (Aeson.Array Array
arr) Map Text (Text, Value)
objectDisclosureMap =
  -- Recursively process array elements
  Array -> Value
Aeson.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> Array -> Array
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\Value
el -> Value -> Map Text (Text, Value) -> Value
processSDArraysInValue Value
el Map Text (Text, Value)
objectDisclosureMap) Array
arr
processSDArraysInValue Value
value Map Text (Text, Value)
_objectDisclosureMap = Value
value  -- Primitive values, keep as is

-- | Recursively process arrays in claims to replace {"...": "<digest>"} objects with values.
-- Also processes _sd arrays in array disclosure values (for nested selective disclosure).
-- | Process arrays in claims, also processing _sd arrays in array disclosure values.
processArraysInClaimsWithSD
  :: Aeson.Object
  -> Map.Map T.Text Aeson.Value  -- Array disclosures: digest -> value
  -> Map.Map T.Text (T.Text, Aeson.Value)  -- Object disclosures: digest -> (claimName, claimValue)
  -> Either SDJWTError Aeson.Object
processArraysInClaimsWithSD :: Object
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError Object
processArraysInClaimsWithSD Object
claims Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap = do
  [(Key, Value)]
processedPairs <- ((Key, Value) -> Either SDJWTError (Key, Value))
-> [(Key, Value)] -> Either SDJWTError [(Key, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Key
key, Value
value) -> do
    Value
processedValue <- Value
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError Value
processValueForArraysWithSD Value
value Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap
    (Key, Value) -> Either SDJWTError (Key, Value)
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
key, Value
processedValue)
    ) (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
claims)
  Object -> Either SDJWTError Object
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Either SDJWTError Object)
-> Object -> Either SDJWTError Object
forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key, Value)]
processedPairs

-- | Remove _sd_alg metadata field while preserving the JSON type structure.
removeSDAlgPreservingType :: Aeson.Value -> Aeson.Value
removeSDAlgPreservingType :: Value -> Value
removeSDAlgPreservingType (Aeson.Object Object
obj') =
  let objWithoutSDAlg :: Object
objWithoutSDAlg = Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"_sd_alg" Object
obj'
  -- Preserve the object type: if empty, return empty object {}, not []
  in if Object -> Bool
forall v. KeyMap v -> Bool
KeyMap.null Object
objWithoutSDAlg
    then Object -> Value
Aeson.Object Object
forall v. KeyMap v
KeyMap.empty
    else Object -> Value
Aeson.Object Object
objWithoutSDAlg
removeSDAlgPreservingType (Aeson.Array Array
arr') =
  -- Preserve the array type: if empty, return empty array []
  if Array -> Bool
forall a. Vector a -> Bool
V.null Array
arr'
    then Array -> Value
Aeson.Array Array
forall a. Vector a
V.empty
    else Array -> Value
Aeson.Array Array
arr'
removeSDAlgPreservingType Value
value = Value
value

-- | Process an ellipsis object {"...": "<digest>"} by replacing it with the disclosure value.
processEllipsisObject
  :: Aeson.Object
  -> Map.Map T.Text Aeson.Value  -- Array disclosures: digest -> value
  -> Map.Map T.Text (T.Text, Aeson.Value)  -- Object disclosures: digest -> (claimName, claimValue)
  -> Either SDJWTError (Maybe Aeson.Value)
processEllipsisObject :: Object
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError (Maybe Value)
processEllipsisObject Object
obj Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap =
  -- Check if this is a {"...": "<digest>"} object
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
"...") Object
obj of
    Just (Aeson.String Text
digest) ->
      -- Validate that ellipsis object only contains the "..." key
      -- Per RFC 9901 Section 4.2.4.2: "There MUST NOT be any other keys in the object."
      if Object -> Int
forall v. KeyMap v -> Int
KeyMap.size Object
obj Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        then
          -- Look up the value for this digest
          case Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
digest Map Text Value
arrayDisclosureMap of
            Just Value
value -> do
              -- Process _sd arrays in the array disclosure value (for nested selective disclosure)
              let processedSD :: Value
processedSD = Value -> Map Text (Text, Value) -> Value
processSDArraysInValue Value
value Map Text (Text, Value)
objectDisclosureMap
                  -- Remove _sd_alg (metadata field) from array disclosure values
                  processedWithoutSDAlg :: Value
processedWithoutSDAlg = Value -> Value
removeSDAlgPreservingType Value
processedSD
              -- Recursively process nested arrays with ellipsis objects (RFC 9901 Section 7.1 Step 2.c.iii.3)
              -- This handles cases where array disclosure values are themselves arrays with ellipsis objects
              Value
processedValue <- Value
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError Value
processValueForArraysWithSD Value
processedWithoutSDAlg Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap
              Maybe Value -> Either SDJWTError (Maybe Value)
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
processedValue)
            Maybe Value
Nothing ->
              -- No disclosure found - per RFC 9901 Section 7.3, remove the array element
              -- "Verifiers ignore all selectively disclosable array elements for which
              -- they did not receive a Disclosure."
              Maybe Value -> Either SDJWTError (Maybe Value)
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Value
forall a. Maybe a
Nothing
        else SDJWTError -> Either SDJWTError (Maybe Value)
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError (Maybe Value))
-> SDJWTError -> Either SDJWTError (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidDigest Text
"Ellipsis object must contain only the \"...\" key (RFC 9901 Section 4.2.4.2)"
    Maybe Value
_ -> Maybe Value -> Either SDJWTError (Maybe Value)
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Maybe Value
forall a. a -> Maybe a
Just (Object -> Value
Aeson.Object Object
obj))  -- Not an ellipsis object, keep as is

-- | Recursively process a JSON value to replace {"...": "<digest>"} objects in arrays,
-- and also process _sd arrays in array disclosure values (for nested selective disclosure).
processValueForArraysWithSD
  :: Aeson.Value
  -> Map.Map T.Text Aeson.Value  -- Array disclosures: digest -> value
  -> Map.Map T.Text (T.Text, Aeson.Value)  -- Object disclosures: digest -> (claimName, claimValue)
  -> Either SDJWTError Aeson.Value
processValueForArraysWithSD :: Value
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError Value
processValueForArraysWithSD (Aeson.Array Array
arr) Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap = do
  -- Process each element in the array
  [Value]
processedElements <- (Value -> Either SDJWTError Value)
-> [Value] -> Either SDJWTError [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Value
el -> Value
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError Value
processValueForArraysWithSD Value
el Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap) (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
arr)
  -- Replace {"...": "<digest>"} objects with actual values
  -- Per RFC 9901 Section 7.3: "Verifiers ignore all selectively disclosable array elements
  -- for which they did not receive a Disclosure."
  [Maybe Value]
replacedElements <- (Value -> Either SDJWTError (Maybe Value))
-> [Value] -> Either SDJWTError [Maybe Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Value
el -> case Value
el of
        Aeson.Object Object
obj -> Object
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError (Maybe Value)
processEllipsisObject Object
obj Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap
        Value
_ -> Maybe Value -> Either SDJWTError (Maybe Value)
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
el)  -- Not an object, keep as is
        ) [Value]
processedElements
  Value -> Either SDJWTError Value
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either SDJWTError Value)
-> Value -> Either SDJWTError Value
forall a b. (a -> b) -> a -> b
$ Array -> Value
Aeson.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array) -> [Value] -> Array
forall a b. (a -> b) -> a -> b
$ (Maybe Value -> Maybe Value) -> [Maybe Value] -> [Value]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Maybe Value -> Maybe Value
forall a. a -> a
id [Maybe Value]
replacedElements
processValueForArraysWithSD (Aeson.Object Object
obj) Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap = do
  -- Recursively process nested objects and _sd arrays
  [(Key, Value)]
processedPairs <- ((Key, Value) -> Either SDJWTError (Key, Value))
-> [(Key, Value)] -> Either SDJWTError [(Key, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Key
key, Value
value) -> do
    Value
processedValue <- Value
-> Map Text Value
-> Map Text (Text, Value)
-> Either SDJWTError Value
processValueForArraysWithSD Value
value Map Text Value
arrayDisclosureMap Map Text (Text, Value)
objectDisclosureMap
    (Key, Value) -> Either SDJWTError (Key, Value)
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
key, Value
processedValue)
    ) (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
obj)
  let processedKeyMap :: Object
processedKeyMap = [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key, Value)]
processedPairs
      -- Also process _sd arrays in this object
      processedWithSD :: Value
processedWithSD = Value -> Map Text (Text, Value) -> Value
processSDArraysInValue (Object -> Value
Aeson.Object Object
processedKeyMap) Map Text (Text, Value)
objectDisclosureMap
  Value -> Either SDJWTError Value
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
processedWithSD
processValueForArraysWithSD Value
value Map Text Value
_arrayDisclosureMap Map Text (Text, Value)
_objectDisclosureMap = Value -> Either SDJWTError Value
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value  -- Primitive values, keep as is

-- | Process payload from presentation (convenience function).
processPayloadFromPresentation
  :: HashAlgorithm
  -> SDJWTPresentation
  -> Maybe KeyBindingInfo  -- ^ Key binding info if KB-JWT was present and verified
  -> Either SDJWTError ProcessedSDJWTPayload
processPayloadFromPresentation :: HashAlgorithm
-> SDJWTPresentation
-> Maybe KeyBindingInfo
-> Either SDJWTError ProcessedSDJWTPayload
processPayloadFromPresentation HashAlgorithm
hashAlg SDJWTPresentation
presentation Maybe KeyBindingInfo
mbKeyBindingInfo = do
  SDJWTPayload
sdPayload <- Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT (SDJWTPresentation -> Text
presentationJWT SDJWTPresentation
presentation)
  HashAlgorithm
-> SDJWTPayload
-> [EncodedDisclosure]
-> Maybe KeyBindingInfo
-> Either SDJWTError ProcessedSDJWTPayload
processPayload HashAlgorithm
hashAlg SDJWTPayload
sdPayload (SDJWTPresentation -> [EncodedDisclosure]
selectedDisclosures SDJWTPresentation
presentation) Maybe KeyBindingInfo
mbKeyBindingInfo