{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module SDJWT.Internal.Presentation
( createPresentation
, selectDisclosures
, selectDisclosuresByNames
, addKeyBinding
) where
import SDJWT.Internal.Types (HashAlgorithm(..), Digest(..), SDJWT(..), SDJWTPayload(..), SDJWTPresentation(..), SDJWTError(..), EncodedDisclosure(..), Disclosure(..))
import SDJWT.Internal.Disclosure (decodeDisclosure, getDisclosureClaimName, getDisclosureValue)
import SDJWT.Internal.Digest (extractDigestsFromValue, computeDigest, computeDigestText, extractDigestStringsFromSDArray, defaultHashAlgorithm)
import SDJWT.Internal.Utils (splitJSONPointer, unescapeJSONPointer, groupPathsByFirstSegment)
import SDJWT.Internal.KeyBinding (addKeyBindingToPresentation)
import SDJWT.Internal.JWT (JWKLike)
import SDJWT.Internal.Verification (parsePayloadFromJWT, extractDigestsFromPayload)
import qualified Data.Text as T
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Aeson.Key as Key
import qualified Data.Vector as V
import Data.Int (Int64)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.List (partition, find, nubBy)
import Data.Either (partitionEithers)
import Text.Read (readMaybe)
createPresentation
:: SDJWT
-> [EncodedDisclosure]
-> SDJWTPresentation
createPresentation :: SDJWT -> [EncodedDisclosure] -> SDJWTPresentation
createPresentation (SDJWT Text
jwt [EncodedDisclosure]
_) [EncodedDisclosure]
selectedDisclos =
SDJWTPresentation
{ presentationJWT :: Text
presentationJWT = Text
jwt
, selectedDisclosures :: [EncodedDisclosure]
selectedDisclosures = [EncodedDisclosure]
selectedDisclos
, keyBindingJWT :: Maybe Text
keyBindingJWT = Maybe Text
forall a. Maybe a
Nothing
}
selectDisclosuresByNames
:: SDJWT
-> [T.Text]
-> Either SDJWTError SDJWTPresentation
selectDisclosuresByNames :: SDJWT -> [Text] -> Either SDJWTError SDJWTPresentation
selectDisclosuresByNames sdjwt :: SDJWT
sdjwt@(SDJWT Text
issuerJWT [EncodedDisclosure]
allDisclosures) [Text]
claimNames = do
HashAlgorithm
hashAlg <- Text -> Either SDJWTError HashAlgorithm
extractHashAlgorithmFromJWT Text
issuerJWT
[Disclosure]
decodedDisclosures <- (EncodedDisclosure -> Either SDJWTError Disclosure)
-> [EncodedDisclosure] -> Either SDJWTError [Disclosure]
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 -> Either SDJWTError Disclosure
decodeDisclosure [EncodedDisclosure]
allDisclosures
let ([Text]
topLevelNames, [[Text]]
nestedPaths) = [Text] -> ([Text], [[Text]])
partitionNestedPaths [Text]
claimNames
SDJWTPayload
sdPayload <- Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT Text
issuerJWT
let payloadValueObj :: Value
payloadValueObj = SDJWTPayload -> Value
payloadValue SDJWTPayload
sdPayload
[EncodedDisclosure]
selectedDisclos <- HashAlgorithm
-> [Text]
-> [[Text]]
-> Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresRecursively HashAlgorithm
hashAlg [Text]
topLevelNames [[Text]]
nestedPaths Value
payloadValueObj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
let shouldRecurse :: Bool
shouldRecurse = Bool -> Bool
not ([[Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
nestedPaths)
[EncodedDisclosure]
arrayElementDisclos <- HashAlgorithm
-> [Text]
-> Text
-> [EncodedDisclosure]
-> [Disclosure]
-> Bool
-> Either SDJWTError [EncodedDisclosure]
collectArrayElementDisclosures HashAlgorithm
hashAlg [Text]
topLevelNames Text
issuerJWT [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures Bool
shouldRecurse
let allSelectedDisclosRaw :: [EncodedDisclosure]
allSelectedDisclosRaw = [EncodedDisclosure]
selectedDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
arrayElementDisclos
allSelectedDisclos :: [EncodedDisclosure]
allSelectedDisclos = (EncodedDisclosure -> EncodedDisclosure -> Bool)
-> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\EncodedDisclosure
enc1 EncodedDisclosure
enc2 -> HashAlgorithm -> EncodedDisclosure -> Digest
computeDigest HashAlgorithm
hashAlg EncodedDisclosure
enc1 Digest -> Digest -> Bool
forall a. Eq a => a -> a -> Bool
== HashAlgorithm -> EncodedDisclosure -> Digest
computeDigest HashAlgorithm
hashAlg EncodedDisclosure
enc2) [EncodedDisclosure]
allSelectedDisclosRaw
HashAlgorithm
-> [EncodedDisclosure] -> Text -> Either SDJWTError ()
validateDisclosureDependencies HashAlgorithm
hashAlg [EncodedDisclosure]
allSelectedDisclos Text
issuerJWT
SDJWTPresentation -> Either SDJWTError SDJWTPresentation
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTPresentation -> Either SDJWTError SDJWTPresentation)
-> SDJWTPresentation -> Either SDJWTError SDJWTPresentation
forall a b. (a -> b) -> a -> b
$ SDJWT -> [EncodedDisclosure] -> SDJWTPresentation
createPresentation SDJWT
sdjwt [EncodedDisclosure]
allSelectedDisclos
collectDisclosuresRecursively
:: HashAlgorithm
-> [T.Text]
-> [[T.Text]]
-> Aeson.Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresRecursively :: HashAlgorithm
-> [Text]
-> [[Text]]
-> Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresRecursively HashAlgorithm
hashAlg [Text]
topLevelNames [[Text]]
nestedPaths Value
value [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures = do
case Value
value of
Aeson.Object Object
obj -> HashAlgorithm
-> [Text]
-> [[Text]]
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectFromObject HashAlgorithm
hashAlg [Text]
topLevelNames [[Text]]
nestedPaths Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
Aeson.Array Array
arr -> HashAlgorithm
-> [Text]
-> [[Text]]
-> Array
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectFromArray HashAlgorithm
hashAlg [Text]
topLevelNames [[Text]]
nestedPaths Array
arr [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
Value
_ -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
collectTopLevelDisclosures
:: HashAlgorithm
-> [T.Text]
-> KeyMap.KeyMap Aeson.Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectTopLevelDisclosures :: HashAlgorithm
-> [Text]
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectTopLevelDisclosures HashAlgorithm
hashAlg [Text]
topLevelNames Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures =
if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
topLevelNames
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
let rootDigests :: [Text]
rootDigests = Object -> [Text]
extractDigestStringsFromSDArray Object
obj
if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rootDigests
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
let matchingDisclos :: [EncodedDisclosure]
matchingDisclos = ((EncodedDisclosure, Disclosure) -> Maybe EncodedDisclosure)
-> [(EncodedDisclosure, Disclosure)] -> [EncodedDisclosure]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(EncodedDisclosure
encDisclosure, Disclosure
decoded) ->
let digestText :: Text
digestText = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure
in do
Text
claimName <- Disclosure -> Maybe Text
getDisclosureClaimName Disclosure
decoded
if Text
digestText Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
rootDigests Bool -> Bool -> Bool
&& Text
claimName Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
topLevelNames
then EncodedDisclosure -> Maybe EncodedDisclosure
forall a. a -> Maybe a
Just EncodedDisclosure
encDisclosure
else Maybe EncodedDisclosure
forall a. Maybe a
Nothing
) ([(EncodedDisclosure, Disclosure)] -> [EncodedDisclosure])
-> [(EncodedDisclosure, Disclosure)] -> [EncodedDisclosure]
forall a b. (a -> b) -> a -> b
$ [EncodedDisclosure]
-> [Disclosure] -> [(EncodedDisclosure, Disclosure)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [EncodedDisclosure]
matchingDisclos
findDisclosureForClaim
:: HashAlgorithm
-> T.Text
-> KeyMap.KeyMap Aeson.Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Maybe (EncodedDisclosure, Disclosure)
findDisclosureForClaim :: HashAlgorithm
-> Text
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Maybe (EncodedDisclosure, Disclosure)
findDisclosureForClaim HashAlgorithm
hashAlg Text
claimName Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures =
let sdArrayDigests :: [Text]
sdArrayDigests = Object -> [Text]
extractDigestStringsFromSDArray Object
obj
in ((EncodedDisclosure, Disclosure) -> Bool)
-> [(EncodedDisclosure, Disclosure)]
-> Maybe (EncodedDisclosure, Disclosure)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(EncodedDisclosure
encDisclosure, Disclosure
decoded) ->
let digestText :: Text
digestText = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure
decodedClaimName :: Maybe Text
decodedClaimName = Disclosure -> Maybe Text
getDisclosureClaimName Disclosure
decoded
in Text
digestText Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
sdArrayDigests Bool -> Bool -> Bool
&& Maybe Text
decodedClaimName Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
claimName
) ([(EncodedDisclosure, Disclosure)]
-> Maybe (EncodedDisclosure, Disclosure))
-> [(EncodedDisclosure, Disclosure)]
-> Maybe (EncodedDisclosure, Disclosure)
forall a b. (a -> b) -> a -> b
$ [EncodedDisclosure]
-> [Disclosure] -> [(EncodedDisclosure, Disclosure)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
collectNestedDisclosuresForSegment
:: HashAlgorithm
-> T.Text
-> [[T.Text]]
-> KeyMap.KeyMap Aeson.Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectNestedDisclosuresForSegment :: HashAlgorithm
-> Text
-> [[Text]]
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectNestedDisclosuresForSegment HashAlgorithm
hashAlg Text
firstSeg [[Text]]
remainingPaths Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures = do
let claimDisclosure :: Maybe (EncodedDisclosure, Disclosure)
claimDisclosure = HashAlgorithm
-> Text
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Maybe (EncodedDisclosure, Disclosure)
findDisclosureForClaim HashAlgorithm
hashAlg Text
firstSeg Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
let nestedValue :: Value
nestedValue = case Maybe (EncodedDisclosure, Disclosure)
claimDisclosure of
Just (EncodedDisclosure
_, Disclosure
decoded) -> Disclosure -> Value
getDisclosureValue Disclosure
decoded
Maybe (EncodedDisclosure, Disclosure)
Nothing -> Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Aeson.Null (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
firstSeg) Object
obj
let ([[Text]]
emptyPaths, [[Text]]
nonEmptyPaths) = ([Text] -> Bool) -> [[Text]] -> ([[Text]], [[Text]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
remainingPaths
[EncodedDisclosure]
thisLevelDisclos <- if [[Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
emptyPaths
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else case Maybe (EncodedDisclosure, Disclosure)
claimDisclosure of
Just (EncodedDisclosure
encDisclosure, Disclosure
_) -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [EncodedDisclosure
encDisclosure]
Maybe (EncodedDisclosure, Disclosure)
Nothing -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
[EncodedDisclosure]
deeperDisclos <- if [[Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
nonEmptyPaths
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[EncodedDisclosure]
nestedDisclos2 <- HashAlgorithm
-> [Text]
-> [[Text]]
-> Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresRecursively HashAlgorithm
hashAlg [] [[Text]]
nonEmptyPaths Value
nestedValue [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
[EncodedDisclosure]
parentDisclos <- if Bool -> Bool
not ([EncodedDisclosure] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EncodedDisclosure]
nestedDisclos2) Bool -> Bool -> Bool
&& Value -> Bool
isRecursiveValue Value
nestedValue
then case Maybe (EncodedDisclosure, Disclosure)
claimDisclosure of
Just (EncodedDisclosure
encDisclosure, Disclosure
_) -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [EncodedDisclosure
encDisclosure]
Maybe (EncodedDisclosure, Disclosure)
Nothing -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure]
parentDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
nestedDisclos2)
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure]
thisLevelDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
deeperDisclos)
collectFromObject
:: HashAlgorithm
-> [T.Text]
-> [[T.Text]]
-> KeyMap.KeyMap Aeson.Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectFromObject :: HashAlgorithm
-> [Text]
-> [[Text]]
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectFromObject HashAlgorithm
hashAlg [Text]
topLevelNames [[Text]]
nestedPaths Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures = do
[EncodedDisclosure]
topLevelDisclos <- HashAlgorithm
-> [Text]
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectTopLevelDisclosures HashAlgorithm
hashAlg [Text]
topLevelNames Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
let groupedByFirst :: Map Text [[Text]]
groupedByFirst = [[Text]] -> Map Text [[Text]]
groupPathsByFirstSegment [[Text]]
nestedPaths
[[EncodedDisclosure]]
nestedDisclos <- ((Text, [[Text]]) -> Either SDJWTError [EncodedDisclosure])
-> [(Text, [[Text]])] -> Either SDJWTError [[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 (\(Text
firstSeg, [[Text]]
remainingPaths) ->
HashAlgorithm
-> Text
-> [[Text]]
-> Object
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectNestedDisclosuresForSegment HashAlgorithm
hashAlg Text
firstSeg [[Text]]
remainingPaths Object
obj [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
) (Map Text [[Text]] -> [(Text, [[Text]])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text [[Text]]
groupedByFirst)
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure])
-> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a b. (a -> b) -> a -> b
$ [EncodedDisclosure]
topLevelDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [[EncodedDisclosure]] -> [EncodedDisclosure]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EncodedDisclosure]]
nestedDisclos
collectFromArray
:: HashAlgorithm
-> [T.Text]
-> [[T.Text]]
-> V.Vector Aeson.Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectFromArray :: HashAlgorithm
-> [Text]
-> [[Text]]
-> Array
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectFromArray HashAlgorithm
hashAlg [Text]
_topLevelNames [[Text]]
nestedPaths Array
arr [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures = do
let groupedByFirstIndex :: Map Int [[Text]]
groupedByFirstIndex = ([[Text]] -> [[Text]] -> [[Text]])
-> [(Int, [[Text]])] -> Map Int [[Text]]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
(++) ([(Int, [[Text]])] -> Map Int [[Text]])
-> [(Int, [[Text]])] -> Map Int [[Text]]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Maybe (Int, [[Text]])) -> [[Text]] -> [(Int, [[Text]])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[Text]
path -> case [Text]
path of
[] -> Maybe (Int, [[Text]])
forall a. Maybe a
Nothing
(Text
firstSeg:[Text]
rest) -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
firstSeg) :: Maybe Int of
Just Int
idx -> (Int, [[Text]]) -> Maybe (Int, [[Text]])
forall a. a -> Maybe a
Just (Int
idx, [[Text]
rest])
Maybe Int
Nothing -> Maybe (Int, [[Text]])
forall a. Maybe a
Nothing
) [[Text]]
nestedPaths
[[EncodedDisclosure]]
results <- ((Int, [[Text]]) -> Either SDJWTError [EncodedDisclosure])
-> [(Int, [[Text]])] -> Either SDJWTError [[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 (\(Int
firstIdx, [[Text]]
remainingPaths) ->
if Int
firstIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
firstIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Array -> Int
forall a. Vector a -> Int
V.length Array
arr
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
let element :: Value
element = Array
arr Array -> Int -> Value
forall a. Vector a -> Int -> a
V.! Int
firstIdx
let ([[Text]]
emptyPaths, [[Text]]
nonEmptyPaths) = ([Text] -> Bool) -> [[Text]] -> ([[Text]], [[Text]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
remainingPaths
[EncodedDisclosure]
thisLevelDisclos <- if [[Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
emptyPaths
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else HashAlgorithm
-> Value
-> [EncodedDisclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresForArrayElement HashAlgorithm
hashAlg Value
element [EncodedDisclosure]
allDisclosures
[EncodedDisclosure]
deeperDisclos <- if [[Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
nonEmptyPaths
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
case Value
element of
Aeson.Object Object
ellipsisObj ->
case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
"...") Object
ellipsisObj of
Just (Aeson.String Text
digest) ->
case (EncodedDisclosure -> Bool)
-> [EncodedDisclosure] -> Maybe EncodedDisclosure
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\EncodedDisclosure
encDisclosure ->
HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
digest
) [EncodedDisclosure]
allDisclosures of
Just EncodedDisclosure
encDisclosure -> do
Disclosure
decoded <- EncodedDisclosure -> Either SDJWTError Disclosure
decodeDisclosure EncodedDisclosure
encDisclosure
let actualValue :: Value
actualValue = Disclosure -> Value
getDisclosureValue Disclosure
decoded
[EncodedDisclosure]
nestedDisclos <- HashAlgorithm
-> [Text]
-> [[Text]]
-> Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresRecursively HashAlgorithm
hashAlg [] [[Text]]
nonEmptyPaths Value
actualValue [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure
encDisclosure] [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
nestedDisclos)
Maybe EncodedDisclosure
Nothing -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Maybe Value
_ -> do
[EncodedDisclosure]
nestedDisclos <- HashAlgorithm
-> [Text]
-> [[Text]]
-> Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresRecursively HashAlgorithm
hashAlg [] [[Text]]
nonEmptyPaths Value
element [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [EncodedDisclosure]
nestedDisclos
Value
_ -> do
[EncodedDisclosure]
nestedDisclos <- HashAlgorithm
-> [Text]
-> [[Text]]
-> Value
-> [EncodedDisclosure]
-> [Disclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresRecursively HashAlgorithm
hashAlg [] [[Text]]
nonEmptyPaths Value
element [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [EncodedDisclosure]
nestedDisclos
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure]
thisLevelDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
deeperDisclos)
) (Map Int [[Text]] -> [(Int, [[Text]])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int [[Text]]
groupedByFirstIndex)
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure])
-> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a b. (a -> b) -> a -> b
$ [[EncodedDisclosure]] -> [EncodedDisclosure]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EncodedDisclosure]]
results
collectDisclosuresForArrayElement
:: HashAlgorithm
-> Aeson.Value
-> [EncodedDisclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresForArrayElement :: HashAlgorithm
-> Value
-> [EncodedDisclosure]
-> Either SDJWTError [EncodedDisclosure]
collectDisclosuresForArrayElement HashAlgorithm
hashAlg Value
value [EncodedDisclosure]
allDisclosures = do
case Value
value of
Aeson.Object Object
ellipsisObj -> do
case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
"...") Object
ellipsisObj of
Just (Aeson.String Text
digestText) -> do
let matchingDisclos :: [EncodedDisclosure]
matchingDisclos = (EncodedDisclosure -> Maybe EncodedDisclosure)
-> [EncodedDisclosure] -> [EncodedDisclosure]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\EncodedDisclosure
encDisclosure ->
let digestText2 :: Text
digestText2 = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure
in if Text
digestText2 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
digestText
then EncodedDisclosure -> Maybe EncodedDisclosure
forall a. a -> Maybe a
Just EncodedDisclosure
encDisclosure
else Maybe EncodedDisclosure
forall a. Maybe a
Nothing
) [EncodedDisclosure]
allDisclosures
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [EncodedDisclosure]
matchingDisclos
Maybe Value
_ -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Value
_ -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
isRecursiveValue :: Aeson.Value -> Bool
isRecursiveValue :: Value -> Bool
isRecursiveValue Value
value = case Value
value of
Aeson.Object Object
obj ->
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
_) -> Bool
True
Maybe Value
_ -> Bool
False
Value
_ -> Bool
False
selectDisclosures
:: SDJWT
-> [EncodedDisclosure]
-> Either SDJWTError SDJWTPresentation
selectDisclosures :: SDJWT -> [EncodedDisclosure] -> Either SDJWTError SDJWTPresentation
selectDisclosures sdjwt :: SDJWT
sdjwt@(SDJWT Text
_ [EncodedDisclosure]
allDisclosures) [EncodedDisclosure]
selectedDisclos = do
let allDisclosuresSet :: Set Text
allDisclosuresSet = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ((EncodedDisclosure -> Text) -> [EncodedDisclosure] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map EncodedDisclosure -> Text
unEncodedDisclosure [EncodedDisclosure]
allDisclosures)
let selectedSet :: Set Text
selectedSet = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ((EncodedDisclosure -> Text) -> [EncodedDisclosure] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map EncodedDisclosure -> Text
unEncodedDisclosure [EncodedDisclosure]
selectedDisclos)
if Set Text
selectedSet Set Text -> Set Text -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Text
allDisclosuresSet
then SDJWTPresentation -> Either SDJWTError SDJWTPresentation
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDJWTPresentation -> Either SDJWTError SDJWTPresentation)
-> SDJWTPresentation -> Either SDJWTError SDJWTPresentation
forall a b. (a -> b) -> a -> b
$ SDJWT -> [EncodedDisclosure] -> SDJWTPresentation
createPresentation SDJWT
sdjwt [EncodedDisclosure]
selectedDisclos
else SDJWTError -> Either SDJWTError SDJWTPresentation
forall a b. a -> Either a b
Left (SDJWTError -> Either SDJWTError SDJWTPresentation)
-> SDJWTError -> Either SDJWTError SDJWTPresentation
forall a b. (a -> b) -> a -> b
$ Text -> SDJWTError
InvalidDisclosureFormat Text
"Selected disclosures must be a subset of original disclosures"
addKeyBinding
:: JWKLike jwk => HashAlgorithm
-> jwk
-> T.Text
-> T.Text
-> Int64
-> SDJWTPresentation
-> Aeson.Object
-> IO (Either SDJWTError SDJWTPresentation)
addKeyBinding :: forall jwk.
JWKLike jwk =>
HashAlgorithm
-> jwk
-> Text
-> Text
-> Int64
-> SDJWTPresentation
-> Object
-> IO (Either SDJWTError SDJWTPresentation)
addKeyBinding HashAlgorithm
hashAlg jwk
holderKey Text
audience Text
nonce Int64
issuedAt SDJWTPresentation
presentation Object
optionalClaims =
HashAlgorithm
-> jwk
-> Text
-> Text
-> Int64
-> SDJWTPresentation
-> Object
-> IO (Either SDJWTError SDJWTPresentation)
forall jwk.
JWKLike jwk =>
HashAlgorithm
-> jwk
-> Text
-> Text
-> Int64
-> SDJWTPresentation
-> Object
-> IO (Either SDJWTError SDJWTPresentation)
addKeyBindingToPresentation HashAlgorithm
hashAlg jwk
holderKey Text
audience Text
nonce Int64
issuedAt SDJWTPresentation
presentation Object
optionalClaims
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
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
parseJSONPointerPath :: T.Text -> Maybe [T.Text]
parseJSONPointerPath :: Text -> Maybe [Text]
parseJSONPointerPath Text
path = do
let segments :: [Text]
segments = Text -> [Text]
splitJSONPointer Text
path
case [Text]
segments of
[] -> Maybe [Text]
forall a. Maybe a
Nothing
[Text
_] -> Maybe [Text]
forall a. Maybe a
Nothing
[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)
extractHashAlgorithmFromJWT :: T.Text -> Either SDJWTError HashAlgorithm
Text
jwt =
(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 -> Maybe HashAlgorithm -> HashAlgorithm
forall a. a -> Maybe a -> a
fromMaybe HashAlgorithm
defaultHashAlgorithm (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 Text
jwt)
validateDisclosureDependencies
:: HashAlgorithm
-> [EncodedDisclosure]
-> T.Text
-> Either SDJWTError ()
validateDisclosureDependencies :: HashAlgorithm
-> [EncodedDisclosure] -> Text -> Either SDJWTError ()
validateDisclosureDependencies HashAlgorithm
hashAlg [EncodedDisclosure]
selectedDisclos Text
issuerJWT = do
Set Text
issuerDigests <- Text -> Either SDJWTError (Set Text)
extractDigestsFromJWTPayload Text
issuerJWT
let selectedDigests :: Set Text
selectedDigests = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (EncodedDisclosure -> Text) -> [EncodedDisclosure] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg) [EncodedDisclosure]
selectedDisclos
let allValidDigests :: Set Text
allValidDigests = Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
issuerDigests Set Text
selectedDigests
(EncodedDisclosure -> Either SDJWTError ())
-> [EncodedDisclosure] -> Either SDJWTError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\EncodedDisclosure
encDisclosure -> do
let disclosureDigestText :: Text
disclosureDigestText = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure
if Text
disclosureDigestText Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
allValidDigests
then () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else 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 issuer-signed JWT or other selected disclosures: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disclosureDigestText
) [EncodedDisclosure]
selectedDisclos
[Disclosure]
decodedSelected <- (EncodedDisclosure -> Either SDJWTError Disclosure)
-> [EncodedDisclosure] -> Either SDJWTError [Disclosure]
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 -> Either SDJWTError Disclosure
decodeDisclosure [EncodedDisclosure]
selectedDisclos
(Disclosure -> Either SDJWTError ())
-> [Disclosure] -> Either SDJWTError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Disclosure
disclosure -> do
case Disclosure -> Value
getDisclosureValue Disclosure
disclosure of
Aeson.Object Object
obj -> do
let childDigests :: [Text]
childDigests = Object -> [Text]
extractDigestStringsFromSDArray Object
obj
if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
childDigests
then () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
(Text -> Either SDJWTError ()) -> [Text] -> Either SDJWTError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Text
childDigestText -> do
if Text
childDigestText Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
selectedDigests
then () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else if Text
childDigestText Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
issuerDigests
then () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
) [Text]
childDigests
Value
_ -> () -> Either SDJWTError ()
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
) [Disclosure]
decodedSelected
extractDigestsFromJWTPayload :: T.Text -> Either SDJWTError (Set.Set T.Text)
Text
jwt =
Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT Text
jwt Either SDJWTError SDJWTPayload
-> (SDJWTPayload -> Either SDJWTError (Set Text))
-> Either SDJWTError (Set Text)
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
>>= \SDJWTPayload
sdPayload ->
([Digest] -> Set Text)
-> Either SDJWTError [Digest] -> Either SDJWTError (Set Text)
forall a b. (a -> b) -> Either SDJWTError a -> Either SDJWTError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text)
-> ([Digest] -> [Text]) -> [Digest] -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Digest -> Text) -> [Digest] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Digest -> Text
unDigest) (SDJWTPayload -> Either SDJWTError [Digest]
extractDigestsFromPayload SDJWTPayload
sdPayload)
collectArrayElementDisclosures
:: HashAlgorithm
-> [T.Text]
-> T.Text
-> [EncodedDisclosure]
-> [Disclosure]
-> Bool
-> Either SDJWTError [EncodedDisclosure]
collectArrayElementDisclosures :: HashAlgorithm
-> [Text]
-> Text
-> [EncodedDisclosure]
-> [Disclosure]
-> Bool
-> Either SDJWTError [EncodedDisclosure]
collectArrayElementDisclosures HashAlgorithm
hashAlg [Text]
claimNames Text
issuerJWT [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures Bool
shouldRecurse = do
if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
claimNames
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
SDJWTPayload
sdPayload <- Text -> Either SDJWTError SDJWTPayload
parsePayloadFromJWT Text
issuerJWT
let payloadValueObj :: Value
payloadValueObj = SDJWTPayload -> Value
payloadValue SDJWTPayload
sdPayload
case Value
payloadValueObj of
Aeson.Object Object
obj -> do
[(Text, [Digest])]
arrayDigests <- (Text -> Either SDJWTError (Text, [Digest]))
-> [Text] -> Either SDJWTError [(Text, [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 (\Text
claimName -> do
[Digest]
payloadDigests <- case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
claimName) Object
obj of
Just (Aeson.Array Array
arr) -> do
[Digest]
digests <- Value -> Either SDJWTError [Digest]
extractDigestsFromValue (Array -> Value
Aeson.Array Array
arr)
[Digest] -> Either SDJWTError [Digest]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [Digest]
digests
Maybe Value
_ -> [Digest] -> Either SDJWTError [Digest]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
let rootDigests :: [Text]
rootDigests = Object -> [Text]
extractDigestStringsFromSDArray Object
obj
[Digest]
disclosureDigests <- if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rootDigests
then [Digest] -> Either SDJWTError [Digest]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
case ((EncodedDisclosure, Disclosure) -> Bool)
-> [(EncodedDisclosure, Disclosure)]
-> Maybe (EncodedDisclosure, Disclosure)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(EncodedDisclosure
encDisclosure, Disclosure
decoded) ->
let digestText :: Text
digestText = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure
claimNameFromDisclosure :: Maybe Text
claimNameFromDisclosure = Disclosure -> Maybe Text
getDisclosureClaimName Disclosure
decoded
in Text
digestText Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
rootDigests Bool -> Bool -> Bool
&& Maybe Text
claimNameFromDisclosure Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
claimName
) ([(EncodedDisclosure, Disclosure)]
-> Maybe (EncodedDisclosure, Disclosure))
-> [(EncodedDisclosure, Disclosure)]
-> Maybe (EncodedDisclosure, Disclosure)
forall a b. (a -> b) -> a -> b
$ [EncodedDisclosure]
-> [Disclosure] -> [(EncodedDisclosure, Disclosure)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EncodedDisclosure]
allDisclosures [Disclosure]
decodedDisclosures of
Just (EncodedDisclosure
_, Disclosure
decoded) -> do
let value :: Value
value = Disclosure -> Value
getDisclosureValue Disclosure
decoded
case Value
value of
Aeson.Array Array
arr -> Value -> Either SDJWTError [Digest]
extractDigestsFromValue (Array -> Value
Aeson.Array Array
arr)
Value
_ -> [Digest] -> Either SDJWTError [Digest]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Maybe (EncodedDisclosure, Disclosure)
Nothing -> [Digest] -> Either SDJWTError [Digest]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
(Text, [Digest]) -> Either SDJWTError (Text, [Digest])
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
claimName, [Digest]
payloadDigests [Digest] -> [Digest] -> [Digest]
forall a. [a] -> [a] -> [a]
++ [Digest]
disclosureDigests)
) [Text]
claimNames
let selectedArrayElementDisclos :: [EncodedDisclosure]
selectedArrayElementDisclos = if Bool
shouldRecurse
then (EncodedDisclosure -> Maybe EncodedDisclosure)
-> [EncodedDisclosure] -> [EncodedDisclosure]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\EncodedDisclosure
encDisclosure ->
let digestText :: Text
digestText = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure
in if ((Text, [Digest]) -> Bool) -> [(Text, [Digest])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Text
_, [Digest]
digests) -> (Digest -> Bool) -> [Digest] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
digestText) (Text -> Bool) -> (Digest -> Text) -> Digest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest -> Text
unDigest) [Digest]
digests) [(Text, [Digest])]
arrayDigests
then EncodedDisclosure -> Maybe EncodedDisclosure
forall a. a -> Maybe a
Just EncodedDisclosure
encDisclosure
else Maybe EncodedDisclosure
forall a. Maybe a
Nothing
) [EncodedDisclosure]
allDisclosures
else []
let collectNestedRecursive :: [EncodedDisclosure] -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
collectNestedRecursive :: [EncodedDisclosure]
-> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
collectNestedRecursive [EncodedDisclosure]
currentDisclos [EncodedDisclosure]
alreadyCollected = do
[[EncodedDisclosure]]
nestedDisclos <- (EncodedDisclosure -> Either SDJWTError [EncodedDisclosure])
-> [EncodedDisclosure] -> Either SDJWTError [[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 (\EncodedDisclosure
encDisclosure -> do
Disclosure
decoded <- EncodedDisclosure -> Either SDJWTError Disclosure
decodeDisclosure EncodedDisclosure
encDisclosure
let value :: Value
value = Disclosure -> Value
getDisclosureValue Disclosure
decoded
case Value
value of
Aeson.Array Array
nestedArr -> do
[Digest]
nestedDigests <- Value -> Either SDJWTError [Digest]
extractDigestsFromValue (Array -> Value
Aeson.Array Array
nestedArr)
let matchingDisclos :: [EncodedDisclosure]
matchingDisclos = (EncodedDisclosure -> Maybe EncodedDisclosure)
-> [EncodedDisclosure] -> [EncodedDisclosure]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\EncodedDisclosure
encDisclosure2 ->
let digestText2 :: Text
digestText2 = HashAlgorithm -> EncodedDisclosure -> Text
computeDigestText HashAlgorithm
hashAlg EncodedDisclosure
encDisclosure2
in if (Digest -> Bool) -> [Digest] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
digestText2) (Text -> Bool) -> (Digest -> Text) -> Digest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest -> Text
unDigest) [Digest]
nestedDigests Bool -> Bool -> Bool
&&
Bool -> Bool
not (EncodedDisclosure
encDisclosure2 EncodedDisclosure -> [EncodedDisclosure] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EncodedDisclosure]
alreadyCollected) Bool -> Bool -> Bool
&&
Bool -> Bool
not (EncodedDisclosure
encDisclosure2 EncodedDisclosure -> [EncodedDisclosure] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EncodedDisclosure]
currentDisclos)
then EncodedDisclosure -> Maybe EncodedDisclosure
forall a. a -> Maybe a
Just EncodedDisclosure
encDisclosure2
else Maybe EncodedDisclosure
forall a. Maybe a
Nothing
) [EncodedDisclosure]
allDisclosures
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return [EncodedDisclosure]
matchingDisclos
Value
_ -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
) [EncodedDisclosure]
currentDisclos
let newDisclos :: [EncodedDisclosure]
newDisclos = [[EncodedDisclosure]] -> [EncodedDisclosure]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EncodedDisclosure]]
nestedDisclos
if [EncodedDisclosure] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EncodedDisclosure]
newDisclos
then [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[EncodedDisclosure]
deeperDisclos <- [EncodedDisclosure]
-> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
collectNestedRecursive [EncodedDisclosure]
newDisclos ([EncodedDisclosure]
alreadyCollected [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
currentDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
newDisclos)
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure]
newDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
deeperDisclos)
[EncodedDisclosure]
nestedDisclos <- if Bool
shouldRecurse
then [EncodedDisclosure]
-> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
collectNestedRecursive [EncodedDisclosure]
selectedArrayElementDisclos [EncodedDisclosure]
selectedArrayElementDisclos
else [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []
[EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure])
-> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a b. (a -> b) -> a -> b
$ [EncodedDisclosure]
selectedArrayElementDisclos [EncodedDisclosure] -> [EncodedDisclosure] -> [EncodedDisclosure]
forall a. [a] -> [a] -> [a]
++ [EncodedDisclosure]
nestedDisclos
Value
_ -> [EncodedDisclosure] -> Either SDJWTError [EncodedDisclosure]
forall a. a -> Either SDJWTError a
forall (m :: * -> *) a. Monad m => a -> m a
return []