{-# LANGUAGE OverloadedStrings #-}
-- | SD-JWT issuance: Creating SD-JWTs from claims sets.
--
-- This module provides functions for creating SD-JWTs on the issuer side.
-- It handles marking claims as selectively disclosable, creating disclosures,
-- computing digests, and building the final signed JWT.
--
-- == Nested Structures
--
-- This module supports nested structures (RFC 9901 Sections 6.2 and 6.3) using
-- JSON Pointer syntax (RFC 6901) for specifying nested claim paths.
--
-- === JSON Pointer Syntax
--
-- Nested paths use forward slash (@/@) as a separator. Paths can refer to both
-- object properties and array elements:
--
-- @
-- -- Object properties
-- ["address\/street_address", "address\/locality"]
-- @
--
-- This marks @street_address@ and @locality@ within the @address@ object as
-- selectively disclosable.
--
-- @
-- -- Array elements
-- ["nationalities\/0", "nationalities\/2"]
-- @
--
-- This marks elements at indices 0 and 2 in the @nationalities@ array as
-- selectively disclosable.
--
-- @
-- -- Mixed object and array paths
-- ["address\/street_address", "nationalities\/1"]
-- @
--
-- === Ambiguity Resolution
--
-- Paths with numeric segments (e.g., @["x\/22"]@) are ambiguous:
-- they could refer to an array element at index 22, or an object property
-- with key @"22"@. The library resolves this ambiguity by checking the actual
-- claim type at runtime:
--
-- * If @x@ is an array → @["x\/22"]@ refers to array element at index 22
-- * If @x@ is an object → @["x\/22"]@ refers to object property @"22"@
--
-- This follows JSON Pointer semantics (RFC 6901) where the path alone doesn't
-- determine the type.
--
-- === Escaping Special Characters
--
-- JSON Pointer provides escaping for keys containing special characters:
--
-- * @~1@ represents a literal forward slash @/@
-- * @~0@ represents a literal tilde @~@
--
-- Examples:
--
-- * @["contact~1email"]@ → marks the literal key @"contact\/email"@ as selectively disclosable
-- * @["user~0name"]@ → marks the literal key @"user~name"@ as selectively disclosable
-- * @["address\/email"]@ → marks @email@ within @address@ object as selectively disclosable
--
-- === Nested Structure Patterns
--
-- The module supports two patterns for nested structures:
--
-- 1. /Structured SD-JWT/ (Section 6.2): Parent object stays in payload with @_sd@ array
--    containing digests for sub-claims.
--
-- 2. /Recursive Disclosures/ (Section 6.3): Parent is selectively disclosable, and its
--    disclosure contains an @_sd@ array with digests for sub-claims.
--
-- The pattern is automatically detected based on whether the parent claim is also
-- in the selective claims list.
--
-- === Examples
--
-- Structured SD-JWT (Section 6.2):
--
-- @
-- buildSDJWTPayload SHA256 ["address\/street_address", "address\/locality"] claims
-- @
--
-- This creates a payload where @address@ object contains an @_sd@ array.
--
-- Recursive Disclosures (Section 6.3):
--
-- @
-- buildSDJWTPayload SHA256 ["address", "address\/street_address", "address\/locality"] claims
-- @
--
-- This creates a payload where @address@ digest is in top-level @_sd@, and the
-- @address@ disclosure contains an @_sd@ array with sub-claim digests.
--
-- Array Elements:
--
-- @
-- buildSDJWTPayload SHA256 ["nationalities\/0", "nationalities\/2"] claims
-- @
--
-- This marks array elements at indices 0 and 2 as selectively disclosable.
--
-- Nested Arrays:
--
-- @
-- buildSDJWTPayload SHA256 ["nested_array\/0\/0", "nested_array\/0\/1", "nested_array\/1\/0"] claims
-- @
--
-- This marks nested array elements. The path @["nested_array\/0\/0"]@ refers to
-- element at index 0 of the array at index 0 of @nested_array@.
--
-- Mixed Object and Array Paths:
--
-- @
-- buildSDJWTPayload SHA256 ["address\/street_address", "nationalities\/1"] claims
-- @
--
-- This marks both an object property and an array element as selectively disclosable.
--
-- == Decoy Digests
--
-- Decoy digests are optional random digests added to @_sd@ arrays to obscure
-- the actual number of selectively disclosable claims. This is useful for
-- privacy-preserving applications where you want to hide how many claims are
-- selectively disclosable.
--
-- To use decoy digests:
--
-- 1. Build the SD-JWT payload using buildSDJWTPayload
-- 2. Generate decoy digests using addDecoyDigest
-- 3. Manually add them to the @_sd@ array in the payload
-- 4. Sign the modified payload
--
-- Example:
--
-- @
-- -- Build the initial payload
-- (payload, disclosures) <- buildSDJWTPayload SHA256 ["given_name", "email"] claims
-- 
-- -- Generate decoy digests
-- decoy1 <- addDecoyDigest SHA256
-- decoy2 <- addDecoyDigest SHA256
-- 
-- -- Add decoy digests to the _sd array
-- case payloadValue payload of
--   Aeson.Object obj -> do
--     case KeyMap.lookup "_sd" obj of
--       Just (Aeson.Array sdArray) -> do
--         let decoyDigests = [Aeson.String (unDigest decoy1), Aeson.String (unDigest decoy2)]
--         let updatedSDArray = sdArray <> V.fromList decoyDigests
--         let updatedObj = KeyMap.insert "_sd" (Aeson.Array updatedSDArray) obj
--         -- Sign the updated payload...
--       _ -> -- Handle error
--   _ -> -- Handle error
-- @
--
-- During verification, decoy digests that don't match any disclosure are
-- automatically ignored, so they don't affect verification.
module SDJWT.Internal.Issuance
  ( -- * Public API
    createSDJWT
  , createSDJWTWithDecoys
  , addDecoyDigest
  , buildSDJWTPayload
  , addHolderKeyToClaims
  ) where

import SDJWT.Internal.Types (HashAlgorithm(..), Salt(..), Digest(..), EncodedDisclosure(..), SDJWTPayload(..), SDJWT(..), SDJWTError(..))
import SDJWT.Internal.Utils (generateSalt, hashToBytes, base64urlEncode, splitJSONPointer, unescapeJSONPointer, groupPathsByFirstSegment)
import SDJWT.Internal.Digest (computeDigest, hashAlgorithmToText)
import SDJWT.Internal.Disclosure (createObjectDisclosure, createArrayDisclosure)
import SDJWT.Internal.JWT (signJWTWithHeaders, JWKLike)
import SDJWT.Internal.Monad (SDJWTIO, runSDJWTIO, partitionAndHandle)
import SDJWT.Internal.Issuance.Nested (processNestedStructures, processRecursiveDisclosures)
import SDJWT.Internal.Issuance.Types
  ( TopLevelClaimsConfig(..)
  , TopLevelClaimsResult(..)
  , BuildSDJWTPayloadConfig(..)
  , BuildSDJWTPayloadResult(..)
  , CreateSDJWTConfig(..)
  , CreateSDJWTWithDecoysConfig(..)
  )
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.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Vector as V
import Data.List (sortBy, partition, find)
import Data.Ord (comparing)
import Text.Read (readMaybe)
import Data.Either (partitionEithers)
import Data.Maybe (mapMaybe)
import Control.Monad (replicateM)
import Control.Monad.Except (throwError)

-- | Mark a claim as selectively disclosable (internal use only).
--
-- This function only works for object claims (JSON objects), not for array elements.
-- It's used internally by buildSDJWTPayload and Issuance.Nested.
-- External users should use buildSDJWTPayload or createSDJWT with JSON Pointer paths.
markSelectivelyDisclosable
  :: HashAlgorithm
  -> T.Text  -- ^ Claim name
  -> Aeson.Value  -- ^ Claim value
  -> IO (Either SDJWTError (Digest, EncodedDisclosure))
markSelectivelyDisclosable :: HashAlgorithm
-> Text
-> Value
-> IO (Either SDJWTError (Digest, EncodedDisclosure))
markSelectivelyDisclosable HashAlgorithm
hashAlg Text
claimName Value
claimValue =
  (ByteString -> Either SDJWTError (Digest, EncodedDisclosure))
-> IO ByteString
-> IO (Either SDJWTError (Digest, EncodedDisclosure))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ByteString
saltBytes ->
    let salt :: Salt
salt = ByteString -> Salt
Salt ByteString
saltBytes
    in case Salt -> Text -> Value -> Either SDJWTError EncodedDisclosure
createObjectDisclosure Salt
salt Text
claimName Value
claimValue of
         Left SDJWTError
err -> SDJWTError -> Either SDJWTError (Digest, EncodedDisclosure)
forall a b. a -> Either a b
Left SDJWTError
err
         Right EncodedDisclosure
encodedDisclosure ->
           let digest :: Digest
digest = HashAlgorithm -> EncodedDisclosure -> Digest
computeDigest HashAlgorithm
hashAlg EncodedDisclosure
encodedDisclosure
           in (Digest, EncodedDisclosure)
-> Either SDJWTError (Digest, EncodedDisclosure)
forall a b. b -> Either a b
Right (Digest
digest, EncodedDisclosure
encodedDisclosure)
  ) IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
generateSalt


-- | Build SD-JWT payload from claims, marking specified claims as selectively disclosable.
--
-- This function:
--
-- 1. Separates selectively disclosable claims from regular claims
-- 2. Creates disclosures for selectively disclosable claims
-- 3. Computes digests
-- 4. Builds the JSON payload with _sd array containing digests
-- 5. Returns the payload and all disclosures
--
-- Supports nested structures (Section 6.2, 6.3):
--
-- - Use JSON Pointer syntax for nested paths: ["address\/street_address", "address\/locality"]
-- - For Section 6.2 (structured): parent object stays, sub-claims get _sd array within parent
-- - For Section 6.3 (recursive): parent is selectively disclosable, disclosure contains _sd array
-- | Build SD-JWT payload using ExceptT (internal implementation).
buildSDJWTPayloadExceptT
  :: BuildSDJWTPayloadConfig
  -> SDJWTIO BuildSDJWTPayloadResult
buildSDJWTPayloadExceptT :: BuildSDJWTPayloadConfig -> SDJWTIO BuildSDJWTPayloadResult
buildSDJWTPayloadExceptT BuildSDJWTPayloadConfig
config = do
  let hashAlg :: HashAlgorithm
hashAlg = BuildSDJWTPayloadConfig -> HashAlgorithm
buildHashAlg BuildSDJWTPayloadConfig
config
  let selectiveClaimNames :: [Text]
selectiveClaimNames = BuildSDJWTPayloadConfig -> [Text]
buildSelectiveClaimNames BuildSDJWTPayloadConfig
config
  let claims :: Object
claims = BuildSDJWTPayloadConfig -> Object
buildClaims BuildSDJWTPayloadConfig
config
  
  -- Group claims by nesting level (top-level vs nested)
  let ([Text]
topLevelClaims, [[Text]]
nestedPaths) = [Text] -> ([Text], [[Text]])
partitionNestedPaths [Text]
selectiveClaimNames
  
  -- Identify recursive disclosures (Section 6.3)
  let recursiveParents :: Set Text
recursiveParents = [Text] -> [[Text]] -> Set Text
identifyRecursiveParents [Text]
topLevelClaims [[Text]]
nestedPaths
  
  -- Separate recursive disclosures (Section 6.3) from structured disclosures (Section 6.2)
  let ([[Text]]
recursivePaths, [[Text]]
structuredPaths) = Set Text -> [[Text]] -> ([[Text]], [[Text]])
separateRecursiveAndStructuredPaths Set Text
recursiveParents [[Text]]
nestedPaths
  
  -- Process structured nested structures (Section 6.2: structured SD-JWT)
  (Object
structuredPayload, [EncodedDisclosure]
structuredDisclosures, Object
remainingClaimsAfterStructured) <-
    IO (Either SDJWTError (Object, [EncodedDisclosure], Object))
-> ExceptT
     SDJWTError
     IO
     (Either SDJWTError (Object, [EncodedDisclosure], Object))
forall a. IO a -> ExceptT SDJWTError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HashAlgorithm
-> [[Text]]
-> Object
-> IO (Either SDJWTError (Object, [EncodedDisclosure], Object))
processNestedStructures HashAlgorithm
hashAlg [[Text]]
structuredPaths Object
claims) ExceptT
  SDJWTError
  IO
  (Either SDJWTError (Object, [EncodedDisclosure], Object))
-> (Either SDJWTError (Object, [EncodedDisclosure], Object)
    -> ExceptT SDJWTError IO (Object, [EncodedDisclosure], Object))
-> ExceptT SDJWTError IO (Object, [EncodedDisclosure], Object)
forall a b.
ExceptT SDJWTError IO a
-> (a -> ExceptT SDJWTError IO b) -> ExceptT SDJWTError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SDJWTError
 -> ExceptT SDJWTError IO (Object, [EncodedDisclosure], Object))
-> ((Object, [EncodedDisclosure], Object)
    -> ExceptT SDJWTError IO (Object, [EncodedDisclosure], Object))
-> Either SDJWTError (Object, [EncodedDisclosure], Object)
-> ExceptT SDJWTError IO (Object, [EncodedDisclosure], Object)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SDJWTError
-> ExceptT SDJWTError IO (Object, [EncodedDisclosure], Object)
forall a. SDJWTError -> ExceptT SDJWTError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Object, [EncodedDisclosure], Object)
-> ExceptT SDJWTError IO (Object, [EncodedDisclosure], Object)
forall a. a -> ExceptT SDJWTError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  
  -- Process recursive disclosures (Section 6.3)
  ([(Text, Digest, EncodedDisclosure)]
recursiveParentInfo, [EncodedDisclosure]
recursiveDisclosures, Object
remainingClaimsAfterRecursive) <-
    IO
  (Either
     SDJWTError
     ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object))
-> ExceptT
     SDJWTError
     IO
     (Either
        SDJWTError
        ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object))
forall a. IO a -> ExceptT SDJWTError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HashAlgorithm
-> [[Text]]
-> Object
-> IO
     (Either
        SDJWTError
        ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object))
processRecursiveDisclosures HashAlgorithm
hashAlg [[Text]]
recursivePaths Object
remainingClaimsAfterStructured) ExceptT
  SDJWTError
  IO
  (Either
     SDJWTError
     ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object))
-> (Either
      SDJWTError
      ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object)
    -> ExceptT
         SDJWTError
         IO
         ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object))
-> ExceptT
     SDJWTError
     IO
     ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object)
forall a b.
ExceptT SDJWTError IO a
-> (a -> ExceptT SDJWTError IO b) -> ExceptT SDJWTError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SDJWTError
 -> ExceptT
      SDJWTError
      IO
      ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object))
-> (([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure],
     Object)
    -> ExceptT
         SDJWTError
         IO
         ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object))
-> Either
     SDJWTError
     ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object)
-> ExceptT
     SDJWTError
     IO
     ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SDJWTError
-> ExceptT
     SDJWTError
     IO
     ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object)
forall a. SDJWTError -> ExceptT SDJWTError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object)
-> ExceptT
     SDJWTError
     IO
     ([(Text, Digest, EncodedDisclosure)], [EncodedDisclosure], Object)
forall a. a -> ExceptT SDJWTError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  
  -- Process top-level selective claims
  TopLevelClaimsResult
topLevelResult <- TopLevelClaimsConfig -> SDJWTIO TopLevelClaimsResult
processTopLevelSelectiveClaimsExceptT TopLevelClaimsConfig
    { topLevelHashAlg :: HashAlgorithm
topLevelHashAlg = HashAlgorithm
hashAlg
    , topLevelRecursiveParents :: Set Text
topLevelRecursiveParents = Set Text
recursiveParents
    , topLevelClaimNames :: [Text]
topLevelClaimNames = [Text]
topLevelClaims
    , topLevelRemainingClaims :: Object
topLevelRemainingClaims = Object
remainingClaimsAfterRecursive
    }
  
  -- Extract recursive parent digests
  let recursiveParentDigests :: [Digest]
recursiveParentDigests = ((Text, Digest, EncodedDisclosure) -> Digest)
-> [(Text, Digest, EncodedDisclosure)] -> [Digest]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
_, Digest
digest, EncodedDisclosure
_) -> Digest
digest) [(Text, Digest, EncodedDisclosure)]
recursiveParentInfo
  
  -- Combine all disclosures and digests
  let ([EncodedDisclosure]
allDisclosures, [Digest]
allDigests) = [EncodedDisclosure]
-> [EncodedDisclosure]
-> [EncodedDisclosure]
-> [Digest]
-> [Digest]
-> ([EncodedDisclosure], [Digest])
combineAllDisclosuresAndDigests
        [EncodedDisclosure]
structuredDisclosures [EncodedDisclosure]
recursiveDisclosures (TopLevelClaimsResult -> [EncodedDisclosure]
resultDisclosures TopLevelClaimsResult
topLevelResult)
        [Digest]
recursiveParentDigests (TopLevelClaimsResult -> [Digest]
resultDigests TopLevelClaimsResult
topLevelResult)
  
  -- Build final payload
  let payloadObj :: Object
payloadObj = Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
KeyMap.union Object
structuredPayload (TopLevelClaimsResult -> Object
resultRegularClaims TopLevelClaimsResult
topLevelResult)
  let finalPayload :: Object
finalPayload = HashAlgorithm -> Object -> [Digest] -> Object
buildFinalPayloadObject HashAlgorithm
hashAlg Object
payloadObj [Digest]
allDigests
  
  BuildSDJWTPayloadResult -> SDJWTIO BuildSDJWTPayloadResult
forall a. a -> ExceptT SDJWTError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildSDJWTPayloadResult
    { buildPayload :: Value
buildPayload = Object -> Value
Aeson.Object Object
finalPayload
    , buildDisclosures :: [EncodedDisclosure]
buildDisclosures = [EncodedDisclosure]
allDisclosures
    }

buildSDJWTPayload
  :: HashAlgorithm
  -> [T.Text]  -- ^ Claim names to mark as selectively disclosable (supports JSON Pointer syntax for nested paths)
  -> Aeson.Object  -- ^ Original claims object
  -> IO (Either SDJWTError (SDJWTPayload, [EncodedDisclosure]))
buildSDJWTPayload :: HashAlgorithm
-> [Text]
-> Object
-> IO (Either SDJWTError (SDJWTPayload, [EncodedDisclosure]))
buildSDJWTPayload HashAlgorithm
hashAlg [Text]
selectiveClaimNames Object
claims = do
  let config :: BuildSDJWTPayloadConfig
config = BuildSDJWTPayloadConfig
        { buildHashAlg :: HashAlgorithm
buildHashAlg = HashAlgorithm
hashAlg
        , buildSelectiveClaimNames :: [Text]
buildSelectiveClaimNames = [Text]
selectiveClaimNames
        , buildClaims :: Object
buildClaims = Object
claims
        }
  Either SDJWTError BuildSDJWTPayloadResult
result <- SDJWTIO BuildSDJWTPayloadResult
-> IO (Either SDJWTError BuildSDJWTPayloadResult)
forall a. SDJWTIO a -> IO (Either SDJWTError a)
runSDJWTIO (BuildSDJWTPayloadConfig -> SDJWTIO BuildSDJWTPayloadResult
buildSDJWTPayloadExceptT BuildSDJWTPayloadConfig
config)
  case Either SDJWTError BuildSDJWTPayloadResult
result of
    Left SDJWTError
err -> Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
-> IO (Either SDJWTError (SDJWTPayload, [EncodedDisclosure]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
forall a b. a -> Either a b
Left SDJWTError
err)
    Right BuildSDJWTPayloadResult
res -> do
      let payload :: SDJWTPayload
payload = SDJWTPayload
            { sdAlg :: Maybe HashAlgorithm
sdAlg = HashAlgorithm -> Maybe HashAlgorithm
forall a. a -> Maybe a
Just HashAlgorithm
hashAlg
            , payloadValue :: Value
payloadValue = BuildSDJWTPayloadResult -> Value
buildPayload BuildSDJWTPayloadResult
res
            }
      Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
-> IO (Either SDJWTError (SDJWTPayload, [EncodedDisclosure]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SDJWTPayload, [EncodedDisclosure])
-> Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
forall a b. b -> Either a b
Right (SDJWTPayload
payload, BuildSDJWTPayloadResult -> [EncodedDisclosure]
buildDisclosures BuildSDJWTPayloadResult
res))

-- | Create a complete SD-JWT (signed).
--
-- This function creates an SD-JWT and signs it using the issuer's key.
-- Creates a complete SD-JWT with signed JWT using jose.
--
-- Returns the created SD-JWT or an error.
--
-- == Standard JWT Claims
--
-- Standard JWT claims (RFC 7519) can be included in the @claims@ map and will be preserved
-- in the issuer-signed JWT payload. During verification, standard claims like @exp@ and @nbf@
-- are automatically validated if present. See RFC 9901 Section 4.1 for details.
--
-- == Example
--
-- @
-- -- Create SD-JWT without typ header
-- result <- createSDJWT Nothing SHA256 issuerKey ["given_name", "family_name"] claims
--
-- -- Create SD-JWT with typ header
-- result <- createSDJWT (Just "sd-jwt") SHA256 issuerKey ["given_name", "family_name"] claims
--
-- -- Create SD-JWT with expiration time
-- let claimsWithExp = Map.insert "exp" (Aeson.Number (fromIntegral expirationTime)) claims
-- result <- createSDJWT (Just "sd-jwt") SHA256 issuerKey ["given_name"] claimsWithExp
-- @
--
createSDJWT
  :: JWKLike jwk => Maybe T.Text  -- ^ Optional typ header value (RFC 9901 Section 9.11 recommends explicit typing). If @Nothing@, no typ header is added. If @Just "sd-jwt"@ or @Just "example+sd-jwt"@, the typ header is included in the JWT header.
  -> Maybe T.Text  -- ^ Optional kid header value (Key ID for key management). If @Nothing@, no kid header is added.
  -> HashAlgorithm  -- ^ Hash algorithm for digests
  -> jwk  -- ^ Issuer private key JWK (Text or jose JWK object)
  -> [T.Text]  -- ^ Claim names to mark as selectively disclosable
  -> Aeson.Object  -- ^ Original claims object. May include standard JWT claims such as @exp@ (expiration time), @nbf@ (not before), @iss@ (issuer), @sub@ (subject), @iat@ (issued at), etc. These standard claims will be validated during verification if present (see 'SDJWT.Internal.Verification.verifySDJWT').
  -> IO (Either SDJWTError SDJWT)
createSDJWT :: forall jwk.
JWKLike jwk =>
Maybe Text
-> Maybe Text
-> HashAlgorithm
-> jwk
-> [Text]
-> Object
-> IO (Either SDJWTError SDJWT)
createSDJWT Maybe Text
mbTyp Maybe Text
mbKid HashAlgorithm
hashAlg jwk
issuerPrivateKeyJWK [Text]
selectiveClaimNames Object
claims = do
  Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
result <- HashAlgorithm
-> [Text]
-> Object
-> IO (Either SDJWTError (SDJWTPayload, [EncodedDisclosure]))
buildSDJWTPayload HashAlgorithm
hashAlg [Text]
selectiveClaimNames Object
claims
  case Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
result of
    Left SDJWTError
err -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError SDJWT
forall a b. a -> Either a b
Left SDJWTError
err)
    Right (SDJWTPayload
payload, [EncodedDisclosure]
sdDisclosures) -> do
      -- Sign the JWT with optional typ and kid headers
      Either SDJWTError Text
signedJWTResult <- Maybe Text
-> Maybe Text -> jwk -> Value -> IO (Either SDJWTError Text)
forall jwk.
JWKLike jwk =>
Maybe Text
-> Maybe Text -> jwk -> Value -> IO (Either SDJWTError Text)
signJWTWithHeaders Maybe Text
mbTyp Maybe Text
mbKid jwk
issuerPrivateKeyJWK (SDJWTPayload -> Value
payloadValue SDJWTPayload
payload)
      case Either SDJWTError Text
signedJWTResult of
        Left SDJWTError
err -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError SDJWT
forall a b. a -> Either a b
Left SDJWTError
err)
        Right Text
signedJWT -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT))
-> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a b. (a -> b) -> a -> b
$ SDJWT -> Either SDJWTError SDJWT
forall a b. b -> Either a b
Right (SDJWT -> Either SDJWTError SDJWT)
-> SDJWT -> Either SDJWTError SDJWT
forall a b. (a -> b) -> a -> b
$ SDJWT
          { issuerSignedJWT :: Text
issuerSignedJWT = Text
signedJWT
          , disclosures :: [EncodedDisclosure]
disclosures = [EncodedDisclosure]
sdDisclosures
          }

-- | Create an SD-JWT with optional typ header and decoy digests.
--
-- This function is similar to 'createSDJWT' but automatically adds
-- a specified number of decoy digests to the @_sd@ array to obscure the
-- actual number of selectively disclosable claims.
--
-- Returns the created SD-JWT or an error.
--
-- == Standard JWT Claims
--
-- Standard JWT claims (RFC 7519) can be included in the @claims@ map and will be preserved
-- in the issuer-signed JWT payload. During verification, standard claims like @exp@ and @nbf@
-- are automatically validated if present. See RFC 9901 Section 4.1 for details.
--
-- == Example
--
-- @
-- -- Create SD-JWT with 5 decoy digests, no typ header
-- result <- createSDJWTWithDecoys Nothing SHA256 issuerKey ["given_name", "email"] claims 5
--
-- -- Create SD-JWT with 5 decoy digests and typ header
-- result <- createSDJWTWithDecoys (Just "sd-jwt") SHA256 issuerKey ["given_name", "email"] claims 5
-- @
--
createSDJWTWithDecoys
  :: JWKLike jwk => Maybe T.Text  -- ^ Optional typ header value (e.g., Just "sd-jwt" or Just "example+sd-jwt"). If @Nothing@, no typ header is added.
  -> Maybe T.Text  -- ^ Optional kid header value (Key ID for key management). If @Nothing@, no kid header is added.
  -> HashAlgorithm  -- ^ Hash algorithm for digests
  -> jwk  -- ^ Issuer private key JWK (Text or jose JWK object)
  -> [T.Text]  -- ^ Claim names to mark as selectively disclosable
  -> Aeson.Object  -- ^ Original claims object. May include standard JWT claims such as @exp@ (expiration time), @nbf@ (not before), @iss@ (issuer), @sub@ (subject), @iat@ (issued at), etc. These standard claims will be validated during verification if present (see 'SDJWT.Internal.Verification.verifySDJWT').
  -> Int  -- ^ Number of decoy digests to add (must be >= 0)
  -> IO (Either SDJWTError SDJWT)
createSDJWTWithDecoys :: forall jwk.
JWKLike jwk =>
Maybe Text
-> Maybe Text
-> HashAlgorithm
-> jwk
-> [Text]
-> Object
-> Int
-> IO (Either SDJWTError SDJWT)
createSDJWTWithDecoys Maybe Text
mbTyp Maybe Text
mbKid HashAlgorithm
hashAlg jwk
issuerPrivateKeyJWK [Text]
selectiveClaimNames Object
claims Int
decoyCount
  | Int
decoyCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT))
-> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a b. (a -> b) -> a -> b
$ SDJWTError -> Either SDJWTError SDJWT
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError SDJWT)
-> SDJWTError -> Either SDJWTError SDJWT
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidDisclosureFormat Text
"decoyCount must be >= 0"
  | Int
decoyCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe Text
-> Maybe Text
-> HashAlgorithm
-> jwk
-> [Text]
-> Object
-> IO (Either SDJWTError SDJWT)
forall jwk.
JWKLike jwk =>
Maybe Text
-> Maybe Text
-> HashAlgorithm
-> jwk
-> [Text]
-> Object
-> IO (Either SDJWTError SDJWT)
createSDJWT Maybe Text
mbTyp Maybe Text
mbKid HashAlgorithm
hashAlg jwk
issuerPrivateKeyJWK [Text]
selectiveClaimNames Object
claims
  | Bool
otherwise = do
      -- Build the initial payload
      Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
result <- HashAlgorithm
-> [Text]
-> Object
-> IO (Either SDJWTError (SDJWTPayload, [EncodedDisclosure]))
buildSDJWTPayload HashAlgorithm
hashAlg [Text]
selectiveClaimNames Object
claims
      case Either SDJWTError (SDJWTPayload, [EncodedDisclosure])
result of
        Left SDJWTError
err -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError SDJWT
forall a b. a -> Either a b
Left SDJWTError
err)
        Right (SDJWTPayload
payload, [EncodedDisclosure]
sdDisclosures) -> do
          -- Generate decoy digests
          [Digest]
decoys <- Int -> IO Digest -> IO [Digest]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
decoyCount (HashAlgorithm -> IO Digest
addDecoyDigest HashAlgorithm
hashAlg)
          
          -- Add decoy digests to the _sd array
          case SDJWTPayload -> Value
payloadValue SDJWTPayload
payload of
            Aeson.Object Object
obj -> do
              case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
"_sd") Object
obj of
                Just (Aeson.Array Array
sdArray) -> do
                  -- Add decoy digests to the array
                  let decoyDigests :: [Value]
decoyDigests = (Digest -> Value) -> [Digest] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Value
Aeson.String (Text -> Value) -> (Digest -> Text) -> Digest -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest -> Text
unDigest) [Digest]
decoys
                  let updatedSDArray :: Array
updatedSDArray = Array
sdArray Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> [Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
decoyDigests
                  let updatedObj :: Object
updatedObj = Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert (Text -> Key
Key.fromText Text
"_sd") (Array -> Value
Aeson.Array Array
updatedSDArray) Object
obj
                  let updatedPayload :: SDJWTPayload
updatedPayload = SDJWTPayload
payload { payloadValue = Aeson.Object updatedObj }
                  
                  -- Sign the updated payload with optional typ and kid headers
                  Either SDJWTError Text
signedJWTResult <- Maybe Text
-> Maybe Text -> jwk -> Value -> IO (Either SDJWTError Text)
forall jwk.
JWKLike jwk =>
Maybe Text
-> Maybe Text -> jwk -> Value -> IO (Either SDJWTError Text)
signJWTWithHeaders Maybe Text
mbTyp Maybe Text
mbKid jwk
issuerPrivateKeyJWK (SDJWTPayload -> Value
payloadValue SDJWTPayload
updatedPayload)
                  case Either SDJWTError Text
signedJWTResult of
                    Left SDJWTError
err -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTError -> Either SDJWTError SDJWT
forall a b. a -> Either a b
Left SDJWTError
err)
                    Right Text
signedJWT -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT))
-> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a b. (a -> b) -> a -> b
$ SDJWT -> Either SDJWTError SDJWT
forall a b. b -> Either a b
Right (SDJWT -> Either SDJWTError SDJWT)
-> SDJWT -> Either SDJWTError SDJWT
forall a b. (a -> b) -> a -> b
$ SDJWT
                      { issuerSignedJWT :: Text
issuerSignedJWT = Text
signedJWT
                      , disclosures :: [EncodedDisclosure]
disclosures = [EncodedDisclosure]
sdDisclosures
                      }
                Maybe Value
_ -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT))
-> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a b. (a -> b) -> a -> b
$ SDJWTError -> Either SDJWTError SDJWT
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError SDJWT)
-> SDJWTError -> Either SDJWTError SDJWT
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidDisclosureFormat Text
"Payload does not contain _sd array"
            Value
_ -> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT))
-> Either SDJWTError SDJWT -> IO (Either SDJWTError SDJWT)
forall a b. (a -> b) -> a -> b
$ SDJWTError -> Either SDJWTError SDJWT
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError SDJWT)
-> SDJWTError -> Either SDJWTError SDJWT
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidDisclosureFormat Text
"Payload is not an object"

-- | Add holder's public key to claims as a @cnf@ claim (RFC 7800).
--
-- This convenience function adds the holder's public key to the claims map
-- in the format required by RFC 7800 for key confirmation:
--
-- @
-- {
--   "cnf": {
--     "jwk": "<holderPublicKeyJWK>"
--   }
-- }
-- @
--
-- The @cnf@ claim is used during key binding to prove that the holder
-- possesses the corresponding private key.
--
-- == Example
--
-- @
-- let holderPublicKeyJWK = "{\"kty\":\"EC\",\"crv\":\"P-256\",\"x\":\"...\",\"y\":\"...\"}"
-- let claimsWithCnf = addHolderKeyToClaims holderPublicKeyJWK claims
-- result <- createSDJWT (Just "sd-jwt") SHA256 issuerKey ["given_name"] claimsWithCnf
-- @
--
-- == See Also
--
-- * RFC 7800: Proof-of-Possession Key Semantics for JSON Web Tokens (JWT)
-- * RFC 9901 Section 4.3: Key Binding
addHolderKeyToClaims
  :: T.Text  -- ^ Holder's public key as a JWK JSON string
  -> Aeson.Object  -- ^ Original claims object
  -> Aeson.Object  -- ^ Claims object with @cnf@ claim added
addHolderKeyToClaims :: Text -> Object -> Object
addHolderKeyToClaims Text
holderPublicKeyJWK Object
claims =
  let
    -- Parse the JWK JSON string to ensure it's valid JSON
    -- We'll store it as a JSON object value
    jwkValue :: Value
jwkValue = case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict (Text -> ByteString
TE.encodeUtf8 Text
holderPublicKeyJWK) :: Either String Aeson.Value of
      Left String
_ -> Text -> Value
Aeson.String Text
holderPublicKeyJWK  -- If parsing fails, store as string (let verification catch errors)
      Right Value
parsedJWK -> Value
parsedJWK  -- Store as parsed JSON value
    cnfValue :: Value
cnfValue = Object -> Value
Aeson.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key
"jwk", Value
jwkValue)]
  in
    Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"cnf" Value
cnfValue Object
claims

-- | Generate a decoy digest.
--
-- Decoy digests are random digests that don't correspond to any disclosure.
-- They are used to obscure the actual number of selectively disclosable claims.
--
-- According to RFC 9901 Section 4.2.5, decoy digests should be created by
-- hashing over a cryptographically secure random number, then base64url encoding.
--
-- == Advanced Use
--
-- Decoy digests are an advanced feature used to hide the number of selectively
-- disclosable claims. They are optional and must be manually added to the _sd array
-- if you want to obscure the actual number of selectively disclosable claims.
--
-- To use decoy digests, call this function to generate them and manually add
-- them to the _sd array in your payload. This is useful for privacy-preserving
-- applications where you want to hide how many claims are selectively disclosable.
--
addDecoyDigest
  :: HashAlgorithm
  -> IO Digest
addDecoyDigest :: HashAlgorithm -> IO Digest
addDecoyDigest HashAlgorithm
hashAlg =
  -- Generate random bytes for the decoy digest
  -- According to RFC 9901, we hash over a cryptographically secure random number
  -- The size doesn't matter much since we're hashing it anyway
  (ByteString -> Digest) -> IO ByteString -> IO Digest
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ByteString
randomBytes ->
    -- Hash the random bytes using the specified algorithm
    let hashBytes :: ByteString
hashBytes = HashAlgorithm -> ByteString -> ByteString
hashToBytes HashAlgorithm
hashAlg ByteString
randomBytes
        -- Base64url encode to create the digest
        digestText :: Text
digestText = ByteString -> Text
base64urlEncode ByteString
hashBytes
    in Text -> Digest
Digest Text
digestText
  ) IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
generateSalt

-- | Sort digests for deterministic ordering in _sd array.
sortDigests :: [Digest] -> [Digest]
sortDigests :: [Digest] -> [Digest]
sortDigests = (Digest -> Digest -> Ordering) -> [Digest] -> [Digest]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Digest -> Text) -> Digest -> Digest -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Digest -> Text
unDigest)

-- | Identify which nested paths are recursive disclosures (Section 6.3).
--
-- A path is recursive if its first segment is also in topLevelClaims.
-- This means the parent claim is itself selectively disclosable.
identifyRecursiveParents :: [T.Text] -> [[T.Text]] -> Set.Set T.Text
identifyRecursiveParents :: [Text] -> [[Text]] -> Set Text
identifyRecursiveParents [Text]
topLevelClaims [[Text]]
nestedPaths =
  let getFirstSegment :: [a] -> a
getFirstSegment [] = a
""
      getFirstSegment (a
seg:[a]
_) = a
seg
  in [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Text] -> Text
forall {a}. IsString a => [a] -> a
getFirstSegment [[Text]]
nestedPaths) Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
topLevelClaims

-- | Separate recursive disclosures (Section 6.3) from structured disclosures (Section 6.2).
separateRecursiveAndStructuredPaths
  :: Set.Set T.Text  -- ^ Recursive parent claim names
  -> [[T.Text]]  -- ^ All nested paths
  -> ([[T.Text]], [[T.Text]])  -- ^ (recursive paths, structured paths)
separateRecursiveAndStructuredPaths :: Set Text -> [[Text]] -> ([[Text]], [[Text]])
separateRecursiveAndStructuredPaths Set Text
recursiveParents [[Text]]
nestedPaths =
  ([Text] -> Bool) -> [[Text]] -> ([[Text]], [[Text]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[Text]
path -> case [Text]
path of
    [] -> Bool
False
    (Text
first:[Text]
_) -> Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
first Set Text
recursiveParents) [[Text]]
nestedPaths

-- | Process top-level selectively disclosable claims (using ExceptT).
--
-- Creates disclosures and digests for top-level claims that are not recursive parents.
-- This version uses ExceptT for cleaner error handling.
processTopLevelSelectiveClaimsExceptT
  :: TopLevelClaimsConfig
  -> SDJWTIO TopLevelClaimsResult
processTopLevelSelectiveClaimsExceptT :: TopLevelClaimsConfig -> SDJWTIO TopLevelClaimsResult
processTopLevelSelectiveClaimsExceptT TopLevelClaimsConfig
config = do
  let topLevelClaimsWithoutRecursive :: [Text]
topLevelClaimsWithoutRecursive = (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` TopLevelClaimsConfig -> Set Text
topLevelRecursiveParents TopLevelClaimsConfig
config) (TopLevelClaimsConfig -> [Text]
topLevelClaimNames TopLevelClaimsConfig
config)
  let selectiveClaims :: Object
selectiveClaims = (Key -> Value -> Bool) -> Object -> Object
forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filterWithKey
        (\Key
k Value
_ -> Key -> Text
Key.toText Key
k Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
topLevelClaimsWithoutRecursive) (TopLevelClaimsConfig -> Object
topLevelRemainingClaims TopLevelClaimsConfig
config)
  let regularClaims :: Object
regularClaims = (Key -> Value -> Bool) -> Object -> Object
forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filterWithKey
        (\Key
k Value
_ -> Key -> Text
Key.toText Key
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
topLevelClaimsWithoutRecursive) (TopLevelClaimsConfig -> Object
topLevelRemainingClaims TopLevelClaimsConfig
config)
  
  -- Create disclosures and digests for top-level selective claims
  -- According to RFC 9901, top-level arrays are treated as object properties
  -- (disclosure format: [salt, claim_name, claim_value])
  [Either SDJWTError (Digest, EncodedDisclosure)]
disclosureResults <- IO [Either SDJWTError (Digest, EncodedDisclosure)]
-> ExceptT
     SDJWTError IO [Either SDJWTError (Digest, EncodedDisclosure)]
forall a. IO a -> ExceptT SDJWTError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either SDJWTError (Digest, EncodedDisclosure)]
 -> ExceptT
      SDJWTError IO [Either SDJWTError (Digest, EncodedDisclosure)])
-> IO [Either SDJWTError (Digest, EncodedDisclosure)]
-> ExceptT
     SDJWTError IO [Either SDJWTError (Digest, EncodedDisclosure)]
forall a b. (a -> b) -> a -> b
$ ((Key, Value)
 -> IO (Either SDJWTError (Digest, EncodedDisclosure)))
-> [(Key, Value)]
-> IO [Either SDJWTError (Digest, EncodedDisclosure)]
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
k, Value
v) -> HashAlgorithm
-> Text
-> Value
-> IO (Either SDJWTError (Digest, EncodedDisclosure))
markSelectivelyDisclosable (TopLevelClaimsConfig -> HashAlgorithm
topLevelHashAlg TopLevelClaimsConfig
config) (Key -> Text
Key.toText Key
k) Value
v) (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
selectiveClaims)
  
  -- Check for errors using ExceptT helper
  [Either SDJWTError (Digest, EncodedDisclosure)]
-> ([(Digest, EncodedDisclosure)] -> SDJWTIO TopLevelClaimsResult)
-> SDJWTIO TopLevelClaimsResult
forall (m :: * -> *) a b.
Monad m =>
[Either SDJWTError a]
-> ([a] -> ExceptT SDJWTError m b) -> ExceptT SDJWTError m b
partitionAndHandle [Either SDJWTError (Digest, EncodedDisclosure)]
disclosureResults (([(Digest, EncodedDisclosure)] -> SDJWTIO TopLevelClaimsResult)
 -> SDJWTIO TopLevelClaimsResult)
-> ([(Digest, EncodedDisclosure)] -> SDJWTIO TopLevelClaimsResult)
-> SDJWTIO TopLevelClaimsResult
forall a b. (a -> b) -> a -> b
$ \[(Digest, EncodedDisclosure)]
successes -> do
    let ([Digest]
topLevelDigests, [EncodedDisclosure]
topLevelDisclosures) = [(Digest, EncodedDisclosure)] -> ([Digest], [EncodedDisclosure])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Digest, EncodedDisclosure)]
successes
    TopLevelClaimsResult -> SDJWTIO TopLevelClaimsResult
forall a. a -> ExceptT SDJWTError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TopLevelClaimsResult
      { resultDigests :: [Digest]
resultDigests = [Digest]
topLevelDigests
      , resultDisclosures :: [EncodedDisclosure]
resultDisclosures = [EncodedDisclosure]
topLevelDisclosures
      , resultRegularClaims :: Object
resultRegularClaims = Object
regularClaims
      }

-- | Combine all disclosures and digests from structured, recursive, and top-level processing.
combineAllDisclosuresAndDigests
  :: [EncodedDisclosure]  -- ^ Structured disclosures
  -> [EncodedDisclosure]  -- ^ Recursive disclosures
  -> [EncodedDisclosure]  -- ^ Top-level disclosures
  -> [Digest]  -- ^ Recursive parent digests
  -> [Digest]  -- ^ Top-level digests
  -> ([EncodedDisclosure], [Digest])
combineAllDisclosuresAndDigests :: [EncodedDisclosure]
-> [EncodedDisclosure]
-> [EncodedDisclosure]
-> [Digest]
-> [Digest]
-> ([EncodedDisclosure], [Digest])
combineAllDisclosuresAndDigests [EncodedDisclosure]
structuredDisclosures [EncodedDisclosure]
recursiveDisclosures [EncodedDisclosure]
topLevelDisclosures [Digest]
recursiveParentDigests [Digest]
topLevelDigests =
  let allDisclosures :: [EncodedDisclosure]
allDisclosures = [EncodedDisclosure]
structuredDisclosures [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
recursiveDisclosures [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
topLevelDisclosures
      allDigests :: [Digest]
allDigests = [Digest]
recursiveParentDigests [Digest] -> [Digest] -> [Digest]
forall a. [a] -> [a] -> [a]
++ [Digest]
topLevelDigests
  in ([EncodedDisclosure]
allDisclosures, [Digest]
allDigests)

-- | Build the final payload object with _sd_alg and _sd array.
buildFinalPayloadObject
  :: HashAlgorithm
  -> Aeson.Object  -- ^ Base payload (regular claims + structured nested structures)
  -> [Digest]  -- ^ All digests to include in _sd array
  -> Aeson.Object
buildFinalPayloadObject :: HashAlgorithm -> Object -> [Digest] -> Object
buildFinalPayloadObject HashAlgorithm
hashAlg Object
basePayload [Digest]
allDigests =
  let payloadWithAlg :: Object
payloadWithAlg = Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"_sd_alg" (Text -> Value
Aeson.String (HashAlgorithm -> Text
hashAlgorithmToText HashAlgorithm
hashAlg)) Object
basePayload
  in if [Digest] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Digest]
allDigests
       then Object
payloadWithAlg
       else let sortedDigests :: [Value]
sortedDigests = (Digest -> Value) -> [Digest] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Value
Aeson.String (Text -> Value) -> (Digest -> Text) -> Digest -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest -> Text
unDigest) ([Digest] -> [Digest]
sortDigests [Digest]
allDigests)
            in Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"_sd" (Array -> Value
Aeson.Array ([Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
sortedDigests)) Object
payloadWithAlg

-- | Partition claim names into top-level and nested paths.
--
-- Nested paths use JSON Pointer syntax (RFC 6901) with forward slash as separator.
-- Examples:
--   - "address/street_address" → nested path: ["address", "street_address"]
--   - "nationalities/1" → nested path: ["nationalities", "1"] (could be array index OR object key "1")
--   - "user/profile/email" → nested path: ["user", "profile", "email"]
--   - "nested_array/0/1" → nested path: ["nested_array", "0", "1"]
--
-- Note: The path "x/22" is ambiguous - it could refer to:
--   - Array element at index 22 if "x" is an array
--   - Object property "22" if "x" is an object
-- The actual type is determined when processing the claims (see buildSDJWTPayload).
--
-- Escaping (RFC 6901):
--   - "~1" represents a literal forward slash "/"
--   - "~0" represents a literal tilde "~"
-- Examples:
--   - "contact~1email" → literal key "contact/email" (not a nested path)
--   - "user~0name" → literal key "user~name" (not a nested path)
--
-- Returns: (top-level claims, nested paths as list of segments)
partitionNestedPaths :: [T.Text] -> ([T.Text], [[T.Text]])
partitionNestedPaths :: [Text] -> ([Text], [[Text]])
partitionNestedPaths [Text]
claimNames =
  let ([Text]
topLevel, [Text]
nested) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
T.isInfixOf Text
"/") [Text]
claimNames
      nestedPaths :: [[Text]]
nestedPaths = (Text -> Maybe [Text]) -> [Text] -> [[Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe [Text]
parseJSONPointerPath [Text]
nested
      -- Unescape top-level claim names (they may contain ~0 or ~1)
      unescapedTopLevel :: [Text]
unescapedTopLevel = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
unescapeJSONPointer [Text]
topLevel
  in ([Text]
unescapedTopLevel, [[Text]]
nestedPaths)
  where
    -- Parse a JSON Pointer path, handling escaping
    -- Returns Nothing if invalid, Just [segments] if valid nested path
    -- Supports arbitrary depth: ["a"], ["a", "b"], ["a", "b", "c"], etc.
    parseJSONPointerPath :: T.Text -> Maybe [T.Text]
    parseJSONPointerPath :: Text -> Maybe [Text]
parseJSONPointerPath Text
path = do
      -- Split by "/" but handle escaped slashes
      let segments :: [Text]
segments = Text -> [Text]
splitJSONPointer Text
path
      case [Text]
segments of
        [] -> Maybe [Text]
forall a. Maybe a
Nothing  -- Empty path is invalid
        [Text
_] -> Maybe [Text]
forall a. Maybe a
Nothing  -- Single segment is top-level, not nested
        [Text]
_ -> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
unescapeJSONPointer [Text]
segments)  -- Two or more segments = nested path