From b6b9a5e4cc4451f1944b51106606eb475305cf56 Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Wed, 23 Oct 2024 11:43:36 -0400 Subject: [PATCH 1/2] feat: Add support for client-side prerequisite events --- contract-tests/src/Main.hs | 1 + launchdarkly-server-sdk.cabal | 2 + src/LaunchDarkly/Server/Client.hs | 9 +++-- src/LaunchDarkly/Server/Evaluate.hs | 60 +++++++++++++++-------------- src/LaunchDarkly/Server/Util.hs | 21 ++++++++++ test/Spec/Evaluate.hs | 8 ++++ 6 files changed, 70 insertions(+), 31 deletions(-) create mode 100644 src/LaunchDarkly/Server/Util.hs diff --git a/contract-tests/src/Main.hs b/contract-tests/src/Main.hs index 61d071d..f183eec 100644 --- a/contract-tests/src/Main.hs +++ b/contract-tests/src/Main.hs @@ -51,6 +51,7 @@ getAppStatus = , "inline-context" , "anonymous-redaction" , "omit-anonymous-contexts" + , "client-prereq-events" ] } diff --git a/launchdarkly-server-sdk.cabal b/launchdarkly-server-sdk.cabal index 6d2caa0..9baf220 100644 --- a/launchdarkly-server-sdk.cabal +++ b/launchdarkly-server-sdk.cabal @@ -66,6 +66,7 @@ library LaunchDarkly.Server.Network.Streaming LaunchDarkly.Server.Operators LaunchDarkly.Server.Store.Internal + LaunchDarkly.Server.Util Paths_launchdarkly_server_sdk hs-source-dirs: src @@ -174,6 +175,7 @@ test-suite haskell-server-sdk-test LaunchDarkly.Server.Reference LaunchDarkly.Server.Store LaunchDarkly.Server.Store.Internal + LaunchDarkly.Server.Util Paths_launchdarkly_server_sdk hs-source-dirs: test diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs index fb7f020..811f7a3 100644 --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -194,6 +194,7 @@ data FlagState = FlagState , trackEvents :: !Bool , trackReason :: !Bool , debugEventsUntilDate :: !(Maybe Natural) + , prerequisites :: !(Maybe [Text]) } deriving (Show, Generic) @@ -208,6 +209,7 @@ instance ToJSON FlagState where , "trackReason" .= if getField @"trackReason" state then Just True else Nothing , "reason" .= getField @"reason" state , "debugEventsUntilDate" .= getField @"debugEventsUntilDate" state + , "prerequisites" .= getField @"prerequisites" state ] -- | @@ -236,13 +238,13 @@ allFlagsState client context client_side_only with_reasons details_only_for_trac Left _ -> pure AllFlagsState {evaluations = emptyObject, state = emptyObject, valid = False} Right flags -> do filtered <- pure $ (filterObject (\flag -> (not client_side_only) || isClientSideOnlyFlag flag) flags) - details <- mapM (\flag -> (\detail -> (flag, fst detail)) <$> (evaluateDetail flag context HS.empty $ getField @"store" client)) filtered - evaluations <- pure $ mapValues (getField @"value" . snd) details + details <- mapM (\flag -> (\(detail, _, prereqs) -> (flag, (detail, prereqs))) <$> (evaluateDetail flag context HS.empty $ getField @"store" client)) filtered + evaluations <- pure $ mapValues (getField @"value" . fst . snd) details now <- unixMilliseconds state <- pure $ mapValues - ( \(flag, detail) -> do + ( \(flag, (detail, prereqs)) -> do let reason' = getField @"reason" detail inExperiment = isInExperiment flag reason' isDebugging = now < fromMaybe 0 (getField @"debugEventsUntilDate" flag) @@ -256,6 +258,7 @@ allFlagsState client context client_side_only with_reasons details_only_for_trac , trackEvents = trackEvents' || inExperiment , trackReason = trackReason' , debugEventsUntilDate = getField @"debugEventsUntilDate" flag + , prerequisites = if null prereqs then Nothing else Just prereqs } ) details diff --git a/src/LaunchDarkly/Server/Evaluate.hs b/src/LaunchDarkly/Server/Evaluate.hs index e754dfb..b5dfc9a 100644 --- a/src/LaunchDarkly/Server/Evaluate.hs +++ b/src/LaunchDarkly/Server/Evaluate.hs @@ -17,7 +17,7 @@ import Data.Generics.Product (field, getField) import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Data.List (genericIndex) -import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe) import Data.Scientific (Scientific, floatingOrInteger) import Data.Text (Text) import qualified Data.Text as T @@ -37,6 +37,7 @@ import LaunchDarkly.Server.Features (Clause, Flag, Prerequisite, RolloutKind (Ro import LaunchDarkly.Server.Operators (Op (OpSegmentMatch), getOperation) import LaunchDarkly.Server.Reference (getComponents, getError, isValid, makeLiteral, makeReference) import LaunchDarkly.Server.Store.Internal (LaunchDarklyStoreRead, getFlagC, getSegmentC) +import LaunchDarkly.Server.Util (trd, snd3, fst3) setFallback :: EvaluationDetail Value -> Value -> EvaluationDetail Value setFallback detail fallback = case getField @"variationIndex" detail of @@ -55,26 +56,26 @@ evaluateTyped client key context fallback wrap includeReason convert = if status /= Initialized then pure $ EvaluationDetail fallback Nothing $ EvaluationReasonError EvalErrorClientNotReady else - evaluateInternalClient client key context (wrap fallback) includeReason >>= \detail -> + evaluateInternalClient client key context (wrap fallback) includeReason >>= \(detail, _) -> pure $ maybe (EvaluationDetail fallback Nothing $ if isError (getField @"reason" detail) then (getField @"reason" detail) else EvaluationReasonError EvalErrorWrongType) (setValue detail) (convert $ getField @"value" detail) -evaluateInternalClient :: Client -> Text -> Context -> Value -> Bool -> IO (EvaluationDetail Value) -evaluateInternalClient _ _ (Invalid _) fallback _ = pure $ errorDefault EvalErrorInvalidContext fallback +evaluateInternalClient :: Client -> Text -> Context -> Value -> Bool -> IO (EvaluationDetail Value, [Text]) +evaluateInternalClient _ _ (Invalid _) fallback _ = pure $ (errorDefault EvalErrorInvalidContext fallback, []) evaluateInternalClient client key context fallback includeReason = do - (detail, unknown, events) <- + (detail, unknown, events, prereqs) <- getFlagC (getField @"store" client) key >>= \case Left err -> do let event = newUnknownFlagEvent key fallback (EvaluationReasonError $ EvalErrorExternalStore err) context - pure (errorDetail $ EvalErrorExternalStore err, True, pure event) + pure (errorDetail $ EvalErrorExternalStore err, True, pure event, []) Right Nothing -> do let event = newUnknownFlagEvent key fallback (EvaluationReasonError EvalErrorFlagNotFound) context - pure (errorDefault EvalErrorFlagNotFound fallback, True, pure event) + pure (errorDefault EvalErrorFlagNotFound fallback, True, pure event, []) Right (Just flag) -> do - (detail, events) <- evaluateDetail flag context HS.empty $ getField @"store" client + (detail, events, prereqs) <- evaluateDetail flag context HS.empty $ getField @"store" client let detail' = setFallback detail fallback pure ( detail' @@ -88,9 +89,10 @@ evaluateInternalClient client key context fallback includeReason = do (getField @"reason" detail') Nothing context + , prereqs ) processEvalEvents (getField @"config" client) (getField @"events" client) context includeReason events unknown - pure detail + pure (detail, prereqs) getOffValue :: Flag -> EvaluationReason -> EvaluationDetail Value getOffValue flag reason = case getField @"offVariation" flag of @@ -106,14 +108,14 @@ getVariation flag index reason idx = fromIntegral index variations = getField @"variations" flag -evaluateDetail :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (EvaluationDetail Value, [EvalEvent]) -evaluateDetail flag@(getField @"on" -> False) _ _ _ = pure (getOffValue flag EvaluationReasonOff, []) +evaluateDetail :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (EvaluationDetail Value, [EvalEvent], [Text]) +evaluateDetail flag@(getField @"on" -> False) _ _ _ = pure (getOffValue flag EvaluationReasonOff, [], []) evaluateDetail flag context seenFlags store - | HS.member (getField @"key" flag) seenFlags = pure (getOffValue flag $ EvaluationReasonError EvalErrorKindMalformedFlag, []) + | HS.member (getField @"key" flag) seenFlags = pure (getOffValue flag $ EvaluationReasonError EvalErrorKindMalformedFlag, [], []) | otherwise = checkPrerequisites flag context (HS.insert (getField @"key" flag) seenFlags) store >>= \case - (Nothing, events) -> evaluateInternal flag context store >>= (\x -> pure (x, events)) - (Just detail, events) -> pure (detail, events) + (Nothing, events, prereqs) -> evaluateInternal flag context store >>= (\x -> pure (x, events, prereqs)) + (Just detail, events, prereqs) -> pure (detail, events, prereqs) status :: Prerequisite -> EvaluationDetail a -> Flag -> Bool status prereq result prereqFlag = @@ -129,32 +131,34 @@ sequenceUntil p (m : ms) = then return [a] else sequenceUntil p ms >>= \as -> return (a : as) -checkPrerequisites :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (Maybe (EvaluationDetail Value), [EvalEvent]) +checkPrerequisites :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (Maybe (EvaluationDetail Value), [EvalEvent], [Text]) checkPrerequisites flag context seenFlags store = let p = getField @"prerequisites" flag in if null p - then pure (Nothing, []) + then pure (Nothing, [], []) else do - evals <- sequenceUntil (isJust . fst) $ map (checkPrerequisite store context flag seenFlags) p - pure (msum $ map fst evals, concatMap snd evals) + evals <- sequenceUntil (isJust . (\(a, _, _) -> a)) $ map (checkPrerequisite store context flag seenFlags) p + pure (msum $ map fst3 evals, concatMap snd3 evals, mapMaybe trd evals) -checkPrerequisite :: (Monad m, LaunchDarklyStoreRead store m) => store -> Context -> Flag -> HS.HashSet Text -> Prerequisite -> m (Maybe (EvaluationDetail Value), [EvalEvent]) +checkPrerequisite :: (Monad m, LaunchDarklyStoreRead store m) => store -> Context -> Flag -> HS.HashSet Text -> Prerequisite -> m (Maybe (EvaluationDetail Value), [EvalEvent], Maybe Text) checkPrerequisite store context flag seenFlags prereq = - if HS.member (getField @"key" prereq) seenFlags - then pure (Just $ errorDetail EvalErrorKindMalformedFlag, []) + if HS.member prereqKey seenFlags + then pure (Just $ errorDetail EvalErrorKindMalformedFlag, [], Nothing) else - getFlagC store (getField @"key" prereq) >>= \case - Left err -> pure (pure $ getOffValue flag $ EvaluationReasonError $ EvalErrorExternalStore err, []) - Right Nothing -> pure (pure $ getOffValue flag $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), []) + getFlagC store prereqKey >>= \case + Left err -> pure (pure $ getOffValue flag $ EvaluationReasonError $ EvalErrorExternalStore err, [], Nothing) + Right Nothing -> pure (pure $ getOffValue flag $ EvaluationReasonPrerequisiteFailed prereqKey, [], Just prereqKey) Right (Just prereqFlag) -> evaluateDetail prereqFlag context seenFlags store >>= (process prereqFlag) where - process prereqFlag (detail, events) - | isError (getField @"reason" detail) = pure (Just $ errorDetail EvalErrorKindMalformedFlag, mempty) + prereqKey = getField @"key" prereq + process prereqFlag (detail, events, _prereqs) + | isError (getField @"reason" detail) = pure (Just $ errorDetail EvalErrorKindMalformedFlag, mempty, Just prereqKey) | otherwise = let event = newSuccessfulEvalEvent prereqFlag (getField @"variationIndex" detail) (getField @"value" detail) Nothing (getField @"reason" detail) (Just $ getField @"key" flag) context + prereqKey = getField @"key" prereqFlag in if status prereq detail prereqFlag - then pure (Nothing, event : events) - else pure (pure $ getOffValue flag $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), event : events) + then pure (Nothing, event : events, Just prereqKey) + else pure (pure $ getOffValue flag $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), event : events, Just prereqKey) evaluateInternal :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> store -> m (EvaluationDetail Value) evaluateInternal flag context store = result diff --git a/src/LaunchDarkly/Server/Util.hs b/src/LaunchDarkly/Server/Util.hs new file mode 100644 index 0000000..abc2e08 --- /dev/null +++ b/src/LaunchDarkly/Server/Util.hs @@ -0,0 +1,21 @@ +module LaunchDarkly.Server.Util + ( fst3 + , snd3 + , trd + ) +where + +-- | +-- Returns the first element of a 3-tuple. +fst3 :: (a, b, c) -> a +fst3 (x, _, _) = x + +-- | +-- Returns the second element of a 3-tuple. +snd3 :: (a, b, c) -> b +snd3 (_, x, _) = x + +-- | +-- Returns the third element of a 3-tuple. +trd :: (a, b, c) -> c +trd (_, _, x) = x diff --git a/test/Spec/Evaluate.hs b/test/Spec/Evaluate.hs index 8eb456a..09c0064 100644 --- a/test/Spec/Evaluate.hs +++ b/test/Spec/Evaluate.hs @@ -36,6 +36,7 @@ testFlagReturnsOffVariationIfFlagIsOff = TestCase $ do , reason = EvaluationReasonOff } , [] + , [] ) context = makeContext "x" "user" @@ -80,6 +81,7 @@ testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules = TestCase $ do } } , [] + , [] ) context = makeContext "x" "user" @@ -546,6 +548,7 @@ testClauseCanMatchOnKind = TestCase $ do } } , [] + , [] ) expectedFailure = @@ -555,6 +558,7 @@ testClauseCanMatchOnKind = TestCase $ do , reason = EvaluationReasonFallthrough {inExperiment = False} } , [] + , [] ) orgContext = makeContext "x" "org" @@ -624,6 +628,7 @@ testClauseCanMatchCustomAttribute = TestCase $ do } } , [] + , [] ) expectedFailure = @@ -633,6 +638,7 @@ testClauseCanMatchCustomAttribute = TestCase $ do , reason = EvaluationReasonFallthrough {inExperiment = False} } , [] + , [] ) userContext = makeContext "x" "user" & withAttribute "legs" (Number 4) @@ -702,6 +708,7 @@ testClauseCanMatchCustomAttributeReference = TestCase $ do } } , [] + , [] ) expectedFailure = @@ -711,6 +718,7 @@ testClauseCanMatchCustomAttributeReference = TestCase $ do , reason = EvaluationReasonFallthrough {inExperiment = False} } , [] + , [] ) userContext = makeContext "x" "user" & withAttribute "attr~1a" (String "right") From c6721df60a25888188fbb38ecf4d07977b8fc767 Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Wed, 23 Oct 2024 15:17:40 -0400 Subject: [PATCH 2/2] foldr over if null --- src/LaunchDarkly/Server/Client.hs | 2 +- src/LaunchDarkly/Server/Evaluate.hs | 31 ++++++++++++++++++----------- test/Spec/Evaluate.hs | 16 +++++++-------- 3 files changed, 28 insertions(+), 21 deletions(-) diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs index 811f7a3..68547ed 100644 --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -258,7 +258,7 @@ allFlagsState client context client_side_only with_reasons details_only_for_trac , trackEvents = trackEvents' || inExperiment , trackReason = trackReason' , debugEventsUntilDate = getField @"debugEventsUntilDate" flag - , prerequisites = if null prereqs then Nothing else Just prereqs + , prerequisites = prereqs } ) details diff --git a/src/LaunchDarkly/Server/Evaluate.hs b/src/LaunchDarkly/Server/Evaluate.hs index b5dfc9a..67781aa 100644 --- a/src/LaunchDarkly/Server/Evaluate.hs +++ b/src/LaunchDarkly/Server/Evaluate.hs @@ -37,7 +37,7 @@ import LaunchDarkly.Server.Features (Clause, Flag, Prerequisite, RolloutKind (Ro import LaunchDarkly.Server.Operators (Op (OpSegmentMatch), getOperation) import LaunchDarkly.Server.Reference (getComponents, getError, isValid, makeLiteral, makeReference) import LaunchDarkly.Server.Store.Internal (LaunchDarklyStoreRead, getFlagC, getSegmentC) -import LaunchDarkly.Server.Util (trd, snd3, fst3) +import LaunchDarkly.Server.Util (fst3, snd3, trd) setFallback :: EvaluationDetail Value -> Value -> EvaluationDetail Value setFallback detail fallback = case getField @"variationIndex" detail of @@ -63,17 +63,17 @@ evaluateTyped client key context fallback wrap includeReason convert = (setValue detail) (convert $ getField @"value" detail) -evaluateInternalClient :: Client -> Text -> Context -> Value -> Bool -> IO (EvaluationDetail Value, [Text]) -evaluateInternalClient _ _ (Invalid _) fallback _ = pure $ (errorDefault EvalErrorInvalidContext fallback, []) +evaluateInternalClient :: Client -> Text -> Context -> Value -> Bool -> IO (EvaluationDetail Value, Maybe [Text]) +evaluateInternalClient _ _ (Invalid _) fallback _ = pure $ (errorDefault EvalErrorInvalidContext fallback, Nothing) evaluateInternalClient client key context fallback includeReason = do (detail, unknown, events, prereqs) <- getFlagC (getField @"store" client) key >>= \case Left err -> do let event = newUnknownFlagEvent key fallback (EvaluationReasonError $ EvalErrorExternalStore err) context - pure (errorDetail $ EvalErrorExternalStore err, True, pure event, []) + pure (errorDetail $ EvalErrorExternalStore err, True, pure event, Nothing) Right Nothing -> do let event = newUnknownFlagEvent key fallback (EvaluationReasonError EvalErrorFlagNotFound) context - pure (errorDefault EvalErrorFlagNotFound fallback, True, pure event, []) + pure (errorDefault EvalErrorFlagNotFound fallback, True, pure event, Nothing) Right (Just flag) -> do (detail, events, prereqs) <- evaluateDetail flag context HS.empty $ getField @"store" client let detail' = setFallback detail fallback @@ -108,10 +108,10 @@ getVariation flag index reason idx = fromIntegral index variations = getField @"variations" flag -evaluateDetail :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (EvaluationDetail Value, [EvalEvent], [Text]) -evaluateDetail flag@(getField @"on" -> False) _ _ _ = pure (getOffValue flag EvaluationReasonOff, [], []) +evaluateDetail :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (EvaluationDetail Value, [EvalEvent], Maybe [Text]) +evaluateDetail flag@(getField @"on" -> False) _ _ _ = pure (getOffValue flag EvaluationReasonOff, [], Nothing) evaluateDetail flag context seenFlags store - | HS.member (getField @"key" flag) seenFlags = pure (getOffValue flag $ EvaluationReasonError EvalErrorKindMalformedFlag, [], []) + | HS.member (getField @"key" flag) seenFlags = pure (getOffValue flag $ EvaluationReasonError EvalErrorKindMalformedFlag, [], Nothing) | otherwise = checkPrerequisites flag context (HS.insert (getField @"key" flag) seenFlags) store >>= \case (Nothing, events, prereqs) -> evaluateInternal flag context store >>= (\x -> pure (x, events, prereqs)) @@ -131,14 +131,21 @@ sequenceUntil p (m : ms) = then return [a] else sequenceUntil p ms >>= \as -> return (a : as) -checkPrerequisites :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (Maybe (EvaluationDetail Value), [EvalEvent], [Text]) +checkPrerequisites :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (Maybe (EvaluationDetail Value), [EvalEvent], Maybe [Text]) checkPrerequisites flag context seenFlags store = let p = getField @"prerequisites" flag in if null p - then pure (Nothing, [], []) + then pure (Nothing, [], Nothing) else do - evals <- sequenceUntil (isJust . (\(a, _, _) -> a)) $ map (checkPrerequisite store context flag seenFlags) p - pure (msum $ map fst3 evals, concatMap snd3 evals, mapMaybe trd evals) + evals <- sequenceUntil (isJust . fst3) $ map (checkPrerequisite store context flag seenFlags) p + prereqs <- pure $ foldr (collectPrereqs . trd) Nothing evals + pure (msum $ map fst3 evals, concatMap snd3 evals, prereqs) + where + collectPrereqs :: Maybe a -> Maybe [a] -> Maybe [a] + collectPrereqs Nothing Nothing = Nothing + collectPrereqs Nothing (Just x) = Just x + collectPrereqs (Just x) Nothing = Just [x] + collectPrereqs (Just x) (Just xs) = Just (x : xs) checkPrerequisite :: (Monad m, LaunchDarklyStoreRead store m) => store -> Context -> Flag -> HS.HashSet Text -> Prerequisite -> m (Maybe (EvaluationDetail Value), [EvalEvent], Maybe Text) checkPrerequisite store context flag seenFlags prereq = diff --git a/test/Spec/Evaluate.hs b/test/Spec/Evaluate.hs index 09c0064..5e6030c 100644 --- a/test/Spec/Evaluate.hs +++ b/test/Spec/Evaluate.hs @@ -36,7 +36,7 @@ testFlagReturnsOffVariationIfFlagIsOff = TestCase $ do , reason = EvaluationReasonOff } , [] - , [] + , Nothing ) context = makeContext "x" "user" @@ -81,7 +81,7 @@ testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules = TestCase $ do } } , [] - , [] + , Nothing ) context = makeContext "x" "user" @@ -548,7 +548,7 @@ testClauseCanMatchOnKind = TestCase $ do } } , [] - , [] + , Nothing ) expectedFailure = @@ -558,7 +558,7 @@ testClauseCanMatchOnKind = TestCase $ do , reason = EvaluationReasonFallthrough {inExperiment = False} } , [] - , [] + , Nothing ) orgContext = makeContext "x" "org" @@ -628,7 +628,7 @@ testClauseCanMatchCustomAttribute = TestCase $ do } } , [] - , [] + , Nothing ) expectedFailure = @@ -638,7 +638,7 @@ testClauseCanMatchCustomAttribute = TestCase $ do , reason = EvaluationReasonFallthrough {inExperiment = False} } , [] - , [] + , Nothing ) userContext = makeContext "x" "user" & withAttribute "legs" (Number 4) @@ -708,7 +708,7 @@ testClauseCanMatchCustomAttributeReference = TestCase $ do } } , [] - , [] + , Nothing ) expectedFailure = @@ -718,7 +718,7 @@ testClauseCanMatchCustomAttributeReference = TestCase $ do , reason = EvaluationReasonFallthrough {inExperiment = False} } , [] - , [] + , Nothing ) userContext = makeContext "x" "user" & withAttribute "attr~1a" (String "right")