{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Context is a collection of attributes that can be referenced in flag
-- evaluations and analytics events.
--
-- To create a Context of a single kind, such as a user, you may use
-- 'makeContext'.
--
-- To create an LDContext with multiple kinds, use 'makeMultiContext'.
--
-- Additional properties can be set on a single-kind context using the set
-- methods found in this module.
--
-- Each method will always return a Context. However, that Context may be
-- invalid. You can check the validity of the resulting context, and the
-- associated errors by calling 'isValid' and 'getError'.
module LaunchDarkly.Server.Context.Internal
    ( Context (..)
    , SingleContext (..)
    , MultiContext (..)
    , makeContext
    , makeMultiContext
    , withName
    , withAnonymous
    , withAttribute
    , withPrivateAttributes
    , getKey
    , getKeys
    , getCanonicalKey
    , getKinds
    , redactContext
    , redactContextRedactAnonymous
    )
where

import Data.Aeson (FromJSON, Result (Success), ToJSON, Value (..), fromJSON, parseJSON, toJSON, withObject, (.:), (.:?))
import Data.Aeson.Types (Parser, prependFailure, typeMismatch)
import Data.Function ((&))
import Data.Generics.Product (getField, setField)
import qualified Data.HashSet as HS
import Data.List (sortBy)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text, intercalate, replace, unpack)
import qualified GHC.Exts as Exts (fromList)
import GHC.Generics (Generic)
import LaunchDarkly.AesonCompat (KeyMap, deleteKey, emptyObject, foldrWithKey, fromList, insertKey, keyMapUnion, lookupKey, mapValues, objectKeys, singleton, toList)
import LaunchDarkly.Server.Config (Config)
import LaunchDarkly.Server.Reference (Reference)
import qualified LaunchDarkly.Server.Reference as R

-- | data record for the Context type
data Context
    = Single SingleContext
    | Multi MultiContext
    | Invalid {Context -> Text
error :: !Text}
    deriving ((forall x. Context -> Rep Context x)
-> (forall x. Rep Context x -> Context) -> Generic Context
forall x. Rep Context x -> Context
forall x. Context -> Rep Context x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Context x -> Context
$cfrom :: forall x. Context -> Rep Context x
Generic, Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show, Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq)

instance ToJSON Context where
    toJSON :: Context -> Value
toJSON (Single c :: SingleContext
c) = SingleContext -> Value
forall a. ToJSON a => a -> Value
toJSON SingleContext
c
    toJSON (Multi c :: MultiContext
c) = MultiContext -> Value
forall a. ToJSON a => a -> Value
toJSON MultiContext
c
    toJSON (Invalid c :: Text
c) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
c

instance FromJSON Context where
    parseJSON :: Value -> Parser Context
parseJSON a :: Value
a@(Object o :: Object
o) =
        case Text -> Object -> Maybe Value
forall v. Text -> HashMap Text v -> Maybe v
lookupKey "kind" Object
o of
            Nothing -> Value -> Parser Context
parseLegacyUser Value
a
            Just (String "multi") -> Value -> Parser Context
parseMultiContext Value
a
            Just _ -> Value -> Parser Context
parseSingleContext Value
a
    parseJSON invalid :: Value
invalid = String -> Parser Context -> Parser Context
forall a. String -> Parser a -> Parser a
prependFailure "parsing Context failed, " (String -> Value -> Parser Context
forall a. String -> Value -> Parser a
typeMismatch "Object" Value
invalid)

data SingleContext = SingleContext
    { SingleContext -> Text
key :: !Text
    , SingleContext -> Text
fullKey :: !Text
    , SingleContext -> Text
kind :: !Text
    , SingleContext -> Maybe Text
name :: !(Maybe Text)
    , SingleContext -> Bool
anonymous :: !Bool
    , SingleContext -> Maybe Object
attributes :: !(Maybe (KeyMap Value))
    , SingleContext -> Maybe (Set Reference)
privateAttributes :: !(Maybe (Set Reference))
    }
    deriving ((forall x. SingleContext -> Rep SingleContext x)
-> (forall x. Rep SingleContext x -> SingleContext)
-> Generic SingleContext
forall x. Rep SingleContext x -> SingleContext
forall x. SingleContext -> Rep SingleContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SingleContext x -> SingleContext
$cfrom :: forall x. SingleContext -> Rep SingleContext x
Generic, Int -> SingleContext -> ShowS
[SingleContext] -> ShowS
SingleContext -> String
(Int -> SingleContext -> ShowS)
-> (SingleContext -> String)
-> ([SingleContext] -> ShowS)
-> Show SingleContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SingleContext] -> ShowS
$cshowList :: [SingleContext] -> ShowS
show :: SingleContext -> String
$cshow :: SingleContext -> String
showsPrec :: Int -> SingleContext -> ShowS
$cshowsPrec :: Int -> SingleContext -> ShowS
Show, SingleContext -> SingleContext -> Bool
(SingleContext -> SingleContext -> Bool)
-> (SingleContext -> SingleContext -> Bool) -> Eq SingleContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SingleContext -> SingleContext -> Bool
$c/= :: SingleContext -> SingleContext -> Bool
== :: SingleContext -> SingleContext -> Bool
$c== :: SingleContext -> SingleContext -> Bool
Eq)

instance ToJSON SingleContext where
    toJSON :: SingleContext -> Value
toJSON = (Bool -> SingleContext -> Value
toJsonObject Bool
True)

data MultiContext = MultiContext
    { MultiContext -> Text
fullKey :: !Text
    , MultiContext -> KeyMap SingleContext
contexts :: !(KeyMap SingleContext)
    }
    deriving ((forall x. MultiContext -> Rep MultiContext x)
-> (forall x. Rep MultiContext x -> MultiContext)
-> Generic MultiContext
forall x. Rep MultiContext x -> MultiContext
forall x. MultiContext -> Rep MultiContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MultiContext x -> MultiContext
$cfrom :: forall x. MultiContext -> Rep MultiContext x
Generic, Int -> MultiContext -> ShowS
[MultiContext] -> ShowS
MultiContext -> String
(Int -> MultiContext -> ShowS)
-> (MultiContext -> String)
-> ([MultiContext] -> ShowS)
-> Show MultiContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultiContext] -> ShowS
$cshowList :: [MultiContext] -> ShowS
show :: MultiContext -> String
$cshow :: MultiContext -> String
showsPrec :: Int -> MultiContext -> ShowS
$cshowsPrec :: Int -> MultiContext -> ShowS
Show, MultiContext -> MultiContext -> Bool
(MultiContext -> MultiContext -> Bool)
-> (MultiContext -> MultiContext -> Bool) -> Eq MultiContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiContext -> MultiContext -> Bool
$c/= :: MultiContext -> MultiContext -> Bool
== :: MultiContext -> MultiContext -> Bool
$c== :: MultiContext -> MultiContext -> Bool
Eq)

instance ToJSON MultiContext where
    toJSON :: MultiContext -> Value
toJSON (MultiContext {KeyMap SingleContext
contexts :: KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts}) =
        (SingleContext -> Value) -> KeyMap SingleContext -> Object
forall v1 v2. (v1 -> v2) -> HashMap Text v1 -> HashMap Text v2
mapValues (\c :: SingleContext
c -> Bool -> SingleContext -> Value
toJsonObject Bool
False SingleContext
c) KeyMap SingleContext
contexts
            Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Text -> Value -> Object -> Object
forall v. Text -> v -> HashMap Text v -> HashMap Text v
insertKey "kind" "multi"
            Object -> (Object -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Object -> Value
Object

-- |
-- Create a single kind context from the provided hash.
--
-- The provided hash must match the format as outlined in the [SDK
-- documentation](https://docs.launchdarkly.com/sdk/features/user-config).
makeContext :: Text -> Text -> Context
makeContext :: Text -> Text -> Context
makeContext "" _ = $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "context key must not be empty"}
makeContext key :: Text
key kind :: Text
kind = Text -> Text -> Context
makeSingleContext Text
key Text
kind

-- This function is used internally to create a context with legacy key
-- validation rules; namely, a legacy context is allowed to have an empty key.
-- No other type of context is. Users of this SDK can only use the makeContext
-- to create a single-kind context, which includes the non-empty key
-- restriction.
makeSingleContext :: Text -> Text -> Context
makeSingleContext :: Text -> Text -> Context
makeSingleContext _ "" = $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "context kind must not be empty"}
makeSingleContext _ "kind" = $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "context kind cannot be 'kind'"}
makeSingleContext _ "multi" = $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "context kind cannot be 'multi'"}
makeSingleContext key :: Text
key kind :: Text
kind
    | ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['a' .. 'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ['A' .. 'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ['0' .. '9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ['.', '-', '_']) (Text -> String
unpack Text
kind)) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False = $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "context kind contains disallowed characters"}
    | Bool
otherwise =
        SingleContext -> Context
Single
            $WSingleContext :: Text
-> Text
-> Text
-> Maybe Text
-> Bool
-> Maybe Object
-> Maybe (Set Reference)
-> SingleContext
SingleContext
                { $sel:key:SingleContext :: Text
key = Text
key
                , $sel:fullKey:SingleContext :: Text
fullKey = Text -> Text -> Text
canonicalizeKey Text
key Text
kind
                , $sel:kind:SingleContext :: Text
kind = Text
kind
                , $sel:name:SingleContext :: Maybe Text
name = Maybe Text
forall a. Maybe a
Nothing
                , $sel:anonymous:SingleContext :: Bool
anonymous = Bool
False
                , $sel:attributes:SingleContext :: Maybe Object
attributes = Maybe Object
forall a. Maybe a
Nothing
                , $sel:privateAttributes:SingleContext :: Maybe (Set Reference)
privateAttributes = Maybe (Set Reference)
forall a. Maybe a
Nothing
                }

-- |
-- Create a multi-kind context from the list of Contexts provided.
--
-- A multi-kind context is comprised of two or more single kind contexts. You
-- cannot include a multi-kind context instead another multi-kind context.
--
-- Additionally, the kind of each single-kind context must be unique. For
-- instance, you cannot create a multi-kind context that includes two user kind
-- contexts.
--
-- If you attempt to create a multi-kind context from one single-kind context,
-- this method will return the single-kind context instead of a new multi-kind
-- context wrapping that one single-kind.
makeMultiContext :: [Context] -> Context
makeMultiContext :: [Context] -> Context
makeMultiContext [] = $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "multi-kind contexts require at least one single-kind context"}
makeMultiContext [c :: Context
c@(Single _)] = Context
c
makeMultiContext contexts :: [Context]
contexts =
    let singleContexts :: [SingleContext]
singleContexts = (Context -> Maybe SingleContext) -> [Context] -> [SingleContext]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Context -> Maybe SingleContext
unwrapSingleContext [Context]
contexts
        sorted :: [SingleContext]
sorted = (SingleContext -> SingleContext -> Ordering)
-> [SingleContext] -> [SingleContext]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\lhs :: SingleContext
lhs rhs :: SingleContext
rhs -> Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SingleContext -> Text
kind SingleContext
lhs) (SingleContext -> Text
kind SingleContext
rhs)) [SingleContext]
singleContexts
        kinds :: HashSet Text
kinds = [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([Text] -> HashSet Text) -> [Text] -> HashSet Text
forall a b. (a -> b) -> a -> b
$ (SingleContext -> Text) -> [SingleContext] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SingleContext -> Text
kind [SingleContext]
singleContexts
     in case ([Context] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
contexts, [SingleContext] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SingleContext]
singleContexts, HashSet Text -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HashSet Text
kinds) of
            (a :: Int
a, b :: Int
b, _) | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
b -> $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "multi-kind contexts can only contain single-kind contexts"}
            (a :: Int
a, _, c :: Int
c) | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
c -> $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "multi-kind contexts cannot contain two single-kind contexts with the same kind"}
            _ ->
                MultiContext -> Context
Multi
                    $WMultiContext :: Text -> KeyMap SingleContext -> MultiContext
MultiContext
                        { $sel:fullKey:MultiContext :: Text
fullKey = Text -> [Text] -> Text
intercalate ":" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (SingleContext -> Text) -> [SingleContext] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: SingleContext
c -> Text -> Text -> Text
canonicalizeKey (SingleContext -> Text
key SingleContext
c) (SingleContext -> Text
kind SingleContext
c)) [SingleContext]
sorted
                        , $sel:contexts:MultiContext :: KeyMap SingleContext
contexts = [(Text, SingleContext)] -> KeyMap SingleContext
forall v. [(Text, v)] -> KeyMap v
fromList ([(Text, SingleContext)] -> KeyMap SingleContext)
-> [(Text, SingleContext)] -> KeyMap SingleContext
forall a b. (a -> b) -> a -> b
$ (SingleContext -> (Text, SingleContext))
-> [SingleContext] -> [(Text, SingleContext)]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: SingleContext
c -> ((SingleContext -> Text
kind SingleContext
c), SingleContext
c)) [SingleContext]
singleContexts
                        }

-- |
-- Sets the name attribute for a single-kind context.
--
-- Calling this method on an invalid or multi-kind context is a no-op.
withName :: Text -> Context -> Context
withName :: Text -> Context -> Context
withName name :: Text
name (Single c :: SingleContext
c) = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ Maybe Text -> SingleContext -> SingleContext
forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"name" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) SingleContext
c
withName _ c :: Context
c = Context
c

-- |
-- Sets the anonymous attribute for a single-kind context.
--
-- Calling this method on an invalid or multi-kind context is a no-op.
withAnonymous :: Bool -> Context -> Context
withAnonymous :: Bool -> Context -> Context
withAnonymous anonymous :: Bool
anonymous (Single c :: SingleContext
c) = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ Bool -> SingleContext -> SingleContext
forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"anonymous" Bool
anonymous SingleContext
c
withAnonymous _ c :: Context
c = Context
c

-- |
-- Sets the value of any attribute for the context.
--
-- This includes only attributes that are addressable in evaluations -- not
-- metadata such as private attributes. For example, if the attribute name is
-- "privateAttributes", you will be setting an attribute with that name which
-- you can use in evaluations or to record data for your own purposes, but it
-- will be unrelated to 'withPrivateAttributes'.
--
-- If attribute name is "privateAttributeNames", it is ignored and no attribute
-- is set.
--
-- This method uses the Value type to represent a value of any JSON type: null,
-- boolean, number, string, array, or object. For all attribute names that do
-- not have special meaning to LaunchDarkly, you may use any of those types.
-- Values of different JSON types are always treated as different values: for
-- instance, null, false, and the empty string "" are not the same, and the
-- number 1 is not the same as the string "1".
--
-- The following attribute names have special restrictions on their value
-- types, and any value of an unsupported type will be ignored (leaving the
-- attribute unchanged):
--
-- - "name": Must be a string.
-- - "anonymous": Must be a boolean.
--
-- The attribute name "_meta" is not allowed, because it has special meaning in
-- the JSON schema for contexts; any attempt to set an attribute with this name
-- has no effect.
--
-- The attribute names "kind" and "key" are not allowed. They must be provided
-- during the initial context creation. See 'makeContext'.
--
-- Values that are JSON arrays or objects have special behavior when referenced
-- in flag/segment rules.
--
-- For attributes that aren't subject to the special restrictions mentioned
-- above, a value of Null is equivalent to removing any current non-default
-- value of the attribute. Null is not a valid attribute value in the
-- LaunchDarkly model; any expressions in feature flags that reference an
-- attribute with a null value will behave as if the attribute did not exist.
--
-- Calling this method on an invalid or multi-kind context is a no-op.
withAttribute :: Text -> Value -> Context -> Context
withAttribute :: Text -> Value -> Context -> Context
withAttribute "key" _ c :: Context
c = Context
c
withAttribute "kind" _ c :: Context
c = Context
c
withAttribute "name" (String value :: Text
value) c :: Context
c = Text -> Context -> Context
withName Text
value Context
c
withAttribute "name" Null (Single c :: SingleContext
c) = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:name:SingleContext :: Maybe Text
name = Maybe Text
forall a. Maybe a
Nothing}
withAttribute "name" _ c :: Context
c = Context
c
withAttribute "anonymous" (Bool value :: Bool
value) c :: Context
c = Bool -> Context -> Context
withAnonymous Bool
value Context
c
withAttribute "anonymous" _ c :: Context
c = Context
c
withAttribute "_meta" _ c :: Context
c = Context
c
withAttribute "privateAttributeNames" _ c :: Context
c = Context
c
withAttribute _ Null c :: Context
c@(Single SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Maybe Object
Nothing}) = Context
c
withAttribute attr :: Text
attr value :: Value
value (Single c :: SingleContext
c@(SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Maybe Object
Nothing})) =
    SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:attributes:SingleContext :: Maybe Object
attributes = Object -> Maybe Object
forall a. a -> Maybe a
Just (Object -> Maybe Object) -> Object -> Maybe Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall v. Text -> v -> HashMap Text v
singleton Text
attr Value
value}
withAttribute attr :: Text
attr Null (Single c :: SingleContext
c@(SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Just attrs :: Object
attrs})) =
    SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:attributes:SingleContext :: Maybe Object
attributes = Object -> Maybe Object
forall a. a -> Maybe a
Just (Object -> Maybe Object) -> Object -> Maybe Object
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Object
forall v. Text -> HashMap Text v -> HashMap Text v
deleteKey Text
attr Object
attrs}
withAttribute attr :: Text
attr value :: Value
value (Single c :: SingleContext
c@(SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Just attrs :: Object
attrs})) =
    SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:attributes:SingleContext :: Maybe Object
attributes = Object -> Maybe Object
forall a. a -> Maybe a
Just (Object -> Maybe Object) -> Object -> Maybe Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall v. Text -> v -> HashMap Text v -> HashMap Text v
insertKey Text
attr Value
value Object
attrs}
withAttribute _ _ c :: Context
c = Context
c

-- |
-- Sets the private attributes for a single-kind context.
--
-- Calling this method on an invalid or multi-kind context is a no-op.
withPrivateAttributes :: Set Reference -> Context -> Context
withPrivateAttributes :: Set Reference -> Context -> Context
withPrivateAttributes attrs :: Set Reference
attrs (Single c :: SingleContext
c)
    | Set Reference -> Bool
forall a. Set a -> Bool
S.null Set Reference
attrs = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:privateAttributes:SingleContext :: Maybe (Set Reference)
privateAttributes = Maybe (Set Reference)
forall a. Maybe a
Nothing}
    | Bool
otherwise = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:privateAttributes:SingleContext :: Maybe (Set Reference)
privateAttributes = Set Reference -> Maybe (Set Reference)
forall a. a -> Maybe a
Just Set Reference
attrs}
withPrivateAttributes _ c :: Context
c = Context
c

-- Given a key and kind, generate a canonical key.
--
-- In a multi-kind context, each individual context should theoretically
-- contain the same key. To address this restriction, we generate a canonical
-- key that includes the context's kind. However, if the kind is "user", we
-- omit the kind inclusion to maintain backwards compatibility.
canonicalizeKey :: Text -> Text -> Text
canonicalizeKey :: Text -> Text -> Text
canonicalizeKey key :: Text
key "user" = Text
key
canonicalizeKey key :: Text
key kind :: Text
kind = Text
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Text -> Text
replace "%" "%25" Text
key Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
replace ":" "%3A")

unwrapSingleContext :: Context -> Maybe SingleContext
unwrapSingleContext :: Context -> Maybe SingleContext
unwrapSingleContext (Single c :: SingleContext
c) = SingleContext -> Maybe SingleContext
forall a. a -> Maybe a
Just SingleContext
c
unwrapSingleContext _ = Maybe SingleContext
forall a. Maybe a
Nothing

-- Internally used convenience function to retrieve a context's key.
--
-- This method is functionally equivalent to @fromMaybe "" $ getValue "key"@,
-- it's just nicer to use.
getKey :: Context -> Text
getKey :: Context -> Text
getKey (Single c :: SingleContext
c) = SingleContext -> Text
key SingleContext
c
getKey _ = ""

-- Internally used convenience function for retrieving all context keys,
-- indexed by their kind.
--
-- A single kind context will return a single element map containing its kind
-- and key. Multi-kind contexts will return a map of kind / key pairs for each
-- of its sub-contexts. An invalid context will return the empty map.
getKeys :: Context -> KeyMap Text
getKeys :: Context -> KeyMap Text
getKeys (Single c :: SingleContext
c) = Text -> Text -> KeyMap Text
forall v. Text -> v -> HashMap Text v
singleton (SingleContext -> Text
kind SingleContext
c) (SingleContext -> Text
key SingleContext
c)
getKeys (Multi (MultiContext {KeyMap SingleContext
contexts :: KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts})) = (SingleContext -> Text) -> KeyMap SingleContext -> KeyMap Text
forall v1 v2. (v1 -> v2) -> HashMap Text v1 -> HashMap Text v2
mapValues SingleContext -> Text
key KeyMap SingleContext
contexts
getKeys _ = KeyMap Text
forall v. KeyMap v
emptyObject

-- Internally used convenience function to retrieve a context's fully qualified
-- key.
getCanonicalKey :: Context -> Text
getCanonicalKey :: Context -> Text
getCanonicalKey (Single c :: SingleContext
c) = SingleContext -> Text
forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"fullKey" SingleContext
c
getCanonicalKey (Multi c :: MultiContext
c) = MultiContext -> Text
forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"fullKey" MultiContext
c
getCanonicalKey _ = ""

-- Internally used convenience function for retrieving a list of context kinds
-- in the provided context.
--
-- A single kind context will return a single element list containing only that
-- one kind. Multi-kind contexts will return a list of kinds for each of its
-- sub-contexts. An invalid context will return the empty list.
getKinds :: Context -> [Text]
getKinds :: Context -> [Text]
getKinds (Single c :: SingleContext
c) = [SingleContext -> Text
kind SingleContext
c]
getKinds (Multi (MultiContext {KeyMap SingleContext
contexts :: KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts})) = KeyMap SingleContext -> [Text]
forall v. HashMap Text v -> [Text]
objectKeys KeyMap SingleContext
contexts
getKinds _ = []

-- Internally used function for encoding a SingleContext into a JSON object.
--
-- This functionality has been extracted into this separate function because we
-- need to control whether or not the kind property will be included in the
-- final output. If we didn't have this restriction, we could simply inline
-- this function on the SingleContext.
toJsonObject :: Bool -> SingleContext -> Value
toJsonObject :: Bool -> SingleContext -> Value
toJsonObject includeKind :: Bool
includeKind context :: SingleContext
context =
    Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Object
forall v. [(Text, v)] -> KeyMap v
fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ (SingleContext -> [(Text, Value)]
getMapOfRedactableProperties SingleContext
context [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++ Bool -> SingleContext -> [(Text, Value)]
getMapOfRequiredProperties Bool
includeKind SingleContext
context)

-- Contexts can be broken into two different types of attributes -- those which
-- can be redacted, and those which can't.
--
-- This method will return a list of name / value pairs which represent the
-- attributes which are eligible for redaction. The other half of the context
-- can be retrieved through the getMapOfRequiredProperties function.
getMapOfRedactableProperties :: SingleContext -> [(Text, Value)]
getMapOfRedactableProperties :: SingleContext -> [(Text, Value)]
getMapOfRedactableProperties (SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Maybe Text
Nothing, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Maybe Object
Nothing}) = []
getMapOfRedactableProperties (SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Maybe Text
Nothing, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Just attrs :: Object
attrs}) = Object -> [(Text, Value)]
forall v. HashMap Text v -> [(Text, v)]
toList Object
attrs
getMapOfRedactableProperties (SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just n :: Text
n, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Just attrs :: Object
attrs}) = ("name", Text -> Value
String Text
n) (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
: (Object -> [(Text, Value)]
forall v. HashMap Text v -> [(Text, v)]
toList Object
attrs)
getMapOfRedactableProperties (SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just n :: Text
n, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Maybe Object
Nothing}) = [("name", Text -> Value
String Text
n)]

-- Contexts can be broken into two different types of attributes -- those which
-- can be redacted, and those which can't.
--
-- This method will return a list of name / value pairs which represent the
-- attributes which cannot be redacted. The other half of the context can be
-- retrieved through the getMapOfRedactableProperties function.
getMapOfRequiredProperties :: Bool -> SingleContext -> [(Text, Value)]
getMapOfRequiredProperties :: Bool -> SingleContext -> [(Text, Value)]
getMapOfRequiredProperties includeKind :: Bool
includeKind SingleContext {Text
key :: Text
$sel:key:SingleContext :: SingleContext -> Text
key, Text
kind :: Text
$sel:kind:SingleContext :: SingleContext -> Text
kind, Bool
anonymous :: Bool
$sel:anonymous:SingleContext :: SingleContext -> Bool
anonymous, Maybe (Set Reference)
privateAttributes :: Maybe (Set Reference)
$sel:privateAttributes:SingleContext :: SingleContext -> Maybe (Set Reference)
privateAttributes} =
    ((Text, Value) -> Bool) -> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Value
Null (Value -> Bool)
-> ((Text, Value) -> Value) -> (Text, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value) -> Value
forall a b. (a, b) -> b
snd)
        [ ("key", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
key)
        , ("kind", Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ if Bool
includeKind then Text -> Value
String Text
kind else Value
Null)
        , ("anonymous", Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ if Bool
anonymous then Bool -> Value
Bool Bool
True else Value
Null)
        , ("_meta", Value -> (Set Reference -> Value) -> Maybe (Set Reference) -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Set Reference -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe (Set Reference)
privateAttributes)
        ,
            ( "_meta"
            , case Maybe (Set Reference)
privateAttributes of
                Nothing -> Value
Null
                Just attrs :: Set Reference
attrs -> Object -> Value
forall a. ToJSON a => a -> Value
toJSON (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall v. Text -> v -> HashMap Text v
singleton "privateAttributes" (Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Item Array] -> Array
forall l. IsList l => [Item l] -> l
Exts.fromList ([Item Array] -> Array) -> [Item Array] -> Array
forall a b. (a -> b) -> a -> b
$ (Reference -> Value) -> [Reference] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Reference -> Value
forall a. ToJSON a => a -> Value
toJSON ([Reference] -> [Item Array]) -> [Reference] -> [Item Array]
forall a b. (a -> b) -> a -> b
$ Set Reference -> [Reference]
forall a. Set a -> [a]
S.elems Set Reference
attrs)
            )
        ]

-- Internally used function to decode a JSON object using the legacy user
-- scheme into a modern single-kind "user" context.
parseLegacyUser :: Value -> Parser Context
parseLegacyUser :: Value -> Parser Context
parseLegacyUser = String -> (Object -> Parser Context) -> Value -> Parser Context
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "LegacyUser" ((Object -> Parser Context) -> Value -> Parser Context)
-> (Object -> Parser Context) -> Value -> Parser Context
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> do
    (Text
key :: Text) <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "key"
    (Maybe Text
secondary :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "secondary"
    (Maybe Text
ip :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "ip"
    (Maybe Text
country :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "country"
    (Maybe Text
email :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "email"
    (Maybe Text
firstName :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "firstName"
    (Maybe Text
lastName :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "lastName"
    (Maybe Text
avatar :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "avatar"
    (Maybe Text
name :: Maybe Text) <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "name"
    (Maybe Bool
anonymous :: Maybe Bool) <- Object
o Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "anonymous"
    (Maybe Object
custom :: Maybe (KeyMap Value)) <- Object
o Object -> Text -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "custom"
    (Maybe [Text]
privateAttributeNames :: Maybe [Text]) <- Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "privateAttributeNames"
    let context :: Context
context =
            Text -> Text -> Context
makeSingleContext Text
key "user"
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "secondary" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
secondary))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "ip" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
ip))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "country" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
country))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "email" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
email))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "firstName" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
firstName))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "lastName" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
lastName))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "avatar" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
avatar))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "name" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
name))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute "anonymous" (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Bool -> Value
Bool (Bool -> Value) -> Maybe Bool -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
anonymous))
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Set Reference -> Context -> Context
withPrivateAttributes ([Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList ([Reference] -> Set Reference) -> [Reference] -> Set Reference
forall a b. (a -> b) -> a -> b
$ (Text -> Reference) -> [Text] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeLiteral ([Text] -> [Reference]) -> [Text] -> [Reference]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
privateAttributeNames)
     in Context -> Parser Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Parser Context) -> Context -> Parser Context
forall a b. (a -> b) -> a -> b
$ (Text -> Value -> Context -> Context)
-> Context -> Object -> Context
forall v a. (Text -> v -> a -> a) -> a -> HashMap Text v -> a
foldrWithKey (\k :: Text
k v :: Value
v c :: Context
c -> Text -> Value -> Context -> Context
withAttribute Text
k Value
v Context
c) Context
context (Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
fromMaybe Object
forall v. KeyMap v
emptyObject Maybe Object
custom)

-- Internally used function to decode a JSON object using the new context
-- scheme into a modern single-kind context.
parseSingleContext :: Value -> Parser Context
parseSingleContext :: Value -> Parser Context
parseSingleContext = String -> (Object -> Parser Context) -> Value -> Parser Context
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "SingleContext" ((Object -> Parser Context) -> Value -> Parser Context)
-> (Object -> Parser Context) -> Value -> Parser Context
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> do
    (Text
key :: Text) <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "key"
    (Text
kind :: Text) <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "kind"
    (Maybe Object
meta :: Maybe (KeyMap Value)) <- Object
o Object -> Text -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "_meta"
    (Maybe [Text]
privateAttributes :: Maybe [Text]) <- (Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
fromMaybe Object
forall v. KeyMap v
emptyObject Maybe Object
meta) Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "privateAttributes"
    let context :: Context
context =
            Text -> Text -> Context
makeContext Text
key Text
kind
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Set Reference -> Context -> Context
withPrivateAttributes ([Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList ([Reference] -> Set Reference) -> [Reference] -> Set Reference
forall a b. (a -> b) -> a -> b
$ (Text -> Reference) -> [Text] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeReference ([Text] -> [Reference]) -> [Text] -> [Reference]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
privateAttributes)
     in Context -> Parser Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Parser Context) -> Context -> Parser Context
forall a b. (a -> b) -> a -> b
$ (Text -> Value -> Context -> Context)
-> Context -> Object -> Context
forall v a. (Text -> v -> a -> a) -> a -> HashMap Text v -> a
foldrWithKey (\k :: Text
k v :: Value
v c :: Context
c -> Text -> Value -> Context -> Context
withAttribute Text
k Value
v Context
c) Context
context Object
o

-- Internally used function to decode a JSON object using the new context
-- scheme into a modern multi-kind context.
parseMultiContext :: Value -> Parser Context
parseMultiContext :: Value -> Parser Context
parseMultiContext = String -> (Object -> Parser Context) -> Value -> Parser Context
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "MultiContext" ((Object -> Parser Context) -> Value -> Parser Context)
-> (Object -> Parser Context) -> Value -> Parser Context
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> do
    let contextLists :: [(Text, Value)]
contextLists = Object -> [(Text, Value)]
forall v. HashMap Text v -> [(Text, v)]
toList (Object -> [(Text, Value)]) -> Object -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Object
forall v. Text -> HashMap Text v -> HashMap Text v
deleteKey "kind" Object
o
        contextObjectLists :: [(Text, Object)]
contextObjectLists = ((Text, Value) -> Maybe (Text, Object))
-> [(Text, Value)] -> [(Text, Object)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(k :: Text
k, v :: Value
v) -> case (Text
k, Value
v) of (_, Object obj :: Object
obj) -> (Text, Object) -> Maybe (Text, Object)
forall a. a -> Maybe a
Just (Text
k, Object
obj); _ -> Maybe (Text, Object)
forall a. Maybe a
Nothing) [(Text, Value)]
contextLists
        results :: [Result Context]
results = ((Text, Object) -> Result Context)
-> [(Text, Object)] -> [Result Context]
forall a b. (a -> b) -> [a] -> [b]
map (\(kind :: Text
kind, obj :: Object
obj) -> Value -> Result Context
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result Context) -> Value -> Result Context
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall v. Text -> v -> HashMap Text v -> HashMap Text v
insertKey "kind" (Text -> Value
String Text
kind) Object
obj) [(Text, Object)]
contextObjectLists
        single :: [Context]
single = (Result Context -> Maybe Context) -> [Result Context] -> [Context]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\result :: Result Context
result -> case Result Context
result of Success r :: Context
r -> Context -> Maybe Context
forall a. a -> Maybe a
Just Context
r; _ -> Maybe Context
forall a. Maybe a
Nothing) [Result Context]
results
     in case ([(Text, Value)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Value)]
contextLists, [Context] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
single) of
            (a :: Int
a, b :: Int
b) | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
b -> Context -> Parser Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Parser Context) -> Context -> Parser Context
forall a b. (a -> b) -> a -> b
$ $WInvalid :: Text -> Context
Invalid {$sel:error:Single :: Text
error = "multi-kind context JSON contains non-single-kind contexts"}
            (_, _) -> Context -> Parser Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Parser Context) -> Context -> Parser Context
forall a b. (a -> b) -> a -> b
$ [Context] -> Context
makeMultiContext [Context]
single

-- Internally used function which performs context attribute redaction.
redactContext :: Config -> Context -> Value
redactContext :: Config -> Context -> Value
redactContext config :: Config
config context :: Context
context = Config -> Context -> Bool -> Value
internalRedactContext Config
config Context
context Bool
False

-- Internally used function which performs context attribute redaction.
--
-- If a provided context is anonymous, all attributes for that context will be
-- redacted.
redactContextRedactAnonymous :: Config -> Context -> Value
redactContextRedactAnonymous :: Config -> Context -> Value
redactContextRedactAnonymous config :: Config
config context :: Context
context = Config -> Context -> Bool -> Value
internalRedactContext Config
config Context
context Bool
True

internalRedactContext :: Config -> Context -> Bool -> Value
internalRedactContext :: Config -> Context -> Bool -> Value
internalRedactContext _ (Invalid _) _ = Value
Null
internalRedactContext config :: Config
config (Multi MultiContext {KeyMap SingleContext
contexts :: KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts}) redactAnonymous :: Bool
redactAnonymous =
    (SingleContext -> Value) -> KeyMap SingleContext -> Object
forall v1 v2. (v1 -> v2) -> HashMap Text v1 -> HashMap Text v2
mapValues (\context :: SingleContext
context -> Bool -> SingleContext -> Set Reference -> Value
redactSingleContext Bool
False SingleContext
context (Config -> SingleContext -> Bool -> Set Reference
getAllPrivateAttributes Config
config SingleContext
context Bool
redactAnonymous)) KeyMap SingleContext
contexts
        Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Text -> Value -> Object -> Object
forall v. Text -> v -> HashMap Text v -> HashMap Text v
insertKey "kind" "multi"
        Object -> (Object -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Object -> Value
Object
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Value -> Value
forall a. ToJSON a => a -> Value
toJSON
internalRedactContext config :: Config
config (Single context :: SingleContext
context) redactAnonymous :: Bool
redactAnonymous =
    Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> SingleContext -> Set Reference -> Value
redactSingleContext Bool
True SingleContext
context (Config -> SingleContext -> Bool -> Set Reference
getAllPrivateAttributes Config
config SingleContext
context Bool
redactAnonymous)

-- Apply redaction requirements to a SingleContext type.
redactSingleContext :: Bool -> SingleContext -> Set Reference -> Value
redactSingleContext :: Bool -> SingleContext -> Set Reference -> Value
redactSingleContext includeKind :: Bool
includeKind context :: SingleContext
context privateAttributes :: Set Reference
privateAttributes =
    let State {$sel:context:State :: State -> Object
context = Object
redactedContext, [Text]
$sel:redacted:State :: State -> [Text]
redacted :: [Text]
redacted} = (Reference -> State -> State) -> State -> Set Reference -> State
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Reference -> State -> State
applyRedaction $WState :: Object -> [Text] -> State
State {$sel:context:State :: Object
context = [(Text, Value)] -> Object
forall v. [(Text, v)] -> KeyMap v
fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ SingleContext -> [(Text, Value)]
getMapOfRedactableProperties SingleContext
context, $sel:redacted:State :: [Text]
redacted = []} Set Reference
privateAttributes
        redactedValues :: Value
redactedValues = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Item Array] -> Array
forall l. IsList l => [Item l] -> l
Exts.fromList ([Item Array] -> Array) -> [Item Array] -> Array
forall a b. (a -> b) -> a -> b
$ (Text -> Value) -> [Text] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Value
String [Text]
redacted
        required :: Object
required = [(Text, Value)] -> Object
forall v. [(Text, v)] -> KeyMap v
fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ Bool -> SingleContext -> [(Text, Value)]
getMapOfRequiredProperties Bool
includeKind SingleContext
context
     in case [Text]
redacted of
            [] -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object -> Object -> Object
forall v. HashMap Text v -> HashMap Text v -> HashMap Text v
keyMapUnion Object
redactedContext Object
required
            _ -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object -> Object -> Object
forall v. HashMap Text v -> HashMap Text v -> HashMap Text v
keyMapUnion Object
redactedContext (Text -> Value -> Object -> Object
forall v. Text -> v -> HashMap Text v -> HashMap Text v
insertKey "_meta" (Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall v. Text -> v -> HashMap Text v
singleton "redactedAttributes" Value
redactedValues) Object
required)

-- Internally used convenience function for creating a Set of References which
-- can redact all top level values in a provided context.
--
-- Given the context:
-- {
--      "kind": "user",
--      "key": "user-key",
--      "name": "Sandy",
--      "address": {
--          "city": "Chicago"
--      }
-- }
--
-- getAllTopLevelRedactableNames context would yield the set ["name",
-- "address"].
getAllTopLevelRedactableNames :: SingleContext -> Set Reference
getAllTopLevelRedactableNames :: SingleContext -> Set Reference
getAllTopLevelRedactableNames SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Maybe Text
Nothing, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Maybe Object
Nothing} = Set Reference
forall a. Set a
S.empty
getAllTopLevelRedactableNames SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just _, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Maybe Object
Nothing} = Reference -> Set Reference
forall a. a -> Set a
S.singleton (Reference -> Set Reference) -> Reference -> Set Reference
forall a b. (a -> b) -> a -> b
$ Text -> Reference
R.makeLiteral "name"
getAllTopLevelRedactableNames SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Maybe Text
Nothing, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Just attrs :: Object
attrs} = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList ([Reference] -> Set Reference) -> [Reference] -> Set Reference
forall a b. (a -> b) -> a -> b
$ (Text -> Reference) -> [Text] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeLiteral ([Text] -> [Reference]) -> [Text] -> [Reference]
forall a b. (a -> b) -> a -> b
$ Object -> [Text]
forall v. HashMap Text v -> [Text]
objectKeys Object
attrs
getAllTopLevelRedactableNames SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just _, $sel:attributes:SingleContext :: SingleContext -> Maybe Object
attributes = Just attrs :: Object
attrs} = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
S.fromList ([Reference] -> Set Reference) -> [Reference] -> Set Reference
forall a b. (a -> b) -> a -> b
$ (Text -> Reference
R.makeLiteral "name") Reference -> [Reference] -> [Reference]
forall a. a -> [a] -> [a]
: ((Text -> Reference) -> [Text] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeLiteral ([Text] -> [Reference]) -> [Text] -> [Reference]
forall a b. (a -> b) -> a -> b
$ Object -> [Text]
forall v. HashMap Text v -> [Text]
objectKeys Object
attrs)

-- Internally used convenience function to return a set of references which
-- would apply all redaction rules.
--
-- This will return a set which covers the entire context if:
--
-- 1. The allAttributesPrivate config value is set to True, or
-- 2. Anonymous attribute redaction is requested and the context is anonymous.
getAllPrivateAttributes :: Config -> SingleContext -> Bool -> Set Reference
getAllPrivateAttributes :: Config -> SingleContext -> Bool -> Set Reference
getAllPrivateAttributes (forall a s. HasField' "allAttributesPrivate" s a => s -> a
forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"allAttributesPrivate" -> Bool
True) context :: SingleContext
context _ = SingleContext -> Set Reference
getAllTopLevelRedactableNames SingleContext
context
getAllPrivateAttributes _ context :: SingleContext
context@(SingleContext {$sel:anonymous:SingleContext :: SingleContext -> Bool
anonymous = Bool
True}) True = SingleContext -> Set Reference
getAllTopLevelRedactableNames SingleContext
context
getAllPrivateAttributes config :: Config
config SingleContext {$sel:privateAttributes:SingleContext :: SingleContext -> Maybe (Set Reference)
privateAttributes = Maybe (Set Reference)
Nothing} _ = Config -> Set Reference
forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"privateAttributeNames" Config
config
getAllPrivateAttributes config :: Config
config SingleContext {$sel:privateAttributes:SingleContext :: SingleContext -> Maybe (Set Reference)
privateAttributes = Just attrs :: Set Reference
attrs} _ = Set Reference -> Set Reference -> Set Reference
forall a. Ord a => Set a -> Set a -> Set a
S.union (Config -> Set Reference
forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"privateAttributeNames" Config
config) Set Reference
attrs

-- Internally used storage type for returning both the resulting redacted
-- context and the list of any attributes which were redacted.
data State = State
    { State -> Object
context :: KeyMap Value
    , State -> [Text]
redacted :: ![Text]
    }

-- Internally used store type for managing some state while the redaction
-- process is recursing.
data RedactState = RedactState
    { RedactState -> Object
context :: KeyMap Value
    , RedactState -> Reference
reference :: Reference
    , RedactState -> [Text]
redacted :: ![Text]
    }

-- Kick off the redaction process by priming the recursive redaction state.
applyRedaction :: Reference -> State -> State
applyRedaction :: Reference -> State -> State
applyRedaction reference :: Reference
reference State {Object
context :: Object
$sel:context:State :: State -> Object
context, [Text]
redacted :: [Text]
$sel:redacted:State :: State -> [Text]
redacted} =
    let (RedactState {$sel:context:RedactState :: RedactState -> Object
context = Object
c, $sel:redacted:RedactState :: RedactState -> [Text]
redacted = [Text]
r}) = [Text] -> Int -> RedactState -> RedactState
redactComponents (Reference -> [Text]
R.getComponents Reference
reference) 0 $WRedactState :: Object -> Reference -> [Text] -> RedactState
RedactState {Object
context :: Object
$sel:context:RedactState :: Object
context, [Text]
redacted :: [Text]
$sel:redacted:RedactState :: [Text]
redacted, Reference
reference :: Reference
$sel:reference:RedactState :: Reference
reference}
     in $WState :: Object -> [Text] -> State
State {$sel:context:State :: Object
context = Object
c, $sel:redacted:State :: [Text]
redacted = [Text]
r}

-- Recursively apply redaction rules
redactComponents :: [Text] -> Int -> RedactState -> RedactState
-- If there are no components left to explore, then we can just return the
-- current state of things. This branch should never actually execute.
-- References aren't valid if there isn't at least one component, and we don't
-- recurse in the single component case. We just include it here for
-- completeness.
redactComponents :: [Text] -> Int -> RedactState -> RedactState
redactComponents [] _ state :: RedactState
state = RedactState
state
-- kind, key, and anonymous are top level attributes that cannot be redacted.
redactComponents ["kind"] 0 state :: RedactState
state = RedactState
state
redactComponents ["key"] 0 state :: RedactState
state = RedactState
state
redactComponents ["anonymous"] 0 state :: RedactState
state = RedactState
state
-- If we have a single component, then we are either trying to redact a simple
-- top level item, or we have recursed through all reference component parts
-- until the last one. We determine which of those situations we are in through
-- use of the 'level' parameter. 'level' = 0 means we are at the top level of
-- the call stack.
--
-- If we have a single component and we have found it in the current context
-- map, then we know we can redact it.
--
-- If we do not find it in the context, but we are at the top level (and thus
-- making a simple redaction), we consider that a successful redaction.
--
-- Otherwise, if there is no match and we aren't at the top level, the
-- redaction has failed and so we can just return the current state unmodified.
redactComponents [x :: Text
x] level :: Int
level state :: RedactState
state@(RedactState {Object
context :: Object
$sel:context:RedactState :: RedactState -> Object
context, Reference
reference :: Reference
$sel:reference:RedactState :: RedactState -> Reference
reference, [Text]
redacted :: [Text]
$sel:redacted:RedactState :: RedactState -> [Text]
redacted}) = case (Int
level, Text -> Object -> Maybe Value
forall v. Text -> HashMap Text v -> Maybe v
lookupKey Text
x Object
context) of
    (_, Just _) -> RedactState
state {$sel:context:RedactState :: Object
context = Text -> Object -> Object
forall v. Text -> HashMap Text v -> HashMap Text v
deleteKey Text
x Object
context, $sel:redacted:RedactState :: [Text]
redacted = (Reference -> Text
R.getRawPath Reference
reference) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
redacted}
    (0, _) -> RedactState
state {$sel:redacted:RedactState :: [Text]
redacted = (Reference -> Text
R.getRawPath Reference
reference) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
redacted}
    _ -> RedactState
state
redactComponents (x :: Text
x : xs :: [Text]
xs) level :: Int
level state :: RedactState
state@(RedactState {Object
context :: Object
$sel:context:RedactState :: RedactState -> Object
context}) = case Text -> Object -> Maybe Value
forall v. Text -> HashMap Text v -> Maybe v
lookupKey Text
x Object
context of
    Just (Object o :: Object
o) ->
        let substate :: RedactState
substate@(RedactState {$sel:context:RedactState :: RedactState -> Object
context = Object
subcontext}) = [Text] -> Int -> RedactState -> RedactState
redactComponents [Text]
xs (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (RedactState
state {$sel:context:RedactState :: Object
context = Object
o})
         in RedactState
substate {$sel:context:RedactState :: Object
context = Text -> Value -> Object -> Object
forall v. Text -> v -> HashMap Text v -> HashMap Text v
insertKey Text
x (Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
subcontext) Object
context}
    _ -> RedactState
state