diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ All notable changes to the LaunchDarkly Haskell Server-side SDK will be documented in this file. This project adheres to [Semantic Versioning](http://semver.org). +## [2.2.0] - 2021-06-17 +### Added: +- The SDK now supports the ability to control the proportion of traffic allocation to an experiment. This works in conjunction with a new platform feature now available to early access customers. + + + ## [2.1.1] - 2021-03-05 ### Changed: - Updated dependency ranges. Thanks @dbaynard ! diff --git a/launchdarkly-server-sdk.cabal b/launchdarkly-server-sdk.cabal --- a/launchdarkly-server-sdk.cabal +++ b/launchdarkly-server-sdk.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 9c49985b1be9e7892247a17dc58bd99868a99a2c360b9a1f81726b633e62f008 name: launchdarkly-server-sdk -version: 2.1.1 +version: 2.2.0 synopsis: Server-side SDK for integrating with LaunchDarkly description: Please see the README on GitHub at category: Web @@ -52,7 +50,29 @@ Paths_launchdarkly_server_sdk hs-source-dirs: src - default-extensions: AllowAmbiguousTypes DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MonoLocalBinds MultiParamTypeClasses MultiWayIf NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections TypeApplications TypeOperators + default-extensions: + AllowAmbiguousTypes + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MonoLocalBinds + MultiParamTypeClasses + MultiWayIf + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TupleSections + TypeApplications + TypeOperators ghc-options: -fwarn-unused-imports -Wall -Wno-name-shadowing build-depends: aeson >=1.4.4.0 && <1.6 @@ -128,7 +148,29 @@ test src stores/launchdarkly-server-sdk-redis/src - default-extensions: AllowAmbiguousTypes DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MonoLocalBinds MultiParamTypeClasses MultiWayIf NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections TypeApplications TypeOperators + default-extensions: + AllowAmbiguousTypes + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MonoLocalBinds + MultiParamTypeClasses + MultiWayIf + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TupleSections + TypeApplications + TypeOperators ghc-options: -rtsopts -threaded -with-rtsopts=-N -Wno-name-shadowing build-depends: HUnit diff --git a/src/LaunchDarkly/Server/Client/Internal.hs b/src/LaunchDarkly/Server/Client/Internal.hs --- a/src/LaunchDarkly/Server/Client/Internal.hs +++ b/src/LaunchDarkly/Server/Client/Internal.hs @@ -25,7 +25,7 @@ -- | The version string for this library. clientVersion :: Text -clientVersion = "2.1.1" +clientVersion = "2.2.0" -- | The status of the client initialization. data Status diff --git a/src/LaunchDarkly/Server/Details.hs b/src/LaunchDarkly/Server/Details.hs --- a/src/LaunchDarkly/Server/Details.hs +++ b/src/LaunchDarkly/Server/Details.hs @@ -31,10 +31,14 @@ | EvaluationReasonTargetMatch -- ^ indicates that the user key was specifically targeted for this flag. | EvaluationReasonRuleMatch - { ruleIndex :: !Natural + { ruleIndex :: !Natural -- ^ The index of the rule that was matched (0 being the first). - , ruleId :: !Text + , ruleId :: !Text -- ^ The unique identifier of the rule that was matched. + , inExperiment :: !Bool + -- ^ Whether the evaluation was part of an experiment. Is true if + -- the evaluation resulted in an experiment rollout *and* served + -- one of the variations in the experiment. Otherwise false. } -- ^ Indicates that the user matched one of the flag's rules. | EvaluationReasonPrerequisiteFailed @@ -45,6 +49,11 @@ -- one prerequisite flag that either was off or did not return the desired -- variation. | EvaluationReasonFallthrough + { inExperiment :: !Bool + -- ^ Whether the evaluation was part of an experiment. Is + -- true if the evaluation resulted in an experiment rollout *and* + -- served one of the variations in the experiment. Otherwise false. + } -- ^ Indicates that the flag was on but the user did not match any targets -- or rules. | EvaluationReasonError @@ -58,17 +67,17 @@ instance ToJSON EvaluationReason where toJSON x = case x of - EvaluationReasonOff -> + EvaluationReasonOff -> Object $ HM.fromList [("kind", "OFF")] - EvaluationReasonTargetMatch -> + EvaluationReasonTargetMatch -> Object $ HM.fromList [("kind", "TARGET_MATCH")] - (EvaluationReasonRuleMatch ruleIndex ruleId) -> - Object $ HM.fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId)] - (EvaluationReasonPrerequisiteFailed prerequisiteKey) -> + (EvaluationReasonRuleMatch ruleIndex ruleId inExperiment) -> + Object $ HM.fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId), ("inExperiment", toJSON inExperiment)] + (EvaluationReasonPrerequisiteFailed prerequisiteKey) -> Object $ HM.fromList [("kind", "PREREQUISITE_FAILED"), ("prerequisiteKey", toJSON prerequisiteKey)] - EvaluationReasonFallthrough -> - Object $ HM.fromList [("kind", "FALLTHROUGH")] - (EvaluationReasonError errorKind) -> + EvaluationReasonFallthrough inExperiment -> + Object $ HM.fromList [("kind", "FALLTHROUGH"), ("inExperiment", toJSON inExperiment)] + (EvaluationReasonError errorKind) -> Object $ HM.fromList [("kind", "ERROR"), ("errorKind", toJSON errorKind)] -- | Defines the possible values of the errorKind property of EvaluationReason. diff --git a/src/LaunchDarkly/Server/Evaluate.hs b/src/LaunchDarkly/Server/Evaluate.hs --- a/src/LaunchDarkly/Server/Evaluate.hs +++ b/src/LaunchDarkly/Server/Evaluate.hs @@ -1,14 +1,16 @@ module LaunchDarkly.Server.Evaluate where +import Control.Lens ((%~)) import Control.Monad (mzero, msum) import Control.Monad.Extra (ifM, anyM, allM, firstJustM) import Crypto.Hash.SHA1 (hash) import Data.Scientific (Scientific, floatingOrInteger) import Data.Either (either, fromLeft) +import Data.Function ((&)) import Data.Aeson.Types (Value(..)) import Data.Maybe (maybe, fromJust, isJust, fromMaybe) import Data.Text (Text) -import Data.Generics.Product (getField) +import Data.Generics.Product (getField, field) import Data.List (genericIndex, null, find) import qualified Data.Vector as V import qualified Data.Text as T @@ -21,7 +23,7 @@ import LaunchDarkly.Server.Client.Internal (ClientI, Status(Initialized), getStatusI) import LaunchDarkly.Server.User.Internal (UserI, valueOf) -import LaunchDarkly.Server.Features (Flag, Segment, Prerequisite, SegmentRule, Clause, VariationOrRollout, Rule) +import LaunchDarkly.Server.Features (Flag, Segment, Prerequisite, SegmentRule, Clause, VariationOrRollout, Rule, RolloutKind(RolloutKindExperiment)) import LaunchDarkly.Server.Store.Internal (LaunchDarklyStoreRead, getFlagC, getSegmentC) import LaunchDarkly.Server.Operators (Op(OpSegmentMatch), getOperation) import LaunchDarkly.Server.Events (EvalEvent, newUnknownFlagEvent, newSuccessfulEvalEvent, processEvalEvents) @@ -113,9 +115,9 @@ then Just $ getVariation flag (getField @"variation" target) EvaluationReasonTargetMatch else Nothing checkRule (ruleIndex, rule) = ifM (ruleMatchesUser rule user store) (pure $ Just $ getValueForVariationOrRollout flag (getField @"variationOrRollout" rule) user - EvaluationReasonRuleMatch { ruleIndex = ruleIndex, ruleId = getField @"id" rule }) + EvaluationReasonRuleMatch { ruleIndex = ruleIndex, ruleId = getField @"id" rule, inExperiment = False }) (pure Nothing) - fallthrough = getValueForVariationOrRollout flag (getField @"fallthrough" flag) user EvaluationReasonFallthrough + fallthrough = getValueForVariationOrRollout flag (getField @"fallthrough" flag) user (EvaluationReasonFallthrough False) result = let ruleMatch = checkRule <$> zip [0..] (getField @"rules" flag) targetMatch = return . checkTarget <$> getField @"targets" flag @@ -127,24 +129,32 @@ getValueForVariationOrRollout :: Flag -> VariationOrRollout -> UserI -> EvaluationReason -> EvaluationDetail Value getValueForVariationOrRollout flag vr user reason = case variationIndexForUser vr user (getField @"key" flag) (getField @"salt" flag) of - Nothing -> errorDetail EvalErrorKindMalformedFlag - Just x -> getVariation flag x reason + (Nothing, _) -> errorDetail EvalErrorKindMalformedFlag + (Just x, inExperiment) -> (getVariation flag x reason) & field @"reason" %~ setInExperiment inExperiment +setInExperiment :: Bool -> EvaluationReason -> EvaluationReason +setInExperiment inExperiment reason = case reason of + EvaluationReasonFallthrough _ -> EvaluationReasonFallthrough inExperiment + EvaluationReasonRuleMatch index idx _ -> EvaluationReasonRuleMatch index idx inExperiment + x -> x + ruleMatchesUser :: Monad m => LaunchDarklyStoreRead store m => Rule -> UserI -> store -> m Bool ruleMatchesUser rule user store = allM (\clause -> clauseMatchesUser store clause user) (getField @"clauses" rule) -variationIndexForUser :: VariationOrRollout -> UserI -> Text -> Text -> Maybe Natural +variationIndexForUser :: VariationOrRollout -> UserI -> Text -> Text -> (Maybe Natural, Bool) variationIndexForUser vor user key salt - | (Just variation) <- getField @"variation" vor = pure variation + | (Just variation) <- getField @"variation" vor = (pure variation, False) | (Just rollout) <- getField @"rollout" vor = let + isExperiment = (getField @"kind" rollout) == RolloutKindExperiment variations = getField @"variations" rollout - bucket = bucketUser user key (fromMaybe "key" $ getField @"bucketBy" rollout) salt + bucket = bucketUser user key (fromMaybe "key" $ getField @"bucketBy" rollout) salt (getField @"seed" rollout) c acc i = acc >>= \acc -> let t = acc + ((getField @"weight" i) / 100000.0) in - if bucket < t then Left (getField @"variation" i) else Right t - in if null variations then Nothing else pure $ fromLeft (getField @"variation" $ last variations) $ + if bucket < t then Left (Just $ getField @"variation" i, (not $ getField @"untracked" i) && isExperiment) else Right t + in if null variations then (Nothing, False) else fromLeft + (Just $ getField @"variation" $ last variations, (not $ getField @"untracked" $ last variations) && isExperiment) $ foldl c (Right (0.0 :: Float)) variations - | otherwise = Nothing + | otherwise = (Nothing, False) -- Bucketing ------------------------------------------------------------------- @@ -159,10 +169,13 @@ hexStringToNumber bytes = B.foldl' step (Just 0) bytes where step acc x = acc >>= \acc' -> hexCharToNumber x >>= pure . (+) (acc' * 16) -bucketUser :: UserI -> Text -> Text -> Text -> Float -bucketUser user key attribute salt = fromMaybe 0 $ do +bucketUser :: UserI -> Text -> Text -> Text -> Maybe Int -> Float +bucketUser user key attribute salt seed = fromMaybe 0 $ do + let secondarySuffix = maybe "" (T.append ".") $ getField @"secondary" user i <- valueOf user attribute >>= bucketableStringValue >>= \x -> pure $ B.take 15 $ B16.encode $ hash $ encodeUtf8 $ - T.concat [key, ".", salt, ".", x, maybe "" (T.append ".") $ getField @"secondary" user] + case seed of + Nothing -> T.concat [key, ".", salt, ".", x, secondarySuffix] + Just seed' -> T.concat [T.pack $ show seed', ".", x, secondarySuffix] pure $ ((fromIntegral $ fromJust $ hexStringToNumber i) :: Float) / (0xFFFFFFFFFFFFFFF) floatingOrInteger' :: Scientific -> Either Double Integer @@ -208,7 +221,7 @@ segmentRuleMatchesUser rule user key salt = (&&) (all (flip clauseMatchesUserNoSegments user) (getField @"clauses" rule)) (flip (maybe True) (getField @"weight" rule) $ \weight -> - bucketUser user key (fromMaybe "key" $ getField @"bucketBy" rule) salt < weight / 100000.0) + bucketUser user key (fromMaybe "key" $ getField @"bucketBy" rule) salt Nothing < weight / 100000.0) segmentContainsUser :: Segment -> UserI -> Bool segmentContainsUser segment user diff --git a/src/LaunchDarkly/Server/Events.hs b/src/LaunchDarkly/Server/Events.hs --- a/src/LaunchDarkly/Server/Events.hs +++ b/src/LaunchDarkly/Server/Events.hs @@ -295,9 +295,11 @@ where shouldForceReason = case reason of - EvaluationReasonFallthrough -> getField @"trackEventsFallthrough" flag - (EvaluationReasonRuleMatch idx _) -> getField @"trackEvents" (getField @"rules" flag !! fromIntegral idx) - _ -> False + (EvaluationReasonFallthrough inExperiment) -> + inExperiment || getField @"trackEventsFallthrough" flag + (EvaluationReasonRuleMatch idx _ inExperiment) -> + inExperiment || getField @"trackEvents" (getField @"rules" flag !! fromIntegral idx) + _ -> False makeSummaryKey :: EvalEvent -> Text makeSummaryKey event = T.intercalate "-" diff --git a/src/LaunchDarkly/Server/Features.hs b/src/LaunchDarkly/Server/Features.hs --- a/src/LaunchDarkly/Server/Features.hs +++ b/src/LaunchDarkly/Server/Features.hs @@ -1,6 +1,7 @@ module LaunchDarkly.Server.Features where -import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), withObject, (.:), (.:?), object, (.=)) +import Control.Monad (mzero) +import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), withObject, (.:), (.:?), object, (.=), (.!=)) import Data.Text (Text) import Data.HashSet (HashSet) import Data.Generics.Product (getField) @@ -50,12 +51,44 @@ data WeightedVariation = WeightedVariation { variation :: !Natural , weight :: !Float - } deriving (Generic, FromJSON, ToJSON, Show, Eq) + , untracked :: !Bool + } deriving (Generic, ToJSON, Show, Eq) +instance FromJSON WeightedVariation where + parseJSON = withObject "WeightedVariation" $ \o -> do + variation <- o .: "variation" + weight <- o .: "weight" + untracked <- o .:? "untracked" .!= False + pure WeightedVariation { .. } + +data RolloutKind = RolloutKindExperiment | RolloutKindRollout + deriving (Eq, Show) + +instance ToJSON RolloutKind where + toJSON x = String $ case x of + RolloutKindExperiment -> "experiment" + RolloutKindRollout -> "rollout" + +instance FromJSON RolloutKind where + parseJSON x = case x of + (String "experiment") -> pure RolloutKindExperiment + (String "rollout") -> pure RolloutKindRollout + _ -> mzero + data Rollout = Rollout { variations :: ![WeightedVariation] , bucketBy :: !(Maybe Text) - } deriving (Generic, FromJSON, ToJSON, Show, Eq) + , kind :: !RolloutKind + , seed :: !(Maybe Int) + } deriving (Generic, ToJSON, Show, Eq) + +instance FromJSON Rollout where + parseJSON = withObject "rollout" $ \o -> do + variations <- o .: "variations" + bucketBy <- o .:? "bucketBy" + kind <- o .:? "kind" .!= RolloutKindRollout + seed <- o .:? "seed" + pure Rollout { .. } data VariationOrRollout = VariationOrRollout { variation :: !(Maybe Natural) diff --git a/test/Spec/Bucket.hs b/test/Spec/Bucket.hs --- a/test/Spec/Bucket.hs +++ b/test/Spec/Bucket.hs @@ -14,32 +14,39 @@ testBucketUserByKey :: Test testBucketUserByKey = TestList - [ TestCase $ assertEqual "bucket one" 0.42157587 (bucketUser (unwrapUser $ makeUser "userKeyA") "hashKey" "key" "saltyA") - , TestCase $ assertEqual "bucket two" 0.6708485 (bucketUser (unwrapUser $ makeUser "userKeyB") "hashKey" "key" "saltyA") - , TestCase $ assertEqual "bucket three" 0.10343106 (bucketUser (unwrapUser $ makeUser "userKeyC") "hashKey" "key" "saltyA") + [ TestCase $ assertEqual "bucket one" 0.42157587 (bucketUser (unwrapUser $ makeUser "userKeyA") "hashKey" "key" "saltyA" Nothing) + , TestCase $ assertEqual "bucket two" 0.6708485 (bucketUser (unwrapUser $ makeUser "userKeyB") "hashKey" "key" "saltyA" Nothing) + , TestCase $ assertEqual "bucket three" 0.10343106 (bucketUser (unwrapUser $ makeUser "userKeyC") "hashKey" "key" "saltyA" Nothing) ] +testBucketUserWithSeed :: Test +testBucketUserWithSeed = TestList + [ TestCase $ assertEqual "bucket one" 0.09801207 (bucketUser (unwrapUser $ makeUser "userKeyA") "hashKey" "key" "saltyA" (Just 61)) + , TestCase $ assertEqual "bucket two" 0.14483777 (bucketUser (unwrapUser $ makeUser "userKeyB") "hashKey" "key" "saltyA" (Just 61)) + , TestCase $ assertEqual "bucket three" 0.9242641 (bucketUser (unwrapUser $ makeUser "userKeyC") "hashKey" "key" "saltyA" (Just 61)) + ] + testBucketUserByIntAttr :: Test testBucketUserByIntAttr = TestList [ TestCase $ assertEqual "intAttr" 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyD") - & userSetCustom (HM.singleton "intAttr" (Number 33333))) "hashKey" "intAttr" "saltyA" + & userSetCustom (HM.singleton "intAttr" (Number 33333))) "hashKey" "intAttr" "saltyA" Nothing , TestCase $ assertEqual "stringAttr" 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyD") - & userSetCustom (HM.singleton "stringAttr" (String "33333"))) "hashKey" "stringAttr" "saltyA" + & userSetCustom (HM.singleton "stringAttr" (String "33333"))) "hashKey" "stringAttr" "saltyA" Nothing ] testBucketUserByFloatAttrNotAllowed :: Test testBucketUserByFloatAttrNotAllowed = (~=?) 0 $ bucketUser (unwrapUser $ (makeUser "userKeyE") - & userSetCustom (HM.singleton "floatAttr" (Number 999.999))) "hashKey" "floatAttr" "saltyA" + & userSetCustom (HM.singleton "floatAttr" (Number 999.999))) "hashKey" "floatAttr" "saltyA" Nothing testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed :: Test testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed = (~=?) 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyE") - & userSetCustom (HM.singleton "floatAttr" (Number 33333))) "hashKey" "floatAttr" "saltyA" + & userSetCustom (HM.singleton "floatAttr" (Number 33333))) "hashKey" "floatAttr" "saltyA" Nothing testVariationIndexForUser :: Test testVariationIndexForUser = TestCase $ do - assertEqual "test" (Just 0) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyA") "hashKey" "saltyA" - assertEqual "test" (Just 1) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyB") "hashKey" "saltyA" - assertEqual "test" (Just 0) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyC") "hashKey" "saltyA" + assertEqual "test" (Just 0, False) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyA") "hashKey" "saltyA" + assertEqual "test" (Just 1, True) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyB") "hashKey" "saltyA" + assertEqual "test" (Just 0, False) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyC") "hashKey" "saltyA" where @@ -47,14 +54,18 @@ { variation = Nothing , rollout = Just Rollout { bucketBy = Nothing + , seed = Nothing + , kind = RolloutKindExperiment , variations = [ WeightedVariation { variation = 0 , weight = 60000 + , untracked = True } , WeightedVariation { variation = 1 , weight = 40000 + , untracked = False } ] } @@ -63,6 +74,7 @@ allTests :: Test allTests = TestList [ testBucketUserByKey + , testBucketUserWithSeed , testBucketUserByIntAttr , testBucketUserByFloatAttrNotAllowed , testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed diff --git a/test/Spec/Evaluate.hs b/test/Spec/Evaluate.hs --- a/test/Spec/Evaluate.hs +++ b/test/Spec/Evaluate.hs @@ -77,6 +77,8 @@ { value = String "fall" , variationIndex = pure 0 , reason = EvaluationReasonFallthrough + { inExperiment = False + } }, []) user = unwrapUser $ makeUser "x" @@ -160,6 +162,8 @@ { variation = Nothing , rollout = pure Rollout { variations = [] + , seed = Nothing + , kind = RolloutKindRollout , bucketBy = pure "key" } } @@ -307,6 +311,8 @@ { value = "fall" , variationIndex = pure 0 , reason = EvaluationReasonFallthrough + { inExperiment = False + } } testClauseCanMatchCustomAttribute :: Test @@ -321,8 +327,9 @@ { value = Bool True , variationIndex = pure 1 , reason = EvaluationReasonRuleMatch - { ruleIndex = 0 - , ruleId = "clause" + { ruleIndex = 0 + , ruleId = "clause" + , inExperiment = False } }, [])