feat: Add option to omit anonymous users from index and identify events

contract-tests/src/Main.hs

@@ -48,6 +48,7 @@ getAppStatus = json AppStatus
         , "tags"
         , "inline-context"
         , "anonymous-redaction"
+        , "omit-anonymous-contexts"
         ]
     }
 

contract-tests/src/Types.hs

@@ -43,6 +43,7 @@ data EventParams = EventParams
     , allAttributesPrivate :: !(Maybe Bool)
     , globalPrivateAttributes :: !(Maybe (Set Text))
     , flushIntervalMs :: !(Maybe Natural)
+    , omitAnonymousContexts :: !(Maybe Bool)
     } deriving (FromJSON, ToJSON, Show, Generic)
 
 data TagParams = TagParams

contract-tests/src/Utils.hs

@@ -62,4 +62,5 @@ eventConfig (Just p) c = updateConfig LD.configSetEventsURI (getField @"baseUri"
     $ updateConfig LD.configSetEventsCapacity (getField @"capacity" p)
     $ updateConfig LD.configSetAllAttributesPrivate (getField @"allAttributesPrivate" p)
     $ updateConfig LD.configSetPrivateAttributeNames ((S.map R.makeReference) <$> getField @"globalPrivateAttributes" p)
+    $ updateConfig LD.configSetOmitAnonymousContexts (getField @"omitAnonymousContexts" p)
     $ updateConfig LD.configSetFlushIntervalSeconds (getField @"flushIntervalMs" p) c

src/LaunchDarkly/Server/Client.hs

@@ -55,7 +55,7 @@ import LaunchDarkly.Server.Config.ClientContext (ClientContext (..))
 import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..))
 import LaunchDarkly.Server.Config.Internal (ApplicationInfo, Config, getApplicationInfoHeader, shouldSendEvents)
 import LaunchDarkly.Server.Context (getValue)
-import LaunchDarkly.Server.Context.Internal (Context (Invalid), getCanonicalKey, getKey, getKeys, redactContext)
+import LaunchDarkly.Server.Context.Internal (Context (Invalid), getCanonicalKey, getKey, getKeys, redactContext, optionallyRedactAnonymous)
 import LaunchDarkly.Server.DataSource.Internal (DataSource (..), DataSourceFactory, DataSourceUpdates (..), defaultDataSourceUpdates, nullDataSourceFactory)
 import LaunchDarkly.Server.Details (EvalErrorKind (..), EvaluationDetail (..), EvaluationReason (..))
 import LaunchDarkly.Server.Evaluate (evaluateDetail, evaluateTyped)
@@ -129,7 +129,7 @@ makeClient config = mfix $ \client -> do
     clientContext <- makeClientContext config
 
     let dataSourceUpdates = defaultDataSourceUpdates status store
-    dataSource <- dataSourceFactory config clientContext dataSourceUpdates
+    dataSource <- getDataSourceFactory config clientContext dataSourceUpdates
     eventThreadPair <-
         if not (shouldSendEvents config)
             then pure Nothing
@@ -142,8 +142,8 @@ makeClient config = mfix $ \client -> do
 
     pure $ Client {..}
 
-dataSourceFactory :: Config -> DataSourceFactory
-dataSourceFactory config =
+getDataSourceFactory :: Config -> DataSourceFactory
+getDataSourceFactory config =
     if getField @"offline" config || getField @"useLdd" config
         then nullDataSourceFactory
         else case getField @"dataSourceFactory" config of
@@ -266,11 +266,15 @@ identify :: Client -> Context -> IO ()
 identify client (Invalid err) = clientRunLogger client $ $(logWarn) $ "identify called with an invalid context: " <> err
 identify client context = case (getValue "key" context) of
     (String "") -> clientRunLogger client $ $(logWarn) "identify called with empty key"
-    _ -> do
-        let redacted = redactContext (getField @"config" client) context
-        x <- makeBaseEvent $ IdentifyEvent {key = getKey context, context = redacted}
-        _ <- noticeContext (getField @"events" client) context
-        queueEvent (getField @"config" client) (getField @"events" client) (EventTypeIdentify x)
+    _anyValidKey -> do
+        let identifyContext = optionallyRedactAnonymous (getField @"config" client) context
+        case identifyContext of
+            (Invalid err) -> clientRunLogger client $ $(logWarn) $ "identify called with an invalid context: " <> err
+            _ -> do
+                let redacted = redactContext (getField @"config" client) identifyContext
+                x <- makeBaseEvent $ IdentifyEvent {key = getKey context, context = redacted}
+                _ <- noticeContext (getField @"events" client) context
+                queueEvent (getField @"config" client) (getField @"events" client) (EventTypeIdentify x)
 
 -- |
 -- Track reports that a context has performed an event. Custom data can be

src/LaunchDarkly/Server/Config.hs

@@ -27,6 +27,7 @@ module LaunchDarkly.Server.Config
     , configSetUseLdd
     , configSetDataSourceFactory
     , configSetApplicationInfo
+    , configSetOmitAnonymousContexts
     , ApplicationInfo
     , makeApplicationInfo
     , withApplicationValue
@@ -70,6 +71,7 @@ makeConfig key =
         , dataSourceFactory = Nothing
         , manager = Nothing
         , applicationInfo = Nothing
+        , omitAnonymousContexts = False
         }
 
 -- | Set the SDK key used to authenticate with LaunchDarkly.
@@ -221,3 +223,10 @@ configSetManager = setField @"manager" . Just
 -- appropriately configured dict to the 'Config' object.
 configSetApplicationInfo :: ApplicationInfo -> Config -> Config
 configSetApplicationInfo = setField @"applicationInfo" . Just
+
+-- |
+-- Sets whether anonymous contexts should be omitted from index and identify events.
+--
+-- By default, anonymous contexts are included in index and identify events.
+configSetOmitAnonymousContexts :: Bool -> Config -> Config
+configSetOmitAnonymousContexts = setField @"omitAnonymousContexts"

src/LaunchDarkly/Server/Config/Internal.hs

@@ -49,6 +49,7 @@ data Config = Config
     , dataSourceFactory :: !(Maybe DataSourceFactory)
     , manager :: !(Maybe Manager)
     , applicationInfo :: !(Maybe ApplicationInfo)
+    , omitAnonymousContexts :: !Bool
     }
     deriving (Generic)
 

src/LaunchDarkly/Server/Context/Internal.hs

@@ -33,6 +33,8 @@ module LaunchDarkly.Server.Context.Internal
     , getKinds
     , redactContext
     , redactContextRedactAnonymous
+    , optionallyRedactAnonymous
+    , withoutAnonymousContexts
     )
 where
 
@@ -48,8 +50,8 @@ 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.AesonCompat (KeyMap, deleteKey, emptyObject, foldrWithKey, fromList, insertKey, keyMapUnion, lookupKey, mapValues, objectKeys, singleton, toList, objectValues)
+import LaunchDarkly.Server.Config.Internal (Config(..))
 import LaunchDarkly.Server.Reference (Reference)
 import qualified LaunchDarkly.Server.Reference as R
 
@@ -157,7 +159,7 @@ makeMultiContext contexts =
             _ ->
                 Multi
                     MultiContext
-                        { fullKey = intercalate ":" $ map (\c -> canonicalizeKey (key c) (kind c)) sorted
+                        { fullKey = intercalate ":" $ map (\c -> canonicalizeKey (getField @"key" c) (kind c)) sorted
                         , contexts = fromList $ map (\c -> ((kind c), c)) singleContexts
                         }
 
@@ -268,7 +270,7 @@ unwrapSingleContext _ = Nothing
 -- This method is functionally equivalent to @fromMaybe "" $ getValue "key"@,
 -- it's just nicer to use.
 getKey :: Context -> Text
-getKey (Single c) = key c
+getKey (Single c) = getField @"key" c
 getKey _ = ""
 
 -- Internally used convenience function for retrieving all context keys,
@@ -278,8 +280,8 @@ getKey _ = ""
 -- 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 (Single c) = singleton (kind c) (key c)
-getKeys (Multi (MultiContext {contexts})) = mapValues key contexts
+getKeys (Single c) = singleton (kind c) (getField @"key" c)
+getKeys (Multi (MultiContext {contexts})) = mapValues (getField @"key") contexts
 getKeys _ = emptyObject
 
 -- Internally used convenience function to retrieve a context's fully qualified
@@ -520,3 +522,32 @@ redactComponents (x : xs) level state@(RedactState {context}) = case lookupKey x
         let substate@(RedactState {context = subcontext}) = redactComponents xs (level + 1) (state {context = o})
          in substate {context = insertKey x (Object $ subcontext) context}
     _ -> state
+
+-- |
+-- Internally used only.
+--
+-- If the config has omitAnonymousContexts set to True, this method will return a new context with
+-- all anonymous contexts removed. If the config does not have omitAnonymousContexts set to True,
+-- this method will return the context as is.
+optionallyRedactAnonymous :: Config -> Context -> Context
+optionallyRedactAnonymous Config{omitAnonymousContexts=True} c = withoutAnonymousContexts c
+optionallyRedactAnonymous _ c = c
+
+-- |
+-- Internally used only.
+--
+-- For a multi-kind context:
+--
+-- A multi-kind context is made up of two or more single-kind contexts. This method will first discard any
+-- single-kind contexts which are anonymous. It will then create a new multi-kind context from the remaining
+-- single-kind contexts. This may result in an invalid context (e.g. all single-kind contexts are anonymous).
+--
+-- For a single-kind context:
+--
+-- If the context is not anonymous, this method will return the current context as is and unmodified.
+--
+-- If the context is anonymous, this method will return an invalid context.
+withoutAnonymousContexts :: Context -> Context
+withoutAnonymousContexts (Single SingleContext {anonymous = True}) = makeMultiContext []
+withoutAnonymousContexts (Multi MultiContext {contexts}) = makeMultiContext $ map Single $ filter (not . anonymous) $ objectValues contexts
+withoutAnonymousContexts c = c

src/LaunchDarkly/Server/Events.hs

@@ -19,7 +19,7 @@ import GHC.Natural (Natural, naturalFromInteger)
 import LaunchDarkly.AesonCompat (KeyMap, insertKey, keyMapUnion, lookupKey, objectValues)
 import LaunchDarkly.Server.Config.Internal (Config, shouldSendEvents)
 import LaunchDarkly.Server.Context (Context)
-import LaunchDarkly.Server.Context.Internal (getCanonicalKey, getKinds, redactContext, redactContextRedactAnonymous)
+import LaunchDarkly.Server.Context.Internal (getCanonicalKey, getKinds, redactContext, redactContextRedactAnonymous, Context(Invalid), optionallyRedactAnonymous)
 import LaunchDarkly.Server.Details (EvaluationReason (..))
 import LaunchDarkly.Server.Features (Flag)
 
@@ -375,9 +375,12 @@ processEvalEvents config state context includeReason events unknown =
 
 maybeIndexContext :: Natural -> Config -> Context -> EventState -> IO ()
 maybeIndexContext now config context state = do
-    noticedContext <- noticeContext state context
-    when noticedContext $
-        queueEvent config state (EventTypeIndex $ BaseEvent now $ IndexEvent {context = redactContext config context})
+    case optionallyRedactAnonymous config context of
+        (Invalid _) -> pure ()
+        ctx -> do
+            noticedContext <- noticeContext state ctx
+            when noticedContext $
+                queueEvent config state (EventTypeIndex $ BaseEvent now $ IndexEvent {context = redactContext config ctx})
 
 noticeContext :: EventState -> Context -> IO Bool
 noticeContext state context = modifyMVar (getField @"contextKeyLRU" state) $ \cache -> do

test/Spec/Context.hs

@@ -12,7 +12,7 @@ import GHC.Exts (fromList)
 import LaunchDarkly.AesonCompat (lookupKey)
 import LaunchDarkly.Server.Config (configSetAllAttributesPrivate, makeConfig)
 import LaunchDarkly.Server.Context
-import LaunchDarkly.Server.Context.Internal (redactContext, redactContextRedactAnonymous)
+import LaunchDarkly.Server.Context.Internal (redactContext, redactContextRedactAnonymous, withoutAnonymousContexts)
 import qualified LaunchDarkly.Server.Reference as R
 
 confirmInvalidContext :: Context -> Text -> Assertion
@@ -397,6 +397,25 @@ canRedactMultiKindAnonymousContextAttributesCorrectly = TestCase $ do
 
     orgObj = case lookupKey "org" decodedIntoMap of (Just (Object o)) -> o; _decodeFailure -> error "expected object"
 
+canRedactAnonymousContextsAsExpected :: Test
+canRedactAnonymousContextsAsExpected =
+    TestCase $
+        let anonymousUser = makeContext "user-key" "user" & withAnonymous True
+            anonymousOrg = makeContext "org-key" "org" & withAnonymous True
+            device = makeContext "device-key" "device"
+            mc = makeMultiContext [anonymousUser, anonymousOrg, device]
+            anonMc = makeMultiContext [anonymousUser, anonymousOrg]
+         in ( do
+                -- Redacting an anonymous context should result in an invalid context
+                assertEqual "" False $ isValid $ withoutAnonymousContexts anonymousUser
+                -- Redacting a non-anonymous context should result in the same context
+                assertEqual "" device $ withoutAnonymousContexts device
+                -- Redacting a multi-context should result in a multi-context with only the non-anonymous contexts
+                assertEqual "" device $ withoutAnonymousContexts mc
+                -- Redacting a multi-context with only anonymous contexts should result in an invalid context
+                assertEqual "" False $ isValid $ withoutAnonymousContexts anonMc
+            )
+
 allTests :: Test
 allTests =
     TestList
@@ -419,4 +438,5 @@ allTests =
         , canRedactAllAttributesCorrectly
         , canRedactSingleKindAnonymousContextAttributesCorrectly
         , canRedactMultiKindAnonymousContextAttributesCorrectly
+        , canRedactAnonymousContextsAsExpected
         ]