From 70bb935c592d1321e5b379c5c1b29a33de521c69 Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Fri, 23 Aug 2024 12:09:59 -0400 Subject: [PATCH 1/3] feat: Add option to omit anonymous users from index and identify events --- contract-tests/src/Main.hs | 1 + contract-tests/src/Types.hs | 1 + contract-tests/src/Utils.hs | 1 + src/LaunchDarkly/Server/Client.hs | 22 ++++++----- src/LaunchDarkly/Server/Config.hs | 9 +++++ src/LaunchDarkly/Server/Config/Internal.hs | 1 + src/LaunchDarkly/Server/Context/Internal.hs | 43 ++++++++++++++++++--- src/LaunchDarkly/Server/Events.hs | 11 ++++-- test/Spec/Context.hs | 22 ++++++++++- 9 files changed, 91 insertions(+), 20 deletions(-) diff --git a/contract-tests/src/Main.hs b/contract-tests/src/Main.hs index f39696b..430aced 100644 --- a/contract-tests/src/Main.hs +++ b/contract-tests/src/Main.hs @@ -48,6 +48,7 @@ getAppStatus = json AppStatus , "tags" , "inline-context" , "anonymous-redaction" + , "omit-anonymous-contexts" ] } diff --git a/contract-tests/src/Types.hs b/contract-tests/src/Types.hs index 0c02d21..284263f 100644 --- a/contract-tests/src/Types.hs +++ b/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 diff --git a/contract-tests/src/Utils.hs b/contract-tests/src/Utils.hs index f6a6b20..742f0d8 100644 --- a/contract-tests/src/Utils.hs +++ b/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 diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs index cbe73d9..5a7bab8 100644 --- 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, 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 diff --git a/src/LaunchDarkly/Server/Config.hs b/src/LaunchDarkly/Server/Config.hs index 9702ac5..e510daf 100644 --- 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 index 9b61f2a..1481700 100644 --- 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) diff --git a/src/LaunchDarkly/Server/Context/Internal.hs b/src/LaunchDarkly/Server/Context/Internal.hs index cff9052..26f9a56 100644 --- a/src/LaunchDarkly/Server/Context/Internal.hs +++ b/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 diff --git a/src/LaunchDarkly/Server/Events.hs b/src/LaunchDarkly/Server/Events.hs index c52c94f..f89f66e 100644 --- a/src/LaunchDarkly/Server/Events.hs +++ b/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 diff --git a/test/Spec/Context.hs b/test/Spec/Context.hs index 1faa410..61346dd 100644 --- a/test/Spec/Context.hs +++ b/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 ] From 4a1c8a92cd71dcacc0450208a3c7e1c0dc47ffeb Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Fri, 23 Aug 2024 12:53:43 -0400 Subject: [PATCH 2/3] apply all linting and formatting tweaks --- Setup.hs | 1 + contract-tests/Setup.hs | 1 + contract-tests/src/Main.hs | 204 ++++++++++---------- contract-tests/src/Types.hs | 77 +++++--- contract-tests/src/Utils.hs | 60 +++--- src/LaunchDarkly/Server/Client.hs | 2 +- src/LaunchDarkly/Server/Context/Internal.hs | 6 +- src/LaunchDarkly/Server/Events.hs | 2 +- 8 files changed, 193 insertions(+), 160 deletions(-) diff --git a/Setup.hs b/Setup.hs index 9a994af..e8ef27d 100644 --- 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 index 9a994af..e8ef27d 100644 --- 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 index 430aced..61d071d 100644 --- a/contract-tests/src/Main.hs +++ b/contract-tests/src/Main.hs @@ -1,56 +1,58 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Strict #-} +import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar) import Control.Monad.Trans (liftIO) -import Control.Concurrent (MVar, newEmptyMVar, forkIO, putMVar, takeMVar) -import System.Timeout (timeout) -import Data.Aeson (ToJSON, toJSON, Value (..), encode, decode ) +import Data.Aeson (ToJSON, Value (..), decode, encode, toJSON) +import Data.Function ((&)) import Data.Generics.Product (getField) -import Data.Scientific (toRealFloat, floatingOrInteger) +import qualified Data.HashMap.Strict as HM import Data.IORef +import qualified Data.List as L +import qualified Data.Map as M import Data.Maybe +import Data.Scientific (floatingOrInteger, toRealFloat) +import qualified Data.Set as S import Data.Text (Text) +import Data.Text.Lazy (fromStrict, toStrict) +import qualified Data.Text.Lazy as LTB +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) +import LaunchDarkly.Server (Context, getError, withAttribute, withPrivateAttributes) +import qualified LaunchDarkly.Server as LD +import LaunchDarkly.Server.Reference (makeReference) import Network.HTTP.Types +import System.Timeout (timeout) import Types -import Web.Scotty -import qualified Data.HashMap.Strict as HM -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Text.Lazy as LTB -import qualified LaunchDarkly.Server as LD import qualified Utils -import qualified Data.Set as S -import Data.Function ((&)) -import LaunchDarkly.Server (Context, withAttribute, withPrivateAttributes, getError) -import LaunchDarkly.Server.Reference (makeReference) -import Data.Text.Lazy (toStrict, fromStrict) -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import Web.Scotty -data AppState = AppState { clients :: M.Map Int LD.Client, counter :: Int } +data AppState = AppState {clients :: M.Map Int LD.Client, counter :: Int} -data AppStatus = AppStatus { name :: !Text, clientVersion :: !Text, capabilities :: [Text] } deriving (Show, Generic) +data AppStatus = AppStatus {name :: !Text, clientVersion :: !Text, capabilities :: [Text]} deriving (Show, Generic) instance ToJSON AppStatus getAppStatus :: ActionM () -getAppStatus = json AppStatus - { name = "haskell-server-sdk" - , clientVersion = LD.clientVersion - , capabilities = - [ "server-side" - , "server-side-polling" - , "strongly-typed" - , "all-flags-with-reasons" - , "all-flags-client-side-only" - , "all-flags-details-only-for-tracked-flags" - , "context-type" - , "secure-mode-hash" - , "tags" - , "inline-context" - , "anonymous-redaction" - , "omit-anonymous-contexts" - ] - } +getAppStatus = + json + AppStatus + { name = "haskell-server-sdk" + , clientVersion = LD.clientVersion + , capabilities = + [ "server-side" + , "server-side-polling" + , "strongly-typed" + , "all-flags-with-reasons" + , "all-flags-client-side-only" + , "all-flags-details-only-for-tracked-flags" + , "context-type" + , "secure-mode-hash" + , "tags" + , "inline-context" + , "anonymous-redaction" + , "omit-anonymous-contexts" + ] + } shutdownService :: MVar () -> ActionM () shutdownService shutdownMVar = liftIO $ putMVar shutdownMVar () @@ -63,13 +65,13 @@ createClient appStateRef = do let configuration = getField @"configuration" createClientParams canFail = fromMaybe False (getField @"initCanFail" configuration) in case (initialized || canFail) of - True -> do - newCounter <- liftIO $ atomicModifyIORef' appStateRef $ \state -> do - let c = clients state - count = succ $ counter state - (state { clients = M.insert count client c, counter = count }, count) - addHeader "Location" (LTB.pack $ "/client/" ++ (show newCounter)) - False -> status status500 + True -> do + newCounter <- liftIO $ atomicModifyIORef' appStateRef $ \state -> do + let c = clients state + count = succ $ counter state + (state {clients = M.insert count client c, counter = count}, count) + addHeader "Location" (LTB.pack $ "/client/" ++ (show newCounter)) + False -> status status500 runCommand :: IORef AppState -> ActionM () runCommand appStateRef = do @@ -78,17 +80,17 @@ runCommand appStateRef = do appState <- liftIO $ readIORef appStateRef let client = M.lookup (read clientId :: Int) (clients appState) case client of - Nothing -> error "Invalid client provided" - Just c -> case (command commandParams) of - "evaluate" -> evaluateCommand c (evaluate commandParams) - "evaluateAll" -> evaluateAllCommand c (evaluateAll commandParams) - "customEvent" -> customCommand c (customEvent commandParams) - "identifyEvent" -> identifyCommand c (identifyEvent commandParams) - "flushEvents" -> liftIO $ LD.flushEvents c - "contextBuild" -> contextBuildCommand $ contextBuild commandParams - "contextConvert" -> contextConvertCommand $ contextConvert commandParams - "secureModeHash" -> secureModeHashCommand c (secureModeHash commandParams) - _ -> error "An unknown command was requested" + Nothing -> error "Invalid client provided" + Just c -> case (command commandParams) of + "evaluate" -> evaluateCommand c (evaluate commandParams) + "evaluateAll" -> evaluateAllCommand c (evaluateAll commandParams) + "customEvent" -> customCommand c (customEvent commandParams) + "identifyEvent" -> identifyCommand c (identifyEvent commandParams) + "flushEvents" -> liftIO $ LD.flushEvents c + "contextBuild" -> contextBuildCommand $ contextBuild commandParams + "contextConvert" -> contextConvertCommand $ contextConvert commandParams + "secureModeHash" -> secureModeHashCommand c (secureModeHash commandParams) + _ -> error "An unknown command was requested" identifyCommand :: LD.Client -> Maybe IdentifyEventParams -> ActionM () identifyCommand _ Nothing = error "Missing identify event params" @@ -96,19 +98,20 @@ identifyCommand c (Just p) = liftIO $ LD.identify c (getField @"context" p) contextBuildCommand :: Maybe ContextBuildParams -> ActionM () contextBuildCommand Nothing = error "Missing context build params" -contextBuildCommand (Just ContextBuildParams { single = Just buildParam}) = - json $ createContextResponse $ contextBuildSingle buildParam -contextBuildCommand (Just ContextBuildParams { multi = Just buildParams}) = - json $ createContextResponse $ LD.makeMultiContext $ L.map contextBuildSingle buildParams -contextBuildCommand _ = json $ ContextResponse { output = Nothing, errorMessage = Just "No build parameters provided" } +contextBuildCommand (Just ContextBuildParams {single = Just buildParam}) = + json $ createContextResponse $ contextBuildSingle buildParam +contextBuildCommand (Just ContextBuildParams {multi = Just buildParams}) = + json $ createContextResponse $ LD.makeMultiContext $ L.map contextBuildSingle buildParams +contextBuildCommand _ = json $ ContextResponse {output = Nothing, errorMessage = Just "No build parameters provided"} contextBuildSingle :: ContextBuildParam -> LD.Context contextBuildSingle (ContextBuildParam {kind, key, name, anonymous, private, custom}) = - let context = LD.makeContext key (fromMaybe "user" kind) - & contextWithAttribute "name" (String <$> name) - & contextWithAttribute "anonymous" (Bool <$> anonymous) - & withPrivateAttributes (S.map makeReference (fromMaybe S.empty private)) - in HM.foldrWithKey (\k v c -> contextWithAttribute k (Just v) c) context (fromMaybe HM.empty custom) + let context = + LD.makeContext key (fromMaybe "user" kind) + & contextWithAttribute "name" (String <$> name) + & contextWithAttribute "anonymous" (Bool <$> anonymous) + & withPrivateAttributes (S.map makeReference (fromMaybe S.empty private)) + in HM.foldrWithKey (\k v c -> contextWithAttribute k (Just v) c) context (fromMaybe HM.empty custom) contextWithAttribute :: Text -> (Maybe Value) -> Context -> Context contextWithAttribute _ Nothing c = c @@ -116,21 +119,21 @@ contextWithAttribute attr (Just v) c = withAttribute attr v c contextConvertCommand :: Maybe ContextConvertParams -> ActionM () contextConvertCommand Nothing = error "Missing context convert params" -contextConvertCommand (Just ContextConvertParams { input }) = - let context = decode $ encodeUtf8 $ fromStrict input - in case context of - Just ctx -> json $ createContextResponse ctx - Nothing -> json $ ContextResponse { output = Nothing, errorMessage = Just "Error decoding input string" } +contextConvertCommand (Just ContextConvertParams {input}) = + let context = decode $ encodeUtf8 $ fromStrict input + in case context of + Just ctx -> json $ createContextResponse ctx + Nothing -> json $ ContextResponse {output = Nothing, errorMessage = Just "Error decoding input string"} createContextResponse :: Context -> ContextResponse createContextResponse c = case LD.isValid c of - True -> ContextResponse { output = Just $ (toStrict (decodeUtf8 (encode c))), errorMessage = Nothing } - False -> ContextResponse { output = Nothing, errorMessage = Just $ getError c } + True -> ContextResponse {output = Just $ (toStrict (decodeUtf8 (encode c))), errorMessage = Nothing} + False -> ContextResponse {output = Nothing, errorMessage = Just $ getError c} secureModeHashCommand :: LD.Client -> Maybe SecureModeHashParams -> ActionM () secureModeHashCommand _ Nothing = error "Missing secure mode hash params" -secureModeHashCommand _ (Just (SecureModeHashParams { context = Nothing })) = error "This SDK does not support secure mode on non-context types" -secureModeHashCommand c (Just (SecureModeHashParams { context = Just context })) = json $ SecureModeHashResponse { result = LD.secureModeHash c context } +secureModeHashCommand _ (Just (SecureModeHashParams {context = Nothing})) = error "This SDK does not support secure mode on non-context types" +secureModeHashCommand c (Just (SecureModeHashParams {context = Just context})) = json $ SecureModeHashResponse {result = LD.secureModeHash c context} customCommand :: LD.Client -> Maybe CustomEventParams -> ActionM () customCommand _ Nothing = error "Missing custom event params" @@ -145,50 +148,53 @@ evaluateCommand c (Just p) | otherwise = do d <- liftIO $ evaluateWithoutDetail c context flagKey valueType defaultValue json d - where context = (getField @"context" p) - flagKey = (getField @"flagKey" p) - valueType = (getField @"valueType" p) - defaultValue = (getField @"defaultValue" p) + where + context = (getField @"context" p) + flagKey = (getField @"flagKey" p) + valueType = (getField @"valueType" p) + defaultValue = (getField @"defaultValue" p) toFlagResponseWithDetail :: ToJSON a => LD.EvaluationDetail a -> EvaluateFlagResponse -toFlagResponseWithDetail d = EvaluateFlagResponse - { value = toJSON $ (getField @"value" d) - , variationIndex = (getField @"variationIndex" d) - , reason = Just $ (getField @"reason" d) - } +toFlagResponseWithDetail d = + EvaluateFlagResponse + { value = toJSON $ (getField @"value" d) + , variationIndex = (getField @"variationIndex" d) + , reason = Just $ (getField @"reason" d) + } toFlagResponseWithoutDetail :: ToJSON a => a -> EvaluateFlagResponse -toFlagResponseWithoutDetail v = EvaluateFlagResponse - { value = toJSON $ v - , variationIndex = Nothing - , reason = Nothing - } +toFlagResponseWithoutDetail v = + EvaluateFlagResponse + { value = toJSON $ v + , variationIndex = Nothing + , reason = Nothing + } evaluateWithDetail :: LD.Client -> LD.Context -> Text -> Text -> Value -> IO EvaluateFlagResponse evaluateWithDetail c context flagKey "bool" (Bool v) = toFlagResponseWithDetail <$> LD.boolVariationDetail c flagKey context v evaluateWithDetail c context flagKey "int" (Number v) = case floatingOrInteger v of - Left _ -> error("Invalid int format") - Right x -> toFlagResponseWithDetail <$> LD.intVariationDetail c flagKey context x + Left _ -> error ("Invalid int format") + Right x -> toFlagResponseWithDetail <$> LD.intVariationDetail c flagKey context x evaluateWithDetail c context flagKey "double" (Number v) = toFlagResponseWithDetail <$> LD.doubleVariationDetail c flagKey context (toRealFloat v) evaluateWithDetail c context flagKey "string" (String v) = toFlagResponseWithDetail <$> LD.stringVariationDetail c flagKey context v evaluateWithDetail c context flagKey "any" v = toFlagResponseWithDetail <$> LD.jsonVariationDetail c flagKey context v -evaluateWithDetail _ _ _ _ _ = error("Invalid type provided") +evaluateWithDetail _ _ _ _ _ = error ("Invalid type provided") evaluateWithoutDetail :: LD.Client -> LD.Context -> Text -> Text -> Value -> IO EvaluateFlagResponse evaluateWithoutDetail c context flagKey "bool" (Bool v) = toFlagResponseWithoutDetail <$> LD.boolVariation c flagKey context v evaluateWithoutDetail c context flagKey "int" (Number v) = case floatingOrInteger v of - Left _ -> error("Invalid int format") - Right x -> toFlagResponseWithoutDetail <$> LD.intVariation c flagKey context x + Left _ -> error ("Invalid int format") + Right x -> toFlagResponseWithoutDetail <$> LD.intVariation c flagKey context x evaluateWithoutDetail c context flagKey "double" (Number v) = toFlagResponseWithoutDetail <$> LD.doubleVariation c flagKey context (toRealFloat v) evaluateWithoutDetail c context flagKey "string" (String v) = toFlagResponseWithoutDetail <$> LD.stringVariation c flagKey context v evaluateWithoutDetail c context flagKey "any" v = toFlagResponseWithoutDetail <$> LD.jsonVariation c flagKey context v -evaluateWithoutDetail _ _ _ _ _ = error("Invalid type provided") +evaluateWithoutDetail _ _ _ _ _ = error ("Invalid type provided") evaluateAllCommand :: LD.Client -> Maybe EvaluateAllFlagsParams -> ActionM () evaluateAllCommand _ Nothing = error "Missing evaluate all params" evaluateAllCommand c (Just p) = do s <- liftIO $ LD.allFlagsState c (getField @"context" p) (getField @"clientSideOnly" p) (getField @"withReasons" p) (getField @"detailsOnlyForTrackedFlags" p) - json $ EvaluateAllFlagsResponse { state = s } + json $ EvaluateAllFlagsResponse {state = s} stopClient :: IORef AppState -> ActionM () stopClient appStateRef = do @@ -197,10 +203,10 @@ stopClient appStateRef = do let clientId = read clientIdParam :: Int client = M.lookup clientId (clients appState) case client of - Nothing -> error "Invalid client provided" - Just c -> liftIO $ do - LD.close c - modifyIORef' appStateRef (\a -> a { clients = M.delete clientId (clients a)}) + Nothing -> error "Invalid client provided" + Just c -> liftIO $ do + LD.close c + modifyIORef' appStateRef (\a -> a {clients = M.delete clientId (clients a)}) routes :: IORef AppState -> MVar () -> ScottyM () routes appStateRef shutdownMVar = do @@ -212,7 +218,7 @@ routes appStateRef shutdownMVar = do server :: IO () server = do - appStateRef <- newIORef $ AppState { clients = M.empty, counter = 0 } + appStateRef <- newIORef $ AppState {clients = M.empty, counter = 0} shutdownMVar <- newEmptyMVar _ <- forkIO $ scotty 8000 (routes appStateRef shutdownMVar) takeMVar shutdownMVar diff --git a/contract-tests/src/Types.hs b/contract-tests/src/Types.hs index 284263f..32f726b 100644 --- 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) @@ -44,12 +48,14 @@ data EventParams = EventParams , globalPrivateAttributes :: !(Maybe (Set Text)) , flushIntervalMs :: !(Maybe Natural) , omitAnonymousContexts :: !(Maybe Bool) - } deriving (FromJSON, ToJSON, Show, Generic) + } + 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 @@ -60,7 +66,8 @@ data CommandParams = CommandParams , contextBuild :: !(Maybe ContextBuildParams) , contextConvert :: !(Maybe ContextConvertParams) , secureModeHash :: !(Maybe SecureModeHashParams) - } deriving (FromJSON, Generic) + } + deriving (FromJSON, Generic) data EvaluateFlagParams = EvaluateFlagParams { flagKey :: !Text @@ -68,24 +75,28 @@ data EvaluateFlagParams = EvaluateFlagParams , 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 @@ -93,7 +104,8 @@ data CustomEventParams = CustomEventParams , dataValue :: !(Maybe Value) , omitNullData :: !(Maybe Bool) , metricValue :: !(Maybe Double) - } deriving (Generic) + } + deriving (Generic) instance FromJSON CustomEventParams where parseJSON = withObject "CustomEvent" $ \o -> do @@ -102,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) @@ -120,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 index 742f0d8..d2f99e8 100644 --- a/contract-tests/src/Utils.hs +++ b/contract-tests/src/Utils.hs @@ -2,33 +2,34 @@ 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 @@ -36,19 +37,23 @@ 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,9 +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.configSetOmitAnonymousContexts (getField @"omitAnonymousContexts" 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 index 5a7bab8..57f1075 100644 --- 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, optionallyRedactAnonymous) +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) diff --git a/src/LaunchDarkly/Server/Context/Internal.hs b/src/LaunchDarkly/Server/Context/Internal.hs index 26f9a56..49ecb21 100644 --- a/src/LaunchDarkly/Server/Context/Internal.hs +++ b/src/LaunchDarkly/Server/Context/Internal.hs @@ -50,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, objectValues) -import LaunchDarkly.Server.Config.Internal (Config(..)) +import LaunchDarkly.AesonCompat (KeyMap, deleteKey, emptyObject, foldrWithKey, fromList, insertKey, keyMapUnion, lookupKey, mapValues, objectKeys, objectValues, singleton, toList) +import LaunchDarkly.Server.Config.Internal (Config (..)) import LaunchDarkly.Server.Reference (Reference) import qualified LaunchDarkly.Server.Reference as R @@ -530,7 +530,7 @@ redactComponents (x : xs) level state@(RedactState {context}) = case lookupKey x -- 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 Config {omitAnonymousContexts = True} c = withoutAnonymousContexts c optionallyRedactAnonymous _ c = c -- | diff --git a/src/LaunchDarkly/Server/Events.hs b/src/LaunchDarkly/Server/Events.hs index f89f66e..248c2be 100644 --- a/src/LaunchDarkly/Server/Events.hs +++ b/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, Context(Invalid), optionallyRedactAnonymous) +import LaunchDarkly.Server.Context.Internal (Context (Invalid), getCanonicalKey, getKinds, optionallyRedactAnonymous, redactContext, redactContextRedactAnonymous) import LaunchDarkly.Server.Details (EvaluationReason (..)) import LaunchDarkly.Server.Features (Flag) From b1492342256e3983e6ebaffb7ab8c655c038a4f9 Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Fri, 23 Aug 2024 13:04:26 -0400 Subject: [PATCH 3/3] remove log --- src/LaunchDarkly/Server/Client.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs index 57f1075..fb7f020 100644 --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -269,8 +269,8 @@ identify client context = case (getValue "key" context) of _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 + (Invalid _) -> pure () + _anyValidContext -> do let redacted = redactContext (getField @"config" client) identifyContext x <- makeBaseEvent $ IdentifyEvent {key = getKey context, context = redacted} _ <- noticeContext (getField @"events" client) context