feat: Add support for client-side prerequisite events

contract-tests/src/Main.hs

@@ -51,6 +51,7 @@ getAppStatus =
                 , "inline-context"
                 , "anonymous-redaction"
                 , "omit-anonymous-contexts"
+                , "client-prereq-events"
                 ]
             }
 

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

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 = prereqs
                                 }
                         )
                         details

src/LaunchDarkly/Server/Evaluate.hs

@@ -17,7 +17,7 @@
 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.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 (fst3, snd3, trd)
 
 setFallback :: EvaluationDetail Value -> Value -> EvaluationDetail Value
 setFallback detail fallback = case getField @"variationIndex" detail of
@@ -55,26 +56,26 @@
         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, Maybe [Text])
+evaluateInternalClient _ _ (Invalid _) fallback _ = pure $ (errorDefault EvalErrorInvalidContext fallback, Nothing)
 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, 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) <- 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 @@
                             (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 @@
     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], 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) -> 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,41 @@
             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], 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 . fst) $ map (checkPrerequisite store context flag seenFlags) p
-                pure (msum $ map fst evals, concatMap snd 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])
+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

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

test/Spec/Evaluate.hs

@@ -36,6 +36,7 @@ testFlagReturnsOffVariationIfFlagIsOff = TestCase $ do
             , reason = EvaluationReasonOff
             }
         , []
+        , Nothing
         )
 
     context = makeContext "x" "user"
@@ -80,6 +81,7 @@ testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules = TestCase $ do
                     }
             }
         , []
+        , Nothing
         )
 
     context = makeContext "x" "user"
@@ -546,6 +548,7 @@ testClauseCanMatchOnKind = TestCase $ do
                     }
             }
         , []
+        , Nothing
         )
 
     expectedFailure =
@@ -555,6 +558,7 @@ testClauseCanMatchOnKind = TestCase $ do
             , reason = EvaluationReasonFallthrough {inExperiment = False}
             }
         , []
+        , Nothing
         )
 
     orgContext = makeContext "x" "org"
@@ -624,6 +628,7 @@ testClauseCanMatchCustomAttribute = TestCase $ do
                     }
             }
         , []
+        , Nothing
         )
 
     expectedFailure =
@@ -633,6 +638,7 @@ testClauseCanMatchCustomAttribute = TestCase $ do
             , reason = EvaluationReasonFallthrough {inExperiment = False}
             }
         , []
+        , Nothing
         )
 
     userContext = makeContext "x" "user" & withAttribute "legs" (Number 4)
@@ -702,6 +708,7 @@ testClauseCanMatchCustomAttributeReference = TestCase $ do
                     }
             }
         , []
+        , Nothing
         )
 
     expectedFailure =
@@ -711,6 +718,7 @@ testClauseCanMatchCustomAttributeReference = TestCase $ do
             , reason = EvaluationReasonFallthrough {inExperiment = False}
             }
         , []
+        , Nothing
         )
 
     userContext = makeContext "x" "user" & withAttribute "attr~1a" (String "right")