{-# 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
$cfrom :: forall x. Context -> Rep Context x
from :: forall x. Context -> Rep Context x
$cto :: forall x. Rep Context x -> Context
to :: forall x. Rep Context x -> Context
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
$cshowsPrec :: Int -> Context -> ShowS
showsPrec :: Int -> Context -> ShowS
$cshow :: Context -> String
show :: Context -> String
$cshowList :: [Context] -> ShowS
showList :: [Context] -> ShowS
Show, Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
/= :: Context -> Context -> Bool
Eq)

instance ToJSON Context where
    toJSON :: Context -> Value
toJSON (Single SingleContext
c) = SingleContext -> Value
forall a. ToJSON a => a -> Value
toJSON SingleContext
c
    toJSON (Multi MultiContext
c) = MultiContext -> Value
forall a. ToJSON a => a -> Value
toJSON MultiContext
c
    toJSON (Invalid 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 KeyMap Value
o) =
        case Text -> KeyMap Value -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
lookupKey Text
"kind" KeyMap Value
o of
            Maybe Value
Nothing -> Value -> Parser Context
parseLegacyUser Value
a
            Just (String Text
"multi") -> Value -> Parser Context
parseMultiContext Value
a
            Just Value
_ -> Value -> Parser Context
parseSingleContext Value
a
    parseJSON Value
invalid = String -> Parser Context -> Parser Context
forall a. String -> Parser a -> Parser a
prependFailure String
"parsing Context failed, " (String -> Value -> Parser Context
forall a. String -> Value -> Parser a
typeMismatch String
"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 (KeyMap Value)
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
$cfrom :: forall x. SingleContext -> Rep SingleContext x
from :: forall x. SingleContext -> Rep SingleContext x
$cto :: forall x. Rep SingleContext x -> SingleContext
to :: forall x. Rep SingleContext x -> SingleContext
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
$cshowsPrec :: Int -> SingleContext -> ShowS
showsPrec :: Int -> SingleContext -> ShowS
$cshow :: SingleContext -> String
show :: SingleContext -> String
$cshowList :: [SingleContext] -> ShowS
showList :: [SingleContext] -> ShowS
Show, SingleContext -> SingleContext -> Bool
(SingleContext -> SingleContext -> Bool)
-> (SingleContext -> SingleContext -> Bool) -> Eq SingleContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SingleContext -> SingleContext -> Bool
== :: SingleContext -> SingleContext -> Bool
$c/= :: SingleContext -> SingleContext -> Bool
/= :: 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
$cfrom :: forall x. MultiContext -> Rep MultiContext x
from :: forall x. MultiContext -> Rep MultiContext x
$cto :: forall x. Rep MultiContext x -> MultiContext
to :: forall x. Rep MultiContext x -> MultiContext
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
$cshowsPrec :: Int -> MultiContext -> ShowS
showsPrec :: Int -> MultiContext -> ShowS
$cshow :: MultiContext -> String
show :: MultiContext -> String
$cshowList :: [MultiContext] -> ShowS
showList :: [MultiContext] -> ShowS
Show, MultiContext -> MultiContext -> Bool
(MultiContext -> MultiContext -> Bool)
-> (MultiContext -> MultiContext -> Bool) -> Eq MultiContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MultiContext -> MultiContext -> Bool
== :: MultiContext -> MultiContext -> Bool
$c/= :: MultiContext -> MultiContext -> Bool
/= :: MultiContext -> MultiContext -> Bool
Eq)

instance ToJSON MultiContext where
    toJSON :: MultiContext -> Value
toJSON (MultiContext {KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts :: KeyMap SingleContext
contexts}) =
        (SingleContext -> Value) -> KeyMap SingleContext -> KeyMap Value
forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\SingleContext
c -> Bool -> SingleContext -> Value
toJsonObject Bool
False SingleContext
c) KeyMap SingleContext
contexts
            KeyMap Value -> (KeyMap Value -> KeyMap Value) -> KeyMap Value
forall a b. a -> (a -> b) -> b
& Text -> Value -> KeyMap Value -> KeyMap Value
forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"kind" Value
"multi"
            KeyMap Value -> (KeyMap Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& KeyMap Value -> 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 Text
"" Text
_ = Invalid {$sel:error:Single :: Text
error = Text
"context key must not be empty"}
makeContext Text
key 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 Text
_ Text
"" = Invalid {$sel:error:Single :: Text
error = Text
"context kind must not be empty"}
makeSingleContext Text
_ Text
"kind" = Invalid {$sel:error:Single :: Text
error = Text
"context kind cannot be 'kind'"}
makeSingleContext Text
_ Text
"multi" = Invalid {$sel:error:Single :: Text
error = Text
"context kind cannot be 'multi'"}
makeSingleContext Text
key Text
kind
    | ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a' .. Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'.', Char
'-', Char
'_']) (Text -> String
unpack Text
kind)) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False = Invalid {$sel:error:Single :: Text
error = Text
"context kind contains disallowed characters"}
    | Bool
otherwise =
        SingleContext -> Context
Single
            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 (KeyMap Value)
attributes = Maybe (KeyMap Value)
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 [] = Invalid {$sel:error:Single :: Text
error = Text
"multi-kind contexts require at least one single-kind context"}
makeMultiContext [c :: Context
c@(Single SingleContext
_)] = Context
c
makeMultiContext [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 (\SingleContext
lhs 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
contexts, [SingleContext] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SingleContext]
singleContexts, HashSet Text -> Int
forall a. HashSet a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HashSet Text
kinds) of
            (Int
a, Int
b, Int
_) | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
b -> Invalid {$sel:error:Single :: Text
error = Text
"multi-kind contexts can only contain single-kind contexts"}
            (Int
a, Int
_, Int
c) | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
c -> Invalid {$sel:error:Single :: Text
error = Text
"multi-kind contexts cannot contain two single-kind contexts with the same kind"}
            (Int, Int, Int)
_ ->
                MultiContext -> Context
Multi
                    MultiContext
                        { $sel:fullKey:MultiContext :: Text
fullKey = Text -> [Text] -> Text
intercalate Text
":" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (SingleContext -> Text) -> [SingleContext] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\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 (\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 Text
name (Single SingleContext
c) = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ 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 Text
_ 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 Bool
anonymous (Single SingleContext
c) = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"anonymous" Bool
anonymous SingleContext
c
withAnonymous Bool
_ 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 Text
"key" Value
_ Context
c = Context
c
withAttribute Text
"kind" Value
_ Context
c = Context
c
withAttribute Text
"name" (String Text
value) Context
c = Text -> Context -> Context
withName Text
value Context
c
withAttribute Text
"name" Value
Null (Single SingleContext
c) = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {name = Nothing}
withAttribute Text
"name" Value
_ Context
c = Context
c
withAttribute Text
"anonymous" (Bool Bool
value) Context
c = Bool -> Context -> Context
withAnonymous Bool
value Context
c
withAttribute Text
"anonymous" Value
_ Context
c = Context
c
withAttribute Text
"_meta" Value
_ Context
c = Context
c
withAttribute Text
"privateAttributeNames" Value
_ Context
c = Context
c
withAttribute Text
_ Value
Null c :: Context
c@(Single SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Maybe (KeyMap Value)
Nothing}) = Context
c
withAttribute Text
attr Value
value (Single c :: SingleContext
c@(SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Maybe (KeyMap Value)
Nothing})) =
    SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {attributes = Just $ singleton attr value}
withAttribute Text
attr Value
Null (Single c :: SingleContext
c@(SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Just KeyMap Value
attrs})) =
    SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {attributes = Just $ deleteKey attr attrs}
withAttribute Text
attr Value
value (Single c :: SingleContext
c@(SingleContext {$sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Just KeyMap Value
attrs})) =
    SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {attributes = Just $ insertKey attr value attrs}
withAttribute Text
_ Value
_ 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 Set Reference
attrs (Single 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 {privateAttributes = Nothing}
    | Bool
otherwise = SingleContext -> Context
Single (SingleContext -> Context) -> SingleContext -> Context
forall a b. (a -> b) -> a -> b
$ SingleContext
c {privateAttributes = Just attrs}
withPrivateAttributes Set Reference
_ 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 Text
key Text
"user" = Text
key
canonicalizeKey Text
key Text
kind = Text
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
"%" Text
"%25" Text
key Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
":" Text
"%3A")

unwrapSingleContext :: Context -> Maybe SingleContext
unwrapSingleContext :: Context -> Maybe SingleContext
unwrapSingleContext (Single SingleContext
c) = SingleContext -> Maybe SingleContext
forall a. a -> Maybe a
Just SingleContext
c
unwrapSingleContext Context
_ = 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 SingleContext
c) = SingleContext -> Text
key SingleContext
c
getKey Context
_ = Text
""

-- 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 SingleContext
c) = Text -> Text -> KeyMap Text
forall v. Text -> v -> KeyMap v
singleton (SingleContext -> Text
kind SingleContext
c) (SingleContext -> Text
key SingleContext
c)
getKeys (Multi (MultiContext {KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts :: KeyMap SingleContext
contexts})) = (SingleContext -> Text) -> KeyMap SingleContext -> KeyMap Text
forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues SingleContext -> Text
key KeyMap SingleContext
contexts
getKeys Context
_ = 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 SingleContext
c) = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"fullKey" SingleContext
c
getCanonicalKey (Multi MultiContext
c) = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"fullKey" MultiContext
c
getCanonicalKey Context
_ = Text
""

-- 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 SingleContext
c) = [SingleContext -> Text
kind SingleContext
c]
getKinds (Multi (MultiContext {KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts :: KeyMap SingleContext
contexts})) = KeyMap SingleContext -> [Text]
forall v. KeyMap v -> [Text]
objectKeys KeyMap SingleContext
contexts
getKinds Context
_ = []

-- 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 Bool
includeKind SingleContext
context =
    KeyMap Value -> Value
Object (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> KeyMap Value
forall v. [(Text, v)] -> KeyMap v
fromList ([(Text, Value)] -> KeyMap Value)
-> [(Text, Value)] -> KeyMap Value
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 (KeyMap Value)
attributes = Maybe (KeyMap Value)
Nothing}) = []
getMapOfRedactableProperties (SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Maybe Text
Nothing, $sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Just KeyMap Value
attrs}) = KeyMap Value -> [(Text, Value)]
forall v. KeyMap v -> [(Text, v)]
toList KeyMap Value
attrs
getMapOfRedactableProperties (SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just Text
n, $sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Just KeyMap Value
attrs}) = (Text
"name", Text -> Value
String Text
n) (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
: (KeyMap Value -> [(Text, Value)]
forall v. KeyMap v -> [(Text, v)]
toList KeyMap Value
attrs)
getMapOfRedactableProperties (SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just Text
n, $sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Maybe (KeyMap Value)
Nothing}) = [(Text
"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 Bool
includeKind SingleContext {Text
$sel:key:SingleContext :: SingleContext -> Text
key :: Text
key, Text
$sel:kind:SingleContext :: SingleContext -> Text
kind :: Text
kind, Bool
$sel:anonymous:SingleContext :: SingleContext -> Bool
anonymous :: Bool
anonymous, Maybe (Set Reference)
$sel:privateAttributes:SingleContext :: SingleContext -> Maybe (Set Reference)
privateAttributes :: 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)
        [ (Text
"key", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
key)
        , (Text
"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)
        , (Text
"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)
        , (Text
"_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)
        ,
            ( Text
"_meta"
            , case Maybe (Set Reference)
privateAttributes of
                Maybe (Set Reference)
Nothing -> Value
Null
                Just Set Reference
attrs -> KeyMap Value -> Value
forall a. ToJSON a => a -> Value
toJSON (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> KeyMap Value
forall v. Text -> v -> KeyMap v
singleton Text
"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 -> Item Array) -> [Reference] -> [Item Array]
forall a b. (a -> b) -> [a] -> [b]
map Reference -> Value
Reference -> Item Array
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
-> (KeyMap Value -> Parser Context) -> Value -> Parser Context
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"LegacyUser" ((KeyMap Value -> Parser Context) -> Value -> Parser Context)
-> (KeyMap Value -> Parser Context) -> Value -> Parser Context
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
o -> do
    (Text
key :: Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser Text
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"key"
    (Maybe Text
secondary :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"secondary"
    (Maybe Text
ip :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"ip"
    (Maybe Text
country :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"country"
    (Maybe Text
email :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"email"
    (Maybe Text
firstName :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"firstName"
    (Maybe Text
lastName :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"lastName"
    (Maybe Text
avatar :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"avatar"
    (Maybe Text
name :: Maybe Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"name"
    (Maybe Bool
anonymous :: Maybe Bool) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"anonymous"
    (Maybe (KeyMap Value)
custom :: Maybe (KeyMap Value)) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe (KeyMap Value))
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"custom"
    (Maybe [Text]
privateAttributeNames :: Maybe [Text]) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"privateAttributeNames"
    let context :: Context
context =
            Text -> Text -> Context
makeSingleContext Text
key Text
"user"
                Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"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 Text
"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 Text
"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 Text
"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 Text
"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 Text
"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 Text
"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 Text
"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 Text
"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 a. a -> Parser a
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 -> KeyMap Value -> Context
forall v a. (Text -> v -> a -> a) -> a -> KeyMap v -> a
foldrWithKey (\Text
k Value
v Context
c -> Text -> Value -> Context -> Context
withAttribute Text
k Value
v Context
c) Context
context (KeyMap Value -> Maybe (KeyMap Value) -> KeyMap Value
forall a. a -> Maybe a -> a
fromMaybe KeyMap Value
forall v. KeyMap v
emptyObject Maybe (KeyMap Value)
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
-> (KeyMap Value -> Parser Context) -> Value -> Parser Context
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"SingleContext" ((KeyMap Value -> Parser Context) -> Value -> Parser Context)
-> (KeyMap Value -> Parser Context) -> Value -> Parser Context
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
o -> do
    (Text
key :: Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser Text
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"key"
    (Text
kind :: Text) <- KeyMap Value
o KeyMap Value -> Key -> Parser Text
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"kind"
    (Maybe (KeyMap Value)
meta :: Maybe (KeyMap Value)) <- KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe (KeyMap Value))
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"_meta"
    (Maybe [Text]
privateAttributes :: Maybe [Text]) <- (KeyMap Value -> Maybe (KeyMap Value) -> KeyMap Value
forall a. a -> Maybe a -> a
fromMaybe KeyMap Value
forall v. KeyMap v
emptyObject Maybe (KeyMap Value)
meta) KeyMap Value -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"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 a. a -> Parser a
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 -> KeyMap Value -> Context
forall v a. (Text -> v -> a -> a) -> a -> KeyMap v -> a
foldrWithKey (\Text
k Value
v Context
c -> Text -> Value -> Context -> Context
withAttribute Text
k Value
v Context
c) Context
context KeyMap Value
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
-> (KeyMap Value -> Parser Context) -> Value -> Parser Context
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"MultiContext" ((KeyMap Value -> Parser Context) -> Value -> Parser Context)
-> (KeyMap Value -> Parser Context) -> Value -> Parser Context
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
o -> do
    let contextLists :: [(Text, Value)]
contextLists = KeyMap Value -> [(Text, Value)]
forall v. KeyMap v -> [(Text, v)]
toList (KeyMap Value -> [(Text, Value)])
-> KeyMap Value -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ Text -> KeyMap Value -> KeyMap Value
forall v. Text -> KeyMap v -> KeyMap v
deleteKey Text
"kind" KeyMap Value
o
        contextObjectLists :: [(Text, KeyMap Value)]
contextObjectLists = ((Text, Value) -> Maybe (Text, KeyMap Value))
-> [(Text, Value)] -> [(Text, KeyMap Value)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Text
k, Value
v) -> case (Text
k, Value
v) of (Text
_, Object KeyMap Value
obj) -> (Text, KeyMap Value) -> Maybe (Text, KeyMap Value)
forall a. a -> Maybe a
Just (Text
k, KeyMap Value
obj); (Text, Value)
_ -> Maybe (Text, KeyMap Value)
forall a. Maybe a
Nothing) [(Text, Value)]
contextLists
        results :: [Result Context]
results = ((Text, KeyMap Value) -> Result Context)
-> [(Text, KeyMap Value)] -> [Result Context]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
kind, KeyMap Value
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
$ KeyMap Value -> Value
Object (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> KeyMap Value -> KeyMap Value
forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"kind" (Text -> Value
String Text
kind) KeyMap Value
obj) [(Text, KeyMap Value)]
contextObjectLists
        single :: [Context]
single = (Result Context -> Maybe Context) -> [Result Context] -> [Context]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Result Context
result -> case Result Context
result of Success Context
r -> Context -> Maybe Context
forall a. a -> Maybe a
Just Context
r; Result Context
_ -> Maybe Context
forall a. Maybe a
Nothing) [Result Context]
results
     in case ([(Text, Value)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Value)]
contextLists, [Context] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
single) of
            (Int
a, Int
b) | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
b -> Context -> Parser Context
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Parser Context) -> Context -> Parser Context
forall a b. (a -> b) -> a -> b
$ Invalid {$sel:error:Single :: Text
error = Text
"multi-kind context JSON contains non-single-kind contexts"}
            (Int
_, Int
_) -> Context -> Parser Context
forall a. a -> Parser a
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 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 Context
context = Config -> Context -> Bool -> Value
internalRedactContext Config
config Context
context Bool
True

internalRedactContext :: Config -> Context -> Bool -> Value
internalRedactContext :: Config -> Context -> Bool -> Value
internalRedactContext Config
_ (Invalid Text
_) Bool
_ = Value
Null
internalRedactContext Config
config (Multi MultiContext {KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts :: KeyMap SingleContext
contexts}) Bool
redactAnonymous =
    (SingleContext -> Value) -> KeyMap SingleContext -> KeyMap Value
forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\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
        KeyMap Value -> (KeyMap Value -> KeyMap Value) -> KeyMap Value
forall a b. a -> (a -> b) -> b
& Text -> Value -> KeyMap Value -> KeyMap Value
forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"kind" Value
"multi"
        KeyMap Value -> (KeyMap Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& KeyMap Value -> 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 (Single SingleContext
context) 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 Bool
includeKind SingleContext
context Set Reference
privateAttributes =
    let State {$sel:context:State :: State -> KeyMap Value
context = KeyMap Value
redactedContext, [Text]
redacted :: [Text]
$sel:redacted:State :: State -> [Text]
redacted} = (Reference -> State -> State) -> State -> Set Reference -> State
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Reference -> State -> State
applyRedaction State {$sel:context:State :: KeyMap Value
context = [(Text, Value)] -> KeyMap Value
forall v. [(Text, v)] -> KeyMap v
fromList ([(Text, Value)] -> KeyMap Value)
-> [(Text, Value)] -> KeyMap Value
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 :: KeyMap Value
required = [(Text, Value)] -> KeyMap Value
forall v. [(Text, v)] -> KeyMap v
fromList ([(Text, Value)] -> KeyMap Value)
-> [(Text, Value)] -> KeyMap Value
forall a b. (a -> b) -> a -> b
$ Bool -> SingleContext -> [(Text, Value)]
getMapOfRequiredProperties Bool
includeKind SingleContext
context
     in case [Text]
redacted of
            [] -> KeyMap Value -> Value
Object (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion KeyMap Value
redactedContext KeyMap Value
required
            [Text]
_ -> KeyMap Value -> Value
Object (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion KeyMap Value
redactedContext (Text -> Value -> KeyMap Value -> KeyMap Value
forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"_meta" (KeyMap Value -> Value
Object (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> KeyMap Value
forall v. Text -> v -> KeyMap v
singleton Text
"redactedAttributes" Value
redactedValues) KeyMap Value
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 (KeyMap Value)
attributes = Maybe (KeyMap Value)
Nothing} = Set Reference
forall a. Set a
S.empty
getAllTopLevelRedactableNames SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just Text
_, $sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Maybe (KeyMap Value)
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 Text
"name"
getAllTopLevelRedactableNames SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Maybe Text
Nothing, $sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Just KeyMap Value
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
$ KeyMap Value -> [Text]
forall v. KeyMap v -> [Text]
objectKeys KeyMap Value
attrs
getAllTopLevelRedactableNames SingleContext {$sel:name:SingleContext :: SingleContext -> Maybe Text
name = Just Text
_, $sel:attributes:SingleContext :: SingleContext -> Maybe (KeyMap Value)
attributes = Just KeyMap Value
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 Text
"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
$ KeyMap Value -> [Text]
forall v. KeyMap v -> [Text]
objectKeys KeyMap Value
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 (f :: Symbol) a s. HasField' f s a => s -> a
getField @"allAttributesPrivate" -> Bool
True) SingleContext
context Bool
_ = SingleContext -> Set Reference
getAllTopLevelRedactableNames SingleContext
context
getAllPrivateAttributes Config
_ context :: SingleContext
context@(SingleContext {$sel:anonymous:SingleContext :: SingleContext -> Bool
anonymous = Bool
True}) Bool
True = SingleContext -> Set Reference
getAllTopLevelRedactableNames SingleContext
context
getAllPrivateAttributes Config
config SingleContext {$sel:privateAttributes:SingleContext :: SingleContext -> Maybe (Set Reference)
privateAttributes = Maybe (Set Reference)
Nothing} Bool
_ = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"privateAttributeNames" Config
config
getAllPrivateAttributes Config
config SingleContext {$sel:privateAttributes:SingleContext :: SingleContext -> Maybe (Set Reference)
privateAttributes = Just Set Reference
attrs} Bool
_ = Set Reference -> Set Reference -> Set Reference
forall a. Ord a => Set a -> Set a -> Set a
S.union (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 -> KeyMap Value
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 -> KeyMap Value
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 State {KeyMap Value
$sel:context:State :: State -> KeyMap Value
context :: KeyMap Value
context, [Text]
$sel:redacted:State :: State -> [Text]
redacted :: [Text]
redacted} =
    let (RedactState {$sel:context:RedactState :: RedactState -> KeyMap Value
context = KeyMap Value
c, $sel:redacted:RedactState :: RedactState -> [Text]
redacted = [Text]
r}) = [Text] -> Int -> RedactState -> RedactState
redactComponents (Reference -> [Text]
R.getComponents Reference
reference) Int
0 RedactState {KeyMap Value
$sel:context:RedactState :: KeyMap Value
context :: KeyMap Value
context, [Text]
$sel:redacted:RedactState :: [Text]
redacted :: [Text]
redacted, Reference
$sel:reference:RedactState :: Reference
reference :: Reference
reference}
     in State {$sel:context:State :: KeyMap Value
context = KeyMap Value
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 [] Int
_ RedactState
state = RedactState
state
-- kind, key, and anonymous are top level attributes that cannot be redacted.
redactComponents [Text
"kind"] Int
0 RedactState
state = RedactState
state
redactComponents [Text
"key"] Int
0 RedactState
state = RedactState
state
redactComponents [Text
"anonymous"] Int
0 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 [Text
x] Int
level state :: RedactState
state@(RedactState {KeyMap Value
$sel:context:RedactState :: RedactState -> KeyMap Value
context :: KeyMap Value
context, Reference
$sel:reference:RedactState :: RedactState -> Reference
reference :: Reference
reference, [Text]
$sel:redacted:RedactState :: RedactState -> [Text]
redacted :: [Text]
redacted}) = case (Int
level, Text -> KeyMap Value -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
lookupKey Text
x KeyMap Value
context) of
    (Int
_, Just Value
_) -> RedactState
state {context = deleteKey x context, redacted = (R.getRawPath reference) : redacted}
    (Int
0, Maybe Value
_) -> RedactState
state {redacted = (R.getRawPath reference) : redacted}
    (Int, Maybe Value)
_ -> RedactState
state
redactComponents (Text
x : [Text]
xs) Int
level state :: RedactState
state@(RedactState {KeyMap Value
$sel:context:RedactState :: RedactState -> KeyMap Value
context :: KeyMap Value
context}) = case Text -> KeyMap Value -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
lookupKey Text
x KeyMap Value
context of
    Just (Object KeyMap Value
o) ->
        let substate :: RedactState
substate@(RedactState {$sel:context:RedactState :: RedactState -> KeyMap Value
context = KeyMap Value
subcontext}) = [Text] -> Int -> RedactState -> RedactState
redactComponents [Text]
xs (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (RedactState
state {context = o})
         in RedactState
substate {context = insertKey x (Object $ subcontext) context}
    Maybe Value
_ -> RedactState
state