{-# 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
    )
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 Data.Vector as V
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. 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
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
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 SingleContext
c) = forall a. ToJSON a => a -> Value
toJSON SingleContext
c
    toJSON (Multi MultiContext
c) = forall a. ToJSON a => a -> Value
toJSON MultiContext
c
    toJSON (Invalid Text
c) = 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 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 = forall a. String -> Parser a -> Parser a
prependFailure String
"parsing Context failed, " (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. 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
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
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. 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
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
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}) =
        forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\SingleContext
c -> Bool -> SingleContext -> Value
toJsonObject Bool
False SingleContext
c) KeyMap SingleContext
contexts
            forall a b. a -> (a -> b) -> b
& forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"kind" Value
"multi"
            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
    | (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a' .. Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'] forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char
'.', Char
'-', Char
'_']) (Text -> String
unpack Text
kind)) 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 = forall a. Maybe a
Nothing
                , $sel:anonymous:SingleContext :: Bool
anonymous = Bool
False
                , $sel:attributes:SingleContext :: Maybe (KeyMap Value)
attributes = forall a. Maybe a
Nothing
                , $sel:privateAttributes:SingleContext :: Maybe (Set Reference)
privateAttributes = 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Context -> Maybe SingleContext
unwrapSingleContext [Context]
contexts
        sorted :: [SingleContext]
sorted = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\SingleContext
lhs SingleContext
rhs -> forall a. Ord a => a -> a -> Ordering
compare (SingleContext -> Text
kind SingleContext
lhs) (SingleContext -> Text
kind SingleContext
rhs)) [SingleContext]
singleContexts
        kinds :: HashSet Text
kinds = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SingleContext -> Text
kind [SingleContext]
singleContexts
     in case (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
contexts, forall (t :: * -> *) a. Foldable t => t a -> Int
length [SingleContext]
singleContexts, forall (t :: * -> *) a. Foldable t => t a -> Int
length HashSet Text
kinds) of
            (Int
a, Int
b, Int
_) | Int
a 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 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
":" forall a b. (a -> b) -> a -> b
$ 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 = forall v. [(Text, v)] -> KeyMap v
fromList forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) s a. HasField' f s a => a -> s -> s
setField @"name" (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 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 forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:name:SingleContext :: Maybe Text
name = forall a. Maybe a
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 forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:attributes:SingleContext :: Maybe (KeyMap Value)
attributes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall v. Text -> v -> KeyMap v
singleton Text
attr Value
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 forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:attributes:SingleContext :: Maybe (KeyMap Value)
attributes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall v. Text -> KeyMap v -> KeyMap v
deleteKey Text
attr KeyMap Value
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 forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:attributes:SingleContext :: Maybe (KeyMap Value)
attributes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
attr Value
value KeyMap 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)
    | forall a. Set a -> Bool
S.null Set Reference
attrs = SingleContext -> Context
Single forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:privateAttributes:SingleContext :: Maybe (Set Reference)
privateAttributes = forall a. Maybe a
Nothing}
    | Bool
otherwise = SingleContext -> Context
Single forall a b. (a -> b) -> a -> b
$ SingleContext
c {$sel:privateAttributes:SingleContext :: Maybe (Set Reference)
privateAttributes = forall a. a -> Maybe a
Just Set Reference
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 forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Text -> Text
replace Text
"%" Text
"%25" Text
key forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
replace Text
":" Text
"%3A")

unwrapSingleContext :: Context -> Maybe SingleContext
unwrapSingleContext :: Context -> Maybe SingleContext
unwrapSingleContext (Single SingleContext
c) = forall a. a -> Maybe a
Just SingleContext
c
unwrapSingleContext Context
_ = 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) = forall v. Text -> v -> KeyMap 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})) = forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues SingleContext -> Text
key KeyMap SingleContext
contexts
getKeys Context
_ = 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
contexts :: KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts})) = 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 forall a b. (a -> b) -> a -> b
$ forall v. [(Text, v)] -> KeyMap v
fromList forall a b. (a -> b) -> a -> b
$ (SingleContext -> [(Text, Value)]
getMapOfRedactableProperties SingleContext
context 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}) = 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) forall a. a -> [a] -> [a]
: (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
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} =
    forall a. (a -> Bool) -> [a] -> [a]
filter
        (forall a. Eq a => a -> a -> Bool
(/=) Value
Null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        [ (Text
"key", forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Text
key)
        , (Text
"kind", forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ if Bool
includeKind then Text -> Value
String Text
kind else Value
Null)
        , (Text
"anonymous", forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ if Bool
anonymous then Bool -> Value
Bool Bool
True else Value
Null)
        , (Text
"_meta", forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null 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 -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall v. Text -> v -> KeyMap v
singleton Text
"privateAttributes" (Array -> Value
Array forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ 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 = forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"LegacyUser" forall a b. (a -> b) -> a -> b
$ \KeyMap Value
o -> do
    (Text
key :: Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"key"
    (Maybe Text
secondary :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"secondary"
    (Maybe Text
ip :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"ip"
    (Maybe Text
country :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"country"
    (Maybe Text
email :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"email"
    (Maybe Text
firstName :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"firstName"
    (Maybe Text
lastName :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"lastName"
    (Maybe Text
avatar :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"avatar"
    (Maybe Text
name :: Maybe Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"name"
    (Maybe Bool
anonymous :: Maybe Bool) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"anonymous"
    (Maybe (KeyMap Value)
custom :: Maybe (KeyMap Value)) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"custom"
    (Maybe [Text]
privateAttributeNames :: Maybe [Text]) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"privateAttributeNames"
    let context :: Context
context =
            Text -> Text -> Context
makeSingleContext Text
key Text
"user"
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"secondary" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
secondary))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"ip" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
ip))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"country" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
country))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"email" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
email))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"firstName" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
firstName))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"lastName" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
lastName))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"avatar" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
avatar))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"name" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
name))
                forall a b. a -> (a -> b) -> b
& Text -> Value -> Context -> Context
withAttribute Text
"anonymous" (forall a. a -> Maybe a -> a
fromMaybe Value
Null (Bool -> Value
Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
anonymous))
                forall a b. a -> (a -> b) -> b
& Set Reference -> Context -> Context
withPrivateAttributes (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeLiteral forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
privateAttributeNames)
     in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 (forall a. a -> Maybe a -> a
fromMaybe 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 = forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"SingleContext" forall a b. (a -> b) -> a -> b
$ \KeyMap Value
o -> do
    (Text
key :: Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"key"
    (Text
kind :: Text) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"kind"
    (Maybe (KeyMap Value)
meta :: Maybe (KeyMap Value)) <- KeyMap Value
o forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"_meta"
    (Maybe [Text]
privateAttributes :: Maybe [Text]) <- (forall a. a -> Maybe a -> a
fromMaybe forall v. KeyMap v
emptyObject Maybe (KeyMap Value)
meta) forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"privateAttributes"
    let context :: Context
context =
            Text -> Text -> Context
makeContext Text
key Text
kind
                forall a b. a -> (a -> b) -> b
& Set Reference -> Context -> Context
withPrivateAttributes (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeReference forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
privateAttributes)
     in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"MultiContext" forall a b. (a -> b) -> a -> b
$ \KeyMap Value
o -> do
    let contextLists :: [(Text, Value)]
contextLists = forall v. KeyMap v -> [(Text, v)]
toList forall a b. (a -> b) -> a -> b
$ forall v. Text -> KeyMap v -> KeyMap v
deleteKey Text
"kind" KeyMap Value
o
        contextObjectLists :: [(Text, KeyMap Value)]
contextObjectLists = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Text
k, Value
v) -> case (Text
k, Value
v) of (Text
_, Object KeyMap Value
obj) -> forall a. a -> Maybe a
Just (Text
k, KeyMap Value
obj); (Text, Value)
_ -> forall a. Maybe a
Nothing) [(Text, Value)]
contextLists
        results :: [Result Context]
results = forall a b. (a -> b) -> [a] -> [b]
map (\(Text
kind, KeyMap Value
obj) -> forall a. FromJSON a => Value -> Result a
fromJSON forall a b. (a -> b) -> a -> b
$ KeyMap Value -> Value
Object forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Result Context
result -> case Result Context
result of Success Context
r -> forall a. a -> Maybe a
Just Context
r; Result Context
_ -> forall a. Maybe a
Nothing) [Result Context]
results
     in case (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Value)]
contextLists, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
single) of
            (Int
a, Int
b) | Int
a forall a. Eq a => a -> a -> Bool
/= Int
b -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ (Invalid Text
_) = Value
Null
redactContext Config
config (Multi MultiContext {KeyMap SingleContext
contexts :: KeyMap SingleContext
$sel:contexts:MultiContext :: MultiContext -> KeyMap SingleContext
contexts}) =
    forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
mapValues (\SingleContext
context -> Bool -> SingleContext -> Set Reference -> Value
redactSingleContext Bool
False SingleContext
context (Config -> SingleContext -> Set Reference
getAllPrivateAttributes Config
config SingleContext
context)) KeyMap SingleContext
contexts
        forall a b. a -> (a -> b) -> b
& forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"kind" Value
"multi"
        forall a b. a -> (a -> b) -> b
& KeyMap Value -> Value
Object
        forall a b. a -> (a -> b) -> b
& forall a. ToJSON a => a -> Value
toJSON
redactContext Config
config (Single SingleContext
context) =
    forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Bool -> SingleContext -> Set Reference -> Value
redactSingleContext Bool
True SingleContext
context (Config -> SingleContext -> Set Reference
getAllPrivateAttributes Config
config SingleContext
context)

-- 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]
$sel:redacted:State :: State -> [Text]
redacted :: [Text]
redacted} = 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 = forall v. [(Text, v)] -> KeyMap v
fromList 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Value
String [Text]
redacted
        required :: KeyMap Value
required = forall v. [(Text, v)] -> KeyMap v
fromList 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 forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion KeyMap Value
redactedContext KeyMap Value
required
            [Text]
_ -> KeyMap Value -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion KeyMap Value
redactedContext (forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
"_meta" (KeyMap Value -> Value
Object forall a b. (a -> b) -> a -> b
$ 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} = 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} = forall a. a -> Set a
S.singleton 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} = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeLiteral forall a b. (a -> b) -> a -> b
$ 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} = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ (Text -> Reference
R.makeLiteral Text
"name") forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map Text -> Reference
R.makeLiteral forall a b. (a -> b) -> a -> b
$ 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.
--
-- If allAttributesPrivate is True in the config, this will return a set which
-- covers the entire context.
getAllPrivateAttributes :: Config -> SingleContext -> Set Reference
getAllPrivateAttributes :: Config -> SingleContext -> Set Reference
getAllPrivateAttributes (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"allAttributesPrivate" -> Bool
True) SingleContext
context = SingleContext -> Set Reference
getAllTopLevelRedactableNames SingleContext
context
getAllPrivateAttributes Config
config SingleContext {$sel:privateAttributes:SingleContext :: SingleContext -> Maybe (Set Reference)
privateAttributes = Maybe (Set Reference)
Nothing} = 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} = 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
context :: KeyMap Value
$sel:context:State :: State -> KeyMap Value
context, [Text]
redacted :: [Text]
$sel:redacted:State :: State -> [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
context :: KeyMap Value
$sel:context:RedactState :: KeyMap Value
context, [Text]
redacted :: [Text]
$sel:redacted:RedactState :: [Text]
redacted, Reference
reference :: Reference
$sel:reference:RedactState :: 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
context :: KeyMap Value
$sel:context:RedactState :: RedactState -> KeyMap Value
context, Reference
reference :: Reference
$sel:reference:RedactState :: RedactState -> Reference
reference, [Text]
redacted :: [Text]
$sel:redacted:RedactState :: RedactState -> [Text]
redacted}) = case (Int
level, forall v. Text -> KeyMap v -> Maybe v
lookupKey Text
x KeyMap Value
context) of
    (Int
_, Just Value
_) -> RedactState
state {$sel:context:RedactState :: KeyMap Value
context = forall v. Text -> KeyMap v -> KeyMap v
deleteKey Text
x KeyMap Value
context, $sel:redacted:RedactState :: [Text]
redacted = (Reference -> Text
R.getRawPath Reference
reference) forall a. a -> [a] -> [a]
: [Text]
redacted}
    (Int
0, Maybe Value
_) -> RedactState
state {$sel:redacted:RedactState :: [Text]
redacted = (Reference -> Text
R.getRawPath Reference
reference) forall a. a -> [a] -> [a]
: [Text]
redacted}
    (Int, Maybe Value)
_ -> RedactState
state
redactComponents (Text
x : [Text]
xs) Int
level state :: RedactState
state@(RedactState {KeyMap Value
context :: KeyMap Value
$sel:context:RedactState :: RedactState -> KeyMap Value
context}) = case 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 forall a. Num a => a -> a -> a
+ Int
1) (RedactState
state {$sel:context:RedactState :: KeyMap Value
context = KeyMap Value
o})
         in RedactState
substate {$sel:context:RedactState :: KeyMap Value
context = forall v. Text -> v -> KeyMap v -> KeyMap v
insertKey Text
x (KeyMap Value -> Value
Object forall a b. (a -> b) -> a -> b
$ KeyMap Value
subcontext) KeyMap Value
context}
    Maybe Value
_ -> RedactState
state