launchdarkly-server-sdk 2.1.1 → 2.2.0

raw patch · 9 files changed

+175/−51 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• launchdarkly-server-sdk.cabal +48/−6
• src/LaunchDarkly/Server/Client/Internal.hs +1/−1
• src/LaunchDarkly/Server/Details.hs +19/−10
• src/LaunchDarkly/Server/Evaluate.hs +29/−16
• src/LaunchDarkly/Server/Events.hs +5/−3
• src/LaunchDarkly/Server/Features.hs +36/−3
• test/Spec/Bucket.hs +22/−10
• test/Spec/Evaluate.hs +9/−2

@@ -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 !

@@ -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 <https://github.com/launchdarkly/haskell-server-sdk#readme> 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

@@ -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

@@ -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.

@@ -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

@@ -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 "-"

@@ -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)

@@ -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

@@ -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             }         }, [])