{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
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 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
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
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
}
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
}
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
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
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
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
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
getKey :: Context -> Text
getKey :: Context -> Text
getKey (Single SingleContext
c) = SingleContext -> Text
key SingleContext
c
getKey Context
_ = Text
""
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
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
""
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
_ = []
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)
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)]
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)
)
]
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)
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
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
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)
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)
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)
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
data State = State
{ State -> KeyMap Value
context :: KeyMap Value
, State -> [Text]
redacted :: ![Text]
}
data RedactState = RedactState
{ RedactState -> KeyMap Value
context :: KeyMap Value
, RedactState -> Reference
reference :: Reference
, RedactState -> [Text]
redacted :: ![Text]
}
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}
redactComponents :: [Text] -> Int -> RedactState -> RedactState
redactComponents :: [Text] -> Int -> RedactState -> RedactState
redactComponents [] Int
_ RedactState
state = RedactState
state
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
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