{-# LANGUAGE OverloadedStrings #-} -- | Helper functions for running interoperability test cases. -- -- This module provides functions to convert test case formats to the public API format. module TestCaseRunner ( extractDisclosurePaths , convertClaimsToObject , identifySelectivelyDisclosableClaims , compareClaims ) where 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 Data.Maybe (mapMaybe) import Data.List (nub) -- | Convert holder_disclosed_claims (boolean format) to JSON Pointer paths. -- -- Examples: -- {"given_name": true} → ["given_name"] -- {"data_types": [True, False, True]} → ["data_types/0", "data_types/2"] -- {"nested_array": [[True, False], [False, True]]} → ["nested_array/0/0", "nested_array/1/1"] extractDisclosurePaths :: Map.Map T.Text Aeson.Value -> [T.Text] extractDisclosurePaths holderDisclosed = concatMap (\(name, value) -> extractPathsForClaim name value) (Map.toList holderDisclosed) where extractPathsForClaim :: T.Text -> Aeson.Value -> [T.Text] extractPathsForClaim claimName (Aeson.Bool True) = [claimName] extractPathsForClaim _ (Aeson.Bool False) = [] extractPathsForClaim claimName (Aeson.Array arr) = concatMap (\(idx, val) -> extractPathsForArrayElement claimName idx val) (zip [0..] (V.toList arr)) extractPathsForClaim claimName (Aeson.Object obj) = -- For objects, if the value is true-like, include the claim itself -- Otherwise, recurse into nested structure if KeyMap.null obj then [] else concatMap (\(k, v) -> extractPathsForClaim (claimName <> "/" <> Key.toText k) v) (KeyMap.toList obj) extractPathsForClaim _ _ = [] extractPathsForArrayElement :: T.Text -> Int -> Aeson.Value -> [T.Text] extractPathsForArrayElement claimName idx (Aeson.Bool True) = [claimName <> "/" <> T.pack (show idx)] extractPathsForArrayElement _ _ (Aeson.Bool False) = [] extractPathsForArrayElement claimName idx (Aeson.Array arr) = concatMap (\(innerIdx, val) -> extractPathsForArrayElement (claimName <> "/" <> T.pack (show idx)) innerIdx val) (zip [0 :: Int ..] (V.toList arr)) extractPathsForArrayElement claimName idx (Aeson.Object obj) = -- Nested object in array concatMap (\(k, v) -> extractPathsForClaim (claimName <> "/" <> T.pack (show idx) <> "/" <> Key.toText k) v) (KeyMap.toList obj) extractPathsForArrayElement _ _ _ = [] -- | Convert Map Text Value to Aeson.Object. convertClaimsToObject :: Map.Map T.Text Aeson.Value -> Aeson.Object convertClaimsToObject claims = KeyMap.fromList $ map (\(k, v) -> (Key.fromText k, v)) (Map.toList claims) -- | Compare verified claims with expected claims. -- -- This function does a deep comparison, checking that the expected claims match -- the verified claims. It handles nested objects and arrays correctly. -- Only checks that expected claims are present and match - extra claims in verified are ignored. compareClaims :: Aeson.Object -> Aeson.Object -> Either String () compareClaims verified expected = -- Check that all expected keys are present and match let expectedKeys = KeyMap.keys expected missingKeys = filter (\k -> not (KeyMap.member k verified)) expectedKeys in case missingKeys of (_:_) -> Left $ "Missing expected keys: " ++ show (map Key.toText missingKeys) [] -> -- Check each expected key matches let mismatches = mapMaybe (\k -> case (KeyMap.lookup k verified, KeyMap.lookup k expected) of (Just vVal, Just eVal) -> if compareValues vVal eVal then Nothing else Just (Key.toText k, vVal, eVal) _ -> Just (Key.toText k, Aeson.Null, Aeson.Null) ) expectedKeys in case mismatches of [] -> Right () ((keyName, vVal, eVal):_) -> Left $ "Mismatch at key " ++ T.unpack keyName ++ ": expected " ++ show eVal ++ ", got " ++ show vVal where compareValues :: Aeson.Value -> Aeson.Value -> Bool compareValues (Aeson.Object vObj) (Aeson.Object eObj) = case compareClaims vObj eObj of Right () -> True Left _ -> False compareValues (Aeson.Array vArr) (Aeson.Array eArr) = -- For arrays, we need to compare element by element -- But arrays might have different ordering, so we compare lengths and elements V.length vArr == V.length eArr && all (uncurry compareValues) (zip (V.toList vArr) (V.toList eArr)) compareValues v e = v == e -- | Identify which claims are selectively disclosable. -- -- Strategy: -- 1. If holder_disclosed_claims is not empty, use it to identify selectively disclosable claims -- (claims that appear in holder_disclosed_claims were marked with !sd) -- 2. If holder_disclosed_claims is empty, infer from comparing user_claims with expect_verified_user_claims -- (claims that appear in user_claims but not in expect_verified_user_claims were selectively disclosable) -- -- Examples: -- {"given_name": true} → ["given_name"] -- {"nationalities": [False, True]} → ["nationalities/0", "nationalities/1"] (both were !sd, only 1 is disclosed) identifySelectivelyDisclosableClaims :: Map.Map T.Text Aeson.Value -> Map.Map T.Text Aeson.Value -> Map.Map T.Text Aeson.Value -> [T.Text] identifySelectivelyDisclosableClaims userClaims holderDisclosed expectedVerified = if Map.null holderDisclosed then inferFromComparison userClaims expectedVerified else extractAllPaths holderDisclosed where extractAllPaths :: Map.Map T.Text Aeson.Value -> [T.Text] extractAllPaths m = concatMap (\(name, value) -> extractPaths name value) (Map.toList m) extractPaths :: T.Text -> Aeson.Value -> [T.Text] extractPaths claimName (Aeson.Bool _) = [claimName] -- Both True and False mean !sd was present extractPaths claimName (Aeson.Array arr) = concatMap (\(idx, val) -> extractArrayPaths claimName idx val) (zip [0..] (V.toList arr)) extractPaths claimName (Aeson.Object obj) = concatMap (\(k, v) -> extractPaths (claimName <> "/" <> Key.toText k) v) (KeyMap.toList obj) extractPaths _ _ = [] extractArrayPaths :: T.Text -> Int -> Aeson.Value -> [T.Text] extractArrayPaths claimName idx (Aeson.Bool _) = [claimName <> "/" <> T.pack (show idx)] extractArrayPaths claimName idx (Aeson.Array arr) = concatMap (\(innerIdx, val) -> extractArrayPaths (claimName <> "/" <> T.pack (show idx)) innerIdx val) (zip [0..] (V.toList arr)) extractArrayPaths claimName idx (Aeson.Object obj) = concatMap (\(k, v) -> extractPaths (claimName <> "/" <> T.pack (show idx) <> "/" <> Key.toText k) v) (KeyMap.toList obj) extractArrayPaths _ _ _ = [] -- Infer selectively disclosable claims by comparing user_claims with expect_verified_user_claims inferFromComparison :: Map.Map T.Text Aeson.Value -> Map.Map T.Text Aeson.Value -> [T.Text] inferFromComparison user expected = -- Compare each top-level claim concatMap (\(name, userVal) -> case Map.lookup name expected of Just expectedVal -> inferPathsForValue name userVal expectedVal Nothing -> [name] -- Claim not in expected, so it's selectively disclosable ) (Map.toList user) -- Infer selectively disclosable paths by comparing two values inferPathsForValue :: T.Text -> Aeson.Value -> Aeson.Value -> [T.Text] inferPathsForValue claimName (Aeson.Array userArr) (Aeson.Array expectedArr) = -- Compare arrays element by element let userList = V.toList userArr expectedList = V.toList expectedArr userLen = length userList expectedLen = length expectedList -- If arrays have different lengths, mark extra indices as selectively disclosable -- Also mark indices where values differ selectiveIndices = -- Indices beyond expected length are selectively disclosable (if user is longer) (if userLen > expectedLen then [expectedLen .. userLen - 1] else []) ++ -- Indices where values differ (up to expected length) mapMaybe (\(idx, uVal, eVal) -> if idx < expectedLen && not (compareValuesForInference uVal eVal) then Just idx else Nothing ) (zip3 [0..] userList expectedList) -- For each selectively disclosable index, recursively check its contents basePaths = map (\idx -> claimName <> "/" <> T.pack (show idx)) (nub selectiveIndices) -- Recursively infer paths for selectively disclosable elements recursivePaths = concatMap (\(idx, uVal) -> if idx `elem` selectiveIndices then case (uVal, if idx < expectedLen then Just (expectedList !! idx) else Nothing) of (Aeson.Array _, Just (Aeson.Array eArr)) -> -- Recursively check nested array inferPathsForValue (claimName <> "/" <> T.pack (show idx)) uVal (Aeson.Array eArr) (Aeson.Object _, Just (Aeson.Object eObj)) -> -- Recursively check nested object inferPathsForValue (claimName <> "/" <> T.pack (show idx)) uVal (Aeson.Object eObj) (Aeson.Object _, Just (Aeson.Array _)) -> -- Object element was replaced with empty array, recursively mark all its contents as selectively disclosable extractAllPathsFromValue (claimName <> "/" <> T.pack (show idx)) uVal (Aeson.Array _, Nothing) -> -- Array element was removed, recursively mark all its contents as selectively disclosable extractAllPathsFromValue (claimName <> "/" <> T.pack (show idx)) uVal (Aeson.Object _, Nothing) -> -- Object element was removed, recursively mark all its contents as selectively disclosable extractAllPathsFromValue (claimName <> "/" <> T.pack (show idx)) uVal _ -> [] else [] ) (zip [0..] userList) in basePaths ++ recursivePaths inferPathsForValue claimName (Aeson.Object userObj) (Aeson.Object expectedObj) = -- Compare objects property by property let userKeys = KeyMap.keys userObj selectiveKeys = filter (\k -> case (KeyMap.lookup k userObj, KeyMap.lookup k expectedObj) of (Just uVal, Just eVal) -> not (compareValuesForInference uVal eVal) (Just _, Nothing) -> True -- In user but not expected _ -> False ) userKeys basePaths = map (\k -> claimName <> "/" <> Key.toText k) selectiveKeys -- Recursively infer paths for selectively disclosable properties recursivePaths = concatMap (\k -> case (KeyMap.lookup k userObj, KeyMap.lookup k expectedObj) of (Just uVal, Just eVal) -> if k `elem` selectiveKeys then inferPathsForValue (claimName <> "/" <> Key.toText k) uVal eVal else [] (Just uVal, Nothing) -> -- Property was removed, recursively mark all its contents extractAllPathsFromValue (claimName <> "/" <> Key.toText k) uVal _ -> [] ) userKeys in basePaths ++ recursivePaths inferPathsForValue claimName userVal expectedVal = -- Primitive values: if different, the claim is selectively disclosable if userVal == expectedVal then [] else [claimName] -- Compare values for inference (simplified comparison) compareValuesForInference :: Aeson.Value -> Aeson.Value -> Bool compareValuesForInference (Aeson.Array uArr) (Aeson.Array eArr) = V.length uArr == V.length eArr compareValuesForInference (Aeson.Object uObj) (Aeson.Object eObj) = KeyMap.size uObj == KeyMap.size eObj compareValuesForInference u e = u == e -- Extract all paths from a value (for when an element is completely removed) extractAllPathsFromValue :: T.Text -> Aeson.Value -> [T.Text] extractAllPathsFromValue basePath (Aeson.Array arr) = -- Mark the array itself and all its elements basePath : concatMap (\(idx, val) -> extractAllPathsFromValue (basePath <> "/" <> T.pack (show (idx :: Int))) val ) (zip [0..] (V.toList arr)) extractAllPathsFromValue basePath (Aeson.Object obj) = -- Mark the object itself and all its properties basePath : concatMap (\(k, val) -> extractAllPathsFromValue (basePath <> "/" <> Key.toText k) val ) (KeyMap.toList obj) extractAllPathsFromValue basePath _ = [basePath] -- Primitive value