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

…ts (#87)
launchdarkly · Aug 23, 2024 · 85e512a · 85e512a
1 parent 635c383
commit 85e512a
Show file tree

Hide file tree

Showing 11 changed files with 277 additions and 173 deletions.
diff --git a/Setup.hs b/Setup.hs
@@ -1,2 +1,3 @@
 import Distribution.Simple
+
 main = defaultMain
diff --git a/contract-tests/Setup.hs b/contract-tests/Setup.hs
@@ -1,2 +1,3 @@
 import Distribution.Simple
+
 main = defaultMain
diff --git a/contract-tests/src/Main.hs b/contract-tests/src/Main.hs
diff --git a/contract-tests/src/Types.hs b/contract-tests/src/Types.hs
@@ -1,20 +1,21 @@
 module Types where
 
+import Data.Aeson (FromJSON, ToJSON, object, parseJSON, toJSON, withObject, (.!=), (.:), (.:?))
+import Data.Aeson.Types (Value (..))
 import Data.Function ((&))
-import Data.Text (Text)
-import qualified LaunchDarkly.Server as LD
-import Data.Aeson.Types (Value(..))
 import Data.HashMap.Strict (HashMap)
-import Data.Aeson (FromJSON, ToJSON, toJSON, parseJSON, object, withObject, (.:), (.:?), (.!=))
-import GHC.Generics (Generic)
+import Data.Maybe (fromMaybe)
 import Data.Set (Set)
+import Data.Text (Text)
+import GHC.Generics (Generic)
 import GHC.Natural (Natural)
-import Data.Maybe (fromMaybe)
+import qualified LaunchDarkly.Server as LD
 
 data CreateClientParams = CreateClientParams
     { tag :: !Text
     , configuration :: !ConfigurationParams
-    } deriving (FromJSON, ToJSON, Show, Generic)
+    }
+    deriving (FromJSON, ToJSON, Show, Generic)
 
 data ConfigurationParams = ConfigurationParams
     { credential :: !Text
@@ -24,17 +25,20 @@ data ConfigurationParams = ConfigurationParams
     , polling :: !(Maybe PollingParams)
     , events :: !(Maybe EventParams)
     , tags :: !(Maybe TagParams)
-    } deriving (FromJSON, ToJSON, Show, Generic)
+    }
+    deriving (FromJSON, ToJSON, Show, Generic)
 
 data StreamingParams = StreamingParams
     { baseUri :: !(Maybe Text)
     , initialRetryDelayMs :: !(Maybe Int)
-    } deriving (FromJSON, ToJSON, Show, Generic)
+    }
+    deriving (FromJSON, ToJSON, Show, Generic)
 
 data PollingParams = PollingParams
     { baseUri :: !(Maybe Text)
     , pollIntervalMs :: !(Maybe Natural)
-    } deriving (FromJSON, ToJSON, Show, Generic)
+    }
+    deriving (FromJSON, ToJSON, Show, Generic)
 
 data EventParams = EventParams
     { baseUri :: !(Maybe Text)
@@ -43,12 +47,15 @@ data EventParams = EventParams
     , allAttributesPrivate :: !(Maybe Bool)
     , globalPrivateAttributes :: !(Maybe (Set Text))
     , flushIntervalMs :: !(Maybe Natural)
-    } deriving (FromJSON, ToJSON, Show, Generic)
+    , omitAnonymousContexts :: !(Maybe Bool)
+    }
+    deriving (FromJSON, ToJSON, Show, Generic)
 
 data TagParams = TagParams
     { applicationId :: !(Maybe Text)
     , applicationVersion :: !(Maybe Text)
-    } deriving (FromJSON, ToJSON, Show, Generic)
+    }
+    deriving (FromJSON, ToJSON, Show, Generic)
 
 data CommandParams = CommandParams
     { command :: !Text
@@ -59,40 +66,46 @@ data CommandParams = CommandParams
     , contextBuild :: !(Maybe ContextBuildParams)
     , contextConvert :: !(Maybe ContextConvertParams)
     , secureModeHash :: !(Maybe SecureModeHashParams)
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data EvaluateFlagParams = EvaluateFlagParams
     { flagKey :: !Text
     , context :: !LD.Context
     , valueType :: !Text
     , defaultValue :: !Value
     , detail :: !Bool
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data EvaluateFlagResponse = EvaluateFlagResponse
     { value :: !Value
     , variationIndex :: !(Maybe Integer)
     , reason :: !(Maybe LD.EvaluationReason)
-    } deriving (ToJSON, Show, Generic)
+    }
+    deriving (ToJSON, Show, Generic)
 
 data EvaluateAllFlagsParams = EvaluateAllFlagsParams
     { context :: !LD.Context
     , withReasons :: !Bool
     , clientSideOnly :: !Bool
     , detailsOnlyForTrackedFlags :: !Bool
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data EvaluateAllFlagsResponse = EvaluateAllFlagsResponse
     { state :: !LD.AllFlagsState
-    } deriving (ToJSON, Show, Generic)
+    }
+    deriving (ToJSON, Show, Generic)
 
 data CustomEventParams = CustomEventParams
     { eventKey :: !Text
     , context :: !LD.Context
     , dataValue :: !(Maybe Value)
     , omitNullData :: !(Maybe Bool)
     , metricValue :: !(Maybe Double)
-    } deriving (Generic)
+    }
+    deriving (Generic)
 
 instance FromJSON CustomEventParams where
     parseJSON = withObject "CustomEvent" $ \o -> do
@@ -101,16 +114,18 @@ instance FromJSON CustomEventParams where
         dataValue <- o .:? "data"
         omitNullData <- o .:? "omitNullData"
         metricValue <- o .:? "metricValue"
-        return $ CustomEventParams { .. }
+        return $ CustomEventParams {..}
 
 data IdentifyEventParams = IdentifyEventParams
     { context :: !LD.Context
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data ContextBuildParams = ContextBuildParams
     { single :: !(Maybe ContextBuildParam)
     , multi :: !(Maybe [ContextBuildParam])
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data ContextBuildParam = ContextBuildParam
     { kind :: !(Maybe Text)
@@ -119,26 +134,31 @@ data ContextBuildParam = ContextBuildParam
     , anonymous :: !(Maybe Bool)
     , private :: !(Maybe (Set Text))
     , custom :: !(Maybe (HashMap Text Value))
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data ContextConvertParams = ContextConvertParams
     { input :: !Text
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data ContextResponse = ContextResponse
     { output :: !(Maybe Text)
     , errorMessage :: !(Maybe Text)
-    } deriving (Generic)
+    }
+    deriving (Generic)
 
 instance ToJSON ContextResponse where
-    toJSON (ContextResponse { output = Just o, errorMessage = Nothing }) = object [ ("output", String o) ]
-    toJSON (ContextResponse { output = _, errorMessage = Just e }) = object [ ("error", String e) ]
-    toJSON _ = object [ ("error", String "Invalid context response was generated") ]
+    toJSON (ContextResponse {output = Just o, errorMessage = Nothing}) = object [("output", String o)]
+    toJSON (ContextResponse {output = _, errorMessage = Just e}) = object [("error", String e)]
+    toJSON _ = object [("error", String "Invalid context response was generated")]
 
 data SecureModeHashParams = SecureModeHashParams
     { context :: !(Maybe LD.Context)
-    } deriving (FromJSON, Generic)
+    }
+    deriving (FromJSON, Generic)
 
 data SecureModeHashResponse = SecureModeHashResponse
     { result :: !Text
-    } deriving (ToJSON, Show, Generic)
+    }
+    deriving (ToJSON, Show, Generic)
diff --git a/contract-tests/src/Utils.hs b/contract-tests/src/Utils.hs
@@ -2,53 +2,58 @@
 
 module Utils where
 
-import Control.Lens ((&))
 import Control.Concurrent (threadDelay)
+import Control.Lens ((&))
+import Data.Generics.Product (getField)
+import Data.Maybe (fromMaybe)
+import qualified Data.Set as S
+import Data.Text (Text)
+import GHC.Natural (Natural, quotNatural)
 import qualified LaunchDarkly.Server as LD
 import qualified LaunchDarkly.Server.Reference as R
-import qualified Data.Set as S
 import Types
-import GHC.Natural (Natural, quotNatural)
-import Data.Generics.Product (getField)
-import Data.Text (Text)
-import Data.Maybe (fromMaybe)
 
 createClient :: CreateClientParams -> IO LD.Client
 createClient p = LD.makeClient $ createConfig $ getField @"configuration" p
 
 waitClient :: LD.Client -> IO ()
 waitClient client = do
-  status <- LD.getStatus client
-  case status of
-    LD.Initialized -> return ()
-    _ -> threadDelay (1 * 1_000) >> waitClient client
+    status <- LD.getStatus client
+    case status of
+        LD.Initialized -> return ()
+        _ -> threadDelay (1 * 1_000) >> waitClient client
 
 createConfig :: ConfigurationParams -> LD.Config
-createConfig p = LD.makeConfig (getField @"credential" p)
-    & streamingConfig (getField @"streaming" p)
-    & pollingConfig (getField @"polling" p)
-    & tagsConfig (getField @"tags" p)
-    & eventConfig (getField @"events" p)
+createConfig p =
+    LD.makeConfig (getField @"credential" p)
+        & streamingConfig (getField @"streaming" p)
+        & pollingConfig (getField @"polling" p)
+        & tagsConfig (getField @"tags" p)
+        & eventConfig (getField @"events" p)
 
 updateConfig :: (a -> LD.Config -> LD.Config) -> Maybe a -> LD.Config -> LD.Config
 updateConfig f Nothing config = config
 updateConfig f (Just x) config = f x config
 
 streamingConfig :: Maybe StreamingParams -> LD.Config -> LD.Config
 streamingConfig Nothing c = c
-streamingConfig (Just p) c = updateConfig LD.configSetStreamURI (getField @"baseUri" p)
-    $ updateConfig LD.configSetInitialRetryDelay (getField @"initialRetryDelayMs" p) c
+streamingConfig (Just p) c =
+    updateConfig LD.configSetStreamURI (getField @"baseUri" p) $
+        updateConfig LD.configSetInitialRetryDelay (getField @"initialRetryDelayMs" p) c
 
 pollingConfig :: Maybe PollingParams -> LD.Config -> LD.Config
 pollingConfig Nothing c = c
-pollingConfig (Just p) c = updateConfig LD.configSetBaseURI (getField @"baseUri" p)
-    $ updateConfig LD.configSetStreaming (Just False)
-    $ updateConfig LD.configSetPollIntervalSeconds ((`quotNatural` 1_000) <$> getField @"pollIntervalMs" p) c
+pollingConfig (Just p) c =
+    updateConfig LD.configSetBaseURI (getField @"baseUri" p) $
+        updateConfig LD.configSetStreaming (Just False) $
+            updateConfig LD.configSetPollIntervalSeconds ((`quotNatural` 1_000) <$> getField @"pollIntervalMs" p) c
 
 tagsConfig :: Maybe TagParams -> LD.Config -> LD.Config
 tagsConfig Nothing c = c
 tagsConfig (Just params) c = LD.configSetApplicationInfo appInfo c
-    where appInfo = LD.makeApplicationInfo
+  where
+    appInfo =
+        LD.makeApplicationInfo
             & setApplicationInfo "id" (getField @"applicationId" params)
             & setApplicationInfo "version" (getField @"applicationVersion" params)
 
@@ -58,8 +63,10 @@ setApplicationInfo key (Just value) appInfo = LD.withApplicationValue key value
 
 eventConfig :: Maybe EventParams -> LD.Config -> LD.Config
 eventConfig Nothing c = updateConfig LD.configSetSendEvents (Just False) c
-eventConfig (Just p) c = updateConfig LD.configSetEventsURI (getField @"baseUri" p)
-    $ updateConfig LD.configSetEventsCapacity (getField @"capacity" p)
-    $ updateConfig LD.configSetAllAttributesPrivate (getField @"allAttributesPrivate" p)
-    $ updateConfig LD.configSetPrivateAttributeNames ((S.map R.makeReference) <$> getField @"globalPrivateAttributes" p)
-    $ updateConfig LD.configSetFlushIntervalSeconds (getField @"flushIntervalMs" p) c
+eventConfig (Just p) c =
+    updateConfig LD.configSetEventsURI (getField @"baseUri" p) $
+        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
diff --git a/src/LaunchDarkly/Server/Client.hs b/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, optionallyRedactAnonymous, redactContext)
 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 _) -> pure ()
+            _anyValidContext -> 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

diff --git a/src/LaunchDarkly/Server/Config.hs b/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"
diff --git a/src/LaunchDarkly/Server/Config/Internal.hs b/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)