packages feed

launchdarkly-server-sdk 3.1.1 → 4.0.0

raw patch · 54 files changed

+6351/−3807 lines, 54 filesdep +memorydep +monad-loopsdep −hedisdep −retrydep ~aesondep ~attoparsecdep ~base

Dependencies added: memory, monad-loops

Dependencies removed: hedis, retry

Dependency ranges changed: aeson, attoparsec, base, base16-bytestring, bytestring, containers, exceptions, extra, generic-lens, hashtables, http-client, lens, monad-logger, pcre-light, text, time, vector, yaml

Files

CHANGELOG.md view
@@ -2,6 +2,52 @@  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). +## [4.0.0] - 2023-02-21+The latest version of this SDK supports LaunchDarkly's new custom contexts feature. Contexts are an evolution of a previously-existing concept, "users." Contexts let you create targeting rules for feature flags based on a variety of different information, including attributes pertaining to users, organizations, devices, and more. You can even combine contexts to create "multi-contexts."++This feature is only available to members of LaunchDarkly's Early Access Program (EAP). If you're in the EAP, you can use contexts by updating your SDK to the latest version and, if applicable, updating your Relay Proxy. Outdated SDK versions do not support contexts, and will cause unpredictable flag evaluation behavior.++If you are not in the EAP, only use single contexts of kind "user", or continue to use the user type if available. If you try to create contexts, the context will be sent to LaunchDarkly, but any data not related to the user object will be ignored.++For detailed information about this version, please refer to the list below. For information on how to upgrade from the previous version, please read the [migration guide](https://docs.launchdarkly.com/sdk/server-side/haskell/migration-3-to-4).++### Added:+- The type `Context` from the `LaunchDarkly.Server.Context` module defines the new context model.+- All SDK methods that took a hash representing the user now accept an `LDContext`.+- Added support for [Secure Mode](https://docs.launchdarkly.com/sdk/features/secure-mode#haskell).++### Changed _(breaking changes from 3.x)_:+- The `secondary` attribute which existed in the user hash is no longer a supported feature. If you set an attribute with that name in `Context`, it will simply be a custom attribute like any other.+- Analytics event data now uses a new JSON schema due to differences between the context model and the old user model.++### Changed (requirements/dependencies/build):+- The minimum supported Stackage resolver is LTS 16.31.++### Changed (behavioral changes):+- The default polling URL has changed from `https://app.launchdarkly.com` to `https://sdk.launchdarkly.com`.+- Several optimizations within the flag evaluation logic have improved the performance of evaluations. For instance, target lists are now stored internally as sets for faster matching.++### Removed:+- Removed the `User` type and all associated functions from the `LaunchDarkly.Server.User` module.+- Removed support for the `secondary` meta-attribute in the user hash.+- The `alias` method no longer exists because alias events are not needed in the new context model.+- The `configSetInlineUsersInEvents` configuration option no longer exists because it is not relevant in the new context model.+- Removed all types and options that were deprecated as of the most recent 3.x release.+- The old Redis store integration has been removed from this repository and published to its own separate package. You can learn more by reviewing the [Haskell redis docs](https://docs.launchdarkly.com/sdk/features/storing-data/redis#haskell) or reviewing the published package on [Hackage](https://hackage.haskell.org/package/launchdarkly-server-sdk-redis-hedis).++### Deprecated:++The following methods in `TestData` have been deprecated and replaced with new context-aware options.+- `variationForAllUsers` was replaced with `variationForAll`+- `valueForAllUsers` was replaced with `valueForAll`+- `variationForUser` was replaced with `variationForKey`+- `ifMatch` was replaced with `ifMatchContext`+- `ifNotMatch` was replaced with `ifNotMatchContext`+- `andMatch` was replaced with `andMatchContext`+- `andNotMatch` was replaced with `andNotMatchContext`++The config method `configSetUserKeyLRUCapacity` has been deprecated and replaced with `configSetContextKeyLRUCapacity`.+ ## [3.1.1] - 2023-02-17 ### Fixed: - The polling thread will be shutdown if the LaunchDarkly polling API returns an unrecoverable response code.
launchdarkly-server-sdk.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           launchdarkly-server-sdk-version:        3.1.1+version:        4.0.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@@ -28,6 +28,7 @@     test-data/filesource/no-data.json     test-data/filesource/segment-only.json     test-data/filesource/segment-with-duplicate-key.json+    test-data/filesource/targets.json     test-data/filesource/value-only.json     test-data/filesource/value-with-duplicate-key.json @@ -41,7 +42,8 @@       LaunchDarkly.Server       LaunchDarkly.Server.Client       LaunchDarkly.Server.Config-      LaunchDarkly.Server.User+      LaunchDarkly.Server.Context+      LaunchDarkly.Server.Reference       LaunchDarkly.Server.Store       LaunchDarkly.Server.Integrations.FileData       LaunchDarkly.Server.Integrations.TestData@@ -51,6 +53,7 @@       LaunchDarkly.Server.Config.ClientContext       LaunchDarkly.Server.Config.HttpConfiguration       LaunchDarkly.Server.Config.Internal+      LaunchDarkly.Server.Context.Internal       LaunchDarkly.Server.DataSource.Internal       LaunchDarkly.Server.Details       LaunchDarkly.Server.Evaluate@@ -63,7 +66,6 @@       LaunchDarkly.Server.Network.Streaming       LaunchDarkly.Server.Operators       LaunchDarkly.Server.Store.Internal-      LaunchDarkly.Server.User.Internal       Paths_launchdarkly_server_sdk   hs-source-dirs:       src@@ -92,38 +94,38 @@       TypeOperators   ghc-options: -fwarn-unused-imports -Wall -Wno-name-shadowing   build-depends:-      aeson >=1.4.4.0 && <1.6 || >=2.0.1.0 && <2.2-    , attoparsec >=0.13.2.2 && <0.15-    , base >=4.12 && <5-    , base16-bytestring >=0.1.1.6 && <1.1-    , bytestring >=0.10.8.2 && <0.12+      aeson >=1.4.7.1 && <1.6 || >=2.0.1.0 && <2.2+    , attoparsec >=0.13.2.4 && <0.15+    , base >=4.13 && <5+    , base16-bytestring >=0.1.1.7 && <1.1+    , bytestring >=0.10.10.1 && <0.12     , clock ==0.8.*-    , containers >=0.6.0.1 && <0.7+    , containers >=0.6.2.1 && <0.7     , cryptohash >=0.11.9 && <0.12-    , exceptions >=0.10.2 && <0.11-    , extra >=1.6.17 && <1.8-    , generic-lens >=1.1.0.0 && <2.3-    , hashtables >=1.2.3.4 && <1.4-    , hedis >=0.12.7 && <0.16-    , http-client >=0.6.4 && <0.8+    , exceptions >=0.10.4 && <0.11+    , extra >=1.7.9 && <1.8+    , generic-lens >=2.0.0.0 && <2.3+    , hashtables >=1.2.4.1 && <1.4+    , http-client >=0.6.4.1 && <0.8     , http-client-tls >=0.3.5.3 && <0.4     , http-types >=0.12.3 && <0.13     , iso8601-time >=0.1.5 && <0.2-    , lens >=4.17.1 && <5.3+    , lens >=4.18.1 && <5.3     , lrucache >=1.2.0.1 && <1.3-    , monad-logger >=0.3.30 && <0.4+    , memory >=0.15.0+    , monad-logger >=0.3.36 && <0.4+    , monad-loops ==0.4.*     , mtl >=2.2.2 && <2.4-    , pcre-light >=0.4.0.4 && <0.5+    , pcre-light >=0.4.1.0 && <0.5     , random >=1.1 && <1.3-    , retry >=0.8.0.1 && <0.10     , scientific >=0.3.6.2 && <0.4     , semver >=0.3.4 && <0.5-    , text >=1.2.3.1 && <2.1-    , time >=1.8.0.2 && <1.13+    , text >=1.2.4.0 && <2.1+    , time >=1.9.3 && <1.13     , unordered-containers >=0.2.10.0 && <0.3     , uuid >=1.3.13 && <1.4-    , vector >=0.12.0.3 && <0.13-    , yaml >=0.11.1 && <0.12+    , vector >=0.12.1.2 && <0.13+    , yaml >=0.11.5.0 && <0.12   default-language: Haskell2010  test-suite haskell-server-sdk-test@@ -131,19 +133,20 @@   main-is: Spec.hs   other-modules:       Spec.Bucket+      Spec.Client       Spec.Config+      Spec.Context       Spec.DataSource       Spec.Evaluate       Spec.Features       Spec.Integrations.FileData       Spec.Integrations.TestData       Spec.Operators-      Spec.Redis+      Spec.PersistentDataStore+      Spec.Reference       Spec.Segment       Spec.Store-      Spec.StoreInterface       Spec.Streaming-      Spec.User       Util.Features       LaunchDarkly.AesonCompat       LaunchDarkly.Server@@ -154,6 +157,8 @@       LaunchDarkly.Server.Config.ClientContext       LaunchDarkly.Server.Config.HttpConfiguration       LaunchDarkly.Server.Config.Internal+      LaunchDarkly.Server.Context+      LaunchDarkly.Server.Context.Internal       LaunchDarkly.Server.DataSource.Internal       LaunchDarkly.Server.Details       LaunchDarkly.Server.Evaluate@@ -167,17 +172,13 @@       LaunchDarkly.Server.Network.Polling       LaunchDarkly.Server.Network.Streaming       LaunchDarkly.Server.Operators+      LaunchDarkly.Server.Reference       LaunchDarkly.Server.Store       LaunchDarkly.Server.Store.Internal-      LaunchDarkly.Server.User-      LaunchDarkly.Server.User.Internal-      LaunchDarkly.Server.Store.Redis-      LaunchDarkly.Server.Store.Redis.Internal       Paths_launchdarkly_server_sdk   hs-source-dirs:       test       src-      stores/launchdarkly-server-sdk-redis/src   default-extensions:       AllowAmbiguousTypes       DataKinds@@ -201,39 +202,39 @@       TupleSections       TypeApplications       TypeOperators-  ghc-options: -rtsopts -threaded -with-rtsopts=-N -Wno-name-shadowing+  ghc-options: -rtsopts -threaded -with-rtsopts=-N -Wno-name-shadowing -fwarn-unused-imports   build-depends:       HUnit-    , aeson >=1.4.4.0 && <1.6 || >=2.0.1.0 && <2.2-    , attoparsec >=0.13.2.2 && <0.15-    , base >=4.12 && <5-    , base16-bytestring >=0.1.1.6 && <1.1-    , bytestring >=0.10.8.2 && <0.12+    , aeson >=1.4.7.1 && <1.6 || >=2.0.1.0 && <2.2+    , attoparsec >=0.13.2.4 && <0.15+    , base >=4.13 && <5+    , base16-bytestring >=0.1.1.7 && <1.1+    , bytestring >=0.10.10.1 && <0.12     , clock ==0.8.*-    , containers >=0.6.0.1 && <0.7+    , containers >=0.6.2.1 && <0.7     , cryptohash >=0.11.9 && <0.12-    , exceptions >=0.10.2 && <0.11-    , extra >=1.6.17 && <1.8-    , generic-lens >=1.1.0.0 && <2.3-    , hashtables >=1.2.3.4 && <1.4-    , hedis >=0.12.7 && <0.16-    , http-client >=0.6.4 && <0.8+    , exceptions >=0.10.4 && <0.11+    , extra >=1.7.9 && <1.8+    , generic-lens >=2.0.0.0 && <2.3+    , hashtables >=1.2.4.1 && <1.4+    , http-client >=0.6.4.1 && <0.8     , http-client-tls >=0.3.5.3 && <0.4     , http-types >=0.12.3 && <0.13     , iso8601-time >=0.1.5 && <0.2-    , lens >=4.17.1 && <5.3+    , lens >=4.18.1 && <5.3     , lrucache >=1.2.0.1 && <1.3-    , monad-logger >=0.3.30 && <0.4+    , memory >=0.15.0+    , monad-logger >=0.3.36 && <0.4+    , monad-loops ==0.4.*     , mtl >=2.2.2 && <2.4-    , pcre-light >=0.4.0.4 && <0.5+    , pcre-light >=0.4.1.0 && <0.5     , random >=1.1 && <1.3-    , retry >=0.8.0.1 && <0.10     , scientific >=0.3.6.2 && <0.4     , semver >=0.3.4 && <0.5-    , text >=1.2.3.1 && <2.1-    , time >=1.8.0.2 && <1.13+    , text >=1.2.4.0 && <2.1+    , time >=1.9.3 && <1.13     , unordered-containers >=0.2.10.0 && <0.3     , uuid >=1.3.13 && <1.4-    , vector >=0.12.0.3 && <0.13-    , yaml >=0.11.1 && <0.12+    , vector >=0.12.1.2 && <0.13+    , yaml >=0.11.5.0 && <0.12   default-language: Haskell2010
src/LaunchDarkly/AesonCompat.hs view
@@ -1,4 +1,24 @@ {-# LANGUAGE CPP #-}++-- |+-- The LaunchDarkly SDK supports a subset of Aeson 1.x and 2.x. These two+-- versions differ in their type signatures, but are otherwise largely+-- compatible. To support both versions, we provide this compatibility module.+--+-- Depending on the version of Aeson you have installed, this module will+-- expose a KeyMap type that is either+--+-- - In the case of 1.x, a HashMap T.Text, or+-- - In the case of 2.x, the new KeyMap type+--+-- The compatibility layer exposes common map operations that the SDK needs and+-- may prove useful to customers. In nearly all instances, these are simple+-- aliases for the underlying Aeson equivalents.+--+-- The Aeson 2.x KeyMap is keyed by a new Key type that does not exist in 1.x.+-- To keep the API as consistent as possible, all functions requiring a key+-- will provide a Text value. In the 2.x compatibility layer, we will convert+-- it to a from the appropriate Key type as necessary. module LaunchDarkly.AesonCompat where  #if MIN_VERSION_aeson(2,0,0)@@ -10,7 +30,7 @@ #else import qualified Data.HashMap.Strict as HM #endif-import qualified Data.Text                  as T+import qualified Data.Text as T  #if MIN_VERSION_aeson(2,0,0) type KeyMap = KeyMap.KeyMap@@ -68,6 +88,9 @@  keyMapUnion :: KeyMap.KeyMap v -> KeyMap.KeyMap v -> KeyMap.KeyMap v keyMapUnion = KeyMap.union++foldrWithKey :: (T.Text -> v -> a -> a) -> a -> KeyMap.KeyMap v -> a+foldrWithKey f accum initial = KeyMap.foldrWithKey (\k v a -> f (keyToText k) v a) accum initial #else type KeyMap = HM.HashMap T.Text @@ -124,4 +147,7 @@  keyMapUnion :: HM.HashMap T.Text v -> HM.HashMap T.Text v -> HM.HashMap T.Text v keyMapUnion = HM.union++foldrWithKey :: (T.Text -> v -> a -> a) -> a -> HM.HashMap T.Text v -> a+foldrWithKey = HM.foldrWithKey #endif
src/LaunchDarkly/Server.hs view
@@ -1,75 +1,10 @@--- | This module re-exports the User, Client, and Config modules.-+-- | This module re-exports the Client, Config, and Context modules. module LaunchDarkly.Server-    ( Config-    , makeConfig-    , configSetKey-    , configSetBaseURI-    , configSetStreamURI-    , configSetEventsURI-    , configSetStreaming-    , configSetAllAttributesPrivate-    , configSetPrivateAttributeNames-    , configSetFlushIntervalSeconds-    , configSetPollIntervalSeconds-    , configSetUserKeyLRUCapacity-    , configSetInlineUsersInEvents-    , configSetEventsCapacity-    , configSetLogger-    , configSetManager-    , configSetSendEvents-    , configSetOffline-    , configSetRequestTimeoutSeconds-    , configSetStoreBackend-    , configSetStoreTTL-    , configSetUseLdd-    , configSetDataSourceFactory-    , configSetApplicationInfo-    , ApplicationInfo-    , makeApplicationInfo-    , withApplicationValue-    , User-    , makeUser-    , userSetKey-    , userSetSecondary-    , userSetIP-    , userSetCountry-    , userSetEmail-    , userSetFirstName-    , userSetLastName-    , userSetAvatar-    , userSetName-    , userSetAnonymous-    , userSetCustom-    , userSetPrivateAttributeNames-    , Client-    , makeClient-    , clientVersion-    , boolVariation-    , boolVariationDetail-    , stringVariation-    , stringVariationDetail-    , intVariation-    , intVariationDetail-    , doubleVariation-    , doubleVariationDetail-    , jsonVariation-    , jsonVariationDetail-    , EvaluationDetail(..)-    , EvaluationReason(..)-    , EvalErrorKind(..)-    , allFlags-    , allFlagsState-    , AllFlagsState-    , close-    , flushEvents-    , identify-    , track-    , alias-    , Status(..)-    , getStatus+    ( module LaunchDarkly.Server.Client+    , module LaunchDarkly.Server.Config+    , module LaunchDarkly.Server.Context     ) where -import LaunchDarkly.Server.User-import LaunchDarkly.Server.Config import LaunchDarkly.Server.Client+import LaunchDarkly.Server.Config+import LaunchDarkly.Server.Context
src/LaunchDarkly/Server/Client.hs view
@@ -1,5 +1,4 @@ -- | This module contains the core functionality of the SDK.- module LaunchDarkly.Server.Client     ( Client     , makeClient@@ -14,62 +13,66 @@     , doubleVariationDetail     , jsonVariation     , jsonVariationDetail-    , EvaluationDetail(..)-    , EvaluationReason(..)-    , EvalErrorKind(..)-    , allFlags+    , EvaluationDetail (..)+    , EvaluationReason (..)+    , EvalErrorKind (..)     , allFlagsState     , AllFlagsState+    , secureModeHash     , close     , flushEvents     , identify     , track-    , alias-    , Status(..)+    , Status (..)     , getStatus     ) where -import           Control.Concurrent                    (forkFinally, killThread)-import           Control.Concurrent.MVar               (putMVar, takeMVar, newEmptyMVar)-import           Control.Monad                         (void, forM_, unless)-import           Control.Monad.IO.Class                (liftIO)-import           Control.Monad.Logger                  (LoggingT, logDebug, logWarn)-import           Control.Monad.Fix                     (mfix)-import           Data.IORef                            (newIORef, writeIORef, readIORef)-import           Data.Maybe                            (fromMaybe)-import           Data.Text                             (Text)-import qualified Data.Text as                          T-import           Data.Text.Encoding                    (encodeUtf8)-import           Data.Aeson                            (Value(..), toJSON, ToJSON, (.=), object)-import           Data.Generics.Product                 (getField)-import           Data.Scientific                       (toRealFloat, fromFloatDigits)-import qualified Network.HTTP.Client as                Http-import           GHC.Generics                          (Generic)-import           GHC.Natural                           (Natural)-import           Network.HTTP.Client                   (newManager)-import           Network.HTTP.Client.TLS               (tlsManagerSettings)-import           System.Clock                          (TimeSpec(..))+import Control.Concurrent (forkFinally, killThread)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Monad (forM_, void)+import Control.Monad.Fix (mfix)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger (LoggingT, logDebug, logWarn)+import Data.Aeson (ToJSON, Value (..), object, toJSON, (.=))+import Data.Generics.Product (getField)+import qualified Data.HashSet as HS+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import Data.Scientific (fromFloatDigits, toRealFloat)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import Network.HTTP.Client (newManager)+import qualified Network.HTTP.Client as Http+import Network.HTTP.Client.TLS (tlsManagerSettings)+import System.Clock (TimeSpec (..)) -import           LaunchDarkly.Server.Client.Internal          (Client(..), ClientI(..), getStatusI, clientVersion)-import           LaunchDarkly.Server.Client.Status            (Status(..))-import           LaunchDarkly.Server.Config.ClientContext     (ClientContext(..))-import           LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..))-import           LaunchDarkly.Server.Config.Internal          (ConfigI, Config(..), shouldSendEvents, getApplicationInfoHeader, ApplicationInfo)-import           LaunchDarkly.Server.DataSource.Internal      (DataSource(..), DataSourceFactory, DataSourceUpdates(..), defaultDataSourceUpdates, nullDataSourceFactory)-import           LaunchDarkly.Server.Details                  (EvaluationDetail(..), EvaluationReason(..), EvalErrorKind(..))-import           LaunchDarkly.Server.Evaluate                 (evaluateTyped, evaluateDetail)-import           LaunchDarkly.Server.Events                   (IdentifyEvent(..), CustomEvent(..), AliasEvent(..), EventType(..), makeBaseEvent, queueEvent, makeEventState, addUserToEvent, userGetContextKind, maybeIndexUser, unixMilliseconds, noticeUser)-import           LaunchDarkly.Server.Features                 (isClientSideOnlyFlag, isInExperiment)-import           LaunchDarkly.Server.Network.Eventing         (eventThread)-import           LaunchDarkly.Server.Network.Polling          (pollingThread)-import           LaunchDarkly.Server.Network.Streaming        (streamingThread)-import           LaunchDarkly.Server.Store.Internal           (makeStoreIO, getAllFlagsC)-import           LaunchDarkly.Server.User.Internal            (User(..), userSerializeRedacted)-import           LaunchDarkly.AesonCompat                     (KeyMap, insertKey, emptyObject, mapValues, filterObject)+import LaunchDarkly.AesonCompat (KeyMap, emptyObject, filterObject, insertKey, mapValues)+import LaunchDarkly.Server.Client.Internal (Client (..), clientVersion, getStatusI)+import LaunchDarkly.Server.Client.Status (Status (..))+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.DataSource.Internal (DataSource (..), DataSourceFactory, DataSourceUpdates (..), defaultDataSourceUpdates, nullDataSourceFactory)+import LaunchDarkly.Server.Details (EvalErrorKind (..), EvaluationDetail (..), EvaluationReason (..))+import LaunchDarkly.Server.Evaluate (evaluateDetail, evaluateTyped)+import LaunchDarkly.Server.Events (CustomEvent (..), EventType (..), IdentifyEvent (..), makeBaseEvent, makeEventState, maybeIndexContext, noticeContext, queueEvent, unixMilliseconds)+import LaunchDarkly.Server.Features (isClientSideOnlyFlag, isInExperiment)+import LaunchDarkly.Server.Network.Eventing (eventThread)+import LaunchDarkly.Server.Network.Polling (pollingThread)+import LaunchDarkly.Server.Network.Streaming (streamingThread)+import LaunchDarkly.Server.Store.Internal (getAllFlagsC, makeStoreIO)++import Crypto.Hash.SHA256 (hash)+import Crypto.MAC.HMAC (hmac)+import Data.ByteArray.Encoding (Base (Base16), convertToBase) import Data.ByteString (ByteString)+import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Types (HeaderName) - networkDataSourceFactory :: (ClientContext -> DataSourceUpdates -> LoggingT IO ()) -> DataSourceFactory networkDataSourceFactory threadF clientContext dataSourceUpdates = do     initialized <- liftIO $ newIORef False@@ -88,94 +91,101 @@             $(logDebug) "Waiting on download thread to die"             liftIO $ void $ takeMVar sync -    pure $ DataSource{..}+    pure $ DataSource {..} -makeHttpConfiguration :: ConfigI -> IO HttpConfiguration+makeHttpConfiguration :: Config -> IO HttpConfiguration makeHttpConfiguration config = do     tlsManager <- newManager tlsManagerSettings-    let headers = [ ("Authorization", encodeUtf8 $ getField @"key" config)-                  , ("User-Agent" , "HaskellServerClient/" <> encodeUtf8 clientVersion)-                  ]+    let headers =+            [ ("Authorization", encodeUtf8 $ getField @"key" config)+            , ("User-Agent", "HaskellServerClient/" <> encodeUtf8 clientVersion)+            ]         defaultRequestHeaders = addTagsHeader headers (getField @"applicationInfo" config)         defaultRequestTimeout = Http.responseTimeoutMicro $ fromIntegral $ getField @"requestTimeoutSeconds" config * 1000000-    pure $ HttpConfiguration{..}-    where-        addTagsHeader :: [(HeaderName, ByteString)] -> Maybe ApplicationInfo -> [(HeaderName, ByteString)]-        addTagsHeader headers Nothing = headers-        addTagsHeader headers (Just info) = case getApplicationInfoHeader info of-            Nothing -> headers-            Just header -> ("X-LaunchDarkly-Tags", encodeUtf8 header) : headers+    pure $ HttpConfiguration {..}+  where+    addTagsHeader :: [(HeaderName, ByteString)] -> Maybe ApplicationInfo -> [(HeaderName, ByteString)]+    addTagsHeader headers Nothing = headers+    addTagsHeader headers (Just info) = case getApplicationInfoHeader info of+        Nothing -> headers+        Just header -> ("X-LaunchDarkly-Tags", encodeUtf8 header) : headers -makeClientContext :: ConfigI -> IO ClientContext+makeClientContext :: Config -> IO ClientContext makeClientContext config = do     let runLogger = getField @"logger" config     httpConfiguration <- makeHttpConfiguration config-    pure $ ClientContext{..}+    pure $ ClientContext {..}  -- | Create a new instance of the LaunchDarkly client. makeClient :: Config -> IO Client-makeClient (Config config) = mfix $ \(Client client) -> do-    status  <- newIORef Uninitialized-    store   <- makeStoreIO (getField @"storeBackend" config) (TimeSpec (fromIntegral $ getField @"storeTTLSeconds" config) 0)+makeClient config = mfix $ \client -> do+    status <- newIORef Uninitialized+    store <- makeStoreIO (getField @"storeBackend" config) (TimeSpec (fromIntegral $ getField @"storeTTLSeconds" config) 0)     manager <- case getField @"manager" config of-      Just manager -> pure manager-      Nothing      -> newManager tlsManagerSettings-    events  <- makeEventState config+        Just manager -> pure manager+        Nothing -> newManager tlsManagerSettings+    events <- makeEventState config      clientContext <- makeClientContext config      let dataSourceUpdates = defaultDataSourceUpdates status store     dataSource <- dataSourceFactory config clientContext dataSourceUpdates-    eventThreadPair    <- if not (shouldSendEvents config) then pure Nothing else do-        sync   <- newEmptyMVar-        thread <- forkFinally (runLogger clientContext $ eventThread manager client clientContext) (\_ -> putMVar sync ())-        pure $ pure (thread, sync)+    eventThreadPair <-+        if not (shouldSendEvents config)+            then pure Nothing+            else do+                sync <- newEmptyMVar+                thread <- forkFinally (runLogger clientContext $ eventThread manager client clientContext) (\_ -> putMVar sync ())+                pure $ pure (thread, sync)      dataSourceStart dataSource -    pure $ Client $ ClientI{..}-+    pure $ Client {..} -dataSourceFactory :: ConfigI -> DataSourceFactory+dataSourceFactory :: Config -> DataSourceFactory dataSourceFactory config =-    if getField @"offline" config || getField @"useLdd" config then-        nullDataSourceFactory-    else-        case getField @"dataSourceFactory" config of+    if getField @"offline" config || getField @"useLdd" config+        then nullDataSourceFactory+        else case getField @"dataSourceFactory" config of             Just factory ->                 factory             Nothing ->                 let dataSourceThread =-                        if getField @"streaming" config then-                            streamingThread (getField @"streamURI" config)-                        else-                            pollingThread (getField @"baseURI" config) (getField @"pollIntervalSeconds" config)-                in networkDataSourceFactory dataSourceThread+                        if getField @"streaming" config+                            then streamingThread (getField @"streamURI" config) (getField @"initialRetryDelay" config)+                            else pollingThread (getField @"baseURI" config) (getField @"pollIntervalSeconds" config)+                 in networkDataSourceFactory dataSourceThread -clientRunLogger :: ClientI -> (LoggingT IO () -> IO ())+clientRunLogger :: Client -> (LoggingT IO () -> IO ()) clientRunLogger client = getField @"logger" $ getField @"config" client  -- | Return the initialization status of the Client getStatus :: Client -> IO Status-getStatus (Client client) = getStatusI client+getStatus client = getStatusI client --- TODO(mmk) This method exists in multiple places. Should we move this into a util file?+-- TODO(mmk) This method exists in multiple places. Should we move this into a+-- util file? fromObject :: Value -> KeyMap Value fromObject x = case x of (Object o) -> o; _ -> error "expected object" --- | AllFlagsState captures the state of all feature flag keys as evaluated for--- a specific user. This includes their values, as well as other metadata.+-- |+-- AllFlagsState captures the state of all feature flag keys as evaluated for+-- a specific context. This includes their values, as well as other metadata. data AllFlagsState = AllFlagsState     { evaluations :: !(KeyMap Value)     , state :: !(KeyMap FlagState)     , valid :: !Bool-    } deriving (Show, Generic)+    }+    deriving (Show, Generic)  instance ToJSON AllFlagsState where-    toJSON state = Object $-        insertKey "$flagsState" (toJSON $ getField @"state" state) $-        insertKey "$valid" (toJSON $ getField @"valid" state)-        (fromObject $ toJSON $ getField @"evaluations" state)+    toJSON state =+        Object $+            insertKey "$flagsState" (toJSON $ getField @"state" state) $+                insertKey+                    "$valid"+                    (toJSON $ getField @"valid" state)+                    (fromObject $ toJSON $ getField @"evaluations" state)  data FlagState = FlagState     { version :: !(Maybe Natural)@@ -184,21 +194,25 @@     , trackEvents :: !Bool     , trackReason :: !Bool     , debugEventsUntilDate :: !(Maybe Natural)-    } deriving (Show, Generic)+    }+    deriving (Show, Generic)  instance ToJSON FlagState where-    toJSON state = object $-        filter ((/=) Null . snd)-        [ "version" .= getField @"version" state-        , "variation" .= getField @"variation" state-        , "trackEvents" .= if getField @"trackEvents" state then Just True else Nothing-        , "trackReason" .= if getField @"trackReason" state then Just True else Nothing-        , "reason" .= getField @"reason" state-        , "debugEventsUntilDate" .= getField @"debugEventsUntilDate" state-        ]+    toJSON state =+        object $+            filter+                ((/=) Null . snd)+                [ "version" .= getField @"version" state+                , "variation" .= getField @"variation" state+                , "trackEvents" .= if getField @"trackEvents" state then Just True else Nothing+                , "trackReason" .= if getField @"trackReason" state then Just True else Nothing+                , "reason" .= getField @"reason" state+                , "debugEventsUntilDate" .= getField @"debugEventsUntilDate" state+                ] --- | Returns an object that encapsulates the state of all feature flags for a--- given user. This includes the flag values, and also metadata that can be+-- |+-- Returns an object that encapsulates the state of all feature flags for a+-- given context. This includes the flag values, and also metadata that can be -- used on the front end. -- -- The most common use case for this method is to bootstrap a set of@@ -215,119 +229,112 @@ -- -- For more information, see the Reference Guide: -- https://docs.launchdarkly.com/sdk/features/all-flags#haskell-allFlagsState :: Client -> User -> Bool -> Bool -> Bool -> IO (AllFlagsState)-allFlagsState (Client client) (User user) client_side_only with_reasons details_only_for_tracked_flags  = do+allFlagsState :: Client -> Context -> Bool -> Bool -> Bool -> IO (AllFlagsState)+allFlagsState client context client_side_only with_reasons details_only_for_tracked_flags = do     status <- getAllFlagsC $ getField @"store" client     case status of-        Left _      -> pure AllFlagsState { evaluations = emptyObject, state = emptyObject, valid = False }+        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 user $ getField @"store" client)) filtered+            details <- mapM (\flag -> (\detail -> (flag, fst detail)) <$> (evaluateDetail flag context HS.empty $ getField @"store" client)) filtered             evaluations <- pure $ mapValues (getField @"value" . snd) details             now <- unixMilliseconds-            state <- pure $ mapValues (\(flag, detail) -> do-                let reason' = getField @"reason" detail-                    inExperiment = isInExperiment flag reason'-                    isDebugging = now < fromMaybe 0 (getField @"debugEventsUntilDate" flag)-                    trackReason' = inExperiment-                    trackEvents' = getField @"trackEvents" flag-                    omitDetails = details_only_for_tracked_flags && (not (trackEvents' || trackReason' || isDebugging))-                FlagState-                    { version = if omitDetails then Nothing else Just $ getField @"version" flag-                    , variation = getField @"variationIndex" detail-                    , reason = if omitDetails || ((not with_reasons) && (not trackReason')) then Nothing else Just reason'-                    , trackEvents = trackEvents' || inExperiment-                    , trackReason = trackReason'-                    , debugEventsUntilDate = getField @"debugEventsUntilDate" flag-                    }) details-            pure $ AllFlagsState { evaluations = evaluations, state = state, valid = True }---- | Returns a map from feature flag keys to values for a given user. If the--- result of the flag's evaluation would result in the default value, `Null`--- will be returned. This method does not send analytics events back to--- LaunchDarkly.-allFlags :: Client -> User -> IO (KeyMap Value)-allFlags (Client client) (User user) = do-    status <- getAllFlagsC $ getField @"store" client-    case status of-        Left _      -> pure emptyObject-        Right flags -> do-            evals <- mapM (\flag -> evaluateDetail flag user $ getField @"store" client) flags-            pure $ mapValues (getField @"value" . fst) evals+            state <-+                pure $+                    mapValues+                        ( \(flag, detail) -> do+                            let reason' = getField @"reason" detail+                                inExperiment = isInExperiment flag reason'+                                isDebugging = now < fromMaybe 0 (getField @"debugEventsUntilDate" flag)+                                trackReason' = inExperiment+                                trackEvents' = getField @"trackEvents" flag+                                omitDetails = details_only_for_tracked_flags && (not (trackEvents' || trackReason' || isDebugging))+                            FlagState+                                { version = if omitDetails then Nothing else Just $ getField @"version" flag+                                , variation = getField @"variationIndex" detail+                                , reason = if omitDetails || ((not with_reasons) && (not trackReason')) then Nothing else Just reason'+                                , trackEvents = trackEvents' || inExperiment+                                , trackReason = trackReason'+                                , debugEventsUntilDate = getField @"debugEventsUntilDate" flag+                                }+                        )+                        details+            pure $ AllFlagsState {evaluations = evaluations, state = state, valid = True} --- | Identify reports details about a user.-identify :: Client -> User -> IO ()-identify (Client client) (User user)-    | T.null (getField @"key" user) = clientRunLogger client $ $(logWarn) "identify called with empty user key!"-    | otherwise = do-        let user' = userSerializeRedacted (getField @"config" client) user-        x <- makeBaseEvent $ IdentifyEvent { key = getField @"key" user, user = user' }-        _ <- noticeUser (getField @"events" client) user+-- | Identify reports details about a context.+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) --- | Track reports that a user has performed an event. Custom data can be+-- |+-- Track reports that a context has performed an event. Custom data can be -- attached to the event, and / or a numeric value. -- -- The numeric value is used by the LaunchDarkly experimentation feature in--- numeric custom metrics, and will also be returned as part of the custom event--- for Data Export.-track :: Client -> User -> Text -> Maybe Value -> Maybe Double -> IO ()-track (Client client) (User user) key value metric = do-    x <- makeBaseEvent $ addUserToEvent (getField @"config" client) user CustomEvent-        { key         = key-        , user        = Nothing-        , userKey     = Nothing-        , metricValue = metric-        , value       = value-        , contextKind = userGetContextKind user-        }+-- numeric custom metrics, and will also be returned as part of the custom+-- event for Data Export.+track :: Client -> Context -> Text -> Maybe Value -> Maybe Double -> IO ()+track client (Invalid err) _ _ _ = clientRunLogger client $ $(logWarn) $ "track called with invalid context: " <> err+track client context key value metric = do+    x <-+        makeBaseEvent $+            CustomEvent+                { key = key+                , contextKeys = getKeys context+                , metricValue = metric+                , value = value+                }     let config = (getField @"config" client)         events = (getField @"events" client)     queueEvent config events (EventTypeCustom x)-    unless (getField @"inlineUsersInEvents" config) $-        unixMilliseconds >>= \now -> maybeIndexUser now config user events+    unixMilliseconds >>= \now -> maybeIndexContext now config context events --- | Alias associates two users for analytics purposes with an alias event.+-- |+-- Generates the secure mode hash value for a context. ----- The first parameter should be the new version of the user,--- the second parameter should be the old version.-alias :: Client -> User -> User -> IO ()-alias (Client client) (User currentUser) (User previousUser) = do-    x <- makeBaseEvent $ AliasEvent-        { key                 = getField @"key" currentUser-        , contextKind         = userGetContextKind currentUser-        , previousKey         = getField @"key" previousUser-        , previousContextKind = userGetContextKind previousUser-        }-    queueEvent (getField @"config" client) (getField @"events" client) (EventTypeAlias x)+-- For more information, see the Reference Guide:+-- <https://docs.launchdarkly.com/sdk/features/secure-mode#haskell>.+secureModeHash :: Client -> Context -> Text+secureModeHash client context =+    let config = getField @"config" client+        sdkKey = getField @"key" config+     in decodeUtf8 $ convertToBase Base16 $ hmac hash 64 (encodeUtf8 sdkKey) (encodeUtf8 $ getCanonicalKey context) --- | Flush tells the client that all pending analytics events (if any) should be--- delivered as soon as possible. Flushing is asynchronous, so this method will--- return before it is complete.+-- |+-- Flush tells the client that all pending analytics events (if any) should+-- be delivered as soon as possible. Flushing is asynchronous, so this method+-- will return before it is complete. flushEvents :: Client -> IO ()-flushEvents (Client client) = putMVar (getField @"flush" $ getField @"events" client) ()+flushEvents client = putMVar (getField @"flush" $ getField @"events" client) () --- | Close shuts down the LaunchDarkly client. After calling this, the--- LaunchDarkly client should no longer be used. The method will block until all--- pending analytics events have been sent.+-- |+-- Close shuts down the LaunchDarkly client. After calling this, the+-- LaunchDarkly client should no longer be used. The method will block until+-- all pending analytics events have been sent. close :: Client -> IO ()-close outer@(Client client) = clientRunLogger client $ do+close client = clientRunLogger client $ do     $(logDebug) "Setting client status to ShuttingDown"     liftIO $ writeIORef (getField @"status" client) ShuttingDown     liftIO $ dataSourceStop $ getField @"dataSource" client     forM_ (getField @"eventThreadPair" client) $ \(_, sync) -> do         $(logDebug) "Triggering event flush"-        liftIO $ flushEvents outer+        liftIO $ flushEvents client         $(logDebug) "Waiting on event thread to die"         liftIO $ void $ takeMVar sync     $(logDebug) "Client background resources destroyed"  type ValueConverter a = (a -> Value, Value -> Maybe a) -reorderStuff :: ValueConverter a -> Bool -> Client -> Text -> User -> a -> IO (EvaluationDetail a)-reorderStuff converter includeReason (Client client) key (User user) fallback = evaluateTyped client key user fallback (fst converter) includeReason (snd converter)+reorderStuff :: ValueConverter a -> Bool -> Client -> Text -> Context -> a -> IO (EvaluationDetail a)+reorderStuff converter includeReason client key context fallback = evaluateTyped client key context fallback (fst converter) includeReason (snd converter) -dropReason :: (Text -> User -> a -> IO (EvaluationDetail a)) -> Text -> User -> a -> IO a+dropReason :: (Text -> Context -> a -> IO (EvaluationDetail a)) -> Text -> Context -> a -> IO a dropReason = (((fmap (getField @"value") .) .) .)  boolConverter :: ValueConverter Bool@@ -346,42 +353,43 @@ jsonConverter = (,) id pure  -- | Evaluate a Boolean typed flag.-boolVariation :: Client -> Text -> User -> Bool -> IO Bool+boolVariation :: Client -> Text -> Context -> Bool -> IO Bool boolVariation = dropReason . reorderStuff boolConverter False  -- | Evaluate a Boolean typed flag, and return an explanation.-boolVariationDetail :: Client -> Text -> User -> Bool -> IO (EvaluationDetail Bool)+boolVariationDetail :: Client -> Text -> Context -> Bool -> IO (EvaluationDetail Bool) boolVariationDetail = reorderStuff boolConverter True  -- | Evaluate a String typed flag.-stringVariation :: Client -> Text -> User -> Text -> IO Text+stringVariation :: Client -> Text -> Context -> Text -> IO Text stringVariation = dropReason . reorderStuff stringConverter False  -- | Evaluate a String typed flag, and return an explanation.-stringVariationDetail :: Client -> Text -> User -> Text -> IO (EvaluationDetail Text)+stringVariationDetail :: Client -> Text -> Context -> Text -> IO (EvaluationDetail Text) stringVariationDetail = reorderStuff stringConverter True  -- | Evaluate a Number typed flag, and truncate the result.-intVariation :: Client -> Text -> User -> Int -> IO Int+intVariation :: Client -> Text -> Context -> Int -> IO Int intVariation = dropReason . reorderStuff intConverter False --- | Evaluate a Number typed flag, truncate the result, and return an+-- |+-- Evaluate a Number typed flag, truncate the result, and return an -- explanation.-intVariationDetail :: Client -> Text -> User -> Int -> IO (EvaluationDetail Int)+intVariationDetail :: Client -> Text -> Context -> Int -> IO (EvaluationDetail Int) intVariationDetail = reorderStuff intConverter True  -- | Evaluate a Number typed flag.-doubleVariation :: Client -> Text -> User -> Double -> IO Double+doubleVariation :: Client -> Text -> Context -> Double -> IO Double doubleVariation = dropReason . reorderStuff doubleConverter False  -- | Evaluate a Number typed flag, and return an explanation.-doubleVariationDetail :: Client -> Text -> User -> Double -> IO (EvaluationDetail Double)+doubleVariationDetail :: Client -> Text -> Context -> Double -> IO (EvaluationDetail Double) doubleVariationDetail = reorderStuff doubleConverter True  -- | Evaluate a JSON typed flag.-jsonVariation :: Client -> Text -> User -> Value -> IO Value+jsonVariation :: Client -> Text -> Context -> Value -> IO Value jsonVariation = dropReason . reorderStuff jsonConverter False  -- | Evaluate a JSON typed flag, and return an explanation.-jsonVariationDetail :: Client -> Text -> User -> Value -> IO (EvaluationDetail Value)+jsonVariationDetail :: Client -> Text -> Context -> Value -> IO (EvaluationDetail Value) jsonVariationDetail = reorderStuff jsonConverter True
src/LaunchDarkly/Server/Client/Internal.hs view
@@ -1,51 +1,52 @@ module LaunchDarkly.Server.Client.Internal-    ( Client(..)-    , ClientI(..)-    , Status(..)+    ( Client (..)+    , Status (..)     , clientVersion     , setStatus     , getStatusI     ) where -import Data.Text                           (Text)-import Data.IORef                          (IORef, readIORef, atomicModifyIORef')-import GHC.Generics                        (Generic)-import Control.Concurrent                  (ThreadId)-import Control.Concurrent.MVar             (MVar)-import Data.Generics.Product               (getField)+import Control.Concurrent (ThreadId)+import Control.Concurrent.MVar (MVar)+import Data.Generics.Product (getField)+import Data.IORef (IORef, atomicModifyIORef', readIORef)+import Data.Text (Text)+import GHC.Generics (Generic) -import LaunchDarkly.Server.Client.Status       (Status(..), transitionStatus)-import LaunchDarkly.Server.Config.Internal     (ConfigI)-import LaunchDarkly.Server.Store.Internal      (StoreHandle, getInitializedC)-import LaunchDarkly.Server.Events              (EventState)+import LaunchDarkly.Server.Client.Status (Status (..), transitionStatus)+import LaunchDarkly.Server.Config.Internal (Config) import LaunchDarkly.Server.DataSource.Internal (DataSource)---- | Client is the LaunchDarkly client. Client instances are thread-safe.--- Applications should instantiate a single instance for the lifetime of their--- application.-newtype Client = Client ClientI+import LaunchDarkly.Server.Events (EventState)+import LaunchDarkly.Server.Store.Internal (StoreHandle, getInitializedC)  -- | The version string for this library. clientVersion :: Text-clientVersion = "3.1.1"+clientVersion = "4.0.0" -setStatus :: ClientI -> Status -> IO ()+-- |+-- Client is the LaunchDarkly client. Client instances are thread-safe.+-- Applications should instantiate a single instance for the lifetime of their+-- application.+data Client = Client+    { config :: !(Config)+    , store :: !(StoreHandle IO)+    , status :: !(IORef Status)+    , events :: !EventState+    , eventThreadPair :: !(Maybe (ThreadId, MVar ()))+    , dataSource :: !DataSource+    }+    deriving (Generic)++setStatus :: Client -> Status -> IO () setStatus client status' =     atomicModifyIORef' (getField @"status" client) (fmap (,()) (transitionStatus status')) -getStatusI :: ClientI -> IO Status-getStatusI client = readIORef (getField @"status" client) >>= \case-    Unauthorized -> pure Unauthorized-    ShuttingDown -> pure ShuttingDown-    _            -> getInitializedC (getField @"store" client) >>= \case-        Right True -> pure Initialized-        _          -> pure Uninitialized--data ClientI = ClientI-    { config             :: !(ConfigI)-    , store              :: !(StoreHandle IO)-    , status             :: !(IORef Status)-    , events             :: !EventState-    , eventThreadPair    :: !(Maybe (ThreadId, MVar ()))-    , dataSource         :: !DataSource-    } deriving (Generic)+getStatusI :: Client -> IO Status+getStatusI client =+    readIORef (getField @"status" client) >>= \case+        Unauthorized -> pure Unauthorized+        ShuttingDown -> pure ShuttingDown+        _ ->+            getInitializedC (getField @"store" client) >>= \case+                Right True -> pure Initialized+                _ -> pure Uninitialized
src/LaunchDarkly/Server/Client/Status.hs view
@@ -1,25 +1,25 @@ module LaunchDarkly.Server.Client.Status-    ( Status(..)+    ( Status (..)     , transitionStatus     )-    where+where  -- | The status of the client initialization. data Status-    = Uninitialized-      -- ^ The client has not yet finished connecting to LaunchDarkly.-    | Unauthorized-      -- ^ The client attempted to connect to LaunchDarkly and was denied.-    | Initialized-      -- ^ The client has successfuly connected to LaunchDarkly.-    | ShuttingDown-      -- ^ The client is being terminated+    = -- | The client has not yet finished connecting to LaunchDarkly.+      Uninitialized+    | -- | The client attempted to connect to LaunchDarkly and was denied.+      Unauthorized+    | -- | The client has successfuly connected to LaunchDarkly.+      Initialized+    | -- | The client is being terminated+      ShuttingDown     deriving (Show, Eq)  transitionStatus :: Status -> Status -> Status-transitionStatus requestedStatus oldStatus = +transitionStatus requestedStatus oldStatus =     case requestedStatus of         -- Only allow setting Initialized if Uninitialized-        Initialized   -> if oldStatus == Uninitialized then Initialized  else oldStatus+        Initialized -> if oldStatus == Uninitialized then Initialized else oldStatus         -- Only allow setting status if not ShuttingDown-        _             -> if oldStatus == ShuttingDown  then ShuttingDown else requestedStatus+        _ -> if oldStatus == ShuttingDown then ShuttingDown else requestedStatus
src/LaunchDarkly/Server/Config.hs view
@@ -1,5 +1,6 @@--- | This module is for configuration of the SDK.+{-# LANGUAGE NumericUnderscores #-} +-- | This module is for configuration of the SDK. module LaunchDarkly.Server.Config     ( Config     , makeConfig@@ -8,12 +9,13 @@     , configSetStreamURI     , configSetEventsURI     , configSetStreaming+    , configSetInitialRetryDelay     , configSetAllAttributesPrivate     , configSetPrivateAttributeNames     , configSetFlushIntervalSeconds     , configSetPollIntervalSeconds+    , configSetContextKeyLRUCapacity     , configSetUserKeyLRUCapacity-    , configSetInlineUsersInEvents     , configSetEventsCapacity     , configSetLogger     , configSetManager@@ -30,152 +32,187 @@     , withApplicationValue     ) where -import Control.Monad.Logger                (LoggingT, runStdoutLoggingT)-import Data.Generics.Product               (setField)-import Data.Set                            (Set)-import Data.Text                           (Text, dropWhileEnd)-import GHC.Natural                         (Natural)-import Network.HTTP.Client                 (Manager)+import Control.Monad.Logger (LoggingT, runStdoutLoggingT)+import Data.Generics.Product (setField)+import Data.Set (Set)+import Data.Text (Text, dropWhileEnd)+import GHC.Natural (Natural)+import Network.HTTP.Client (Manager) -import LaunchDarkly.Server.Config.Internal (Config(..), mapConfig, ConfigI(..), ApplicationInfo, makeApplicationInfo, withApplicationValue)-import LaunchDarkly.Server.Store           (StoreInterface)+import LaunchDarkly.Server.Config.Internal (ApplicationInfo, Config (..), makeApplicationInfo, withApplicationValue) import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory)+import LaunchDarkly.Server.Reference (Reference)+import LaunchDarkly.Server.Store (PersistentDataStore)  -- | Create a default configuration from a given SDK key. makeConfig :: Text -> Config makeConfig key =-    Config $ ConfigI-    { key                   = key-    , baseURI               = "https://app.launchdarkly.com"-    , streamURI             = "https://stream.launchdarkly.com"-    , eventsURI             = "https://events.launchdarkly.com"-    , storeBackend          = Nothing-    , storeTTLSeconds       = 10-    , streaming             = True-    , allAttributesPrivate  = False-    , privateAttributeNames = mempty-    , flushIntervalSeconds  = 5-    , pollIntervalSeconds   = 30-    , userKeyLRUCapacity    = 1000-    , inlineUsersInEvents   = False-    , eventsCapacity        = 10000-    , logger                = runStdoutLoggingT-    , sendEvents            = True-    , offline               = False-    , requestTimeoutSeconds = 30-    , useLdd                = False-    , dataSourceFactory     = Nothing-    , manager               = Nothing-    , applicationInfo       = Nothing-    }+    Config+        { key = key+        , baseURI = "https://sdk.launchdarkly.com"+        , streamURI = "https://stream.launchdarkly.com"+        , eventsURI = "https://events.launchdarkly.com"+        , storeBackend = Nothing+        , storeTTLSeconds = 10+        , streaming = True+        , initialRetryDelay = 1_000+        , allAttributesPrivate = False+        , privateAttributeNames = mempty+        , flushIntervalSeconds = 5+        , pollIntervalSeconds = 30+        , contextKeyLRUCapacity = 1_000+        , eventsCapacity = 10_000+        , logger = runStdoutLoggingT+        , sendEvents = True+        , offline = False+        , requestTimeoutSeconds = 30+        , useLdd = False+        , dataSourceFactory = Nothing+        , manager = Nothing+        , applicationInfo = Nothing+        }  -- | Set the SDK key used to authenticate with LaunchDarkly. configSetKey :: Text -> Config -> Config-configSetKey = mapConfig . setField @"key"+configSetKey = setField @"key" --- | The base URI of the main LaunchDarkly service. This should not normally be+-- |+-- The base URI of the main LaunchDarkly service. This should not normally be -- changed except for testing. configSetBaseURI :: Text -> Config -> Config-configSetBaseURI = mapConfig . setField @"baseURI" . dropWhileEnd ((==) '/')+configSetBaseURI = setField @"baseURI" . dropWhileEnd ((==) '/') --- | The base URI of the LaunchDarkly streaming service. This should not+-- |+-- The base URI of the LaunchDarkly streaming service. This should not -- normally be changed except for testing. configSetStreamURI :: Text -> Config -> Config-configSetStreamURI = mapConfig . setField @"streamURI" . dropWhileEnd ((==) '/')+configSetStreamURI = setField @"streamURI" . dropWhileEnd ((==) '/') --- | The base URI of the LaunchDarkly service that accepts analytics events.+-- |+-- The base URI of the LaunchDarkly service that accepts analytics events. -- This should not normally be changed except for testing. configSetEventsURI :: Text -> Config -> Config-configSetEventsURI = mapConfig . setField @"eventsURI" . dropWhileEnd ((==) '/')+configSetEventsURI = setField @"eventsURI" . dropWhileEnd ((==) '/')  -- | Configures a handle to an external store such as Redis.-configSetStoreBackend :: Maybe StoreInterface -> Config -> Config-configSetStoreBackend = mapConfig . setField @"storeBackend"+configSetStoreBackend :: Maybe PersistentDataStore -> Config -> Config+configSetStoreBackend = setField @"storeBackend" --- | When a store backend is configured, control how long values should be+-- |+-- When a store backend is configured, control how long values should be -- cached in memory before going back to the backend. configSetStoreTTL :: Natural -> Config -> Config-configSetStoreTTL = mapConfig . setField @"storeTTLSeconds"+configSetStoreTTL = setField @"storeTTLSeconds" --- | Sets whether streaming mode should be enabled. By default, streaming is+-- |+-- Sets whether streaming mode should be enabled. By default, streaming is -- enabled. It should only be disabled on the advice of LaunchDarkly support. configSetStreaming :: Bool -> Config -> Config-configSetStreaming = mapConfig . setField @"streaming"+configSetStreaming = setField @"streaming" --- | Sets whether or not all user attributes (other than the key) should be--- hidden from LaunchDarkly. If this is true, all user attribute values will be--- private, not just the attributes specified in PrivateAttributeNames.+-- |+-- The initial delay in milliseconds before reconnecting after an error in the+-- SSE client. Defaults to 1 second.+--+-- This only applies to the streaming connection. Providing a non-positive+-- integer is a no-op.+configSetInitialRetryDelay :: Int -> Config -> Config+configSetInitialRetryDelay seconds config+    | seconds <= 0 = config+    | otherwise = setField @"initialRetryDelay" seconds config++-- |+-- Sets whether or not all context attributes (other than the key) should be+-- hidden from LaunchDarkly. If this is true, all context attribute values will+-- be private, not just the attributes specified in PrivateAttributeNames. configSetAllAttributesPrivate :: Bool -> Config -> Config-configSetAllAttributesPrivate = mapConfig . setField @"allAttributesPrivate"+configSetAllAttributesPrivate = setField @"allAttributesPrivate" --- | Marks a set of user attribute names private. Any users sent to LaunchDarkly--- with this configuration active will have attributes with these names removed.-configSetPrivateAttributeNames :: Set Text -> Config -> Config-configSetPrivateAttributeNames = mapConfig . setField @"privateAttributeNames"+-- |+-- Marks a set of context attribute names private. Any contexts sent to+-- LaunchDarkly with this configuration active will have attributes with these+-- names removed.+configSetPrivateAttributeNames :: Set Reference -> Config -> Config+configSetPrivateAttributeNames = setField @"privateAttributeNames" --- | The time between flushes of the event buffer. Decreasing the flush interval--- means that the event buffer is less likely to reach capacity.+-- |+-- The time between flushes of the event buffer. Decreasing the flush+-- interval means that the event buffer is less likely to reach capacity. configSetFlushIntervalSeconds :: Natural -> Config -> Config-configSetFlushIntervalSeconds = mapConfig . setField @"flushIntervalSeconds"+configSetFlushIntervalSeconds = setField @"flushIntervalSeconds"  -- | The polling interval (when streaming is disabled). configSetPollIntervalSeconds :: Natural -> Config -> Config-configSetPollIntervalSeconds = mapConfig . setField @"pollIntervalSeconds"+configSetPollIntervalSeconds = setField @"pollIntervalSeconds" --- | The number of user keys that the event processor can remember at any one--- time, so that duplicate user details will not be sent in analytics events.-configSetUserKeyLRUCapacity :: Natural -> Config -> Config-configSetUserKeyLRUCapacity = mapConfig . setField @"userKeyLRUCapacity"+-- |+-- The number of context keys that the event processor can remember at any+-- one time, so that duplicate context details will not be sent in analytics+-- events.+configSetContextKeyLRUCapacity :: Natural -> Config -> Config+configSetContextKeyLRUCapacity = setField @"contextKeyLRUCapacity" --- | Set to true if you need to see the full user details in every analytics--- event.-configSetInlineUsersInEvents :: Bool -> Config -> Config-configSetInlineUsersInEvents = mapConfig . setField @"inlineUsersInEvents"+{-# DEPRECATED configSetUserKeyLRUCapacity "Use configSetContextKeyLRUCapacity instead" #-} --- | The capacity of the events buffer. The client buffers up to this many+-- |+-- Deprecated historically named function which proxies to+-- 'configSetContextKeyLRUCapacity'.+configSetUserKeyLRUCapacity :: Natural -> Config -> Config+configSetUserKeyLRUCapacity = configSetContextKeyLRUCapacity++-- |+-- The capacity of the events buffer. The client buffers up to this many -- events in memory before flushing. If the capacity is exceeded before the -- buffer is flushed, events will be discarded. configSetEventsCapacity :: Natural -> Config -> Config-configSetEventsCapacity = mapConfig . setField @"eventsCapacity"+configSetEventsCapacity = setField @"eventsCapacity"  -- | Set the logger to be used by the client. configSetLogger :: (LoggingT IO () -> IO ()) -> Config -> Config-configSetLogger = mapConfig . setField @"logger"+configSetLogger = setField @"logger" --- | Sets whether to send analytics events back to LaunchDarkly. By default, the--- client will send events. This differs from Offline in that it only affects--- sending events, not streaming or polling for events from the server.+-- |+-- Sets whether to send analytics events back to LaunchDarkly. By default,+-- the client will send events. This differs from Offline in that it only+-- affects sending events, not streaming or polling for events from the server. configSetSendEvents :: Bool -> Config -> Config-configSetSendEvents = mapConfig . setField @"sendEvents"+configSetSendEvents = setField @"sendEvents" --- | Sets whether this client is offline. An offline client will not make any+-- |+-- Sets whether this client is offline. An offline client will not make any -- network connections to LaunchDarkly, and will return default values for all -- feature flags. configSetOffline :: Bool -> Config -> Config-configSetOffline = mapConfig . setField @"offline"+configSetOffline = setField @"offline" --- | Sets how long an the HTTP client should wait before a response is returned.+-- |+-- Sets how long an the HTTP client should wait before a response is+-- returned. configSetRequestTimeoutSeconds :: Natural -> Config -> Config-configSetRequestTimeoutSeconds = mapConfig . setField @"requestTimeoutSeconds"+configSetRequestTimeoutSeconds = setField @"requestTimeoutSeconds" --- | Sets whether this client should use the LaunchDarkly Relay Proxy in daemon--- mode. In this mode, the client does not subscribe to the streaming or polling--- API, but reads data only from the feature store. See:+-- |+-- Sets whether this client should use the LaunchDarkly Relay Proxy in daemon+-- mode. In this mode, the client does not subscribe to the streaming or+-- polling API, but reads data only from the feature store. See: -- https://docs.launchdarkly.com/home/relay-proxy configSetUseLdd :: Bool -> Config -> Config-configSetUseLdd = mapConfig . setField @"useLdd"+configSetUseLdd = setField @"useLdd" --- | Sets a data source to use instead of the default network based data source+-- |+-- Sets a data source to use instead of the default network based data source -- see "LaunchDarkly.Server.Integrations.FileData" configSetDataSourceFactory :: Maybe DataSourceFactory -> Config -> Config-configSetDataSourceFactory = mapConfig . setField @"dataSourceFactory"+configSetDataSourceFactory = setField @"dataSourceFactory" --- | Sets the 'Manager' to use with the client. If not set explicitly a new+-- |+-- Sets the 'Manager' to use with the client. If not set explicitly a new -- 'Manager' will be created when creating the client. configSetManager :: Manager -> Config -> Config-configSetManager = mapConfig . setField @"manager" . Just+configSetManager = setField @"manager" . Just --- | An object that allows configuration of application metadata.+-- |+-- An object that allows configuration of application metadata. -- -- Application metadata may be used in LaunchDarkly analytics or other product -- features, but does not affect feature flag evaluations.@@ -183,4 +220,4 @@ -- If you want to set non-default values for any of these fields, provide the -- appropriately configured dict to the 'Config' object. configSetApplicationInfo :: ApplicationInfo -> Config -> Config-configSetApplicationInfo = mapConfig . setField @"applicationInfo" . Just+configSetApplicationInfo = setField @"applicationInfo" . Just
src/LaunchDarkly/Server/Config/ClientContext.hs view
@@ -1,13 +1,11 @@-module LaunchDarkly.Server.Config.ClientContext-    (ClientContext(..))-    where+module LaunchDarkly.Server.Config.ClientContext (ClientContext (..))+where  import Control.Monad.Logger (LoggingT)  import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration) -data ClientContext = ClientContext +data ClientContext = ClientContext     { runLogger :: !(LoggingT IO () -> IO ())     , httpConfiguration :: !HttpConfiguration     }-
src/LaunchDarkly/Server/Config/HttpConfiguration.hs view
@@ -1,14 +1,14 @@ module LaunchDarkly.Server.Config.HttpConfiguration-    ( HttpConfiguration(..)+    ( HttpConfiguration (..)     , prepareRequest     )-    where+where -import Network.HTTP.Client (Manager, ResponseTimeout, Request, requestHeaders, responseTimeout, setRequestIgnoreStatus, parseRequest)-import Network.HTTP.Types  (Header) import Control.Monad.Catch (MonadThrow)+import Network.HTTP.Client (Manager, Request, ResponseTimeout, parseRequest, requestHeaders, responseTimeout, setRequestIgnoreStatus)+import Network.HTTP.Types (Header) -data HttpConfiguration = HttpConfiguration +data HttpConfiguration = HttpConfiguration     { defaultRequestHeaders :: ![Header]     , defaultRequestTimeout :: !ResponseTimeout     , tlsManager :: !Manager@@ -17,8 +17,9 @@ prepareRequest :: (MonadThrow m) => HttpConfiguration -> String -> m Request prepareRequest config uri = do     baseReq <- parseRequest uri-    pure $ setRequestIgnoreStatus $ baseReq -        { requestHeaders       = defaultRequestHeaders config <> requestHeaders baseReq -        , responseTimeout      = defaultRequestTimeout config -        } -+    pure $+        setRequestIgnoreStatus $+            baseReq+                { requestHeaders = defaultRequestHeaders config <> requestHeaders baseReq+                , responseTimeout = defaultRequestTimeout config+                }
src/LaunchDarkly/Server/Config/Internal.hs view
@@ -1,7 +1,5 @@ module LaunchDarkly.Server.Config.Internal-    ( Config(..)-    , mapConfig-    , ConfigI(..)+    ( Config (..)     , shouldSendEvents     , ApplicationInfo     , makeApplicationInfo@@ -9,58 +7,56 @@     , getApplicationInfoHeader     ) where -import Control.Monad.Logger               (LoggingT)-import Data.Generics.Product              (getField)-import Data.Text                          (Text)+import Control.Monad.Logger (LoggingT)+import Data.Generics.Product (getField)+import Data.Set (Set)+import Data.Text (Text) import qualified Data.Text as T-import Data.Set                           (Set)-import GHC.Natural                        (Natural)-import GHC.Generics                       (Generic)-import Network.HTTP.Client                (Manager)+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import Network.HTTP.Client (Manager) -import LaunchDarkly.Server.Store               (StoreInterface)-import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory)-import LaunchDarkly.AesonCompat (KeyMap, insertKey, emptyObject, toList)-import qualified LaunchDarkly.AesonCompat as AesonCompat-import Data.List (sortBy) import Control.Lens ((&))+import Data.List (sortBy) import Data.Ord (comparing)--mapConfig :: (ConfigI -> ConfigI) -> Config -> Config-mapConfig f (Config c) = Config $ f c--shouldSendEvents :: ConfigI -> Bool-shouldSendEvents config = (not $ getField @"offline" config) && (getField @"sendEvents" config)+import LaunchDarkly.AesonCompat (KeyMap, emptyObject, insertKey, toList)+import qualified LaunchDarkly.AesonCompat as AesonCompat+import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory)+import LaunchDarkly.Server.Reference (Reference)+import LaunchDarkly.Server.Store (PersistentDataStore)  -- | Config allows advanced configuration of the LaunchDarkly client.-newtype Config = Config ConfigI--data ConfigI = ConfigI-    { key                   :: !Text-    , baseURI               :: !Text-    , streamURI             :: !Text-    , eventsURI             :: !Text-    , storeBackend          :: !(Maybe StoreInterface)-    , storeTTLSeconds       :: !Natural-    , streaming             :: !Bool-    , allAttributesPrivate  :: !Bool-    , privateAttributeNames :: !(Set Text)-    , flushIntervalSeconds  :: !Natural-    , pollIntervalSeconds   :: !Natural-    , userKeyLRUCapacity    :: !Natural-    , inlineUsersInEvents   :: !Bool-    , eventsCapacity        :: !Natural-    , logger                :: !(LoggingT IO () -> IO ())-    , sendEvents            :: !Bool-    , offline               :: !Bool+data Config = Config+    { key :: !Text+    , baseURI :: !Text+    , streamURI :: !Text+    , eventsURI :: !Text+    , storeBackend :: !(Maybe PersistentDataStore)+    , storeTTLSeconds :: !Natural+    , streaming :: !Bool+    , initialRetryDelay :: !Int+    , allAttributesPrivate :: !Bool+    , privateAttributeNames :: !(Set Reference)+    , flushIntervalSeconds :: !Natural+    , pollIntervalSeconds :: !Natural+    , contextKeyLRUCapacity :: !Natural+    , eventsCapacity :: !Natural+    , logger :: !(LoggingT IO () -> IO ())+    , sendEvents :: !Bool+    , offline :: !Bool     , requestTimeoutSeconds :: !Natural-    , useLdd                :: !Bool-    , dataSourceFactory     :: !(Maybe DataSourceFactory)-    , manager               :: !(Maybe Manager)-    , applicationInfo       :: !(Maybe ApplicationInfo)-    } deriving (Generic)+    , useLdd :: !Bool+    , dataSourceFactory :: !(Maybe DataSourceFactory)+    , manager :: !(Maybe Manager)+    , applicationInfo :: !(Maybe ApplicationInfo)+    }+    deriving (Generic) --- | An object that allows configuration of application metadata.+shouldSendEvents :: Config -> Bool+shouldSendEvents config = (not $ getField @"offline" config) && (getField @"sendEvents" config)++-- |+-- An object that allows configuration of application metadata. -- -- Application metadata may be used in LaunchDarkly analytics or other product -- features, but does not affect feature flag evaluations.@@ -72,7 +68,8 @@ makeApplicationInfo :: ApplicationInfo makeApplicationInfo = ApplicationInfo emptyObject --- | Set a new name / value pair into the application info instance.+-- |+-- Set a new name / value pair into the application info instance. -- -- Values have the following restrictions: -- - Cannot be empty@@ -84,16 +81,18 @@ withApplicationValue _ "" info = info withApplicationValue name value info@(ApplicationInfo map)     | (name `elem` ["id", "version"]) == False = info-    | T.length(value) > 64 = info-    | (all (`elem` ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ ['.', '-', '_']) (T.unpack value)) == False = info+    | T.length (value) > 64 = info+    | (all (`elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ ['.', '-', '_']) (T.unpack value)) == False = info     | otherwise = ApplicationInfo $ insertKey name value map  getApplicationInfoHeader :: ApplicationInfo -> Maybe Text getApplicationInfoHeader (ApplicationInfo values)     | AesonCompat.null values = Nothing-    | otherwise = toList values-        & sortBy (comparing fst)-        & map makeTag-        & T.unwords-        & Just-    where makeTag (key, value) = "application-" <> key <> "/" <> value+    | otherwise =+        toList values+            & sortBy (comparing fst)+            & map makeTag+            & T.unwords+            & Just+  where+    makeTag (key, value) = "application-" <> key <> "/" <> value
+ src/LaunchDarkly/Server/Context.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Context is a collection of attributes that can be referenced in flag+-- evaluations and analytics events.+--+-- To create a Context of a single kind, such as a user, you may use+-- 'makeContext'.+--+-- To create an LDContext with multiple kinds, use 'makeMultiContext'.+--+-- Additional properties can be set on a single-kind context using the set+-- methods found in this module.+--+-- Each method will always return a Context. However, that Context may be+-- invalid. You can check the validity of the resulting context, and the+-- associated errors by calling 'isValid' and 'getError'.+module LaunchDarkly.Server.Context+    ( Context+    , makeContext+    , makeMultiContext+    , withName+    , withAnonymous+    , withAttribute+    , withPrivateAttributes+    , isValid+    , getError+    , getIndividualContext+    , getValueForReference+    , getValue+    )+where++import Data.Aeson (Value (..))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import LaunchDarkly.AesonCompat (lookupKey)+import LaunchDarkly.Server.Context.Internal (Context (..), MultiContext (..), SingleContext (..), makeContext, makeMultiContext, withAnonymous, withAttribute, withName, withPrivateAttributes)+import LaunchDarkly.Server.Reference (Reference)+import qualified LaunchDarkly.Server.Reference as R++-- | Determines if the provided context is valid.+isValid :: Context -> Bool+isValid (Invalid _) = False+isValid _ = True++-- | Returns the error associated with the context if it is invalid.+getError :: Context -> Text+getError (Invalid e) = e+getError _ = ""++-- |+-- Returns the single-kind Context corresponding to one of the kinds in this+-- context.+--+-- If this method is called on a single-kind Context and the requested kind+-- matches the context's kind, then that context is returned.+--+-- If the method is called on a multi-context, the provided kind must match the+-- context kind of one of the individual contexts.+--+-- If there is no context corresponding to `kind`, the method returns Nothing.+getIndividualContext :: Text -> Context -> Maybe Context+getIndividualContext kind (Multi (MultiContext {contexts})) = Single <$> lookupKey kind contexts+getIndividualContext kind c@(Single (SingleContext {kind = k}))+    | kind == k = Just c+    | otherwise = Nothing+getIndividualContext _ _ = Nothing++-- |+-- Looks up the value of any attribute of the Context by name. This includes+-- only attributes that are addressable in evaluations-- not metadata such as+-- private attributes.+--+-- For a single-kind context, the attribute name can be any custom attribute.+-- It can also be one of the built-in ones like "kind", "key", or "name".+--+-- For a multi-kind context, the only supported attribute name is "kind". Use+-- 'getIndividualContext' to inspect a Context for a particular kind and then+-- get its attributes.+--+-- This method does not support complex expressions for getting individual+-- values out of JSON objects or arrays, such as "/address/street". Use+-- 'getValueForReference' for that purpose.+--+-- If the value is found, the return value is the attribute value; otherwise,+-- it is Null.+getValue :: Text -> Context -> Value+getValue ref = getValueForReference (R.makeLiteral ref)++-- |+-- Looks up the value of any attribute of the Context, or a value contained+-- within an attribute, based on a 'Reference' instance. This includes only+-- attributes that are addressable in evaluations-- not metadata such as+-- private attributes.+--+-- This implements the same behavior that the SDK uses to resolve attribute+-- references during a flag evaluation. In a single-kind context, the+-- 'Reference' can represent a simple attribute name-- either a built-in one+-- like "name" or "key", or a custom attribute -- or, it can be a+-- slash-delimited path using a JSON-Pointer-like syntax. See 'Reference' for+-- more details.+--+-- For a multi-kind context, the only supported attribute name is "kind". Use+-- 'getIndividualContext' to inspect a Context for a particular kind and then+-- get its attributes.+--+-- If the value is found, the return value is the attribute value; otherwise,+-- it is Null.+getValueForReference :: Reference -> Context -> Value+getValueForReference (R.isValid -> False) _ = Null+getValueForReference reference context = case R.getComponents reference of+    [] -> Null+    (component : components) ->+        let value = getTopLevelValue component context+         in foldl getValueFromJsonObject value components++-- This helper method retrieves a Value from a JSON object type.+--+-- If the key does not exist, or the type isn't an object, this method will+-- return Null.+getValueFromJsonObject :: Value -> Text -> Value+getValueFromJsonObject (Object nm) component = fromMaybe Null (lookupKey component nm)+getValueFromJsonObject _ _ = Null++-- Attribute retrieval can mostly be defined recursively. However, this isn't+-- true for the top level attribute since the entire context isn't stored in a+-- single object property.+--+-- To prime the recursion, we define this simple helper function to retrieve+-- attributes addressable at the top level.+getTopLevelValue :: Text -> Context -> Value+getTopLevelValue _ (Invalid _) = Null+getTopLevelValue "kind" (Multi _) = "multi"+getTopLevelValue _ (Multi _) = Null+getTopLevelValue "key" (Single SingleContext {key}) = String key+getTopLevelValue "kind" (Single SingleContext {kind}) = String kind+getTopLevelValue "name" (Single SingleContext {name = Nothing}) = Null+getTopLevelValue "name" (Single SingleContext {name = Just n}) = String n+getTopLevelValue "anonymous" (Single SingleContext {anonymous}) = Bool anonymous+getTopLevelValue _ (Single SingleContext {attributes = Nothing}) = Null+getTopLevelValue key (Single SingleContext {attributes = Just attrs}) = fromMaybe Null $ lookupKey key attrs
+ src/LaunchDarkly/Server/Context/Internal.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Context is a collection of attributes that can be referenced in flag+-- evaluations and analytics events.+--+-- To create a Context of a single kind, such as a user, you may use+-- 'makeContext'.+--+-- To create an LDContext with multiple kinds, use 'makeMultiContext'.+--+-- Additional properties can be set on a single-kind context using the set+-- methods found in this module.+--+-- Each method will always return a Context. However, that Context may be+-- invalid. You can check the validity of the resulting context, and the+-- associated errors by calling 'isValid' and 'getError'.+module LaunchDarkly.Server.Context.Internal+    ( Context (..)+    , SingleContext (..)+    , MultiContext (..)+    , makeContext+    , makeMultiContext+    , withName+    , withAnonymous+    , withAttribute+    , withPrivateAttributes+    , getKey+    , getKeys+    , getCanonicalKey+    , getKinds+    , redactContext+    )+where++import Data.Aeson (FromJSON, Result (Success), ToJSON, Value (..), fromJSON, parseJSON, toJSON, withObject, (.:), (.:?))+import Data.Aeson.Types (Parser, prependFailure, typeMismatch)+import Data.Function ((&))+import Data.Generics.Product (getField, setField)+import qualified Data.HashSet as HS+import Data.List (sortBy)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text, intercalate, replace, unpack)+import qualified Data.Vector as V+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.Server.Reference (Reference)+import qualified LaunchDarkly.Server.Reference as R++-- | data record for the Context type+data Context+    = Single SingleContext+    | Multi MultiContext+    | Invalid {error :: !Text}+    deriving (Generic, Show, Eq)++instance ToJSON Context where+    toJSON (Single c) = toJSON c+    toJSON (Multi c) = toJSON c+    toJSON (Invalid c) = toJSON c++instance FromJSON Context where+    parseJSON a@(Object o) =+        case lookupKey "kind" o of+            Nothing -> parseLegacyUser a+            Just (String "multi") -> parseMultiContext a+            Just _ -> parseSingleContext a+    parseJSON invalid = prependFailure "parsing Context failed, " (typeMismatch "Object" invalid)++data SingleContext = SingleContext+    { key :: !Text+    , fullKey :: !Text+    , kind :: !Text+    , name :: !(Maybe Text)+    , anonymous :: !Bool+    , attributes :: !(Maybe (KeyMap Value))+    , privateAttributes :: !(Maybe (Set Reference))+    }+    deriving (Generic, Show, Eq)++instance ToJSON SingleContext where+    toJSON = (toJsonObject True)++data MultiContext = MultiContext+    { fullKey :: !Text+    , contexts :: !(KeyMap SingleContext)+    }+    deriving (Generic, Show, Eq)++instance ToJSON MultiContext where+    toJSON (MultiContext {contexts}) =+        mapValues (\c -> toJsonObject False c) contexts+            & insertKey "kind" "multi"+            & Object++-- |+-- Create a single kind context from the provided hash.+--+-- The provided hash must match the format as outlined in the [SDK+-- documentation](https://docs.launchdarkly.com/sdk/features/user-config).+makeContext :: Text -> Text -> Context+makeContext "" _ = Invalid {error = "context key must not be empty"}+makeContext key kind = makeSingleContext key kind++-- This function is used internally to create a context with legacy key+-- validation rules; namely, a legacy context is allowed to have an empty key.+-- No other type of context is. Users of this SDK can only use the makeContext+-- to create a single-kind context, which includes the non-empty key+-- restriction.+makeSingleContext :: Text -> Text -> Context+makeSingleContext _ "" = Invalid {error = "context kind must not be empty"}+makeSingleContext _ "kind" = Invalid {error = "context kind cannot be 'kind'"}+makeSingleContext _ "multi" = Invalid {error = "context kind cannot be 'multi'"}+makeSingleContext key kind+    | (all (`elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ ['.', '-', '_']) (unpack kind)) == False = Invalid {error = "context kind contains disallowed characters"}+    | otherwise =+        Single+            SingleContext+                { key = key+                , fullKey = canonicalizeKey key kind+                , kind = kind+                , name = Nothing+                , anonymous = False+                , attributes = Nothing+                , privateAttributes = Nothing+                }++-- |+-- Create a multi-kind context from the list of Contexts provided.+--+-- A multi-kind context is comprised of two or more single kind contexts. You+-- cannot include a multi-kind context instead another multi-kind context.+--+-- Additionally, the kind of each single-kind context must be unique. For+-- instance, you cannot create a multi-kind context that includes two user kind+-- contexts.+--+-- If you attempt to create a multi-kind context from one single-kind context,+-- this method will return the single-kind context instead of a new multi-kind+-- context wrapping that one single-kind.+makeMultiContext :: [Context] -> Context+makeMultiContext [] = Invalid {error = "multi-kind contexts require at least one single-kind context"}+makeMultiContext [c@(Single _)] = c+makeMultiContext contexts =+    let singleContexts = mapMaybe unwrapSingleContext contexts+        sorted = sortBy (\lhs rhs -> compare (kind lhs) (kind rhs)) singleContexts+        kinds = HS.fromList $ map kind singleContexts+     in case (length contexts, length singleContexts, length kinds) of+            (a, b, _) | a /= b -> Invalid {error = "multi-kind contexts can only contain single-kind contexts"}+            (a, _, c) | a /= c -> Invalid {error = "multi-kind contexts cannot contain two single-kind contexts with the same kind"}+            _ ->+                Multi+                    MultiContext+                        { fullKey = intercalate ":" $ map (\c -> canonicalizeKey (key c) (kind c)) sorted+                        , contexts = fromList $ map (\c -> ((kind c), c)) singleContexts+                        }++-- |+-- Sets the name attribute for a single-kind context.+--+-- Calling this method on an invalid or multi-kind context is a no-op.+withName :: Text -> Context -> Context+withName name (Single c) = Single $ setField @"name" (Just name) c+withName _ c = c++-- |+-- Sets the anonymous attribute for a single-kind context.+--+-- Calling this method on an invalid or multi-kind context is a no-op.+withAnonymous :: Bool -> Context -> Context+withAnonymous anonymous (Single c) = Single $ setField @"anonymous" anonymous c+withAnonymous _ c = c++-- |+-- Sets the value of any attribute for the context.+--+-- This includes only attributes that are addressable in evaluations -- not+-- metadata such as private attributes. For example, if the attribute name is+-- "privateAttributes", you will be setting an attribute with that name which+-- you can use in evaluations or to record data for your own purposes, but it+-- will be unrelated to 'withPrivateAttributes'.+--+-- If attribute name is "privateAttributeNames", it is ignored and no attribute+-- is set.+--+-- This method uses the Value type to represent a value of any JSON type: null,+-- boolean, number, string, array, or object. For all attribute names that do+-- not have special meaning to LaunchDarkly, you may use any of those types.+-- Values of different JSON types are always treated as different values: for+-- instance, null, false, and the empty string "" are not the same, and the+-- number 1 is not the same as the string "1".+--+-- The following attribute names have special restrictions on their value+-- types, and any value of an unsupported type will be ignored (leaving the+-- attribute unchanged):+--+-- - "name": Must be a string.+-- - "anonymous": Must be a boolean.+--+-- The attribute name "_meta" is not allowed, because it has special meaning in+-- the JSON schema for contexts; any attempt to set an attribute with this name+-- has no effect.+--+-- The attribute names "kind" and "key" are not allowed. They must be provided+-- during the initial context creation. See 'makeContext'.+--+-- Values that are JSON arrays or objects have special behavior when referenced+-- in flag/segment rules.+--+-- For attributes that aren't subject to the special restrictions mentioned+-- above, a value of Null is equivalent to removing any current non-default+-- value of the attribute. Null is not a valid attribute value in the+-- LaunchDarkly model; any expressions in feature flags that reference an+-- attribute with a null value will behave as if the attribute did not exist.+--+-- Calling this method on an invalid or multi-kind context is a no-op.+withAttribute :: Text -> Value -> Context -> Context+withAttribute "key" _ c = c+withAttribute "kind" _ c = c+withAttribute "name" (String value) c = withName value c+withAttribute "name" Null (Single c) = Single $ c {name = Nothing}+withAttribute "name" _ c = c+withAttribute "anonymous" (Bool value) c = withAnonymous value c+withAttribute "anonymous" _ c = c+withAttribute "_meta" _ c = c+withAttribute "privateAttributeNames" _ c = c+withAttribute _ Null c@(Single SingleContext {attributes = Nothing}) = c+withAttribute attr value (Single c@(SingleContext {attributes = Nothing})) =+    Single $ c {attributes = Just $ singleton attr value}+withAttribute attr Null (Single c@(SingleContext {attributes = Just attrs})) =+    Single $ c {attributes = Just $ deleteKey attr attrs}+withAttribute attr value (Single c@(SingleContext {attributes = Just attrs})) =+    Single $ c {attributes = Just $ insertKey attr value attrs}+withAttribute _ _ c = c++-- |+-- Sets the private attributes for a single-kind context.+--+-- Calling this method on an invalid or multi-kind context is a no-op.+withPrivateAttributes :: Set Reference -> Context -> Context+withPrivateAttributes attrs (Single c)+    | S.null attrs = Single $ c {privateAttributes = Nothing}+    | otherwise = Single $ c {privateAttributes = Just attrs}+withPrivateAttributes _ c = c++-- Given a key and kind, generate a canonical key.+--+-- In a multi-kind context, each individual context should theoretically+-- contain the same key. To address this restriction, we generate a canonical+-- key that includes the context's kind. However, if the kind is "user", we+-- omit the kind inclusion to maintain backwards compatibility.+canonicalizeKey :: Text -> Text -> Text+canonicalizeKey key "user" = key+canonicalizeKey key kind = kind <> ":" <> (replace "%" "%25" key & replace ":" "%3A")++unwrapSingleContext :: Context -> Maybe SingleContext+unwrapSingleContext (Single c) = Just c+unwrapSingleContext _ = Nothing++-- Internally used convenience function to retrieve a context's key.+--+-- This method is functionally equivalent to @fromMaybe "" $ getValue "key"@,+-- it's just nicer to use.+getKey :: Context -> Text+getKey (Single c) = key c+getKey _ = ""++-- Internally used convenience function for retrieving all context keys,+-- indexed by their kind.+--+-- A single kind context will return a single element map containing its kind+-- 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 _ = emptyObject++-- Internally used convenience function to retrieve a context's fully qualified+-- key.+getCanonicalKey :: Context -> Text+getCanonicalKey (Single c) = getField @"fullKey" c+getCanonicalKey (Multi c) = getField @"fullKey" c+getCanonicalKey _ = ""++-- Internally used convenience function for retrieving a list of context kinds+-- in the provided context.+--+-- A single kind context will return a single element list containing only that+-- one kind. Multi-kind contexts will return a list of kinds for each of its+-- sub-contexts. An invalid context will return the empty list.+getKinds :: Context -> [Text]+getKinds (Single c) = [kind c]+getKinds (Multi (MultiContext {contexts})) = objectKeys contexts+getKinds _ = []++-- Internally used function for encoding a SingleContext into a JSON object.+--+-- This functionality has been extracted into this separate function because we+-- need to control whether or not the kind property will be included in the+-- final output. If we didn't have this restriction, we could simply inline+-- this function on the SingleContext.+toJsonObject :: Bool -> SingleContext -> Value+toJsonObject includeKind context =+    Object $ fromList $ (getMapOfRedactableProperties context ++ getMapOfRequiredProperties includeKind context)++-- Contexts can be broken into two different types of attributes -- those which+-- can be redacted, and those which can't.+--+-- This method will return a list of name / value pairs which represent the+-- attributes which are eligible for redaction. The other half of the context+-- can be retrieved through the getMapOfRequiredProperties function.+getMapOfRedactableProperties :: SingleContext -> [(Text, Value)]+getMapOfRedactableProperties (SingleContext {name = Nothing, attributes = Nothing}) = []+getMapOfRedactableProperties (SingleContext {name = Nothing, attributes = Just attrs}) = toList attrs+getMapOfRedactableProperties (SingleContext {name = Just n, attributes = Just attrs}) = ("name", String n) : (toList attrs)+getMapOfRedactableProperties (SingleContext {name = Just n, attributes = Nothing}) = [("name", String n)]++-- Contexts can be broken into two different types of attributes -- those which+-- can be redacted, and those which can't.+--+-- This method will return a list of name / value pairs which represent the+-- attributes which cannot be redacted. The other half of the context can be+-- retrieved through the getMapOfRedactableProperties function.+getMapOfRequiredProperties :: Bool -> SingleContext -> [(Text, Value)]+getMapOfRequiredProperties includeKind SingleContext {key, kind, anonymous, privateAttributes} =+    filter+        ((/=) Null . snd)+        [ ("key", toJSON $ key)+        , ("kind", toJSON $ if includeKind then String kind else Null)+        , ("anonymous", toJSON $ if anonymous then Bool True else Null)+        , ("_meta", maybe Null toJSON privateAttributes)+        ,+            ( "_meta"+            , case privateAttributes of+                Nothing -> Null+                Just attrs -> toJSON $ singleton "privateAttributes" (Array $ V.fromList $ map toJSON $ S.elems attrs)+            )+        ]++-- Internally used function to decode a JSON object using the legacy user+-- scheme into a modern single-kind "user" context.+parseLegacyUser :: Value -> Parser Context+parseLegacyUser = withObject "LegacyUser" $ \o -> do+    (key :: Text) <- o .: "key"+    (secondary :: Maybe Text) <- o .:? "secondary"+    (ip :: Maybe Text) <- o .:? "ip"+    (country :: Maybe Text) <- o .:? "country"+    (email :: Maybe Text) <- o .:? "email"+    (firstName :: Maybe Text) <- o .:? "firstName"+    (lastName :: Maybe Text) <- o .:? "lastName"+    (avatar :: Maybe Text) <- o .:? "avatar"+    (name :: Maybe Text) <- o .:? "name"+    (anonymous :: Maybe Bool) <- o .:? "anonymous"+    (custom :: Maybe (KeyMap Value)) <- o .:? "custom"+    (privateAttributeNames :: Maybe [Text]) <- o .:? "privateAttributeNames"+    let context =+            makeSingleContext key "user"+                & withAttribute "secondary" (fromMaybe Null (String <$> secondary))+                & withAttribute "ip" (fromMaybe Null (String <$> ip))+                & withAttribute "country" (fromMaybe Null (String <$> country))+                & withAttribute "email" (fromMaybe Null (String <$> email))+                & withAttribute "firstName" (fromMaybe Null (String <$> firstName))+                & withAttribute "lastName" (fromMaybe Null (String <$> lastName))+                & withAttribute "avatar" (fromMaybe Null (String <$> avatar))+                & withAttribute "name" (fromMaybe Null (String <$> name))+                & withAttribute "anonymous" (fromMaybe Null (Bool <$> anonymous))+                & withPrivateAttributes (S.fromList $ map R.makeLiteral $ fromMaybe [] privateAttributeNames)+     in return $ foldrWithKey (\k v c -> withAttribute k v c) context (fromMaybe emptyObject custom)++-- Internally used function to decode a JSON object using the new context+-- scheme into a modern single-kind context.+parseSingleContext :: Value -> Parser Context+parseSingleContext = withObject "SingleContext" $ \o -> do+    (key :: Text) <- o .: "key"+    (kind :: Text) <- o .: "kind"+    (meta :: Maybe (KeyMap Value)) <- o .:? "_meta"+    (privateAttributes :: Maybe [Text]) <- (fromMaybe emptyObject meta) .:? "privateAttributes"+    let context =+            makeContext key kind+                & withPrivateAttributes (S.fromList $ map R.makeReference $ fromMaybe [] privateAttributes)+     in return $ foldrWithKey (\k v c -> withAttribute k v c) context o++-- Internally used function to decode a JSON object using the new context+-- scheme into a modern multi-kind context.+parseMultiContext :: Value -> Parser Context+parseMultiContext = withObject "MultiContext" $ \o -> do+    let contextLists = toList $ deleteKey "kind" o+        contextObjectLists = mapMaybe (\(k, v) -> case (k, v) of (_, Object obj) -> Just (k, obj); _ -> Nothing) contextLists+        results = map (\(kind, obj) -> fromJSON $ Object $ insertKey "kind" (String kind) obj) contextObjectLists+        single = mapMaybe (\result -> case result of Success r -> Just r; _ -> Nothing) results+     in case (length contextLists, length single) of+            (a, b) | a /= b -> return $ Invalid {error = "multi-kind context JSON contains non-single-kind contexts"}+            (_, _) -> return $ makeMultiContext single++-- Internally used function which performs context attribute redaction.+redactContext :: Config -> Context -> Value+redactContext _ (Invalid _) = Null+redactContext config (Multi MultiContext {contexts}) =+    mapValues (\context -> redactSingleContext False context (getAllPrivateAttributes config context)) contexts+        & insertKey "kind" "multi"+        & Object+        & toJSON+redactContext config (Single context) =+    toJSON $ redactSingleContext True context (getAllPrivateAttributes config context)++-- Apply redaction requirements to a SingleContext type.+redactSingleContext :: Bool -> SingleContext -> Set Reference -> Value+redactSingleContext includeKind context privateAttributes =+    let State {context = redactedContext, redacted} = foldr applyRedaction State {context = fromList $ getMapOfRedactableProperties context, redacted = []} privateAttributes+        redactedValues = Array $ V.fromList $ map String redacted+        required = fromList $ getMapOfRequiredProperties includeKind context+     in case redacted of+            [] -> Object $ keyMapUnion redactedContext required+            _ -> Object $ keyMapUnion redactedContext (insertKey "_meta" (Object $ singleton "redactedAttributes" redactedValues) required)++-- Internally used convenience function for creating a Set of References which+-- can redact all top level values in a provided context.+--+-- Given the context:+-- {+--      "kind": "user",+--      "key": "user-key",+--      "name": "Sandy",+--      "address": {+--          "city": "Chicago"+--      }+-- }+--+-- getAllTopLevelRedactableNames context would yield the set ["name",+-- "address"].+getAllTopLevelRedactableNames :: SingleContext -> Set Reference+getAllTopLevelRedactableNames SingleContext {name = Nothing, attributes = Nothing} = S.empty+getAllTopLevelRedactableNames SingleContext {name = Just _, attributes = Nothing} = S.singleton $ R.makeLiteral "name"+getAllTopLevelRedactableNames SingleContext {name = Nothing, attributes = Just attrs} = S.fromList $ map R.makeLiteral $ objectKeys attrs+getAllTopLevelRedactableNames SingleContext {name = Just _, attributes = Just attrs} = S.fromList $ (R.makeLiteral "name") : (map R.makeLiteral $ objectKeys attrs)++-- Internally used convenience function to return a set of references which+-- would apply all redaction rules.+--+-- If allAttributesPrivate is True in the config, this will return a set which+-- covers the entire context.+getAllPrivateAttributes :: Config -> SingleContext -> Set Reference+getAllPrivateAttributes (getField @"allAttributesPrivate" -> True) context = getAllTopLevelRedactableNames context+getAllPrivateAttributes config SingleContext {privateAttributes = Nothing} = getField @"privateAttributeNames" config+getAllPrivateAttributes config SingleContext {privateAttributes = Just attrs} = S.union (getField @"privateAttributeNames" config) attrs++-- Internally used storage type for returning both the resulting redacted+-- context and the list of any attributes which were redacted.+data State = State+    { context :: KeyMap Value+    , redacted :: ![Text]+    }++-- Internally used store type for managing some state while the redaction+-- process is recursing.+data RedactState = RedactState+    { context :: KeyMap Value+    , reference :: Reference+    , redacted :: ![Text]+    }++-- Kick off the redaction process by priming the recursive redaction state.+applyRedaction :: Reference -> State -> State+applyRedaction reference State {context, redacted} =+    let (RedactState {context = c, redacted = r}) = redactComponents (R.getComponents reference) 0 RedactState {context, redacted, reference}+     in State {context = c, redacted = r}++-- Recursively apply redaction rules+redactComponents :: [Text] -> Int -> RedactState -> RedactState+-- If there are no components left to explore, then we can just return the+-- current state of things. This branch should never actually execute.+-- References aren't valid if there isn't at least one component, and we don't+-- recurse in the single component case. We just include it here for+-- completeness.+redactComponents [] _ state = state+-- kind, key, and anonymous are top level attributes that cannot be redacted.+redactComponents ["kind"] 0 state = state+redactComponents ["key"] 0 state = state+redactComponents ["anonymous"] 0 state = state+-- If we have a single component, then we are either trying to redact a simple+-- top level item, or we have recursed through all reference component parts+-- until the last one. We determine which of those situations we are in through+-- use of the 'level' parameter. 'level' = 0 means we are at the top level of+-- the call stack.+--+-- If we have a single component and we have found it in the current context+-- map, then we know we can redact it.+--+-- If we do not find it in the context, but we are at the top level (and thus+-- making a simple redaction), we consider that a successful redaction.+--+-- Otherwise, if there is no match and we aren't at the top level, the+-- redaction has failed and so we can just return the current state unmodified.+redactComponents [x] level state@(RedactState {context, reference, redacted}) = case (level, lookupKey x context) of+    (_, Just _) -> state {context = deleteKey x context, redacted = (R.getRawPath reference) : redacted}+    (0, _) -> state {redacted = (R.getRawPath reference) : redacted}+    _ -> state+redactComponents (x : xs) level state@(RedactState {context}) = case lookupKey x context of+    Just (Object o) ->+        let substate@(RedactState {context = subcontext}) = redactComponents xs (level + 1) (state {context = o})+         in substate {context = insertKey x (Object $ subcontext) context}+    _ -> state
src/LaunchDarkly/Server/DataSource/Internal.hs view
@@ -1,21 +1,21 @@ module LaunchDarkly.Server.DataSource.Internal     ( DataSourceFactory     , nullDataSourceFactory-    , DataSource(..)-    , DataSourceUpdates(..)+    , DataSource (..)+    , DataSourceUpdates (..)     , defaultDataSourceUpdates     )-    where+where -import Data.IORef          (IORef, atomicModifyIORef')-import Data.Text           (Text)-import GHC.Natural         (Natural)+import Data.IORef (IORef, atomicModifyIORef')+import Data.Text (Text)+import GHC.Natural (Natural) +import LaunchDarkly.AesonCompat (KeyMap)+import LaunchDarkly.Server.Client.Status (Status, transitionStatus) import LaunchDarkly.Server.Config.ClientContext (ClientContext)-import LaunchDarkly.Server.Client.Status        (Status, transitionStatus)-import LaunchDarkly.Server.Features             (Segment, Flag)-import LaunchDarkly.Server.Store.Internal       (initializeStore, insertFlag, insertSegment, deleteFlag, deleteSegment, StoreHandle)-import LaunchDarkly.AesonCompat                 (KeyMap)+import LaunchDarkly.Server.Features (Flag, Segment)+import LaunchDarkly.Server.Store.Internal (StoreHandle, deleteFlag, deleteSegment, initializeStore, insertFlag, insertSegment)  type DataSourceFactory = ClientContext -> DataSourceUpdates -> IO DataSource @@ -40,12 +40,12 @@  defaultDataSourceUpdates :: IORef Status -> StoreHandle IO -> DataSourceUpdates defaultDataSourceUpdates status store =-    let modifyStatus status' = atomicModifyIORef' status (fmap (,()) (transitionStatus status')) -    in DataSourceUpdates-        { dataSourceUpdatesInit = initializeStore store -        , dataSourceUpdatesInsertFlag = insertFlag store -        , dataSourceUpdatesInsertSegment = insertSegment store -        , dataSourceUpdatesDeleteFlag = deleteFlag store -        , dataSourceUpdatesDeleteSegment = deleteSegment store -        , dataSourceUpdatesSetStatus = modifyStatus -        }+    let modifyStatus status' = atomicModifyIORef' status (fmap (,()) (transitionStatus status'))+     in DataSourceUpdates+            { dataSourceUpdatesInit = initializeStore store+            , dataSourceUpdatesInsertFlag = insertFlag store+            , dataSourceUpdatesInsertSegment = insertSegment store+            , dataSourceUpdatesDeleteFlag = deleteFlag store+            , dataSourceUpdatesDeleteSegment = deleteSegment store+            , dataSourceUpdatesSetStatus = modifyStatus+            }
src/LaunchDarkly/Server/Details.hs view
@@ -1,88 +1,91 @@ {-# LANGUAGE OverloadedLists #-}+ module LaunchDarkly.Server.Details where -import           Data.Aeson.Types       (Value(..), ToJSON, toJSON)-import           Data.Text              (Text)-import           GHC.Exts               (fromList)-import           GHC.Natural            (Natural)-import           GHC.Generics           (Generic)+import Data.Aeson.Types (ToJSON, Value (..), toJSON)+import Data.Text (Text)+import GHC.Exts (fromList)+import GHC.Generics (Generic)+import GHC.Natural (Natural) --- | Combines the result of a flag evaluation with an explanation of how it was+-- |+-- Combines the result of a flag evaluation with an explanation of how it was -- calculated. data EvaluationDetail value = EvaluationDetail-    { value          :: !value-      -- ^ The result of the flag evaluation. This will be either one of the-      -- flag's variations or the default value passed by the application.+    { value :: !value+    -- ^ The result of the flag evaluation. This will be either one of the+    -- flag's variations or the default value passed by the application.     , variationIndex :: !(Maybe Integer)-      -- ^ The index of the returned value within the flag's list of variations,-      -- e.g. 0 for the first variation - or Nothing if the default value was-      -- returned.-    , reason         :: !EvaluationReason-      -- ^ Describes the main factor that influenced the flag evaluation value.-    } deriving (Generic, Eq, Show)+    -- ^ The index of the returned value within the flag's list of variations,+    -- e.g. 0 for the first variation - or Nothing if the default value was+    -- returned.+    , reason :: !EvaluationReason+    -- ^ Describes the main factor that influenced the flag evaluation value.+    }+    deriving (Generic, Eq, Show)  instance ToJSON a => ToJSON (EvaluationDetail a) where     toJSON = toJSON  -- | Defines the possible values of the Kind property of EvaluationReason. data EvaluationReason-    = EvaluationReasonOff-      -- ^ Indicates that the flag was off and therefore returned its configured+    = -- | Indicates that the flag was off and therefore returned its configured       -- off value.-    | EvaluationReasonTargetMatch-      -- ^ indicates that the user key was specifically targeted for this flag.+      EvaluationReasonOff+    | -- | indicates that the context key was specifically targeted for this flag.+      EvaluationReasonTargetMatch     | EvaluationReasonRuleMatch-          { ruleIndex    :: !Natural-            -- ^ The index of the rule that was matched (0 being the first).-          , 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-          { prerequisiteKey :: !Text-            -- ^ The flag key of the prerequisite that failed.-          }-      -- ^ Indicates that the flag was considered off because it had at least+        { ruleIndex :: !Natural+        -- ^ The index of the rule that was matched (0 being the first).+        , 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 context matched one of the flag's rules.+      EvaluationReasonPrerequisiteFailed+        { prerequisiteKey :: !Text+        -- ^ The flag key of the prerequisite that failed.+        }+    | -- \^ Indicates that the flag was considered off because it had at least       -- 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+      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 context did not match any targets       -- or rules.-    | EvaluationReasonError-          { errorKind :: !EvalErrorKind-            -- ^ Describes the type of error.-          }-      -- ^ Indicates that the flag could not be evaluated, e.g. because it does-      -- not exist or due to an unexpected error. In this case the result value-      -- will be the default value that the caller passed to the client.+      EvaluationReasonError+        { errorKind :: !EvalErrorKind+        -- ^ Describes the type of error.+        }+    -- \^ Indicates that the flag could not be evaluated, e.g. because it does+    -- not exist or due to an unexpected error. In this case the result value+    -- will be the default value that the caller passed to the client.     deriving (Generic, Eq, Show)  instance ToJSON EvaluationReason where     toJSON x = case x of-        EvaluationReasonOff                                        ->+        EvaluationReasonOff ->             Object $ fromList [("kind", "OFF")]-        EvaluationReasonTargetMatch                                ->+        EvaluationReasonTargetMatch ->             Object $ fromList [("kind", "TARGET_MATCH")]-        (EvaluationReasonRuleMatch ruleIndex ruleId True)  ->+        (EvaluationReasonRuleMatch ruleIndex ruleId True) ->             Object $ fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId), ("inExperiment", toJSON True)]-        (EvaluationReasonRuleMatch ruleIndex ruleId False)  ->+        (EvaluationReasonRuleMatch ruleIndex ruleId False) ->             Object $ fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId)]-        (EvaluationReasonPrerequisiteFailed prerequisiteKey)       ->+        (EvaluationReasonPrerequisiteFailed prerequisiteKey) ->             Object $ fromList [("kind", "PREREQUISITE_FAILED"), ("prerequisiteKey", toJSON prerequisiteKey)]-        EvaluationReasonFallthrough True                   ->+        EvaluationReasonFallthrough True ->             Object $ fromList [("kind", "FALLTHROUGH"), ("inExperiment", toJSON True)]-        EvaluationReasonFallthrough False                   ->+        EvaluationReasonFallthrough False ->             Object $ fromList [("kind", "FALLTHROUGH")]-        (EvaluationReasonError errorKind)                          ->+        (EvaluationReasonError errorKind) ->             Object $ fromList [("kind", "ERROR"), ("errorKind", toJSON errorKind)]  isInExperiment :: EvaluationReason -> Bool@@ -93,26 +96,30 @@  -- | Defines the possible values of the errorKind property of EvaluationReason. data EvalErrorKind-    = EvalErrorKindMalformedFlag-      -- ^ Indicates that there was an internal inconsistency in the flag data,+    = -- | Indicates that there was an internal inconsistency in the flag data,       -- e.g. a rule specified a nonexistent variation.-    | EvalErrorFlagNotFound-      -- ^ Indicates that the caller provided a flag key that did not match any+      EvalErrorKindMalformedFlag+    | -- | Indicates that the caller provided a flag key that did not match any       -- known flag.-    | EvalErrorWrongType-      -- ^ Indicates that the result value was not of the requested type, e.g.+      EvalErrorFlagNotFound+    | -- | Indicates that the result value was not of the requested type, e.g.       -- you called boolVariationDetail but the value was an integer.-    | EvalErrorClientNotReady-      -- ^ Indicates that the caller tried to evaluate a flag before the client+      EvalErrorWrongType+    | -- | Indicates that the caller tried to evaluate a flag before the client       -- had successfully initialized.-    | EvalErrorExternalStore !Text-      -- ^ Indicates that some error was returned by the external feature store.+      EvalErrorClientNotReady+    | -- | Indicates that the caller tried to evaluate a flag with an invalid+      -- context+      EvalErrorInvalidContext+    | -- | Indicates that some error was returned by the external feature store.+      EvalErrorExternalStore !Text     deriving (Generic, Eq, Show)  instance ToJSON EvalErrorKind where     toJSON x = String $ case x of         EvalErrorKindMalformedFlag -> "MALFORMED_FLAG"-        EvalErrorFlagNotFound      -> "FLAG_NOT_FOUND"-        EvalErrorWrongType         -> "WRONG_TYPE"-        EvalErrorClientNotReady    -> "CLIENT_NOT_READY"-        EvalErrorExternalStore _   -> "EXTERNAL_STORE_ERROR"+        EvalErrorFlagNotFound -> "FLAG_NOT_FOUND"+        EvalErrorWrongType -> "WRONG_TYPE"+        EvalErrorClientNotReady -> "CLIENT_NOT_READY"+        EvalErrorExternalStore _ -> "EXTERNAL_STORE_ERROR"+        EvalErrorInvalidContext -> "ERROR_INVALID_CONTEXT"
src/LaunchDarkly/Server/Evaluate.hs view
@@ -1,239 +1,397 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+ 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, field)-import           Data.List                           (genericIndex, null, find)-import qualified Data.Vector as                      V-import qualified Data.Text as                        T-import qualified Data.ByteString as                  B-import qualified Data.ByteString.Base16 as           B16-import           Data.Text.Encoding                  (encodeUtf8)-import           GHC.Natural                         (Natural)-import           Data.Word                           (Word8)-import           Data.ByteString                     (ByteString)+import Control.Lens ((%~))+import Control.Monad (msum, mzero)+import Control.Monad.Extra (firstJustM)+import Crypto.Hash.SHA1 (hash)+import Data.Aeson.Types (Value (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import Data.Either (fromLeft)+import Data.Function ((&))+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.Scientific (Scientific, floatingOrInteger)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Vector as V+import Data.Word (Word8)+import GHC.Natural (Natural) -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, 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)-import           LaunchDarkly.Server.Details         (EvaluationDetail(..), EvaluationReason(..), EvalErrorKind(..))+import Data.Either.Extra (mapRight)+import Data.Foldable (foldlM)+import Data.List.Extra (firstJust)+import LaunchDarkly.Server.Client.Internal (Client, Status (Initialized), getStatusI)+import LaunchDarkly.Server.Context (getIndividualContext, getValueForReference)+import LaunchDarkly.Server.Context.Internal (Context (Invalid), getKey, getKinds)+import LaunchDarkly.Server.Details (EvalErrorKind (..), EvaluationDetail (..), EvaluationReason (..))+import LaunchDarkly.Server.Events (EvalEvent, newSuccessfulEvalEvent, newUnknownFlagEvent, processEvalEvents)+import LaunchDarkly.Server.Features (Clause, Flag, Prerequisite, RolloutKind (RolloutKindExperiment), Rule, Segment (..), SegmentRule, SegmentTarget (..), Target, VariationOrRollout)+import LaunchDarkly.Server.Operators (Op (OpSegmentMatch), getOperation)+import LaunchDarkly.Server.Reference (getComponents, getError, isValid, makeLiteral, makeReference)+import LaunchDarkly.Server.Store.Internal (LaunchDarklyStoreRead, getFlagC, getSegmentC)  setFallback :: EvaluationDetail Value -> Value -> EvaluationDetail Value setFallback detail fallback = case getField @"variationIndex" detail of-    Nothing -> detail { value = fallback }; _ -> detail+    Nothing -> detail {value = fallback}+    _ -> detail  setValue :: EvaluationDetail Value -> a -> EvaluationDetail a-setValue x v = x { value = v }+setValue x v = x {value = v}  isError :: EvaluationReason -> Bool isError reason = case reason of (EvaluationReasonError _) -> True; _ -> False -evaluateTyped :: ClientI -> Text -> UserI -> a -> (a -> Value) -> Bool -> (Value -> Maybe a) -> IO (EvaluationDetail a)-evaluateTyped client key user fallback wrap includeReason convert = getStatusI client >>= \status -> if status /= Initialized-    then pure $ EvaluationDetail fallback Nothing $ EvaluationReasonError EvalErrorClientNotReady-    else evaluateInternalClient client key user (wrap fallback) includeReason >>= \r -> pure $ maybe-        (EvaluationDetail fallback Nothing $ if isError (getField @"reason" r)-            then (getField @"reason" r) else EvaluationReasonError EvalErrorWrongType)-        (setValue r) (convert $ getField @"value" r)+evaluateTyped :: Client -> Text -> Context -> a -> (a -> Value) -> Bool -> (Value -> Maybe a) -> IO (EvaluationDetail a)+evaluateTyped client key context fallback wrap includeReason convert =+    getStatusI client >>= \status ->+        if status /= Initialized+            then pure $ EvaluationDetail fallback Nothing $ EvaluationReasonError EvalErrorClientNotReady+            else+                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 :: ClientI -> Text -> UserI -> Value -> Bool -> IO (EvaluationDetail Value)-evaluateInternalClient client key user fallback includeReason = do-    (reason, unknown, events) <- getFlagC (getField @"store" client) key >>= \case-        Left err          -> do-            let event = newUnknownFlagEvent key fallback (EvaluationReasonError $ EvalErrorExternalStore err)-            pure (errorDetail $ EvalErrorExternalStore err, True, pure event)-        Right Nothing     -> do-            let event = newUnknownFlagEvent key fallback (EvaluationReasonError EvalErrorFlagNotFound)-            pure (errorDefault EvalErrorFlagNotFound fallback, True, pure event)-        Right (Just flag) -> do-            (reason, events) <- evaluateDetail flag user $ getField @"store" client-            let reason' = setFallback reason fallback-            pure (reason', False, flip (:) events $ newSuccessfulEvalEvent flag (getField @"variationIndex" reason')-                (getField @"value" reason') (Just fallback) (getField @"reason" reason') Nothing)-    processEvalEvents (getField @"config" client) (getField @"events" client) user includeReason events unknown-    pure reason+evaluateInternalClient :: Client -> Text -> Context -> Value -> Bool -> IO (EvaluationDetail Value)+evaluateInternalClient _ _ (Invalid _) fallback _ = pure $ errorDefault EvalErrorInvalidContext fallback+evaluateInternalClient client key context fallback includeReason = do+    (detail, unknown, events) <-+        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)+            Right Nothing -> do+                let event = newUnknownFlagEvent key fallback (EvaluationReasonError EvalErrorFlagNotFound) context+                pure (errorDefault EvalErrorFlagNotFound fallback, True, pure event)+            Right (Just flag) -> do+                (detail, events) <- evaluateDetail flag context HS.empty $ getField @"store" client+                let detail' = setFallback detail fallback+                pure+                    ( detail'+                    , False+                    , flip (:) events $+                        newSuccessfulEvalEvent+                            flag+                            (getField @"variationIndex" detail')+                            (getField @"value" detail')+                            (Just fallback)+                            (getField @"reason" detail')+                            Nothing+                            context+                    )+    processEvalEvents (getField @"config" client) (getField @"events" client) context includeReason events unknown+    pure detail  getOffValue :: Flag -> EvaluationReason -> EvaluationDetail Value getOffValue flag reason = case getField @"offVariation" flag of     Just offVariation -> getVariation flag offVariation reason-    Nothing -> EvaluationDetail { value = Null, variationIndex = mzero, reason = reason }+    Nothing -> EvaluationDetail {value = Null, variationIndex = mzero, reason = reason}  getVariation :: Flag -> Integer -> EvaluationReason -> EvaluationDetail Value getVariation flag index reason-    | idx < 0 = EvaluationDetail { value = Null, variationIndex = mzero, reason = EvaluationReasonError EvalErrorKindMalformedFlag }-    | idx >= length variations = EvaluationDetail { value = Null, variationIndex = mzero, reason = EvaluationReasonError EvalErrorKindMalformedFlag }-    | otherwise = EvaluationDetail { value = genericIndex variations index, variationIndex = pure index, reason = reason }-  where idx = fromIntegral index-        variations = getField @"variations" flag+    | idx < 0 = EvaluationDetail {value = Null, variationIndex = mzero, reason = EvaluationReasonError EvalErrorKindMalformedFlag}+    | idx >= length variations = EvaluationDetail {value = Null, variationIndex = mzero, reason = EvaluationReasonError EvalErrorKindMalformedFlag}+    | otherwise = EvaluationDetail {value = genericIndex variations index, variationIndex = pure index, reason = reason}+  where+    idx = fromIntegral index+    variations = getField @"variations" flag -evaluateDetail :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> UserI -> store-    -> m (EvaluationDetail Value, [EvalEvent])-evaluateDetail flag user store = if getField @"on" flag-    then checkPrerequisites flag user store >>= \case-        (Nothing, events)     -> evaluateInternal flag user store >>= (\x -> pure (x, events))-        (Just reason, events) -> pure (getOffValue flag reason, events)-    else pure (getOffValue flag EvaluationReasonOff, [])+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 flag context seenFlags store+    | 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)  status :: Prerequisite -> EvaluationDetail a -> Flag -> Bool-status prereq result prereqFlag = getField @"on" prereqFlag && (getField @"variationIndex" result) ==-    pure (getField @"variation" prereq)--checkPrerequisite :: (Monad m, LaunchDarklyStoreRead store m) => store -> UserI -> Flag -> Prerequisite-    -> m (Maybe EvaluationReason, [EvalEvent])-checkPrerequisite store user flag prereq = getFlagC store (getField @"key" prereq) >>= \case-    Left err                -> pure (pure $ EvaluationReasonError $ EvalErrorExternalStore err, [])-    Right Nothing           -> pure (pure $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), [])-    Right (Just prereqFlag) -> evaluateDetail prereqFlag user store >>= \(r, events) -> let-        event = newSuccessfulEvalEvent prereqFlag (getField @"variationIndex" r) (getField @"value" r) Nothing-            (getField @"reason" r) (Just $ getField @"key" flag)-        in if status prereq r prereqFlag then pure (Nothing, event : events) else-            pure (pure $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), event : events)+status prereq result prereqFlag =+    getField @"on" prereqFlag+        && (getField @"variationIndex" result)+            == pure (getField @"variation" prereq)  sequenceUntil :: Monad m => (a -> Bool) -> [m a] -> m [a]-sequenceUntil _ []     = return []-sequenceUntil p (m:ms) = m >>= \a -> if p a then return [a] else-    sequenceUntil p ms >>= \as -> return (a:as)+sequenceUntil _ [] = return []+sequenceUntil p (m : ms) =+    m >>= \a ->+        if p a+            then return [a]+            else sequenceUntil p ms >>= \as -> return (a : as) -checkPrerequisites :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> UserI -> store-    -> m (Maybe EvaluationReason, [EvalEvent])-checkPrerequisites flag user store = let p = getField @"prerequisites" flag in if null p then pure (Nothing, []) else do-    evals <- sequenceUntil (isJust . fst) $ map (checkPrerequisite store user flag) p-    pure (msum $ map fst evals, concatMap snd evals)+checkPrerequisites :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> HS.HashSet Text -> store -> m (Maybe (EvaluationDetail Value), [EvalEvent])+checkPrerequisites flag context seenFlags store =+    let p = getField @"prerequisites" flag+     in if null p+            then pure (Nothing, [])+            else do+                evals <- sequenceUntil (isJust . fst) $ map (checkPrerequisite store context flag seenFlags) p+                pure (msum $ map fst evals, concatMap snd evals) -evaluateInternal :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> UserI -> store -> m (EvaluationDetail Value)-evaluateInternal flag user store = result where-    checkTarget target = if elem (getField @"key" user) (getField @"values" target)-        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, inExperiment = False })-        (pure Nothing)-    fallthrough = getValueForVariationOrRollout flag (getField @"fallthrough" flag) user (EvaluationReasonFallthrough False)-    result = let-        ruleMatch   = checkRule <$> zip [0..] (getField @"rules" flag)-        targetMatch = return . checkTarget <$> getField @"targets" flag-        in fromMaybe fallthrough <$> firstJustM Prelude.id (ruleMatch ++ targetMatch)+checkPrerequisite :: (Monad m, LaunchDarklyStoreRead store m) => store -> Context -> Flag -> HS.HashSet Text -> Prerequisite -> m (Maybe (EvaluationDetail Value), [EvalEvent])+checkPrerequisite store context flag seenFlags prereq =+    if HS.member (getField @"key" prereq) seenFlags+        then pure (Just $ errorDetail EvalErrorKindMalformedFlag, [])+        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), [])+                Right (Just prereqFlag) -> evaluateDetail prereqFlag context seenFlags store >>= (process prereqFlag)+  where+    process prereqFlag (detail, events)+        | isError (getField @"reason" detail) = pure (Just $ errorDetail EvalErrorKindMalformedFlag, mempty)+        | otherwise =+            let event = newSuccessfulEvalEvent prereqFlag (getField @"variationIndex" detail) (getField @"value" detail) Nothing (getField @"reason" detail) (Just $ getField @"key" flag) context+             in if status prereq detail prereqFlag+                    then pure (Nothing, event : events)+                    else pure (pure $ getOffValue flag $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), event : events) +evaluateInternal :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> store -> m (EvaluationDetail Value)+evaluateInternal flag context store = result+  where+    fallthrough = getValueForVariationOrRollout flag (getField @"fallthrough" flag) context (EvaluationReasonFallthrough False)+    result =+        let+            targetEvaluationResults = pure <$> checkTargets context flag+            ruleEvaluationResults = (checkRule flag context store) <$> zip [0 ..] (getField @"rules" flag)+         in+            fromMaybe fallthrough <$> firstJustM Prelude.id (targetEvaluationResults ++ ruleEvaluationResults)++checkRule :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> Context -> store -> (Natural, Rule) -> m (Maybe (EvaluationDetail Value))+checkRule flag context store (ruleIndex, rule) =+    ruleMatchesContext rule context store+        >>= pure . \case+            Left _ -> Just $ errorDetail EvalErrorKindMalformedFlag+            Right True -> Just $ getValueForVariationOrRollout flag (getField @"variationOrRollout" rule) context EvaluationReasonRuleMatch {ruleIndex = ruleIndex, ruleId = getField @"id" rule, inExperiment = False}+            Right False -> Nothing++checkTargets :: Context -> Flag -> [Maybe (EvaluationDetail Value)]+checkTargets context flag =+    let userTargets = getField @"targets" flag+        contextTargets = getField @"contextTargets" flag+     in case contextTargets of+            [] -> checkTarget context "user" flag <$> userTargets+            _ -> checkContextTargets context flag userTargets contextTargets++checkContextTargets :: Context -> Flag -> [Target] -> [Target] -> [Maybe (EvaluationDetail Value)]+checkContextTargets context flag userTargets contextTargets =+    checkContextTarget context flag userTargets <$> contextTargets++checkContextTarget :: Context -> Flag -> [Target] -> Target -> Maybe (EvaluationDetail Value)+checkContextTarget context flag userTargets contextTarget =+    let contextKind = getField @"contextKind" contextTarget+        values = getField @"values" contextTarget+     in if contextKind == "user" && HS.null values+            then -- If the context target doesn't have any values specified, we are supposed to fall back to the user targets+                firstJust Prelude.id $ (checkTarget context "user" flag) <$> userTargets+            else checkTarget context contextKind flag contextTarget++checkTarget :: Context -> Text -> Flag -> Target -> Maybe (EvaluationDetail Value)+checkTarget context contextKind flag target =+    case getIndividualContext contextKind context of+        Nothing -> Nothing+        Just ctx ->+            if elem (getKey ctx) (getField @"values" target)+                then Just $ getVariation flag (getField @"variation" target) EvaluationReasonTargetMatch+                else Nothing+ errorDefault :: EvalErrorKind -> Value -> EvaluationDetail Value-errorDefault kind v = EvaluationDetail { value = v, variationIndex = mzero, reason = EvaluationReasonError kind }+errorDefault kind v = EvaluationDetail {value = v, variationIndex = mzero, reason = EvaluationReasonError kind}  errorDetail :: EvalErrorKind -> EvaluationDetail Value errorDetail kind = errorDefault kind Null -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+getValueForVariationOrRollout :: Flag -> VariationOrRollout -> Context -> EvaluationReason -> EvaluationDetail Value+getValueForVariationOrRollout flag vr context reason =+    case variationIndexForContext vr context (getField @"key" flag) (getField @"salt" flag) of+        (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+    EvaluationReasonFallthrough _ -> EvaluationReasonFallthrough inExperiment     EvaluationReasonRuleMatch index idx _ -> EvaluationReasonRuleMatch index idx inExperiment-    x                                     -> x+    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)+ruleMatchesContext :: Monad m => LaunchDarklyStoreRead store m => Rule -> Context -> store -> m (Either Text Bool)+ruleMatchesContext rule context store = foldlM (checkRule store context) (Right True) clauses+  where+    clauses = getField @"clauses" rule+    checkRule :: Monad m => LaunchDarklyStoreRead store m => store -> Context -> Either Text Bool -> Clause -> m (Either Text Bool)+    checkRule _ _ (Left e) _ = pure $ Left e+    checkRule _ _ (Right False) _ = pure $ Right False+    checkRule store context _ clause = clauseMatchesContext store clause context HS.empty -variationIndexForUser :: VariationOrRollout -> UserI -> Text -> Text -> (Maybe Integer, Bool)-variationIndexForUser vor user key salt+variationIndexForContext :: VariationOrRollout -> Context -> Text -> Text -> (Maybe Integer, Bool)+variationIndexForContext vor context key salt     | (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 (getField @"seed" rollout)-        c acc i = acc >>= \acc -> let t = acc + ((getField @"weight" i) / 100000.0) in-            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+    | (Just rollout) <- getField @"rollout" vor =+        let+            isRolloutExperiment = (getField @"kind" rollout) == RolloutKindExperiment+            bucketBy = fromMaybe "key" $ if isRolloutExperiment then Nothing else getField @"bucketBy" rollout+            variations = getField @"variations" rollout+            bucket = bucketContext context (getField @"contextKind" rollout) key bucketBy salt (getField @"seed" rollout)+            isExperiment = isRolloutExperiment && (isJust bucket)+            c acc i =+                acc >>= \acc ->+                    let t = acc + ((getField @"weight" i) / 100000.0)+                     in case bucket of+                            Just v | v >= t -> Right t+                            _ -> Left (Just $ getField @"variation" i, (not $ getField @"untracked" i) && isExperiment)+         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, False)  -- Bucketing -------------------------------------------------------------------  hexCharToNumber :: Word8 -> Maybe Natural-hexCharToNumber w = fmap fromIntegral $ if-    | 48 <= w && w <= 57  -> pure $ w - 48-    | 65 <= w && w <= 70  -> pure $ w - 55-    | 97 <= w && w <= 102 -> pure $ w - 87-    | otherwise           -> Nothing+hexCharToNumber w =+    fmap fromIntegral $+        if+                | 48 <= w && w <= 57 -> pure $ w - 48+                | 65 <= w && w <= 70 -> pure $ w - 55+                | 97 <= w && w <= 102 -> pure $ w - 87+                | otherwise -> Nothing  hexStringToNumber :: ByteString -> Maybe Natural-hexStringToNumber bytes = B.foldl' step (Just 0) bytes where+hexStringToNumber bytes = B.foldl' step (Just 0) bytes+  where     step acc x = acc >>= \acc' -> hexCharToNumber x >>= pure . (+) (acc' * 16) -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 $-        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)+bucketContext :: Context -> Maybe Text -> Text -> Text -> Text -> Maybe Int -> Maybe Float+bucketContext context kind key attribute salt seed =+    let bucketBy = case kind of+            Nothing -> makeLiteral attribute+            Just _ -> makeReference attribute+     in case getIndividualContext (fromMaybe "user" kind) context of+            Nothing -> Nothing+            Just ctx ->+                let bucketableString = bucketableStringValue $ getValueForReference bucketBy ctx+                 in Just $ calculateBucketValue bucketableString key salt seed +calculateBucketValue :: (Maybe Text) -> Text -> Text -> Maybe Int -> Float+calculateBucketValue Nothing _ _ _ = 0+calculateBucketValue (Just text) key salt seed =+    let seed' = case seed of+            Nothing -> T.concat [key, ".", salt, ".", text]+            Just seed' -> T.concat [T.pack $ show seed', ".", text]+        byteString = B.take 15 $ B16.encode $ hash $ encodeUtf8 $ seed'+     in ((fromIntegral $ fromJust $ hexStringToNumber byteString) :: Float) / 0xFFFFFFFFFFFFFFF+ floatingOrInteger' :: Scientific -> Either Double Integer floatingOrInteger' = floatingOrInteger  bucketableStringValue :: Value -> Maybe Text bucketableStringValue (String x) = pure x bucketableStringValue (Number s) = either (const Nothing) (pure . T.pack . show) (floatingOrInteger' s)-bucketableStringValue _          = Nothing+bucketableStringValue _ = Nothing  -- Clause ----------------------------------------------------------------------  maybeNegate :: Clause -> Bool -> Bool maybeNegate clause value = if getField @"negate" clause then not value else value -matchAny :: (Value -> Value -> Bool) -> Value -> [Value] -> Bool-matchAny op value = any (op value)+-- For a given clause, determine if the provided value matches that clause.+--+-- The operation to be check and the values to compare against are both extract from within the Clause itself.+matchAnyClauseValue :: Clause -> Value -> Bool+matchAnyClauseValue clause contextValue = any (f contextValue) v+  where+    f = getOperation $ getField @"op" clause+    v = getField @"values" clause -clauseMatchesUserNoSegments :: Clause -> UserI -> Bool-clauseMatchesUserNoSegments clause user = case valueOf user $ getField @"attribute" clause of-    Nothing        -> False-    Just (Null)    -> False-    Just (Array a) -> maybeNegate clause $ V.any (\x -> matchAny f x v) a-    Just x         -> maybeNegate clause $ matchAny f x v-    where-        f = getOperation $ getField @"op" clause-        v = getField @"values" clause+-- If attribute is "kind", then we treat operator and values as a match expression against a list of all individual+-- kinds in the context. That is, for a multi-kind context with kinds of "org" and "user", it is a match if either+-- of those strings is a match with Operator and Values.+clauseMatchesByKind :: Clause -> Context -> Bool+clauseMatchesByKind clause context = foldr f False (getKinds context)+  where+    f kind result+        | result == True = True+        | otherwise = matchAnyClauseValue clause (String kind) -clauseMatchesUser :: (Monad m, LaunchDarklyStoreRead store m) => store -> Clause -> UserI -> m Bool-clauseMatchesUser store clause user-    | getField @"op" clause == OpSegmentMatch = do-        let values = [ x | String x <- getField @"values" clause]-        x <- anyM (\k -> getSegmentC store k >>= pure . checkSegment) values-        pure $ maybeNegate clause x-    | otherwise = pure $ clauseMatchesUserNoSegments clause user-    where-        checkSegment :: Either Text (Maybe Segment) -> Bool-        checkSegment (Right (Just segment)) = segmentContainsUser segment user-        checkSegment _                      = False+clauseMatchesContextNoSegments :: Clause -> Context -> Either Text Bool+clauseMatchesContextNoSegments clause context+    | isValid (getField @"attribute" clause) == False = Left $ getError $ getField @"attribute" clause+    | ["kind"] == getComponents (getField @"attribute" clause) = Right $ maybeNegate clause $ clauseMatchesByKind clause context+    | otherwise = case getIndividualContext (getField @"contextKind" clause) context of+        Nothing -> Right False+        Just ctx -> case getValueForReference (getField @"attribute" clause) ctx of+            Null -> Right False+            Array a -> Right $ maybeNegate clause $ V.any (matchAnyClauseValue clause) a+            x -> Right $ maybeNegate clause $ matchAnyClauseValue clause x +clauseMatchesContext :: (Monad m, LaunchDarklyStoreRead store m) => store -> Clause -> Context -> HS.HashSet Text -> m (Either Text Bool)+clauseMatchesContext store clause context seenSegments+    | getField @"op" clause == OpSegmentMatch =+        let values = [x | String x <- getField @"values" clause]+         in foldlM (checkSegment store context seenSegments) (Right False) values >>= pure . mapRight (maybeNegate clause)+    | otherwise = pure $ clauseMatchesContextNoSegments clause context++checkSegment :: (Monad m, LaunchDarklyStoreRead store m) => store -> Context -> HS.HashSet Text -> Either Text Bool -> Text -> m (Either Text Bool)+checkSegment _ _ _ (Left e) _ = pure $ Left e+checkSegment _ _ _ (Right True) _ = pure $ Right True+checkSegment store context seenSegments _ value =+    getSegmentC store value >>= \case+        Right (Just segment) -> segmentContainsContext store segment context seenSegments+        _ -> pure $ Right False+ -- Segment --------------------------------------------------------------------- -segmentRuleMatchesUser :: SegmentRule -> UserI -> Text -> Text -> Bool-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 Nothing < weight / 100000.0)+segmentRuleMatchesContext :: (Monad m, LaunchDarklyStoreRead store m) => store -> SegmentRule -> Context -> Text -> Text -> HS.HashSet Text -> m (Either Text Bool)+segmentRuleMatchesContext store rule context key salt seenSegments =+    foldlM (checkClause store) (Right True) (getField @"clauses" rule) >>= \result ->+        pure $ case result of+            Left _ -> result+            Right False -> result+            _ ->+                Right $+                    ( flip (maybe True) (getField @"weight" rule) $ \weight ->+                        let bucket = bucketContext context (getField @"rolloutContextKind" rule) key (fromMaybe "key" $ getField @"bucketBy" rule) salt Nothing+                         in case bucket of+                                Just v | v >= (weight / 100000.0) -> False+                                _ -> True+                    )+  where+    checkClause :: (Monad m, LaunchDarklyStoreRead store m) => store -> Either Text Bool -> Clause -> m (Either Text Bool)+    checkClause _ (Left e) _ = pure $ Left e+    checkClause _ (Right False) _ = pure $ Right False+    checkClause store _ clause = clauseMatchesContext store clause context seenSegments -segmentContainsUser :: Segment -> UserI -> Bool-segmentContainsUser segment user-    | elem (getField @"key" user) (getField @"included" segment) = True-    | elem (getField @"key" user) (getField @"excluded" segment) = False-    | Just _ <- find-        (\r -> segmentRuleMatchesUser r user (getField @"key" segment) (getField @"salt" segment))-        (getField @"rules" segment) = True-    | otherwise = False+segmentContainsContext :: (Monad m, LaunchDarklyStoreRead store m) => store -> Segment -> Context -> HS.HashSet Text -> m (Either Text Bool)+segmentContainsContext store (Segment {included, includedContexts, excluded, excludedContexts, key, salt, rules}) context seenSegments+    | HS.member key seenSegments = pure $ Left "segment rule caused a circular reference; this is probably a temporary condition"+    | contextKeyInTargetList included "user" context = pure $ Right True+    | (any (flip contextKeyInSegmentTarget context) includedContexts) = pure $ Right True+    | contextKeyInTargetList excluded "user" context = pure $ Right False+    | (any (flip contextKeyInSegmentTarget context) excludedContexts) = pure $ Right False+    | otherwise = foldlM (checkRules store) (Right False) rules+  where+    checkRules :: (Monad m, LaunchDarklyStoreRead store m) => store -> Either Text Bool -> SegmentRule -> m (Either Text Bool)+    checkRules _ (Left e) _ = pure $ Left e+    checkRules _ (Right True) _ = pure $ Right True+    checkRules store _ rule = segmentRuleMatchesContext store rule context key salt (HS.insert key seenSegments)++contextKeyInSegmentTarget :: SegmentTarget -> Context -> Bool+contextKeyInSegmentTarget (SegmentTarget {values, contextKind}) = contextKeyInTargetList values contextKind++contextKeyInTargetList :: (HashSet Text) -> Text -> Context -> Bool+contextKeyInTargetList targets kind context = case getIndividualContext kind context of+    Just ctx -> elem (getKey ctx) targets+    Nothing -> False
src/LaunchDarkly/Server/Events.hs view
@@ -1,176 +1,183 @@ module LaunchDarkly.Server.Events where -import           Data.Aeson                          (ToJSON, Value(..), toJSON, object, (.=))-import           Data.Text                           (Text)-import           GHC.Exts                            (fromList)-import           GHC.Natural                         (Natural, naturalFromInteger)-import           GHC.Generics                        (Generic)-import           Data.Generics.Product               (HasField', getField, field, setField)-import qualified Data.Text as                        T-import           Control.Concurrent.MVar             (MVar, putMVar, swapMVar, newEmptyMVar, newMVar, tryTakeMVar, modifyMVar_, modifyMVar, readMVar)-import           Data.Time.Clock.POSIX               (getPOSIXTime)-import           Control.Lens                        ((&), (%~))-import           Data.Maybe                          (fromMaybe)-import           Data.Cache.LRU                      (LRU, newLRU)-import           Control.Monad                       (when, unless)-import qualified Data.Cache.LRU as                   LRU--import           LaunchDarkly.AesonCompat            (KeyMap, keyMapUnion, insertKey, mapValues, objectValues, lookupKey)-import           LaunchDarkly.Server.Config.Internal (ConfigI, shouldSendEvents)-import           LaunchDarkly.Server.User.Internal   (UserI, userSerializeRedacted)-import           LaunchDarkly.Server.Details         (EvaluationReason(..))-import           LaunchDarkly.Server.Features        (Flag)--data ContextKind = ContextKindUser | ContextKindAnonymousUser-    deriving (Eq, Show)--instance ToJSON ContextKind where-  toJSON contextKind = String $ case contextKind of-      ContextKindUser          -> "user"-      ContextKindAnonymousUser -> "anonymousUser"+import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, tryTakeMVar)+import Control.Lens ((%~), (&))+import Control.Monad (when)+import Data.Aeson (ToJSON, Value (..), object, toJSON, (.=))+import Data.Cache.LRU (LRU, newLRU)+import qualified Data.Cache.LRU as LRU+import Data.Generics.Product (HasField', field, getField, setField)+import qualified Data.HashSet as HS+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock.POSIX (getPOSIXTime)+import GHC.Exts (fromList)+import GHC.Generics (Generic)+import GHC.Natural (Natural, naturalFromInteger) -userGetContextKind :: UserI -> ContextKind-userGetContextKind user = if getField @"anonymous" user-    then ContextKindAnonymousUser else ContextKindUser+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, getKeys, getKinds, redactContext)+import LaunchDarkly.Server.Details (EvaluationReason (..))+import LaunchDarkly.Server.Features (Flag)  data EvalEvent = EvalEvent-    { key                  :: !Text-    , variation            :: !(Maybe Integer)-    , value                :: !Value-    , defaultValue         :: !(Maybe Value)-    , version              :: !(Maybe Natural)-    , prereqOf             :: !(Maybe Text)-    , reason               :: !EvaluationReason-    , trackEvents          :: !Bool-    , forceIncludeReason   :: !Bool-    , debug                :: !Bool+    { key :: !Text+    , context :: !Context+    , variation :: !(Maybe Integer)+    , value :: !Value+    , defaultValue :: !(Maybe Value)+    , version :: !(Maybe Natural)+    , prereqOf :: !(Maybe Text)+    , reason :: !EvaluationReason+    , trackEvents :: !Bool+    , forceIncludeReason :: !Bool+    , debug :: !Bool     , debugEventsUntilDate :: !(Maybe Natural)-    } deriving (Generic, Eq, Show)+    }+    deriving (Generic, Eq, Show)  data EventState = EventState-    { events              :: !(MVar [EventType])+    { events :: !(MVar [EventType])     , lastKnownServerTime :: !(MVar Integer)-    , flush               :: !(MVar ())-    , summary             :: !(MVar (KeyMap (FlagSummaryContext (KeyMap CounterContext))))-    , startDate           :: !(MVar Natural)-    , userKeyLRU          :: !(MVar (LRU Text ()))-    } deriving (Generic)+    , flush :: !(MVar ())+    , summary :: !(MVar (KeyMap FlagSummaryContext))+    , startDate :: !(MVar Natural)+    , contextKeyLRU :: !(MVar (LRU Text ()))+    }+    deriving (Generic) -makeEventState :: ConfigI -> IO EventState+makeEventState :: Config -> IO EventState makeEventState config = do-    events              <- newMVar []+    events <- newMVar []     lastKnownServerTime <- newMVar 0-    flush               <- newEmptyMVar-    summary             <- newMVar mempty-    startDate           <- newEmptyMVar-    userKeyLRU          <- newMVar $ newLRU $ pure $ fromIntegral $ getField @"userKeyLRUCapacity" config-    pure EventState{..}--convertFeatures :: KeyMap (FlagSummaryContext (KeyMap CounterContext))-    -> KeyMap (FlagSummaryContext [CounterContext])-convertFeatures summary = flip mapValues summary $ \context -> context & field @"counters" %~ objectValues+    flush <- newEmptyMVar+    summary <- newMVar mempty+    startDate <- newEmptyMVar+    contextKeyLRU <- newMVar $ newLRU $ pure $ fromIntegral $ getField @"contextKeyLRUCapacity" config+    pure EventState {..} -queueEvent :: ConfigI -> EventState -> EventType -> IO ()-queueEvent config state event = if not (shouldSendEvents config) then pure () else-    modifyMVar_ (getField @"events" state) $ \events ->-        pure $ case event of-          EventTypeSummary _ -> event : events-          _ | length events < fromIntegral (getField @"eventsCapacity" config) -> event : events-          _ -> events+queueEvent :: Config -> EventState -> EventType -> IO ()+queueEvent config state event =+    if not (shouldSendEvents config)+        then pure ()+        else modifyMVar_ (getField @"events" state) $ \events ->+            pure $ case event of+                EventTypeSummary _ -> event : events+                _ | length events < fromIntegral (getField @"eventsCapacity" config) -> event : events+                _ -> events  unixMilliseconds :: IO Natural unixMilliseconds = round . (* 1000) <$> getPOSIXTime  makeBaseEvent :: a -> IO (BaseEvent a)-makeBaseEvent child = unixMilliseconds >>= \now -> pure $ BaseEvent { creationDate = now, event = child }+makeBaseEvent child = unixMilliseconds >>= \now -> pure $ BaseEvent {creationDate = now, event = child} -processSummary :: ConfigI -> EventState -> IO ()-processSummary config state = tryTakeMVar (getField @"startDate" state) >>= \case-    Nothing          -> pure ()-    (Just startDate) -> do-        endDate  <- unixMilliseconds-        features <- convertFeatures <$> swapMVar (getField @"summary" state) mempty-        queueEvent config state $ EventTypeSummary $ SummaryEvent {..}+processSummary :: Config -> EventState -> IO ()+processSummary config state =+    tryTakeMVar (getField @"startDate" state) >>= \case+        Nothing -> pure ()+        (Just startDate) -> do+            endDate <- unixMilliseconds+            features <- swapMVar (getField @"summary" state) mempty+            queueEvent config state $ EventTypeSummary $ SummaryEvent {..}  class EventKind a where     eventKind :: a -> Text  data SummaryEvent = SummaryEvent     { startDate :: !Natural-    , endDate   :: !Natural-    , features  :: !(KeyMap (FlagSummaryContext [CounterContext]))-    } deriving (Generic, Show, ToJSON)+    , endDate :: !Natural+    , features :: !(KeyMap FlagSummaryContext)+    }+    deriving (Generic, Show, ToJSON)  instance EventKind SummaryEvent where     eventKind _ = "summary" -data FlagSummaryContext a = FlagSummaryContext+data FlagSummaryContext = FlagSummaryContext     { defaultValue :: Maybe Value-    , counters     :: a-    } deriving (Generic, Show)+    , counters :: KeyMap CounterContext+    , contextKinds :: HS.HashSet Text+    }+    deriving (Generic, Show) -instance ToJSON a => ToJSON (FlagSummaryContext a) where-    toJSON ctx = object $ filter ((/=) Null . snd)-        [ ("default",  toJSON $ getField @"defaultValue" ctx)-        , ("counters", toJSON $ getField @"counters"     ctx)-        ]+instance ToJSON FlagSummaryContext where+    toJSON ctx =+        object $+            filter+                ((/=) Null . snd)+                [ ("default", toJSON $ getField @"defaultValue" ctx)+                , ("counters", toJSON $ objectValues $ getField @"counters" ctx)+                , ("contextKinds", toJSON $ getField @"contextKinds" ctx)+                ]  data CounterContext = CounterContext-    { count     :: !Natural-    , version   :: !(Maybe Natural)+    { count :: !Natural+    , version :: !(Maybe Natural)     , variation :: !(Maybe Integer)-    , value     :: !Value-    , unknown   :: !Bool-    } deriving (Generic, Show)+    , value :: !Value+    , unknown :: !Bool+    }+    deriving (Generic, Show)  instance ToJSON CounterContext where-    toJSON context = object $-        [ "count" .= getField @"count" context-        , "value" .= getField @"value" context-        ] <> filter ((/=) Null . snd)-        [ "version" .= getField @"version" context-        , "variation" .= getField @"variation" context-        , "unknown" .= if getField @"unknown" context then Just True else Nothing-        ]+    toJSON context =+        object $+            [ "count" .= getField @"count" context+            , "value" .= getField @"value" context+            ]+                <> filter+                    ((/=) Null . snd)+                    [ "version" .= getField @"version" context+                    , "variation" .= getField @"variation" context+                    , "unknown" .= if getField @"unknown" context then Just True else Nothing+                    ]  data IdentifyEvent = IdentifyEvent-    { key  :: !Text-    , user :: !Value-    } deriving (Generic, ToJSON, Show)+    { key :: !Text+    , context :: !Value+    }+    deriving (Generic, ToJSON, Show)  instance EventKind IdentifyEvent where     eventKind _ = "identify" -data IndexEvent = IndexEvent { user :: Value } deriving (Generic, ToJSON, Show)+data IndexEvent = IndexEvent {context :: Value} deriving (Generic, ToJSON, Show)  instance EventKind IndexEvent where     eventKind _ = "index"  data FeatureEvent = FeatureEvent-    { key          :: !Text-    , user         :: !(Maybe Value)-    , userKey      :: !(Maybe Text)-    , value        :: !Value+    { key :: !Text+    , context :: !(Maybe Value)+    , contextKeys :: !(Maybe (KeyMap Text))+    , value :: !Value     , defaultValue :: !(Maybe Value)-    , version      :: !(Maybe Natural)-    , variation    :: !(Maybe Integer)-    , reason       :: !(Maybe EvaluationReason)-    , contextKind  :: !ContextKind-    } deriving (Generic, Show)+    , version :: !(Maybe Natural)+    , prereqOf :: !(Maybe Text)+    , variation :: !(Maybe Integer)+    , reason :: !(Maybe EvaluationReason)+    }+    deriving (Generic, Show)  instance ToJSON FeatureEvent where-    toJSON event = object $ filter ((/=) Null . snd)-        [ ("key",         toJSON $ getField @"key"          event)-        , ("user",        toJSON $ getField @"user"         event)-        , ("userKey",     toJSON $ getField @"userKey"      event)-        , ("value",       toJSON $ getField @"value"        event)-        , ("default",     toJSON $ getField @"defaultValue" event)-        , ("version",     toJSON $ getField @"version"      event)-        , ("variation",   toJSON $ getField @"variation"    event)-        , ("reason",      toJSON $ getField @"reason"       event)-        , ("contextKind", let c = getField @"contextKind" event in-            if c == ContextKindUser then Null else toJSON c)-        ]+    toJSON event =+        object $+            filter+                ((/=) Null . snd)+                [ ("key", toJSON $ getField @"key" event)+                , ("context", toJSON $ getField @"context" event)+                , ("contextKeys", toJSON $ getField @"contextKeys" event)+                , ("value", toJSON $ getField @"value" event)+                , ("default", toJSON $ getField @"defaultValue" event)+                , ("version", toJSON $ getField @"version" event)+                , ("prereqOf", toJSON $ getField @"prereqOf" event)+                , ("variation", toJSON $ getField @"variation" event)+                , ("reason", toJSON $ getField @"reason" event)+                ]  instance EventKind FeatureEvent where     eventKind _ = "feature"@@ -183,201 +190,202 @@ instance ToJSON DebugEvent where     toJSON (DebugEvent x) = toJSON x -addUserToEvent :: (HasField' "user" r (Maybe Value), HasField' "userKey" r (Maybe Text)) => ConfigI -> UserI -> r -> r-addUserToEvent config user event = if getField @"inlineUsersInEvents" config-    then setField @"user" (pure $ userSerializeRedacted config user) event-    else setField @"userKey" (pure $ getField @"key" user) event+addContextToEvent :: (HasField' "context" r (Maybe Value)) => Config -> Context -> r -> r+addContextToEvent config context event = setField @"context" (Just $ redactContext config context) event -forceUserInlineInEvent :: ConfigI -> UserI -> FeatureEvent -> FeatureEvent-forceUserInlineInEvent config user event = setField @"userKey" Nothing $ setField @"user" (pure $ userSerializeRedacted config user) event+contextOrContextKeys :: Bool -> Config -> Context -> FeatureEvent -> FeatureEvent+contextOrContextKeys True config context event = addContextToEvent config context event & setField @"contextKeys" Nothing+contextOrContextKeys False _ context event = event {contextKeys = Just $ getKeys context, context = Nothing} -makeFeatureEvent :: ConfigI -> UserI -> Bool -> EvalEvent -> FeatureEvent-makeFeatureEvent config user includeReason event = addUserToEvent config user $ FeatureEvent-    { key          = getField @"key" event-    , user         = Nothing-    , userKey      = Nothing-    , value        = getField @"value" event-    , defaultValue = getField @"defaultValue" event-    , version      = getField @"version" event-    , variation    = getField @"variation" event-    , reason       = if includeReason || getField @"forceIncludeReason" event-        then pure $ getField @"reason" event else Nothing-    , contextKind  = userGetContextKind user-    }+makeFeatureEvent :: Config -> Context -> Bool -> EvalEvent -> FeatureEvent+makeFeatureEvent config context includeReason event =+    contextOrContextKeys False config context $+        FeatureEvent+            { key = getField @"key" event+            , context = Nothing+            , contextKeys = Nothing+            , value = getField @"value" event+            , defaultValue = getField @"defaultValue" event+            , version = getField @"version" event+            , prereqOf = getField @"prereqOf" event+            , variation = getField @"variation" event+            , reason =+                if includeReason || getField @"forceIncludeReason" event+                    then pure $ getField @"reason" event+                    else Nothing+            }  data CustomEvent = CustomEvent-    { key         :: !Text-    , user        :: !(Maybe Value)-    , userKey     :: !(Maybe Text)+    { key :: !Text+    , contextKeys :: !(KeyMap Text)     , metricValue :: !(Maybe Double)-    , value       :: !(Maybe Value)-    , contextKind :: !ContextKind-    } deriving (Generic, Show)+    , value :: !(Maybe Value)+    }+    deriving (Generic, Show)  instance ToJSON CustomEvent where-    toJSON ctx = object $ filter ((/=) Null . snd)-        [ ("key",         toJSON $ getField @"key"         ctx)-        , ("user",        toJSON $ getField @"user"        ctx)-        , ("userKey",     toJSON $ getField @"userKey"     ctx)-        , ("metricValue", toJSON $ getField @"metricValue" ctx)-        , ("data",        toJSON $ getField @"value"       ctx)-        , ("contextKind", let c = getField @"contextKind" ctx in-            if c == ContextKindUser then Null else toJSON c)-        ]+    toJSON ctx =+        object $+            filter+                ((/=) Null . snd)+                [ ("key", toJSON $ getField @"key" ctx)+                , ("contextKeys", toJSON $ getField @"contextKeys" ctx)+                , ("metricValue", toJSON $ getField @"metricValue" ctx)+                , ("data", toJSON $ getField @"value" ctx)+                ]  instance EventKind CustomEvent where     eventKind _ = "custom" -data AliasEvent = AliasEvent-    { key                 :: !Text-    , contextKind         :: !ContextKind-    , previousKey         :: !Text-    , previousContextKind :: !ContextKind-    }-    deriving (Generic, Show)--instance ToJSON AliasEvent where-    toJSON ctx = object $ filter ((/=) Null . snd)-        [ ("key",                 toJSON $ getField @"key"                 ctx)-        , ("contextKind",         toJSON $ getField @"contextKind"         ctx)-        , ("previousKey",         toJSON $ getField @"previousKey"         ctx)-        , ("previousContextKind", toJSON $ getField @"previousContextKind" ctx)-        ]--instance EventKind AliasEvent where-    eventKind _ = "alias"- data BaseEvent event = BaseEvent     { creationDate :: Natural-    , event        :: event-    } deriving (Generic, Show)+    , event :: event+    }+    deriving (Generic, Show)  fromObject :: Value -> KeyMap Value fromObject x = case x of (Object o) -> o; _ -> error "expected object"  instance (EventKind sub, ToJSON sub) => ToJSON (BaseEvent sub) where-    toJSON event = Object $ keyMapUnion (fromObject $ toJSON $ getField @"event" event) $ fromList-        [ ("creationDate", toJSON $ getField @"creationDate" event)-        , ("kind",         String $ eventKind $ getField @"event" event)-        ]+    toJSON event =+        Object $+            keyMapUnion (fromObject $ toJSON $ getField @"event" event) $+                fromList+                    [ ("creationDate", toJSON $ getField @"creationDate" event)+                    , ("kind", String $ eventKind $ getField @"event" event)+                    ] -data EventType =-      EventTypeIdentify !(BaseEvent IdentifyEvent)-    | EventTypeFeature  !(BaseEvent FeatureEvent)-    | EventTypeSummary  !SummaryEvent-    | EventTypeCustom   !(BaseEvent CustomEvent)-    | EventTypeIndex    !(BaseEvent IndexEvent)-    | EventTypeDebug    !(BaseEvent DebugEvent)-    | EventTypeAlias    !(BaseEvent AliasEvent)+data EventType+    = EventTypeIdentify !(BaseEvent IdentifyEvent)+    | EventTypeFeature !(BaseEvent FeatureEvent)+    | EventTypeSummary !SummaryEvent+    | EventTypeCustom !(BaseEvent CustomEvent)+    | EventTypeIndex !(BaseEvent IndexEvent)+    | EventTypeDebug !(BaseEvent DebugEvent)  instance ToJSON EventType where     toJSON event = case event of         EventTypeIdentify x -> toJSON x-        EventTypeFeature  x -> toJSON x-        EventTypeSummary  x -> Object $ insertKey "kind" (String "summary") (fromObject $ toJSON x)-        EventTypeCustom   x -> toJSON x-        EventTypeIndex    x -> toJSON x-        EventTypeDebug    x -> toJSON x-        EventTypeAlias    x -> toJSON x--newUnknownFlagEvent :: Text -> Value -> EvaluationReason -> EvalEvent-newUnknownFlagEvent key defaultValue reason = EvalEvent-    { key                  = key-    , variation            = Nothing-    , value                = defaultValue-    , defaultValue         = pure defaultValue-    , version              = Nothing-    , prereqOf             = Nothing-    , reason               = reason-    , trackEvents          = False-    , forceIncludeReason   = False-    , debug                = False-    , debugEventsUntilDate = Nothing-    }--newSuccessfulEvalEvent :: Flag -> Maybe Integer -> Value -> Maybe Value -> EvaluationReason -> Maybe Text -> EvalEvent-newSuccessfulEvalEvent flag variation value defaultValue reason prereqOf = EvalEvent-    { key                  = getField @"key" flag-    , variation            = variation-    , value                = value-    , defaultValue         = defaultValue-    , version              = Just $ getField @"version" flag-    , prereqOf             = prereqOf-    , reason               = reason-    , trackEvents          = getField @"trackEvents" flag || shouldForceReason-    , forceIncludeReason   = shouldForceReason-    , debug                = False-    , debugEventsUntilDate = getField @"debugEventsUntilDate" flag-    }+        EventTypeFeature x -> toJSON x+        EventTypeSummary x -> Object $ insertKey "kind" (String "summary") (fromObject $ toJSON x)+        EventTypeCustom x -> toJSON x+        EventTypeIndex x -> toJSON x+        EventTypeDebug x -> toJSON x -    where+newUnknownFlagEvent :: Text -> Value -> EvaluationReason -> Context -> EvalEvent+newUnknownFlagEvent key defaultValue reason context =+    EvalEvent+        { key = key+        , context = context+        , variation = Nothing+        , value = defaultValue+        , defaultValue = pure defaultValue+        , version = Nothing+        , prereqOf = Nothing+        , reason = reason+        , trackEvents = False+        , forceIncludeReason = False+        , debug = False+        , debugEventsUntilDate = Nothing+        } +newSuccessfulEvalEvent :: Flag -> Maybe Integer -> Value -> Maybe Value -> EvaluationReason -> Maybe Text -> Context -> EvalEvent+newSuccessfulEvalEvent flag variation value defaultValue reason prereqOf context =+    EvalEvent+        { key = getField @"key" flag+        , context = context+        , variation = variation+        , value = value+        , defaultValue = defaultValue+        , version = Just $ getField @"version" flag+        , prereqOf = prereqOf+        , reason = reason+        , trackEvents = getField @"trackEvents" flag || shouldForceReason+        , forceIncludeReason = shouldForceReason+        , debug = False+        , debugEventsUntilDate = getField @"debugEventsUntilDate" flag+        }+  where     shouldForceReason = case reason of-        (EvaluationReasonFallthrough inExperiment)     ->+        (EvaluationReasonFallthrough inExperiment) ->             inExperiment || getField @"trackEventsFallthrough" flag         (EvaluationReasonRuleMatch idx _ inExperiment) ->             inExperiment || getField @"trackEvents" (getField @"rules" flag !! fromIntegral idx)-        _                                              -> False+        _ -> False  makeSummaryKey :: EvalEvent -> Text-makeSummaryKey event = T.intercalate "-"-    [ fromMaybe "" $ fmap (T.pack . show) $ getField @"version" event-    , fromMaybe "" $ fmap (T.pack . show) $ getField @"variation" event-    ]+makeSummaryKey event =+    T.intercalate+        "-"+        [ fromMaybe "" $ fmap (T.pack . show) $ getField @"version" event+        , fromMaybe "" $ fmap (T.pack . show) $ getField @"variation" event+        ] -summarizeEvent :: KeyMap (FlagSummaryContext (KeyMap CounterContext))-    -> EvalEvent -> Bool -> KeyMap (FlagSummaryContext (KeyMap CounterContext))-summarizeEvent context event unknown = result where+summarizeEvent :: KeyMap FlagSummaryContext -> EvalEvent -> Bool -> KeyMap FlagSummaryContext+summarizeEvent summaryContext event unknown = result+  where     key = makeSummaryKey event-    root = case lookupKey (getField @"key" event) context of-        (Just x) -> x; Nothing  -> FlagSummaryContext (getField @"defaultValue" event) mempty+    contextKinds = HS.fromList $ getKinds $ getField @"context" event+    root = case lookupKey (getField @"key" event) summaryContext of+        (Just x) -> x+        Nothing ->+            FlagSummaryContext+                { defaultValue = (getField @"defaultValue" event)+                , counters = mempty+                , contextKinds = mempty+                }     leaf = case lookupKey key (getField @"counters" root) of         (Just x) -> x & field @"count" %~ (1 +)-        Nothing  -> CounterContext-            { count     = 1-            , version   = getField @"version" event-            , variation = getField @"variation" event-            , value     = getField @"value" event-            , unknown   = unknown-            }-    result = flip (insertKey $ getField @"key" event) context $-        root & field @"counters" %~ insertKey key leaf+        Nothing ->+            CounterContext+                { count = 1+                , version = getField @"version" event+                , variation = getField @"variation" event+                , value = getField @"value" event+                , unknown = unknown+                }+    result = flip (insertKey $ getField @"key" event) summaryContext $ (root & field @"counters" %~ (insertKey key leaf) & field @"contextKinds" %~ (HS.union contextKinds))  putIfEmptyMVar :: MVar a -> a -> IO ()-putIfEmptyMVar mvar value = tryTakeMVar mvar >>= \case Just x -> putMVar mvar x; Nothing -> putMVar mvar value;+putIfEmptyMVar mvar value = tryTakeMVar mvar >>= \case Just x -> putMVar mvar x; Nothing -> putMVar mvar value  runSummary :: Natural -> EventState -> EvalEvent -> Bool -> IO ()-runSummary now state event unknown = putIfEmptyMVar (getField @"startDate" state) now >>-    modifyMVar_ (getField @"summary" state) (\summary -> pure $ summarizeEvent summary event unknown)+runSummary now state event unknown =+    putIfEmptyMVar (getField @"startDate" state) now+        >> modifyMVar_ (getField @"summary" state) (\summary -> pure $ summarizeEvent summary event unknown) -processEvalEvent :: Natural -> ConfigI -> EventState -> UserI -> Bool -> Bool -> EvalEvent -> IO ()-processEvalEvent now config state user includeReason unknown event = do-    let featureEvent = makeFeatureEvent config user includeReason event+processEvalEvent :: Natural -> Config -> EventState -> Context -> Bool -> Bool -> EvalEvent -> IO ()+processEvalEvent now config state context includeReason unknown event = do+    let featureEvent = makeFeatureEvent config context includeReason event         trackEvents = getField @"trackEvents" event-        inlineUsers = getField @"inlineUsersInEvents" config         debugEventsUntilDate = fromMaybe 0 (getField @"debugEventsUntilDate" event)     lastKnownServerTime <- naturalFromInteger <$> (* 1000) <$> readMVar (getField @"lastKnownServerTime" state)     when trackEvents $-        queueEvent config state $ EventTypeFeature $ BaseEvent now featureEvent+        queueEvent config state $+            EventTypeFeature $+                BaseEvent now featureEvent     when (now < debugEventsUntilDate && lastKnownServerTime < debugEventsUntilDate) $-        queueEvent config state $ EventTypeDebug $ BaseEvent now $ DebugEvent $ forceUserInlineInEvent config user featureEvent+        queueEvent config state $+            EventTypeDebug $+                BaseEvent now $+                    DebugEvent $+                        contextOrContextKeys True config context featureEvent     runSummary now state event unknown-    unless (trackEvents && inlineUsers) $-        maybeIndexUser now config user state+    maybeIndexContext now config context state -processEvalEvents :: ConfigI -> EventState -> UserI -> Bool -> [EvalEvent] -> Bool -> IO ()-processEvalEvents config state user includeReason events unknown = unixMilliseconds >>= \now ->-    mapM_ (processEvalEvent now config state user includeReason unknown) events+processEvalEvents :: Config -> EventState -> Context -> Bool -> [EvalEvent] -> Bool -> IO ()+processEvalEvents config state context includeReason events unknown =+    unixMilliseconds >>= \now -> mapM_ (processEvalEvent now config state context includeReason unknown) events -maybeIndexUser :: Natural -> ConfigI -> UserI -> EventState -> IO ()-maybeIndexUser now config user state = do-    noticedUser <- noticeUser state user-    when noticedUser $-        queueEvent config state (EventTypeIndex $ BaseEvent now $ IndexEvent { user = userSerializeRedacted config user })+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}) -noticeUser :: EventState -> UserI -> IO Bool-noticeUser state user = modifyMVar (getField @"userKeyLRU" state) $ \cache -> do-    let key = getField @"key" user+noticeContext :: EventState -> Context -> IO Bool+noticeContext state context = modifyMVar (getField @"contextKeyLRU" state) $ \cache -> do+    let key = getCanonicalKey context     case LRU.lookup key cache of-        (cache', Just _)  -> pure (cache', False)+        (cache', Just _) -> pure (cache', False)         (cache', Nothing) -> pure (LRU.insert key () cache', True)
src/LaunchDarkly/Server/Features.hs view
@@ -1,69 +1,84 @@ module LaunchDarkly.Server.Features where -import Control.Lens                  (element, (^?))-import Control.Monad                 (mzero)-import Data.Aeson                    (FromJSON(..), ToJSON(..), Value(..), withObject, (.:), (.:?), object, (.=), (.!=))-import Data.Maybe                    (fromMaybe)-import Data.Text                     (Text)-import Data.HashSet                  (HashSet)-import Data.Generics.Product         (getField)-import GHC.Natural                   (Natural)-import GHC.Generics                  (Generic)+import Control.Lens (element, (^?))+import Control.Monad (mzero)+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.!=), (.:), (.:?), (.=))+import Data.Generics.Product (getField)+import Data.HashSet (HashSet)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import GHC.Generics (Generic)+import GHC.Natural (Natural) -import LaunchDarkly.Server.Operators (Op) import LaunchDarkly.Server.Details (EvaluationReason (..)) import qualified LaunchDarkly.Server.Details as D+import LaunchDarkly.Server.Operators (Op)+import LaunchDarkly.Server.Reference (Reference, makeLiteral, makeReference)  data Target = Target-    { values    :: ![Text]+    { values :: !(HashSet Text)     , variation :: !Integer-    } deriving (Generic, FromJSON, ToJSON, Show, Eq)+    , contextKind :: Text+    }+    deriving (Generic, ToJSON, Show, Eq) +instance FromJSON Target where+    parseJSON = withObject "Target" $ \t ->+        Target+            <$> t .: "values"+            <*> t .: "variation"+            <*> t .:? "contextKind" .!= "user"+ data Rule = Rule-    { id                 :: !Text-    , clauses            :: ![Clause]+    { id :: !Text+    , clauses :: ![Clause]     , variationOrRollout :: !VariationOrRollout-    , trackEvents        :: !Bool-    } deriving (Generic, Show, Eq)+    , trackEvents :: !Bool+    }+    deriving (Generic, Show, Eq)  instance FromJSON Rule where     parseJSON = withObject "Rule" $ \o -> do-        id          <- o .:  "id"-        clauses     <- o .:  "clauses"-        variation   <- o .:? "variation"-        rollout     <- o .:? "rollout"-        trackEvents <- o .:  "trackEvents"-        pure Rule-            { id                 = id-            , clauses            = clauses-            , variationOrRollout = VariationOrRollout-                { variation = variation-                , rollout   = rollout+        id <- o .:? "id"+        clauses <- o .: "clauses"+        variation <- o .:? "variation"+        rollout <- o .:? "rollout"+        trackEvents <- o .: "trackEvents"+        pure+            Rule+                { id = fromMaybe "" id+                , clauses = clauses+                , variationOrRollout =+                    VariationOrRollout+                        { variation = variation+                        , rollout = rollout+                        }+                , trackEvents = trackEvents                 }-            , trackEvents        = trackEvents-            }  instance ToJSON Rule where-    toJSON rule = object-        [ "id"          .= getField @"id" rule-        , "clauses"     .= getField @"clauses" rule-        , "trackEvents" .= getField @"trackEvents" rule-        , "variation"   .= getField @"variation" (getField @"variationOrRollout" rule)-        , "rollout"     .= getField @"rollout" (getField @"variationOrRollout" rule)-        ]+    toJSON rule =+        object+            [ "id" .= getField @"id" rule+            , "clauses" .= getField @"clauses" rule+            , "trackEvents" .= getField @"trackEvents" rule+            , "variation" .= getField @"variation" (getField @"variationOrRollout" rule)+            , "rollout" .= getField @"rollout" (getField @"variationOrRollout" rule)+            ]  data WeightedVariation = WeightedVariation     { variation :: !Integer-    , weight    :: !Float+    , weight :: !Float     , untracked :: !Bool-    } deriving (Generic, ToJSON, Show, Eq)+    }+    deriving (Generic, ToJSON, Show, Eq)  instance FromJSON WeightedVariation where     parseJSON = withObject "WeightedVariation" $ \o -> do-        variation <- o .:  "variation"-        weight    <- o .:  "weight"+        variation <- o .: "variation"+        weight <- o .: "weight"         untracked <- o .:? "untracked" .!= False-        pure WeightedVariation { .. }+        pure WeightedVariation {..}  data RolloutKind = RolloutKindExperiment | RolloutKindRollout     deriving (Eq, Show)@@ -71,88 +86,99 @@ instance ToJSON RolloutKind where     toJSON x = String $ case x of         RolloutKindExperiment -> "experiment"-        RolloutKindRollout    -> "rollout"+        RolloutKindRollout -> "rollout"  instance FromJSON RolloutKind where     parseJSON x = case x of         (String "experiment") -> pure RolloutKindExperiment-        (String "rollout")    -> pure RolloutKindRollout-        _                     -> mzero+        (String "rollout") -> pure RolloutKindRollout+        _ -> mzero  data Rollout = Rollout     { variations :: ![WeightedVariation]-    , bucketBy   :: !(Maybe Text)-    , kind       :: !RolloutKind-    , seed       :: !(Maybe Int)-    } deriving (Generic, ToJSON, Show, Eq)+    , bucketBy :: !(Maybe Text)+    , kind :: !RolloutKind+    , contextKind :: !(Maybe Text)+    , 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 { .. }+        variations <- o .: "variations"+        bucketBy <- o .:? "bucketBy"+        kind <- o .:? "kind" .!= RolloutKindRollout+        contextKind <- o .:? "contextKind"+        seed <- o .:? "seed"+        pure Rollout {..}  data VariationOrRollout = VariationOrRollout     { variation :: !(Maybe Integer)-    , rollout   :: !(Maybe Rollout)-    } deriving (Generic, FromJSON, ToJSON, Show, Eq)+    , rollout :: !(Maybe Rollout)+    }+    deriving (Generic, FromJSON, ToJSON, Show, Eq)  data ClientSideAvailability = ClientSideAvailability-    { usingEnvironmentId     :: !Bool-    , usingMobileKey         :: !Bool-    , explicit               :: !Bool-    } deriving (Generic, Show, Eq)+    { usingEnvironmentId :: !Bool+    , usingMobileKey :: !Bool+    , explicit :: !Bool+    }+    deriving (Generic, Show, Eq)  instance FromJSON ClientSideAvailability where-    parseJSON = withObject "ClientSideAvailability" $ \obj -> ClientSideAvailability-        <$> obj .: "usingEnvironmentId"-        <*> obj .: "usingMobileKey"-        <*> pure True+    parseJSON = withObject "ClientSideAvailability" $ \obj ->+        ClientSideAvailability+            <$> obj .: "usingEnvironmentId"+            <*> obj .: "usingMobileKey"+            <*> pure True  instance ToJSON ClientSideAvailability where     toJSON (ClientSideAvailability env mob _) =-        object [ "usingEnvironmentId" .= env, "usingMobileKey" .= mob ]+        object ["usingEnvironmentId" .= env, "usingMobileKey" .= mob]  data Flag = Flag-    { key                    :: !Text-    , version                :: !Natural-    , on                     :: !Bool-    , trackEvents            :: !Bool+    { key :: !Text+    , version :: !Natural+    , on :: !Bool+    , trackEvents :: !Bool     , trackEventsFallthrough :: !Bool-    , deleted                :: !Bool-    , prerequisites          :: ![Prerequisite]-    , salt                   :: !Text-    , targets                :: ![Target]-    , rules                  :: ![Rule]-    , fallthrough            :: !VariationOrRollout-    , offVariation           :: !(Maybe Integer)-    , variations             :: ![Value]-    , debugEventsUntilDate   :: !(Maybe Natural)+    , deleted :: !Bool+    , prerequisites :: ![Prerequisite]+    , salt :: !Text+    , targets :: ![Target]+    , contextTargets :: ![Target]+    , rules :: ![Rule]+    , fallthrough :: !VariationOrRollout+    , offVariation :: !(Maybe Integer)+    , variations :: ![Value]+    , debugEventsUntilDate :: !(Maybe Natural)     , clientSideAvailability :: !ClientSideAvailability-    } deriving (Generic, Show, Eq)+    }+    deriving (Generic, Show, Eq)  instance ToJSON Flag where-    toJSON flag = object $-        [ "key" .= getField @"key" flag-        , "version" .= getField @"version" flag-        , "on" .= getField @"on" flag-        , "trackEvents" .= getField @"trackEvents" flag-        , "trackEventsFallthrough" .= getField @"trackEventsFallthrough" flag-        , "deleted" .= getField @"deleted" flag-        , "prerequisites" .= getField @"prerequisites" flag-        , "salt" .= getField @"salt" flag-        , "targets" .= getField @"targets" flag-        , "rules" .= getField @"rules" flag-        , "fallthrough" .= getField @"fallthrough" flag-        , "offVariation" .= getField @"offVariation" flag-        , "variations" .= getField @"variations" flag-        , "debugEventsUntilDate" .= getField @"debugEventsUntilDate" flag-        , "clientSide" .= (getField @"usingEnvironmentId" $ getField @"clientSideAvailability" flag)-        ] <> case getField @"explicit" $ getField @"clientSideAvailability" flag of-               True -> [ "clientSideAvailability" .= getField @"clientSideAvailability" flag ]-               False -> [ ]+    toJSON flag =+        object $+            [ "key" .= getField @"key" flag+            , "version" .= getField @"version" flag+            , "on" .= getField @"on" flag+            , "trackEvents" .= getField @"trackEvents" flag+            , "trackEventsFallthrough" .= getField @"trackEventsFallthrough" flag+            , "deleted" .= getField @"deleted" flag+            , "prerequisites" .= getField @"prerequisites" flag+            , "salt" .= getField @"salt" flag+            , "targets" .= getField @"targets" flag+            , "contextTargets" .= getField @"contextTargets" flag+            , "rules" .= getField @"rules" flag+            , "fallthrough" .= getField @"fallthrough" flag+            , "offVariation" .= getField @"offVariation" flag+            , "variations" .= getField @"variations" flag+            , "debugEventsUntilDate" .= getField @"debugEventsUntilDate" flag+            , "clientSide" .= (getField @"usingEnvironmentId" $ getField @"clientSideAvailability" flag)+            ]+                <> case getField @"explicit" $ getField @"clientSideAvailability" flag of+                    True -> ["clientSideAvailability" .= getField @"clientSideAvailability" flag]+                    False -> []  instance FromJSON Flag where     parseJSON = withObject "Flag" $ \obj -> do@@ -165,6 +191,7 @@         prerequisites <- obj .: "prerequisites"         salt <- obj .: "salt"         targets <- obj .: "targets"+        contextTargets <- obj .:? "contextTargets" .!= mempty         rules <- obj .: "rules"         fallthrough <- obj .: "fallthrough"         offVariation <- obj .:? "offVariation"@@ -172,10 +199,10 @@         debugEventsUntilDate <- obj .:? "debugEventsUntilDate"         clientSide <- obj .:? "clientSide" .!= False         clientSideAvailability <- obj .:? "clientSideAvailability" .!= ClientSideAvailability clientSide True False-        pure Flag { .. }+        pure Flag {..}  isClientSideOnlyFlag :: Flag -> Bool-isClientSideOnlyFlag flag = getField @"usingEnvironmentId" $ getField  @"clientSideAvailability" flag+isClientSideOnlyFlag flag = getField @"usingEnvironmentId" $ getField @"clientSideAvailability" flag  -- If the reason for the flag is in an experiment, -- or if it's a fallthrough reason and the flag has trackEventsFallthrough@@ -183,40 +210,75 @@ -- otherwise false isInExperiment :: Flag -> EvaluationReason -> Bool isInExperiment _ reason-  | D.isInExperiment reason = True-isInExperiment flag EvaluationReasonFallthrough {..} = getField @"trackEventsFallthrough" flag+    | D.isInExperiment reason = True+isInExperiment flag EvaluationReasonFallthrough {} = getField @"trackEventsFallthrough" flag isInExperiment flag (EvaluationReasonRuleMatch ruleIndex _ _) =     let index = fromIntegral ruleIndex         rules = getField @"rules" flag         rule = rules ^? element index-    in fromMaybe False $ fmap (getField @"trackEvents") rule+     in fromMaybe False $ fmap (getField @"trackEvents") rule isInExperiment _ _ = False  data Prerequisite = Prerequisite-    { key       :: !Text+    { key :: !Text     , variation :: !Integer-    } deriving (Generic, FromJSON, ToJSON, Show, Eq)+    }+    deriving (Generic, FromJSON, ToJSON, Show, Eq)  data SegmentRule = SegmentRule-    { id       :: !Text-    , clauses  :: ![Clause]-    , weight   :: !(Maybe Float)+    { id :: !Text+    , clauses :: ![Clause]+    , weight :: !(Maybe Float)     , bucketBy :: !(Maybe Text)-    } deriving (Generic, FromJSON, ToJSON, Show, Eq)+    , rolloutContextKind :: !(Maybe Text)+    }+    deriving (Generic, ToJSON, Show, Eq) +instance FromJSON SegmentRule where+    parseJSON = withObject "SegmentRule" $ \o -> do+        id <- o .: "id"+        clauses <- o .: "clauses"+        weight <- o .:? "weight"+        bucketBy <- o .:? "bucketBy"+        rolloutContextKind <- o .:? "rolloutContextKind"+        return $ SegmentRule {..}+ data Segment = Segment-    { key      :: !Text+    { key :: !Text     , included :: !(HashSet Text)+    , includedContexts :: ![SegmentTarget]     , excluded :: !(HashSet Text)-    , salt     :: !Text-    , rules    :: ![SegmentRule]-    , version  :: !Natural-    , deleted  :: !Bool-    } deriving (Generic, FromJSON, ToJSON, Show, Eq)+    , excludedContexts :: ![SegmentTarget]+    , salt :: !Text+    , rules :: ![SegmentRule]+    , version :: !Natural+    , deleted :: !Bool+    }+    deriving (Generic, FromJSON, ToJSON, Show, Eq) +data SegmentTarget = SegmentTarget+    { values :: !(HashSet Text)+    , contextKind :: !Text+    }+    deriving (Generic, FromJSON, ToJSON, Show, Eq)+ data Clause = Clause-    { attribute :: !Text-    , negate    :: !Bool-    , op        :: !Op-    , values    :: ![Value]-    } deriving (Generic, FromJSON, ToJSON, Show, Eq)+    { attribute :: !Reference+    , contextKind :: !Text+    , negate :: !Bool+    , op :: !Op+    , values :: ![Value]+    }+    deriving (Generic, ToJSON, Show, Eq)++instance FromJSON Clause where+    parseJSON = withObject "Clause" $ \o -> do+        attr <- o .: "attribute"+        kind <- o .:? "contextKind"+        negate <- o .: "negate"+        op <- o .: "op"+        values <- o .: "values"++        let contextKind = fromMaybe "user" kind+            attribute = case kind of Nothing -> makeLiteral (attr); _ -> makeReference (attr)+        return $ Clause {..}
src/LaunchDarkly/Server/Integrations/FileData.hs view
@@ -1,44 +1,46 @@ {-# LANGUAGE BangPatterns #-}--- | Integration between the LaunchDarkly SDK and file data.++-- |+-- Integration between the LaunchDarkly SDK and file data. -----  The file data source allows you to use local files as a source of feature flag state. This would---  typically be used in a test environment, to operate using a predetermined feature flag state---  without an actual LaunchDarkly connection. See 'dataSourceFactory' for details.+--  The file data source allows you to use local files as a source of feature+--  flag state. This would typically be used in a test environment, to operate+--  using a predetermined feature flag state without an actual LaunchDarkly+--  connection. See 'dataSourceFactory' for details. -- --  @since 2.2.1--- module LaunchDarkly.Server.Integrations.FileData     ( dataSourceFactory     )-    where+where -import           LaunchDarkly.Server.DataSource.Internal (DataSourceFactory, DataSource(..), DataSourceUpdates(..))-import qualified LaunchDarkly.Server.Features as F-import           LaunchDarkly.Server.Client.Status-import           LaunchDarkly.AesonCompat (KeyMap, mapWithKey)-import           Data.Maybe (fromMaybe)+import Control.Applicative ((<|>))+import Data.Aeson (FromJSON, Value, decode) import qualified Data.ByteString.Lazy as BSL-import           Data.HashSet (HashSet)-import           Data.Text (Text)-import           GHC.Generics (Generic)-import           Data.Aeson (Value, FromJSON, decode)-import           Data.Monoid (Monoid, mempty)-import           Data.Semigroup (Semigroup)-import           Data.IORef (newIORef, readIORef, writeIORef)-import           GHC.Natural (Natural)-import           Data.Generics.Product (getField)+import Data.Generics.Product (getField)+import Data.HashSet (HashSet)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import Data.Text (Text) import qualified Data.Yaml as Yaml-import           Control.Applicative ((<|>))+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import LaunchDarkly.AesonCompat (KeyMap, mapWithKey)+import LaunchDarkly.Server.Client.Status+import LaunchDarkly.Server.DataSource.Internal (DataSource (..), DataSourceFactory, DataSourceUpdates (..))+import qualified LaunchDarkly.Server.Features as F  data FileFlag = FileFlag-    { version                :: Maybe Natural-    , on                     :: Maybe Bool-    , targets                :: Maybe [F.Target]-    , rules                  :: Maybe [F.Rule]-    , fallthrough            :: Maybe F.VariationOrRollout-    , offVariation           :: Maybe Integer-    , variations             :: ![Value]-    } deriving (Generic, FromJSON, Show, Eq)+    { version :: Maybe Natural+    , on :: Maybe Bool+    , targets :: Maybe [F.Target]+    , contextTargets :: Maybe [F.Target]+    , rules :: Maybe [F.Rule]+    , fallthrough :: Maybe F.VariationOrRollout+    , offVariation :: Maybe Integer+    , variations :: ![Value]+    }+    deriving (Generic, FromJSON, Show, Eq)  expandSimpleFlag :: Value -> FileFlag expandSimpleFlag value =@@ -46,6 +48,7 @@         { version = Nothing         , on = Nothing         , targets = Nothing+        , contextTargets = Nothing         , rules = Nothing         , fallthrough = Just (F.VariationOrRollout (Just 0) Nothing)         , offVariation = Just 0@@ -54,22 +57,24 @@  fromFileFlag :: Text -> FileFlag -> F.Flag fromFileFlag key fileFlag =-    F.Flag{ F.key = key-          , F.version = fromMaybe 1 $ getField @"version" fileFlag-          , F.on = fromMaybe True $ on fileFlag-          , F.trackEvents = False-          , F.trackEventsFallthrough = False-          , F.deleted = False-          , F.prerequisites = []-          , F.salt = ""-          , F.targets = fromMaybe [] $ targets fileFlag-          , F.rules = fromMaybe [] $ getField @"rules" fileFlag-          , F.fallthrough = fromMaybe noFallthrough $ fallthrough fileFlag-          , F.offVariation = offVariation fileFlag-          , F.variations = variations fileFlag-          , F.debugEventsUntilDate = Nothing-          , F.clientSideAvailability = F.ClientSideAvailability False False False-          }+    F.Flag+        { F.key = key+        , F.version = fromMaybe 1 $ getField @"version" fileFlag+        , F.on = fromMaybe True $ on fileFlag+        , F.trackEvents = False+        , F.trackEventsFallthrough = False+        , F.deleted = False+        , F.prerequisites = []+        , F.salt = ""+        , F.targets = fromMaybe [] $ targets fileFlag+        , F.contextTargets = fromMaybe [] $ contextTargets fileFlag+        , F.rules = fromMaybe [] $ getField @"rules" fileFlag+        , F.fallthrough = fromMaybe noFallthrough $ fallthrough fileFlag+        , F.offVariation = offVariation fileFlag+        , F.variations = variations fileFlag+        , F.debugEventsUntilDate = Nothing+        , F.clientSideAvailability = F.ClientSideAvailability False False False+        }  noFallthrough :: F.VariationOrRollout noFallthrough =@@ -77,27 +82,34 @@  data FileSegment = FileSegment     { included :: Maybe (HashSet Text)+    , includedContexts :: Maybe [F.SegmentTarget]     , excluded :: Maybe (HashSet Text)-    , rules    :: Maybe [F.SegmentRule]-    , version  :: Maybe Natural-    } deriving (Generic, FromJSON, Show, Eq)+    , excludedContexts :: Maybe [F.SegmentTarget]+    , rules :: Maybe [F.SegmentRule]+    , version :: Maybe Natural+    }+    deriving (Generic, FromJSON, Show, Eq)  fromFileSegment :: Text -> FileSegment -> F.Segment fromFileSegment key fileSegment =-    F.Segment{ F.key = key-             , F.version = fromMaybe 1 $ getField @"version" fileSegment-             , F.included = fromMaybe mempty $ included fileSegment-             , F.excluded = fromMaybe mempty $ excluded fileSegment-             , F.salt = ""-             , F.rules = fromMaybe [] $ getField @"rules" fileSegment-             , F.deleted = False-             }+    F.Segment+        { F.key = key+        , F.version = fromMaybe 1 $ getField @"version" fileSegment+        , F.included = fromMaybe mempty $ included fileSegment+        , F.includedContexts = fromMaybe mempty $ includedContexts fileSegment+        , F.excluded = fromMaybe mempty $ excluded fileSegment+        , F.excludedContexts = fromMaybe mempty $ excludedContexts fileSegment+        , F.salt = ""+        , F.rules = fromMaybe [] $ getField @"rules" fileSegment+        , F.deleted = False+        }  data FileBody = FileBody-    { flags      :: Maybe (KeyMap FileFlag)+    { flags :: Maybe (KeyMap FileFlag)     , flagValues :: Maybe (KeyMap Value)-    , segments   :: Maybe (KeyMap FileSegment)-    } deriving (Generic, Show, FromJSON)+    , segments :: Maybe (KeyMap FileSegment)+    }+    deriving (Generic, Show, FromJSON)  instance Semigroup FileBody where     f1 <> f2 =@@ -116,39 +128,45 @@     mappend = (<>)  -- |--- Creates a @DataSourceFactory@ which uses the configured the file data sources.--- This allows you to use local files as a source of--- feature flag state, instead of using an actual LaunchDarkly connection.+-- Creates a @DataSourceFactory@ which uses the configured file data sources. ----- To use the file dataSource you can add it to the 'LaunchDarkly.Server.Config' using 'LaunchDarkly.Server.Config.configSetDataSourceFactory'+-- This allows you to use local files as a source of feature flag state,+-- instead of using an actual LaunchDarkly connection. --+-- To use the file dataSource you can add it to the+-- 'LaunchDarkly.Server.Config' using+-- 'LaunchDarkly.Server.Config.configSetDataSourceFactory'+-- -- @ -- let config = configSetDataSourceFactory (FileData.dataSourceFactory ["./testData/flags.json"]) $ --              makeConfig "sdk-key" -- client <- makeClient config -- @ ----- This will cause the client /not/ to connect to LaunchDarkly to get feature flags. The--- client may still make network connections to send analytics events, unless you have disabled--- this with 'LaunchDarkly.Server.Config.configSetSendEvents' to @False@.--- IMPORTANT: Do /not/ set 'LaunchDarkly.Server.Config.configSetOffline' to @True@; doing so--- would not just put the SDK \"offline\" with regard to LaunchDarkly, but will completely turn off--- all flag data sources to the SDK /including the file data source/.+-- This will cause the client /not/ to connect to LaunchDarkly to get feature+-- flags. The client may still make network connections to send analytics+-- events, unless you have disabled this with+-- 'LaunchDarkly.Server.Config.configSetSendEvents' to @False@. IMPORTANT: Do+-- /not/ set 'LaunchDarkly.Server.Config.configSetOffline' to @True@; doing so+-- would not just put the SDK \"offline\" with regard to LaunchDarkly, but will+-- completely turn off all flag data sources to the SDK /including the file+-- data source/. ----- Flag data files can be either JSON or YAML. They contain an object with three possible--- properties:+-- Flag data files can be either JSON or YAML. They contain an object with+-- three possible properties: -- --      [@flags@]: Feature flag definitions. --      [@flagValues@]: Simplified feature flags that contain only a value.---      [@segments@]: User segment definitions.+--      [@segments@]: Context segment definitions. ----- The format of the data in @flags@ and @segments@ is defined by the LaunchDarkly application--- and is subject to change. Rather than trying to construct these objects yourself, it is simpler--- to request existing flags directly from the LaunchDarkly server in JSON format, and use this--- output as the starting point for your file. In Linux you would do this:+-- The format of the data in @flags@ and @segments@ is defined by the+-- LaunchDarkly application and is subject to change. Rather than trying to+-- construct these objects yourself, it is simpler to request existing flags+-- directly from the LaunchDarkly server in JSON format, and use this output as+-- the starting point for your file. In Linux you would do this: -- -- @--- curl -H "Authorization: {your sdk key}" https://app.launchdarkly.com/sdk/latest-all+-- curl -H "Authorization: {your sdk key}" https://sdk.launchdarkly.com/sdk/latest-all -- @ -- -- The output will look something like this (but with many more properties):@@ -176,9 +194,10 @@ -- } -- @ ----- Data in this format allows the SDK to exactly duplicate all the kinds of flag behavior supported--- by LaunchDarkly. However, in many cases you will not need this complexity, but will just want to--- set specific flag keys to specific values. For that, you can use a much simpler format:+-- Data in this format allows the SDK to exactly duplicate all the kinds of+-- flag behavior supported by LaunchDarkly. However, in many cases you will not+-- need this complexity, but will just want to set specific flag keys to+-- specific values. For that, you can use a much simpler format: -- -- @ -- {@@ -198,12 +217,14 @@ --   my-boolean-flag-key: true -- @ ----- It is also possible to specify both @flags@ and @flagValues@, if you want some flags--- to have simple values and others to have complex behavior. However, it is an error to use the--- same flag key or segment key more than once, either in a single file or across multiple files.+-- It is also possible to specify both @flags@ and @flagValues@, if you want+-- some flags to have simple values and others to have complex behavior.+-- However, it is an error to use the same flag key or segment key more than+-- once, either in a single file or across multiple files. ----- If the data source encounters any error in any file(malformed content, a missing file) it will not load flags from that file.--- If the data source encounters a duplicate key it will ignore that duplicate entry.+-- If the data source encounters any error in any file(malformed content, a+-- missing file) it will not load flags from that file. If the data source+-- encounters a duplicate key it will ignore that duplicate entry. -- -- @since 2.2.1 dataSourceFactory :: [FilePath] -> DataSourceFactory@@ -220,14 +241,14 @@             dataSourceUpdatesSetStatus dataSourceUpdates Initialized             writeIORef inited True         dataSourceStop = pure ()-    pure $ DataSource{..}+    pure $ DataSource {..}  loadFile :: FilePath -> IO FileBody loadFile filePath = do     file <- BSL.readFile filePath     let mDecodedFile = decode file <|> Yaml.decodeThrow (BSL.toStrict file)     case mDecodedFile of-      Just !fileBody ->-          pure fileBody-      Nothing ->-          pure mempty+        Just !fileBody ->+            pure fileBody+        Nothing ->+            pure mempty
src/LaunchDarkly/Server/Integrations/TestData.hs view
@@ -1,15 +1,16 @@ -- |--- A mechanism for providing dynamically updatable feature flag state in a simplified form to an SDK--- client in test scenarios.+-- A mechanism for providing dynamically updatable feature flag state in a+-- simplified form to an SDK client in test scenarios. ----- Unlike "LaunchDarkly.Server.Integrations.FileData", this mechanism does not use any external resources. It provides only--- the data that the application has put into it using the 'update' function.+-- Unlike "LaunchDarkly.Server.Integrations.FileData", this mechanism does not+-- use any external resources. It provides only the data that the application+-- has put into it using the 'update' function. -- -- @ -- td <- TestData.newTestData -- update td =<< (flag td "flag-key-1" --                 \<&\> booleanFlag---                 \<&\> variationForAllUsers True)+--                 \<&\> variationForAll True) -- -- let config = makeConfig "sdkKey" --                 & configSetDataSourceFactory (dataSourceFactory td)@@ -18,20 +19,21 @@ -- -- flags can be updated at any time: -- update td =<< --    (flag td "flag-key-2"---          \<&\> variationForUser "some-user-key" True+--          \<&\> variationForKey "user" "some-user-key" True --          \<&\> fallthroughVariation False) -- @ ----- The above example uses a simple boolean flag, but more complex configurations are possible using--- the methods of the 'FlagBuilder' that is returned by 'flag'. 'FlagBuilder'--- supports many of the ways a flag can be configured on the LaunchDarkly dashboard, but does not--- currently support:+-- The above example uses a simple boolean flag, but more complex+-- configurations are possible using the methods of the 'FlagBuilder' that is+-- returned by 'flag'. 'FlagBuilder' supports many of the ways a flag can be+-- configured on the LaunchDarkly dashboard, but does not currently support: -- --      1. Rule operators other than "in" and "not in" --      2. Percentage rollouts. ----- If the same 'TestData' instance is used to configure multiple 'LaunchDarkly.Server.Client.Client' instances,--- any changes made to the data will propagate to all of the @Client@s.+-- If the same 'TestData' instance is used to configure multiple+-- 'LaunchDarkly.Server.Client.Client' instances, any changes made to the data+-- will propagate to all of the @Client@s. -- -- see "LaunchDarkly.Server.Integrations.FileData" --@@ -43,44 +45,50 @@     , update     , dataSourceFactory -    -- * FlagBuilder+      -- * FlagBuilder     , FlagBuilder     , booleanFlag     , on     , fallthroughVariation     , offVariation+    , variationForAll     , variationForAllUsers+    , valueForAll     , valueForAllUsers+    , variationForKey     , variationForUser     , variations     , ifMatch+    , ifMatchContext     , ifNotMatch+    , ifNotMatchContext     , VariationIndex -    -- * FlagRuleBuilder+      -- * FlagRuleBuilder     , FlagRuleBuilder     , andMatch+    , andMatchContext     , andNotMatch+    , andNotMatchContext     , thenReturn     )-    where--import           Control.Concurrent.MVar                               (MVar, modifyMVar_, newMVar, newEmptyMVar, readMVar, putMVar)-import           Control.Monad                                         (void)-import           Data.Foldable                                         (traverse_)-import           Data.IntMap.Strict                                    (IntMap)-import qualified Data.IntMap.Strict                                    as IntMap-import           Data.Map.Strict                                       (Map)-import qualified Data.Map.Strict                                       as Map-import qualified Data.Maybe                                            as Maybe-import           Data.Text                                             (Text)+where -import           Data.Generics.Product                                 (getField)-import           LaunchDarkly.Server.DataSource.Internal-import qualified LaunchDarkly.Server.Features                          as Features-import           LaunchDarkly.Server.Integrations.TestData.FlagBuilder-import           LaunchDarkly.AesonCompat                              (KeyMap, insertKey, insertKey, lookupKey)+import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar)+import Control.Monad (void)+import Data.Foldable (traverse_)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import Data.Text (Text) +import Data.Generics.Product (getField)+import LaunchDarkly.AesonCompat (KeyMap, insertKey, lookupKey)+import LaunchDarkly.Server.DataSource.Internal+import qualified LaunchDarkly.Server.Features as Features+import LaunchDarkly.Server.Integrations.TestData.FlagBuilder  dataSourceFactory :: TestData -> DataSourceFactory dataSourceFactory (TestData ref) _clientContext dataSourceUpdates = do@@ -104,20 +112,23 @@ type TestDataListener = Features.Flag -> IO ()  data TestData' = TestData'-    { flagBuilders             :: Map Text FlagBuilder-    , currentFlags             :: KeyMap Features.Flag+    { flagBuilders :: Map Text FlagBuilder+    , currentFlags :: KeyMap Features.Flag     , nextDataSourceListenerId :: Int-    , dataSourceListeners      :: IntMap TestDataListener+    , dataSourceListeners :: IntMap TestDataListener     }  -- | Creates a new instance of the test data source.-newTestData :: IO TestData -- ^ a new configurable test data source+newTestData ::+    -- | a new configurable test data source+    IO TestData newTestData =     TestData <$> newMVar (TestData' mempty mempty 0 mempty)  addDataSourceListener :: TestData' -> TestDataListener -> (TestData', Int) addDataSourceListener td listener =-    ( td{ nextDataSourceListenerId = nextDataSourceListenerId td + 1+    ( td+        { nextDataSourceListenerId = nextDataSourceListenerId td + 1         , dataSourceListeners = IntMap.insert (nextDataSourceListenerId td) listener (dataSourceListeners td)         }     , nextDataSourceListenerId td@@ -125,59 +136,71 @@  removeDataSourceListener :: TestData' -> Int -> TestData' removeDataSourceListener td listenerId =-    td{ dataSourceListeners =+    td+        { dataSourceListeners =             IntMap.delete listenerId (dataSourceListeners td)-      }+        }  -- | --  Creates or copies a 'FlagBuilder' for building a test flag configuration. -----  If this flag key has already been defined in this 'TestData' instance, then the builder---  starts with the same configuration that was last provided for this flag.+--  If this flag key has already been defined in this 'TestData' instance, then+--  the builder starts with the same configuration that was last provided for+--  this flag. -----  Otherwise, it starts with a new default configuration in which the flag has @True@ and---  @False@ variations, is @True@ for all users when targeting is turned on and---  @False@ otherwise, and currently has targeting turned on. You can change any of those---  properties, and provide more complex behavior, using the 'FlagBuilder' methods.+--  Otherwise, it starts with a new default configuration in which the flag has+--  @True@ and @False@ variations, is @True@ for all users when targeting is+--  turned on and @False@ otherwise, and currently has targeting turned on. You+--  can change any of those properties, and provide more complex behavior,+--  using the 'FlagBuilder' methods. -- --  Once you have set the desired configuration, pass the builder to 'update'. -- --  see 'update'-flag :: TestData-     -> Text  -- ^ the flag key-     -> IO FlagBuilder -- ^ a flag configuration builder+flag ::+    TestData ->+    -- | the flag key+    Text ->+    -- | a flag configuration builder+    IO FlagBuilder flag (TestData ref) key = do     td <- readMVar ref-    pure $ Maybe.fromMaybe (booleanFlag $ newFlagBuilder key)-         $ Map.lookup key (flagBuilders td)+    pure $+        Maybe.fromMaybe (booleanFlag $ newFlagBuilder key) $+            Map.lookup key (flagBuilders td)  -- | --  Updates the test data with the specified flag configuration. -----  This has the same effect as if a flag were added or modified on the LaunchDarkly dashboard.---  It immediately propagates the flag change to any 'LaunchDarkly.Server.Client.Client' instance(s) that you have---  already configured to use this 'TestData'. If no @Client@ has been started yet,---  it simply adds this flag to the test data which will be provided to any @Client@ that---  you subsequently configure.+--  This has the same effect as if a flag were added or modified on the+--  LaunchDarkly dashboard. It immediately propagates the flag change to any+--  'LaunchDarkly.Server.Client.Client' instance(s) that you have already+--  configured to use this 'TestData'. If no @Client@ has been started yet, it+--  simply adds this flag to the test data which will be provided to any+--  @Client@ that you subsequently configure. -----  Any subsequent changes to this 'FlagBuilder' instance do not affect the test data,---  unless you call 'update'+--  Any subsequent changes to this 'FlagBuilder' instance do not affect the+--  test data, unless you call 'update' -- --  see 'flag'-update :: TestData-       -> FlagBuilder -- ^ a flag configuration builder-       -> IO ()+update ::+    TestData ->+    -- | a flag configuration builder+    FlagBuilder ->+    IO () update (TestData ref) fb =     modifyMVar_ ref $ \td -> do         let key = fbKey fb             mOldFlag = lookupKey key (currentFlags td)             oldFlagVersion = maybe 0 (getField @"version") mOldFlag             newFlag = buildFlag (oldFlagVersion + 1) fb-            td' = td{ flagBuilders = Map.insert key fb (flagBuilders td)+            td' =+                td+                    { flagBuilders = Map.insert key fb (flagBuilders td)                     , currentFlags = insertKey key newFlag (currentFlags td)                     }         notifyListeners td newFlag         pure td'- where-     notifyListeners td newFlag =+  where+    notifyListeners td newFlag =         traverse_ ($ newFlag) (dataSourceListeners td)
src/LaunchDarkly/Server/Integrations/TestData/FlagBuilder.hs view
@@ -1,39 +1,48 @@+{-# LANGUAGE NamedFieldPuns #-}+ module LaunchDarkly.Server.Integrations.TestData.FlagBuilder-    ( FlagBuilder(..)-    , UserKey+    ( FlagBuilder (..)     , VariationIndex     , newFlagBuilder     , booleanFlag     , on     , fallthroughVariation     , offVariation+    , variationForAll     , variationForAllUsers+    , valueForAll     , valueForAllUsers+    , variationForKey     , variationForUser     , variations     , buildFlag-    , UserAttribute     , ifMatch+    , ifMatchContext     , ifNotMatch+    , ifNotMatchContext     , FlagRuleBuilder     , andMatch+    , andMatchContext     , andNotMatch+    , andNotMatchContext     , thenReturn     , Variation     )-    where+where  import qualified Data.Aeson as Aeson-import           Data.Map.Strict (Map)+import Data.Function ((&))+import Data.HashSet (HashSet)+import qualified Data.HashSet as HS+import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import           Data.Text (Text)+import Data.Text (Text) import qualified Data.Text as T-import           GHC.Natural (Natural)+import GHC.Natural (Natural) import qualified LaunchDarkly.Server.Features as F import qualified LaunchDarkly.Server.Operators as Op-import           Data.Function ((&))+import LaunchDarkly.Server.Reference (makeReference) -type UserKey = Text type VariationIndex = Integer  trueVariationForBoolean, falseVariationForBoolean :: VariationIndex@@ -45,8 +54,9 @@ variationForBoolean False = falseVariationForBoolean  -- |--- A builder for feature flag configurations to be used with "LaunchDarkly.Server.Integrations.TestData".--- +-- A builder for feature flag configurations to be used with+-- "LaunchDarkly.Server.Integrations.TestData".+-- -- see 'LaunchDarkly.Server.Integrations.TestData.flag' and -- 'LaunchDarkly.Server.Integrations.TestData.update' data FlagBuilder = FlagBuilder@@ -55,19 +65,32 @@     , fbOn :: Bool     , fbFallthroughVariation :: Maybe VariationIndex     , fbVariations :: [Aeson.Value]-    , fbTargetMap :: Map UserKey VariationIndex+    , fbTargetMap :: Map Text (Map VariationIndex (HashSet Text))     , fbRules :: [FlagRule]-    } deriving (Show)+    }+    deriving (Show) -fbTargets :: FlagBuilder -> [F.Target]-fbTargets flagBuilder =-    Map.elems $-    Map.mapWithKey (flip F.Target) $-    Map.foldrWithKey go mempty (fbTargetMap flagBuilder)+fbTargets :: FlagBuilder -> ([F.Target], [F.Target])+fbTargets FlagBuilder {fbTargetMap = targetMap} =+    Map.foldlWithKey splitIntoTargets ([], []) targetMap   where-    go userKey variation =-        Map.insertWith (<>) variation [userKey]+    splitIntoTargets :: ([F.Target], [F.Target]) -> Text -> Map VariationIndex (HashSet Text) -> ([F.Target], [F.Target])+    splitIntoTargets acc "user" keyMap = Map.foldlWithKey foldForUserKind acc keyMap+    splitIntoTargets acc kind keyMap = Map.foldlWithKey (foldForOtherKind kind) acc keyMap +    -- When processing user kinds, we need to add a full target to the user targets, and a placeholder without the values in the context targets list+    foldForUserKind :: ([F.Target], [F.Target]) -> VariationIndex -> HashSet Text -> ([F.Target], [F.Target])+    foldForUserKind (userTargets, allTargets) variation values =+        ( F.Target {values, variation, contextKind = "user"} : userTargets+        , F.Target {values = mempty, variation, contextKind = "user"} : allTargets+        )++    foldForOtherKind :: Text -> ([F.Target], [F.Target]) -> VariationIndex -> HashSet Text -> ([F.Target], [F.Target])+    foldForOtherKind kind (userTargets, allTargets) variation values =+        ( userTargets+        , F.Target {values = values, variation, contextKind = kind} : allTargets+        )+ buildFlag :: Natural -> FlagBuilder -> F.Flag buildFlag version flagBuilder =     F.Flag@@ -79,7 +102,8 @@         , F.deleted = False         , F.prerequisites = []         , F.salt = "salt"-        , F.targets = fbTargets flagBuilder+        , F.targets = userTargets+        , F.contextTargets = allTargets         , F.rules = mapWithIndex convertFlagRule (fbRules flagBuilder)         , F.fallthrough = F.VariationOrRollout (fbFallthroughVariation flagBuilder) Nothing         , F.offVariation = fbOffVariation flagBuilder@@ -87,10 +111,12 @@         , F.debugEventsUntilDate = Nothing         , F.clientSideAvailability = F.ClientSideAvailability False False False         }+  where+    (userTargets, allTargets) = fbTargets flagBuilder  mapWithIndex :: Integral num => (num -> a -> b) -> [a] -> [b] mapWithIndex f l =-    fmap (uncurry f) (zip [0..] l)+    fmap (uncurry f) (zip [0 ..] l)  newFlagBuilder :: Text -> FlagBuilder newFlagBuilder key =@@ -109,15 +135,16 @@  isBooleanFlag :: FlagBuilder -> Bool isBooleanFlag flagBuilder-  | booleanFlagVariations == fbVariations flagBuilder = True-  | otherwise = False+    | booleanFlagVariations == fbVariations flagBuilder = True+    | otherwise = False --- | +-- | -- A shortcut for setting the flag to use the standard boolean configuration. ----- This is the default for all new flags created with 'LaunchDarkly.Server.Integrations.TestData.flag'. The flag--- will have two variations, @True@ and @False@ (in that order); it will return--- @False@ whenever targeting is off, and @True@ when targeting is on if no other+-- This is the default for all new flags created with+-- 'LaunchDarkly.Server.Integrations.TestData.flag'. The flag will have two+-- variations, @True@ and @False@ (in that order); it will return @False@+-- whenever targeting is off, and @True@ when targeting is on if no other -- settings specify otherwise. booleanFlag :: FlagBuilder -> FlagBuilder booleanFlag flagBuilder@@ -128,205 +155,371 @@             & variations booleanFlagVariations             & fallthroughVariation trueVariationForBoolean             & offVariation falseVariationForBoolean+ -- | -- Sets targeting to be on or off for this flag. ----- The effect of this depends on the rest of the flag configuration, just as it does on the--- real LaunchDarkly dashboard. In the default configuration that you get from calling--- 'LaunchDarkly.Server.Integrations.TestData.flag' with a new flag key, the flag will return @False@ --- whenever targeting is off, and @True@ when targeting is on.-on :: Bool -- ^ isOn @True@ if targeting should be on-   -> FlagBuilder -   -> FlagBuilder+-- The effect of this depends on the rest of the flag configuration, just as it+-- does on the real LaunchDarkly dashboard. In the default configuration that+-- you get from calling 'LaunchDarkly.Server.Integrations.TestData.flag' with a+-- new flag key, the flag will return @False@ whenever targeting is off, and+-- @True@ when targeting is on.+on ::+    -- | isOn @True@ if targeting should be on+    Bool ->+    FlagBuilder ->+    FlagBuilder on isOn fb =-    fb{ fbOn = isOn }+    fb {fbOn = isOn}  -- |--- Removes any existing rules from the flag. +-- Removes any existing rules from the flag. -- This undoes the effect of methods like 'ifMatch' or 'ifNotMatch' clearRules :: FlagBuilder -> FlagBuilder clearRules fb =-    fb{ fbRules = mempty }+    fb {fbRules = mempty}  -- |--- Removes any existing user targets from the flag. --- This undoes the effect of methods like 'variationForUser'-clearUserTargets :: FlagBuilder -> FlagBuilder-clearUserTargets fb =-    fb{ fbTargetMap = mempty }+-- Removes any existing targets from the flag.+-- This undoes the effect of methods like 'variationForKey'+clearTargets :: FlagBuilder -> FlagBuilder+clearTargets fb =+    fb {fbTargetMap = mempty}  -- |+-- Sets the flag to always return the specified variation value for all+-- contexts.+--+-- The value may be of any type that implements 'Aeson.ToJSON'. This method+-- changes the flag to have only a single variation, which is this value, and+-- to return the same variation regardless of whether targeting is on or off.+-- Any existing targets or rules are removed.+valueForAll ::+    Aeson.ToJSON value =>+    value -> -- the desired value to be returned for all contexts+    FlagBuilder ->+    FlagBuilder+valueForAll val fb =+    fb+        & variations [Aeson.toJSON val]+        & variationForAll (0 :: VariationIndex)++{-# DEPRECATED valueForAllUsers "Use valueForAll instead" #-}++-- | -- Sets the flag to always return the specified variation value for all users. ----- The value may be of any type that implements 'Aeson.ToJSON'. This method changes the--- flag to have only a single variation, which is this value, and to return the same--- variation regardless of whether targeting is on or off. Any existing targets or rules--- are removed.-valueForAllUsers :: Aeson.ToJSON value-                 => value -- the desired value to be returned for all users-                 -> FlagBuilder -                 -> FlagBuilder-valueForAllUsers val fb =-    fb & variations [Aeson.toJSON val]-       & variationForAllUsers (0 :: VariationIndex)+-- This function is an alias to 'valueForAll'.+--+-- The value may be of any type that implements 'Aeson.ToJSON'. This method+-- changes the flag to have only a single variation, which is this value, and+-- to return the same variation regardless of whether targeting is on or off.+-- Any existing targets or rules are removed.+valueForAllUsers ::+    Aeson.ToJSON value =>+    value -> -- the desired value to be returned for all users+    FlagBuilder ->+    FlagBuilder+valueForAllUsers = valueForAll  -- | -- Changes the allowable variation values for the flag. ----- The value may be of any JSON type, as defined by 'Aeson.Value'. For instance, a boolean flag--- normally has [toJSON True, toJSON False]; a string-valued flag might have--- [toJSON "red", toJSON "green"]; etc.-variations :: [Aeson.Value] -- ^ the desired variations-           -> FlagBuilder -           -> FlagBuilder+-- The value may be of any JSON type, as defined by 'Aeson.Value'. For+-- instance, a boolean flag normally has [toJSON True, toJSON False]; a+-- string-valued flag might have [toJSON "red", toJSON "green"]; etc.+variations ::+    -- | the desired variations+    [Aeson.Value] ->+    FlagBuilder ->+    FlagBuilder variations values fb =-    fb{ fbVariations = values }+    fb {fbVariations = values}  -- Should this actually use overloaded function names? class Variation val where     -- |-    -- Specifies the fallthrough variation. The fallthrough is the value-    -- that is returned if targeting is on and the user was not matched by a more specific-    -- target or rule.+    -- Specifies the fallthrough variation. The fallthrough is the value that+    -- is returned if targeting is on and the context was not matched by a more+    -- specific target or rule.     ---    -- If the flag was previously configured with other variations and the variation specified is a boolean,-    -- this also changes it to a boolean flag.-    fallthroughVariation :: val -- ^ @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.-                         -> FlagBuilder -                         -> FlagBuilder+    -- If the flag was previously configured with other variations and the+    -- variation specified is a boolean, this also changes it to a boolean+    -- flag.+    fallthroughVariation ::+        -- | @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.+        val ->+        FlagBuilder ->+        FlagBuilder -    -- | -    -- Specifies the off variation for a flag. This is the variation that is returned-    -- whenever targeting is off.+    -- |+    -- Specifies the off variation for a flag. This is the variation that is+    -- returned whenever targeting is off.     ---    -- If the flag was previously configured with other variations and the variation specified is a boolean,-    -- this also changes it to a boolean flag.-    offVariation :: val -- ^ @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.-                 -> FlagBuilder -                 -> FlagBuilder+    -- If the flag was previously configured with other variations and the+    -- variation specified is a boolean, this also changes it to a boolean+    -- flag.+    offVariation ::+        -- | @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.+        val ->+        FlagBuilder ->+        FlagBuilder      -- |+    -- Sets the flag to always return the specified variation for all contexts.+    --+    -- The variation is specified, Targeting is switched on, and any existing+    -- targets or rules are removed. The fallthrough variation is set to the+    -- specified value. The off variation is left unchanged.+    --+    -- If the flag was previously configured with other variations and the+    -- variation specified is a boolean, this also changes it to a boolean+    -- flag.+    variationForAll ::+        -- | @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.+        val ->+        FlagBuilder ->+        FlagBuilder++    -- |     -- Sets the flag to always return the specified variation for all users.     ---    -- The variation is specified, Targeting is switched on, and any existing targets or rules are removed.-    -- The fallthrough variation is set to the specified value. The off variation is left unchanged.+    -- The variation is specified, Targeting is switched on, and any existing+    -- targets or rules are removed. The fallthrough variation is set to the+    -- specified value. The off variation is left unchanged.     ---    -- If the flag was previously configured with other variations and the variation specified is a boolean,-    -- this also changes it to a boolean flag.-    variationForAllUsers :: val -- ^ @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.-                         -> FlagBuilder -                         -> FlagBuilder+    -- If the flag was previously configured with other variations and the+    -- variation specified is a boolean, this also changes it to a boolean+    -- flag.+    variationForAllUsers ::+        -- | @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.+        val ->+        FlagBuilder ->+        FlagBuilder      -- |-    -- Sets the flag to return the specified variation for a specific user key when targeting-    -- is on.+    -- Sets the flag to return the specified variation for a specific context+    -- kind and key when targeting is on.     --     -- This has no effect when targeting is turned off for the flag.     ---    -- If the flag was previously configured with other variations and the variation specified is a boolean,-    -- this also changes it to a boolean flag.-    variationForUser :: UserKey -- ^ a user key to target-                     -> val -- ^ @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.-                     -> FlagBuilder -                     -> FlagBuilder-    +    -- If the flag was previously configured with other variations and the+    -- variation specified is a boolean, this also changes it to a boolean+    -- flag.+    variationForKey ::+        -- | The context kind to match against+        Text ->+        -- | a key to target+        Text ->+        -- | @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.+        val ->+        FlagBuilder ->+        FlagBuilder+     -- |-    -- Finishes defining the rule, specifying the result as either a boolean-    -- or a variation index.-    -- -    -- If the flag was previously configured with other variations and the variation specified is a boolean,-    -- this also changes it to a boolean flag.-    thenReturn :: val -- ^ @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.-               -> FlagRuleBuilder -               -> FlagBuilder+    -- Sets the flag to return the specified variation for a specific user key+    -- when targeting is on.+    --+    -- This has no effect when targeting is turned off for the flag.+    --+    -- If the flag was previously configured with other variations and the+    -- variation specified is a boolean, this also changes it to a boolean+    -- flag.+    variationForUser ::+        -- | a user key to target+        Text ->+        -- | @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.+        val ->+        FlagBuilder ->+        FlagBuilder +    -- |+    -- Finishes defining the rule, specifying the result as either a boolean or+    -- a variation index.+    --+    -- If the flag was previously configured with other variations and the+    -- variation specified is a boolean, this also changes it to a boolean+    -- flag.+    thenReturn ::+        -- | @True@ or @False@ or the desired fallthrough variation index: 0 for the first, 1 for the second, etc.+        val ->+        FlagRuleBuilder ->+        FlagBuilder+ instance Variation Integer where     fallthroughVariation variationIndex fb =-        fb{ fbFallthroughVariation = Just variationIndex }+        fb {fbFallthroughVariation = Just variationIndex}      offVariation variationIndex fb =-        fb{ fbOffVariation = Just variationIndex }+        fb {fbOffVariation = Just variationIndex} -    variationForAllUsers variationIndex fb =-        fb & on True-           & clearRules-           & clearUserTargets-           & fallthroughVariation variationIndex+    variationForAll variationIndex fb =+        fb+            & on True+            & clearRules+            & clearTargets+            & fallthroughVariation variationIndex -    variationForUser userKey variationIndex fb =-        fb{ fbTargetMap = Map.insert userKey variationIndex (fbTargetMap fb) }+    variationForAllUsers = variationForAll +    variationForKey kind key variationIndex fb@(FlagBuilder {fbTargetMap = targetMap}) =+        case Map.lookup kind targetMap of+            Nothing -> fb {fbTargetMap = Map.insert kind (Map.singleton variationIndex $ HS.singleton key) targetMap}+            Just m ->+                case Map.lookup variationIndex m of+                    Nothing -> fb {fbTargetMap = Map.insert kind (Map.insert variationIndex (HS.singleton key) m) targetMap}+                    Just keys -> fb {fbTargetMap = Map.insert kind (Map.insert variationIndex (HS.insert key keys) m) targetMap}++    variationForUser = variationForKey "user"+     thenReturn variationIndex ruleBuilder =         let fb = frbBaseBuilder ruleBuilder-        in fb{ fbRules = FlagRule (frbClauses ruleBuilder) variationIndex : fbRules fb }+         in fb {fbRules = FlagRule (frbClauses ruleBuilder) variationIndex : fbRules fb}  instance Variation Bool where     fallthroughVariation value fb =-        fb & booleanFlag-           & fallthroughVariation (variationForBoolean value)+        fb+            & booleanFlag+            & fallthroughVariation (variationForBoolean value)     offVariation value fb =-        fb & booleanFlag-           & offVariation (variationForBoolean value)-    variationForAllUsers value fb =-        fb & booleanFlag-           & variationForAllUsers (variationForBoolean value)+        fb+            & booleanFlag+            & offVariation (variationForBoolean value)+    variationForAll value fb =+        fb+            & booleanFlag+            & variationForAll (variationForBoolean value)+    variationForAllUsers = variationForAll+    variationForKey kind key value fb =+        fb+            & booleanFlag+            & variationForKey kind key (variationForBoolean value)     variationForUser userKey value fb =-        fb & booleanFlag-           & variationForUser userKey (variationForBoolean value)+        fb+            & booleanFlag+            & variationForUser userKey (variationForBoolean value)     thenReturn value ruleBuilder =-        ruleBuilder { frbBaseBuilder = booleanFlag $ frbBaseBuilder ruleBuilder }+        ruleBuilder {frbBaseBuilder = booleanFlag $ frbBaseBuilder ruleBuilder}             & thenReturn (variationForBoolean value) -type UserAttribute = Text+-- |+-- Starts defining a flag rule, using the "is one of" operator.+--+-- For example, this creates a rule that returns @True@ if the name is+-- \"Patsy\" or \"Edina\":+--+-- @+-- testData+--     & flag "flag"+--     & ifMatchContext "user" "name" [toJSON \"Patsy\", toJSON \"Edina\"]+--     & thenReturn True+-- @+ifMatchContext ::+    -- | the context kind to match again+    Text ->+    -- | the context attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagBuilder ->+    -- | call 'thenReturn' to finish the rule, or add more tests with 'andMatch' or 'andNotMatch'+    FlagRuleBuilder+ifMatchContext kind attribute values fb =+    newFlagRuleBuilder fb+        & andMatchContext kind attribute values +{-# DEPRECATED ifMatch "Use ifMatchContext instead" #-}+ -- | -- Starts defining a flag rule, using the "is one of" operator. ----- For example, this creates a rule that returns @True@ if the name is \"Patsy\" or \"Edina\":--- +-- This is a shortcut for calling 'ifMatch' with a context kind of "user".+--+-- For example, this creates a rule that returns @True@ if the name is+-- \"Patsy\" or \"Edina\":+-- -- @ -- testData --     & flag "flag" --     & ifMatch "name" [toJSON \"Patsy\", toJSON \"Edina\"] --     & thenReturn True -- @-ifMatch :: UserAttribute -- ^ attribute the user attribute to match against-        -> [Aeson.Value] -- ^ values to compare to-        -> FlagBuilder -        -> FlagRuleBuilder -- ^ call 'thenReturn' to finish the rule, or add more tests with 'andMatch' or 'andNotMatch' -ifMatch userAttribute values fb =+ifMatch ::+    -- | the context attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagBuilder ->+    -- | call 'thenReturn' to finish the rule, or add more tests with 'andMatch' or 'andNotMatch'+    FlagRuleBuilder+ifMatch = ifMatchContext "user"++-- |+-- Starts defining a flag rule, using the "is not one of" operator.+--+-- For example, this creates a rule that returns @True@ if the name is neither+-- \"Saffron\" nor \"Bubble\"+--+-- @+-- testData+--     & flag "flag"+--     & ifNotMatchContext "user" "name" [toJSON \"Saffron\", toJSON \"Bubble\"]+--     & thenReturn True+-- @+ifNotMatchContext ::+    -- | context kind to match again+    Text ->+    -- | attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagBuilder ->+    -- | call 'thenReturn' to finish the rule, or add more tests with 'andMatch' or 'andNotMatch'+    FlagRuleBuilder+ifNotMatchContext kind attibute values fb =     newFlagRuleBuilder fb-     & andMatch userAttribute values+        & andNotMatchContext kind attibute values +{-# DEPRECATED ifNotMatch "Use ifNotMatchContext instead" #-}+ -- | -- Starts defining a flag rule, using the "is not one of" operator. ----- For example, this creates a rule that returns @True@ if the name is neither \"Saffron\" nor \"Bubble\"--- +-- This is a shortcut for calling 'ifNotMatchContext' with a context kind of+-- "user".+--+-- For example, this creates a rule that returns @True@ if the name is neither+-- \"Saffron\" nor \"Bubble\"+-- -- @ -- testData --     & flag "flag" --     & ifNotMatch "name" [toJSON \"Saffron\", toJSON \"Bubble\"] --     & thenReturn True -- @-ifNotMatch :: UserAttribute -- ^ attribute the user attribute to match against-           -> [Aeson.Value] -- ^ values to compare to-           -> FlagBuilder -           -> FlagRuleBuilder -- ^ call 'thenReturn' to finish the rule, or add more tests with 'andMatch' or 'andNotMatch' -ifNotMatch userAttribute values fb =-    newFlagRuleBuilder fb-     & andNotMatch userAttribute values+ifNotMatch ::+    -- | attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagBuilder ->+    -- | call 'thenReturn' to finish the rule, or add more tests with 'andMatch' or 'andNotMatch'+    FlagRuleBuilder+ifNotMatch = ifNotMatchContext "user"  data Clause = Clause-    { clauseAttribute :: UserAttribute-    , clauseValues    :: [Aeson.Value]-    , clauseNegate    :: Bool-    } deriving (Show)+    { clauseAttribute :: Text+    , contextKind :: Text+    , clauseValues :: [Aeson.Value]+    , clauseNegate :: Bool+    }+    deriving (Show)  data FlagRule = FlagRule     { frClauses :: [Clause]     , frVariation :: VariationIndex-    } deriving (Show)+    }+    deriving (Show)  convertFlagRule :: Integer -> FlagRule -> F.Rule convertFlagRule idx flagRule =@@ -340,26 +533,33 @@ convertClause :: Clause -> F.Clause convertClause clause =     F.Clause-        { F.attribute = clauseAttribute clause+        { F.attribute = makeReference $ clauseAttribute clause+        , F.contextKind = contextKind clause         , F.negate = clauseNegate clause         , F.values = clauseValues clause         , F.op = Op.OpIn         }+ -- | -- A builder for feature flag rules to be used with 'FlagBuilder'. ----- In the LaunchDarkly model, a flag can have any number of rules, and a rule can have any number of--- clauses. A clause is an individual test such as \"name is \'X\'\". A rule matches a user if all of the--- rule's clauses match the user.+-- In the LaunchDarkly model, a flag can have any number of rules, and a rule+-- can have any number of clauses. A clause is an individual test such as+-- \"name is \'X\'\". A rule matches a context if all of the rule's clauses+-- match the context. ----- To start defining a rule, use one of the matching functions such as 'ifMatch' or 'ifNotMatch'. --- This defines the first clause for the rule.--- Optionally, you may add more clauses with the rule builder functions such as 'andMatch' and 'andNotMatch'. +-- To start defining a rule, use one of the matching functions such as+-- 'ifMatch' or 'ifNotMatch'. This defines the first clause for the rule.+--+-- Optionally, you may add more clauses with the rule builder functions such as+-- 'andMatch' and 'andNotMatch'.+-- -- Finally, call 'thenReturn' to finish defining the rule. data FlagRuleBuilder = FlagRuleBuilder     { frbClauses :: [Clause]     , frbBaseBuilder :: FlagBuilder-    } deriving (Show)+    }+    deriving (Show)  newFlagRuleBuilder :: FlagBuilder -> FlagRuleBuilder newFlagRuleBuilder baseBuilder =@@ -367,42 +567,110 @@         { frbClauses = mempty         , frbBaseBuilder = baseBuilder         }+ -- | -- Adds another clause, using the "is one of" operator. ----- For example, this creates a rule that returns @True@ if the name is \"Patsy\" and the--- country is \"gb\":--- +-- For example, this creates a rule that returns @True@ if the name is+-- \"Patsy\" and the country is \"gb\":+-- -- @--- testData +-- testData --     & flag "flag" --     & ifMatch "name" [toJSON \"Patsy\"] --     & andMatch "country" [toJSON \"gb\"] --     & thenReturn True--- @ -andMatch :: UserAttribute -- ^ the user attribute to match against-         -> [Aeson.Value] -- ^ values to compare to-         -> FlagRuleBuilder -         -> FlagRuleBuilder-andMatch userAttribute values ruleBuilder =-    ruleBuilder{ frbClauses = Clause userAttribute values False : frbClauses ruleBuilder }+-- @+andMatchContext ::+    -- | the context kind to match again+    Text ->+    -- | the context attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagRuleBuilder ->+    FlagRuleBuilder+andMatchContext kind attribute values ruleBuilder =+    ruleBuilder {frbClauses = Clause attribute kind values False : frbClauses ruleBuilder} +{-# DEPRECATED andMatch "Use andMatchContext instead" #-}+ -- |+-- Adds another clause, using the "is one of" operator.+--+-- This is a shortcut for calling 'andMatchContext' with a context kind of+-- "user".+--+-- For example, this creates a rule that returns @True@ if the name is+-- \"Patsy\" and the country is \"gb\":+--+-- @+-- testData+--     & flag "flag"+--     & ifMatch "name" [toJSON \"Patsy\"]+--     & andMatch "country" [toJSON \"gb\"]+--     & thenReturn True+-- @+andMatch ::+    -- | the context attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagRuleBuilder ->+    FlagRuleBuilder+andMatch = andMatchContext "user"++-- | -- Adds another clause, using the "is not one of" operator. ----- For example, this creates a rule that returns @True@ if the name is \"Patsy\" and the--- country is not \"gb\":--- +-- For example, this creates a rule that returns @True@ if the name is+-- \"Patsy\" and the country is not \"gb\":+-- -- @--- testData +-- testData --     & flag "flag"+--     & ifMatchContext "user" "name" [toJSON \"Patsy\"]+--     & andNotMatchContext "user" "country" [toJSON \"gb\"]+--     & thenReturn True+-- @+andNotMatchContext ::+    -- | the context kind to match against+    Text ->+    -- | the context attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagRuleBuilder ->+    FlagRuleBuilder+andNotMatchContext kind attribute values ruleBuilder =+    ruleBuilder {frbClauses = Clause attribute kind values True : frbClauses ruleBuilder}++{-# DEPRECATED andNotMatch "Use andNotMatchContext instead" #-}++-- |+-- Adds another clause, using the "is not one of" operator.+--+-- This is a shortcut for calling 'andNotMatchContext' with a context kind of+-- "user".+--+-- For example, this creates a rule that returns @True@ if the name is+-- \"Patsy\" and the country is not \"gb\":+--+-- @+-- testData+--     & flag "flag" --     & ifMatch "name" [toJSON \"Patsy\"] --     & andNotMatch "country" [toJSON \"gb\"] --     & thenReturn True--- @ -andNotMatch :: UserAttribute -- ^ the user attribute to match against-            -> [Aeson.Value] -- ^ values to compare to-            -> FlagRuleBuilder -            -> FlagRuleBuilder-andNotMatch userAttribute values ruleBuilder =-    ruleBuilder{ frbClauses = Clause userAttribute values True : frbClauses ruleBuilder }+-- @+andNotMatch ::+    -- | the context attribute to match against+    Text ->+    -- | values to compare to+    [Aeson.Value] ->+    FlagRuleBuilder ->+    FlagRuleBuilder+andNotMatch = andNotMatchContext "user"++{-# DEPRECATED variationForAllUsers "Use variationForAll instead" #-}+{-# DEPRECATED variationForUser "Use variationForKey instead" #-}
src/LaunchDarkly/Server/Network/Common.hs view
@@ -2,6 +2,7 @@     ( withResponseGeneric     , tryAuthorized     , checkAuthorization+    , throwIfNot200     , getServerTime     , tryHTTP     , addToAL@@ -9,20 +10,21 @@     , isHttpUnrecoverable     ) where -import Data.ByteString.Internal            (unpackChars)-import Network.HTTP.Client                 (HttpException, Manager, Request(..), Response(..), BodyReader, responseOpen, responseClose)-import Network.HTTP.Types.Header           (hDate)-import Network.HTTP.Types.Status           (unauthorized401, forbidden403)-import Data.Time.Format                    (parseTimeM, defaultTimeLocale, rfc822DateFormat)-import Data.Time.Clock.POSIX               (utcTimeToPOSIXSeconds)-import Data.Maybe                          (fromMaybe)-import Control.Monad                       (when)-import Control.Monad.Catch                 (Exception, MonadCatch, MonadMask, MonadThrow, try, bracket, throwM, handle)-import Control.Monad.Logger                (MonadLogger, logError)-import Control.Monad.IO.Class              (MonadIO, liftIO)+import Control.Monad (when)+import Control.Monad.Catch (Exception, MonadCatch, MonadMask, MonadThrow, bracket, handle, throwM, try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logError)+import Data.ByteString.Internal (unpackChars)+import Data.Maybe (fromMaybe)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Time.Format (defaultTimeLocale, parseTimeM, rfc822DateFormat)+import Network.HTTP.Client (BodyReader, HttpException, Manager, Request (..), Response (..), responseClose, responseOpen, throwErrorStatusCodes)+import Network.HTTP.Types.Header (hDate)+import Network.HTTP.Types.Status (forbidden403, unauthorized401) -import LaunchDarkly.Server.Client.Internal     (ClientI, Status(Unauthorized), setStatus)-import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..))+import LaunchDarkly.Server.Client.Internal (Client, Status (Unauthorized), setStatus)+import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates (..))+import Network.HTTP.Types (ok200)  tryHTTP :: MonadCatch m => m a -> m (Either HttpException a) tryHTTP = try@@ -40,23 +42,28 @@     $(logError) "SDK key is unauthorized"     liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Unauthorized -tryAuthorized :: (MonadIO m, MonadLogger m, MonadCatch m) => ClientI -> m a -> m ()-tryAuthorized client operation = try operation >>= \case-    (Left UnauthorizedE) -> do-        $(logError) "SDK key is unauthorized"-        liftIO $ setStatus client Unauthorized-    _                    -> pure ()+tryAuthorized :: (MonadIO m, MonadLogger m, MonadCatch m) => Client -> m a -> m ()+tryAuthorized client operation =+    try operation >>= \case+        (Left UnauthorizedE) -> do+            $(logError) "SDK key is unauthorized"+            liftIO $ setStatus client Unauthorized+        _ -> pure ()  checkAuthorization :: (MonadThrow m) => Response body -> m () checkAuthorization response = when (elem (responseStatus response) [unauthorized401, forbidden403]) $ throwM UnauthorizedE +throwIfNot200 :: (MonadIO m) => Request -> Response BodyReader -> m ()+throwIfNot200 request response = when (responseStatus response /= ok200) $ throwErrorStatusCodes request response+ getServerTime :: Response body -> Integer getServerTime response     | date == "" = 0     | otherwise = fromMaybe 0 (truncate <$> utcTimeToPOSIXSeconds <$> parsedTime)-    where headers = responseHeaders response-          date = fromMaybe "" $ lookup hDate headers-          parsedTime = parseTimeM True defaultTimeLocale rfc822DateFormat (unpackChars date)+  where+    headers = responseHeaders response+    date = fromMaybe "" $ lookup hDate headers+    parsedTime = parseTimeM True defaultTimeLocale rfc822DateFormat (unpackChars date)  isHttpUnrecoverable :: Int -> Bool isHttpUnrecoverable status
src/LaunchDarkly/Server/Network/Eventing.hs view
@@ -1,58 +1,63 @@ module LaunchDarkly.Server.Network.Eventing (eventThread) where -import           Data.Aeson                          (encode)-import           Data.Function                       ((&))-import           Data.Tuple                          (swap)-import           Data.IORef                          (newIORef, readIORef, atomicModifyIORef')-import qualified Data.UUID as                        UUID-import           Control.Monad.Logger                (MonadLogger, logDebug, logWarn, logError)-import           Control.Monad.IO.Class              (MonadIO, liftIO)-import           Network.HTTP.Client                 (Manager, Request(..), RequestBody(..), httpLbs, responseStatus)-import           Data.Generics.Product               (getField)-import qualified Data.Text as                        T-import           Control.Concurrent                  (killThread, myThreadId)-import           Control.Monad                       (forever, when, void, unless)-import           Control.Monad.Catch                 (MonadMask, MonadThrow)-import           Control.Concurrent.MVar             (takeMVar, readMVar, swapMVar, modifyMVar_)-import           System.Timeout                      (timeout)-import           System.Random                       (newStdGen, random)-import           Data.Text.Encoding                  (decodeUtf8)-import qualified Data.ByteString.Lazy as             L-import           Network.HTTP.Types.Status           (status400, status408, status429, status500)+import Control.Concurrent (killThread, myThreadId)+import Control.Concurrent.MVar (modifyMVar_, readMVar, swapMVar, takeMVar)+import Control.Monad (forever, unless, void, when)+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logDebug, logError, logWarn)+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy as L+import Data.Function ((&))+import Data.Generics.Product (getField)+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Tuple (swap)+import qualified Data.UUID as UUID+import Network.HTTP.Client (Manager, Request (..), RequestBody (..), httpLbs, responseStatus)+import Network.HTTP.Types.Status (Status (statusCode), status400)+import System.Random (newStdGen, random)+import System.Timeout (timeout) -import           LaunchDarkly.Server.Client.Internal (ClientI, Status(ShuttingDown))-import           LaunchDarkly.Server.Network.Common  (tryAuthorized, checkAuthorization, getServerTime, tryHTTP, addToAL)-import           LaunchDarkly.Server.Events          (processSummary, EventState)+import LaunchDarkly.Server.Client.Internal (Client, Status (ShuttingDown)) import LaunchDarkly.Server.Config.ClientContext import LaunchDarkly.Server.Config.HttpConfiguration (prepareRequest)+import LaunchDarkly.Server.Events (EventState, processSummary)+import LaunchDarkly.Server.Network.Common (addToAL, checkAuthorization, getServerTime, isHttpUnrecoverable, tryAuthorized, tryHTTP)  -- A true result indicates a retry does not need to be attempted processSend :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> Request -> m (Bool, Integer)-processSend manager req = (liftIO $ tryHTTP $ httpLbs req manager) >>= \case-    (Left err)       -> $(logError) (T.pack $ show err) >> pure (False, 0)-    (Right response) -> do-        checkAuthorization response-        let code = responseStatus response-            serverTime = getServerTime response in-            $(logWarn) (T.append "@@@ server time from LD was determined to be: " $ T.pack $ show serverTime) >>-            if code < status400-               then pure (True, serverTime)-           else if (elem code [status400, status408, status429]) || code >= status500-           then pure (False, serverTime)-           else $(logWarn) (T.append "got non recoverable event post response dropping payload: " $ T.pack $ show code) >> pure (True, serverTime)+processSend manager req =+    (liftIO $ tryHTTP $ httpLbs req manager) >>= \case+        (Left err) -> $(logError) (T.pack $ show err) >> pure (False, 0)+        (Right response) -> do+            checkAuthorization response+            let code = responseStatus response+                serverTime = getServerTime response+             in $(logWarn) (T.append "@@@ server time from LD was determined to be: " $ T.pack $ show serverTime)+                    >> if code < status400+                        then pure (True, serverTime)+                        else+                            if isHttpUnrecoverable $ statusCode $ code+                                then $(logWarn) (T.append "got non recoverable event post response dropping payload: " $ T.pack $ show code) >> pure (True, serverTime)+                                else pure (False, serverTime)  setEventHeaders :: Request -> Request-setEventHeaders request = request-    { requestHeaders = (requestHeaders request)-        & \l -> addToAL l "Content-Type" "application/json"-        & \l -> addToAL l "X-LaunchDarkly-Event-Schema" "3"-    , method         = "POST"-    }+setEventHeaders request =+    request+        { requestHeaders =+            (requestHeaders request)+                & \l ->+                    addToAL l "Content-Type" "application/json"+                        & \l -> addToAL l "X-LaunchDarkly-Event-Schema" "4"+        , method = "POST"+        }  updateLastKnownServerTime :: EventState -> Integer -> IO () updateLastKnownServerTime state serverTime = modifyMVar_ (getField @"lastKnownServerTime" state) (\lastKnown -> pure $ max serverTime lastKnown) -eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> ClientContext -> m ()+eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> Client -> ClientContext -> m () eventThread manager client clientContext = do     let state = getField @"events" client; config = getField @"config" client; httpConfig = httpConfiguration clientContext     rngRef <- liftIO $ newStdGen >>= newIORef@@ -64,22 +69,24 @@             payloadId <- liftIO $ atomicModifyIORef' rngRef (swap . random)             let                 encoded = encode events'-                thisReq = req-                    { requestBody    = RequestBodyLBS encoded-                    , requestHeaders = (requestHeaders req)-                        & \l -> addToAL l "X-LaunchDarkly-Payload-ID" (UUID.toASCIIBytes payloadId)-                    }+                thisReq =+                    req+                        { requestBody = RequestBodyLBS encoded+                        , requestHeaders =+                            (requestHeaders req)+                                & \l -> addToAL l "X-LaunchDarkly-Payload-ID" (UUID.toASCIIBytes payloadId)+                        }             (success, serverTime) <- processSend manager thisReq             $(logDebug) $ T.append "sending events: " $ decodeUtf8 $ L.toStrict encoded             _ <- case success of-              True -> liftIO $ updateLastKnownServerTime state serverTime-              False -> do-                $(logWarn) "retrying event delivery after one second"-                liftIO $ void $ timeout (1 * 1000000) $ readMVar $ getField @"flush" state-                (success', serverTime') <- processSend manager thisReq-                unless success' $ do-                    $(logWarn) "failed sending events on retry, dropping event batch"-                liftIO $ updateLastKnownServerTime state serverTime'+                True -> liftIO $ updateLastKnownServerTime state serverTime+                False -> do+                    $(logWarn) "retrying event delivery after one second"+                    liftIO $ void $ timeout (1 * 1000000) $ readMVar $ getField @"flush" state+                    (success', serverTime') <- processSend manager thisReq+                    unless success' $ do+                        $(logWarn) "failed sending events on retry, dropping event batch"+                    liftIO $ updateLastKnownServerTime state serverTime'             $(logDebug) "finished send of event batch"         status <- liftIO $ readIORef $ getField @"status" client         liftIO $ when (status == ShuttingDown) (myThreadId >>= killThread)
src/LaunchDarkly/Server/Network/Polling.hs view
@@ -1,43 +1,43 @@ module LaunchDarkly.Server.Network.Polling (pollingThread) where -import           GHC.Generics                            (Generic)-import           Data.Text                               (Text)-import qualified Data.Text as                            T-import           Network.HTTP.Client                     (Manager, Request(..), Response(..), httpLbs)-import           Data.Generics.Product                   (getField)-import           Control.Concurrent                      (threadDelay)-import           Data.Aeson                              (eitherDecode, FromJSON(..))-import           Control.Monad.Logger                    (MonadLogger, logInfo, logError)-import           Control.Monad.IO.Class                  (MonadIO, liftIO)-import           Control.Monad.Catch                     (MonadMask, MonadThrow)-import           Network.HTTP.Types.Status               (ok200, Status (statusCode))--import           LaunchDarkly.Server.Network.Common      (checkAuthorization, tryHTTP, handleUnauthorized, isHttpUnrecoverable)-import           LaunchDarkly.Server.Features            (Flag, Segment)-import           LaunchDarkly.AesonCompat                (KeyMap)+import Control.Concurrent (threadDelay)+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logError, logInfo)+import Data.Aeson (FromJSON (..), eitherDecode)+import Data.Generics.Product (getField)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Network.HTTP.Client (Manager, Request (..), Response (..), httpLbs)+import Network.HTTP.Types.Status (Status (statusCode), ok200) +import LaunchDarkly.AesonCompat (KeyMap)+import LaunchDarkly.Server.Features (Flag, Segment)+import LaunchDarkly.Server.Network.Common (checkAuthorization, handleUnauthorized, isHttpUnrecoverable, tryHTTP) +import Data.ByteString.Lazy (ByteString) import GHC.Natural (Natural)-import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..))+import LaunchDarkly.Server.Client.Internal (Status (..)) import LaunchDarkly.Server.Config.ClientContext-import LaunchDarkly.Server.Client.Internal (Status(..))-import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..), prepareRequest)-import Data.ByteString.Lazy (ByteString)+import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..), prepareRequest)+import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates (..))  data PollingResponse = PollingResponse-    { flags    :: !(KeyMap Flag)+    { flags :: !(KeyMap Flag)     , segments :: !(KeyMap Segment)-    } deriving (Generic, FromJSON, Show)+    }+    deriving (Generic, FromJSON, Show)  processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool-processPoll manager dataSourceUpdates request = liftIO (tryHTTP $ httpLbs request manager) >>= \case-    (Left err)       -> do-        $(logError) (T.pack $ show err)-        pure True-    (Right response) -> checkAuthorization response >> processResponse response--    where-+processPoll manager dataSourceUpdates request =+    liftIO (tryHTTP $ httpLbs request manager) >>= \case+        (Left err) -> do+            $(logError) (T.pack $ show err)+            pure True+        (Right response) ->+            checkAuthorization response >> processResponse response+  where     processResponse :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Response ByteString -> m Bool     processResponse response         | isHttpUnrecoverable $ statusCode $ responseStatus response = do@@ -47,30 +47,25 @@             $(logError) "unexpected polling status code"             pure True         | otherwise = case (eitherDecode (responseBody response) :: Either String PollingResponse) of-            (Left err)   -> do+            (Left err) -> do                 $(logError) (T.pack $ show err)                 pure $ True             (Right body) -> do                 status <- liftIO $ dataSourceUpdatesInit dataSourceUpdates (getField @"flags" body) (getField @"segments" body)                 case status of-                  Right () -> do-                    liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Initialized-                    pure $ True-                  Left err -> do-                    $(logError) $ T.append "store failed put: " err-                    pure $ True---+                    Right () -> do+                        liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Initialized+                        pure $ True+                    Left err -> do+                        $(logError) $ T.append "store failed put: " err+                        pure $ True  pollingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> Natural -> ClientContext -> DataSourceUpdates -> m () pollingThread baseURI pollingIntervalSeconds clientContext dataSourceUpdates = do     let pollingMicroseconds = fromIntegral pollingIntervalSeconds * 1000000     req <- liftIO $ prepareRequest (httpConfiguration clientContext) (T.unpack baseURI ++ "/sdk/latest-all")     handleUnauthorized dataSourceUpdates $ (poll req pollingMicroseconds)--    where-+  where     poll :: (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m ()     poll req pollingMicroseconds = do         $(logInfo) "starting poll"
src/LaunchDarkly/Server/Network/Streaming.hs view
@@ -1,64 +1,71 @@-module LaunchDarkly.Server.Network.Streaming (streamingThread) where+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-} -import           Data.Text                           (Text)-import qualified Data.Text as                        T-import           Data.Attoparsec.Text as             P hiding (Result, try)-import           Data.Function                       (fix)-import           Control.Monad                       (void, mzero)-import           Control.Monad.Catch                 (Exception, MonadCatch, MonadMask, try)-import           Control.Exception                   (throwIO)-import           Data.ByteString                     (ByteString)-import qualified Data.ByteString as                  B-import           Control.Applicative                 (many)-import           Data.Text.Encoding                  (decodeUtf8, encodeUtf8)-import           Network.HTTP.Client                 (Manager, Response(..), Request, HttpException(..), HttpExceptionContent(..), brRead, throwErrorStatusCodes)-import           Control.Monad.Logger                (MonadLogger, logInfo, logWarn, logError, logDebug)-import           Control.Monad.IO.Class              (MonadIO, liftIO)-import           Data.Aeson                          (FromJSON, parseJSON, withObject, eitherDecode, (.:), (.:?), (.!=), fromJSON, Result(..))-import qualified Data.ByteString.Lazy as             L-import           GHC.Natural                         (Natural)-import           GHC.Generics                        (Generic)-import           Control.Retry                       (RetryPolicyM, RetryStatus, fullJitterBackoff, capDelay, retrying)-import           Network.HTTP.Types.Status           (ok200, Status(statusCode))-import           System.Timeout                      (timeout)-import           System.Clock                        (getTime, Clock(Monotonic), TimeSpec(TimeSpec))+module LaunchDarkly.Server.Network.Streaming (streamingThread) where -import           LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..), prepareRequest)-import           LaunchDarkly.Server.Config.ClientContext     (ClientContext(..))-import           LaunchDarkly.Server.Store.Internal           (StoreResult)-import           LaunchDarkly.Server.DataSource.Internal      (DataSourceUpdates(..))-import           LaunchDarkly.Server.Features                 (Flag, Segment)-import           LaunchDarkly.Server.Network.Common           (handleUnauthorized, checkAuthorization, withResponseGeneric, tryHTTP)-import           LaunchDarkly.AesonCompat                     (KeyMap)+import Control.Applicative (many)+import Control.Concurrent (threadDelay)+import Control.Exception (throwIO)+import Control.Monad (mzero, void)+import Control.Monad.Catch (Exception, MonadCatch, MonadMask, try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logDebug, logError, logInfo, logWarn)+import Control.Monad.Loops (iterateUntilM)+import Data.Aeson (FromJSON, Result (..), eitherDecode, fromJSON, parseJSON, withObject, (.!=), (.:), (.:?))+import Data.Attoparsec.Text as P hiding (Result, try)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager, Request, Response (..), brRead)+import Network.HTTP.Types.Status (Status (statusCode))+import System.Clock (Clock (Monotonic), TimeSpec (TimeSpec), getTime)+import System.Random (Random (randomR), newStdGen)+import System.Timeout (timeout) +import LaunchDarkly.AesonCompat (KeyMap)+import LaunchDarkly.Server.Config.ClientContext (ClientContext (..))+import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..), prepareRequest)+import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates (..))+import LaunchDarkly.Server.Features (Flag, Segment)+import LaunchDarkly.Server.Network.Common (checkAuthorization, handleUnauthorized, isHttpUnrecoverable, throwIfNot200, tryHTTP, withResponseGeneric)+import LaunchDarkly.Server.Store.Internal (StoreResult)  data PutBody = PutBody-    { flags    :: !(KeyMap Flag)+    { flags :: !(KeyMap Flag)     , segments :: !(KeyMap Segment)-    } deriving (Generic, Show, FromJSON)+    }+    deriving (Generic, Show, FromJSON)  data PathData d = PathData-    { path     :: !Text+    { path :: !Text     , pathData :: !d-    } deriving (Generic, Show)+    }+    deriving (Generic, Show)  data PathVersion = PathVersion-    { path    :: !Text+    { path :: !Text     , version :: !Natural-    } deriving (Generic, Show, FromJSON)+    }+    deriving (Generic, Show, FromJSON)  instance FromJSON a => FromJSON (PathData a) where     parseJSON = withObject "Put" $ \o -> do         pathData <- o .: "data"-        path     <- o .:? "path" .!= "/"-        pure $ PathData { path = path, pathData = pathData }+        path <- o .:? "path" .!= "/"+        pure $ PathData {path = path, pathData = pathData}  data SSE = SSE-    { name        :: !Text-    , buffer      :: !Text+    { name :: !Text+    , buffer :: !Text     , lastEventId :: !(Maybe Text)-    , retry       :: !(Maybe Text)-    } deriving (Generic, Show, Eq)+    , retry :: !(Maybe Text)+    }+    deriving (Generic, Show, Eq)  nameCharPredicate :: Char -> Bool nameCharPredicate x = x /= '\r' && x /= ':' && x /= '\n'@@ -83,11 +90,11 @@  processField :: (Text, Text) -> SSE -> SSE processField (fieldName, fieldValue) event = case fieldName of-    "event"   -> event { name = fieldValue }-    "id"      -> event { lastEventId = Just fieldValue }-    "retry"   -> event { retry = Just fieldValue }-    "data"    -> event { buffer = T.concat [ buffer event, if T.null (buffer event) then "" else "\n", fieldValue] }-    _         -> event+    "event" -> event {name = fieldValue}+    "id" -> event {lastEventId = Just fieldValue}+    "retry" -> event {retry = Just fieldValue}+    "data" -> event {buffer = T.concat [buffer event, if T.null (buffer event) then "" else "\n", fieldValue]}+    _ -> event  parseEvent :: Parser SSE parseEvent = do@@ -96,49 +103,78 @@     let event = foldr processField (SSE "" "" mzero mzero) fields     if T.null (name event) || T.null (buffer event) then parseEvent else pure event -processPut :: (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m ()+processPut :: (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m Bool processPut dataSourceUpdates value = case eitherDecode value of     Right (PathData _ (PutBody flags segments)) -> do         $(logInfo) "initializing dataSourceUpdates with put"         liftIO (dataSourceUpdatesInit dataSourceUpdates flags segments) >>= \case-            Left err -> $(logError) $ T.append "dataSourceUpdates failed put: " err-            _        -> pure ()-    Left err -> $(logError) $ T.append "failed to parse put body" (T.pack err)+            Left err -> do+                $(logError) $ T.append "dataSourceUpdates failed put: " err+                pure False+            _ -> pure True+    Left err -> do+        $(logError) $ T.append "failed to parse put body" (T.pack err)+        pure False -processPatch :: forall m. (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m ()+processPatch :: forall m. (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m Bool processPatch dataSourceUpdates value = case eitherDecode value of     Right (PathData path body)-        | T.isPrefixOf "/flags/" path    -> insPatch "flag" path dataSourceUpdatesInsertFlag (fromJSON body)+        | T.isPrefixOf "/flags/" path -> insPatch "flag" path dataSourceUpdatesInsertFlag (fromJSON body)         | T.isPrefixOf "/segments/" path -> insPatch "segment" path dataSourceUpdatesInsertSegment (fromJSON body)-        | otherwise                      -> $(logError) "unknown patch path"-    Left err                             -> $(logError) $ T.append "failed to parse patch generic" (T.pack err)-    where-      insPatch :: Text -> Text -> (DataSourceUpdates -> a -> IO (Either Text ())) -> Result a -> m ()-      insPatch name _ _ (Error err) = $(logError) $ T.concat ["failed to parse patch ", name, ": ", T.pack err]-      insPatch name path insert (Success item) = do+        | otherwise -> do+            $(logError) "unknown patch path"+            pure True+    Left err -> do+        $(logError) $ T.append "failed to parse patch generic" (T.pack err)+        pure False+  where+    insPatch :: Text -> Text -> (DataSourceUpdates -> a -> IO (Either Text ())) -> Result a -> m Bool+    insPatch name _ _ (Error err) = do+        $(logError) $ T.concat ["failed to parse patch ", name, ": ", T.pack err]+        pure False+    insPatch name path insert (Success item) = do         $(logInfo) $ T.concat ["patching ", name, " with path: ", path]         status <- liftIO $ insert dataSourceUpdates item-        either (\err -> $(logError) $ T.concat ["dataSourceUpdates failed ", name, " patch: ", err]) pure status+        either+            ( \err -> do+                $(logError) $ T.concat ["dataSourceUpdates failed ", name, " patch: ", err]+                pure False+            )+            (const $ pure True)+            status -processDelete :: forall m. (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m ()+processDelete :: forall m. (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m Bool processDelete dataSourceUpdates value = case eitherDecode value :: Either String PathVersion of     Right (PathVersion path version)-        | T.isPrefixOf "/flags/" path    -> logDelete "flag" path (dataSourceUpdatesDeleteFlag dataSourceUpdates (T.drop 7 path) version)+        | T.isPrefixOf "/flags/" path -> logDelete "flag" path (dataSourceUpdatesDeleteFlag dataSourceUpdates (T.drop 7 path) version)         | T.isPrefixOf "/segments/" path -> logDelete "segment" path (dataSourceUpdatesDeleteSegment dataSourceUpdates (T.drop 10 path) version)-        | otherwise                      -> $(logError) "unknown delete path"-    Left err                             -> $(logError) $ T.append "failed to parse delete" (T.pack err)-    where logDelete :: Text -> Text -> StoreResult () -> m ()-          logDelete name path action = do-            $(logInfo) $ T.concat ["deleting ", name, " with path: ", path]-            status <- liftIO action-            either (\err -> $(logError) $ T.concat ["dataSourceUpdates failed ", name, " delete: ", err]) pure status+        | otherwise -> do+            $(logError) "unknown delete path"+            pure False+    Left err -> do+        $(logError) $ T.append "failed to parse delete" (T.pack err)+        pure False+  where+    logDelete :: Text -> Text -> StoreResult () -> m Bool+    logDelete name path action = do+        $(logInfo) $ T.concat ["deleting ", name, " with path: ", path]+        status <- liftIO action+        either+            ( \err -> do+                $(logError) $ T.concat ["dataSourceUpdates failed ", name, " delete: ", err]+                pure False+            )+            (const $ pure True)+            status -processEvent :: (MonadIO m, MonadLogger m) => DataSourceUpdates -> Text -> L.ByteString -> m ()+processEvent :: (MonadIO m, MonadLogger m) => DataSourceUpdates -> Text -> L.ByteString -> m Bool processEvent dataSourceUpdates name value = case name of-    "put"    -> processPut dataSourceUpdates value-    "patch"  -> processPatch dataSourceUpdates value+    "put" -> processPut dataSourceUpdates value+    "patch" -> processPatch dataSourceUpdates value     "delete" -> processDelete dataSourceUpdates value-    _        -> $(logWarn) "unknown event type"+    _ -> do+        $(logWarn) "unknown event type"+        pure True  data ReadE = ReadETimeout | ReadEClosed deriving (Show, Exception) @@ -147,58 +183,109 @@  -- heartbeat expected every 120 seconds readWithException :: IO ByteString -> IO Text-readWithException body = timeout (1000000 * 300) (brRead body) >>= \case-    Nothing    -> throwIO ReadETimeout-    Just bytes -> if bytes == B.empty then throwIO ReadEClosed else pure (decodeUtf8 bytes)+readWithException body =+    timeout (1_000_000 * 300) (brRead body) >>= \case+        Nothing -> throwIO ReadETimeout+        Just bytes -> if bytes == B.empty then throwIO ReadEClosed else pure (decodeUtf8 bytes) -readStream :: (MonadIO m, MonadLogger m, MonadMask m) => IO ByteString -> DataSourceUpdates -> m ()-readStream body dataSourceUpdates = loop "" where-    loop initial = tryReadE (parseWith (liftIO $ readWithException body) parseEvent initial) >>= \case-        (Left ReadETimeout) -> $(logError) "streaming connection unexpectedly closed"-        (Left ReadEClosed)  -> $(logError) "timeout waiting for SSE event"-        (Right parsed)      -> case parsed of-            Done remaining event -> do-                processEvent dataSourceUpdates (name event) (L.fromStrict $ encodeUtf8 $ buffer event)-                loop remaining-            Fail _ context err ->-                $(logError) $ T.intercalate " " ["failed parsing SSE frame", T.pack $ show context, T.pack err]-            Partial _ -> $(logError) "failed parsing SSE frame unexpected partial"+readStream :: (MonadIO m, MonadLogger m, MonadMask m) => IO ByteString -> DataSourceUpdates -> m Bool+readStream body dataSourceUpdates = do+    $(logError) "starting readStream"+    loop "" False+  where+    loop initial processedEvent =+        tryReadE (parseWith (liftIO $ readWithException body) parseEvent initial) >>= \case+            (Left ReadETimeout) -> do+                $(logError) "streaming connection unexpectedly closed"+                pure processedEvent+            (Left ReadEClosed) -> do+                $(logError) "timeout waiting for SSE event"+                pure processedEvent+            (Right parsed) -> case parsed of+                Done remaining event -> do+                    processed <- processEvent dataSourceUpdates (name event) (L.fromStrict $ encodeUtf8 $ buffer event)+                    if processed then loop remaining True else pure processedEvent+                Fail _ context err -> do+                    $(logError) $ T.intercalate " " ["failed parsing SSE frame", T.pack $ show context, T.pack err]+                    pure processedEvent+                Partial _ -> do+                    $(logError) "failed parsing SSE frame unexpected partial"+                    pure processedEvent --- https://aws.amazon.com/blogs/architecture/exponential-backoff-and-jitter/-retryPolicy :: MonadIO m => RetryPolicyM m-retryPolicy = capDelay (30 * 1000000) $ fullJitterBackoff (1 * 1000000)+-- This function is responsible for consuming a streaming connection.+--+-- It is responsible for opening the connection, parsing the body for as long as it is able, and then handling shut down+-- cleanly. While events are being processed, it is responsible for implementing a sane retry policy that prevents the+-- stampeding herd problem in the unlikely event of upstream failures.+startNewConnection :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> Request -> DataSourceUpdates -> StreamingState -> m StreamingState+startNewConnection manager request dataSourceUpdates state@(StreamingState {activeSince}) = do+    $(logDebug) "starting new streaming connection"+    status <- tryHTTP $ withResponseGeneric request manager $ \response -> do+        checkAuthorization response+            >> throwIfNot200 request response+            >> readStream (responseBody response) dataSourceUpdates+    now <- liftIO $ getTime Monotonic+    handleResponse state now status+  where+    -- This function is responsible for parsing the final output from a now closed streaming connection.+    --+    -- Given the result of the stream run, this function can choose to either mark the state as cancelled, stopping all+    -- further attempts, or it can update the state and wait some amount of time before starting another attempt.+    handleResponse :: (MonadIO m, MonadLogger m, MonadMask m) => StreamingState -> TimeSpec -> (Either HttpException Bool) -> m StreamingState+    handleResponse state now result =+        let state' = updateState state now result+         in if cancel state'+                then pure state'+                else do+                    delay <- calculateDelay state'+                    _ <- liftIO $ threadDelay delay+                    pure state' -data Failure = FailurePermanent | FailureTemporary | FailureReset deriving (Eq)+    -- Once a streaming connection run has ended, we need to update the streaming state.+    --+    -- Given the result of a stream run, this function can either choose to mark the state as cancelled, meaning halt all+    -- further attempts, or it can be updated according to the rules of our streaming specification.+    updateState :: StreamingState -> TimeSpec -> (Either HttpException Bool) -> StreamingState+    updateState state now (Right _) = state {initialConnection = False, activeSince = Just now, attempt = 1}+    updateState state@(StreamingState {attempt = att}) now (Left (HttpExceptionRequest _ (StatusCodeException response _)))+        | isHttpUnrecoverable code = state {cancel = True}+        | otherwise = do+            case activeSince of+                (Just time)+                    | (now >= time + (TimeSpec 60 0)) -> state {attempt = 1, activeSince = Nothing}+                    | otherwise -> state {attempt = att + 1}+                Nothing -> state {attempt = att + 1}+      where+        code = statusCode (responseStatus response)+    updateState state@(StreamingState {attempt = att}) _ _ = state {attempt = att + 1} -handleStream :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> Request -> DataSourceUpdates -> RetryStatus -> m Failure-handleStream manager request dataSourceUpdates _ = do-    $(logDebug) "starting new streaming connection"-    startTime <- liftIO $ getTime Monotonic-    status <- tryHTTP $ withResponseGeneric request manager $ \response -> checkAuthorization response >>-        if responseStatus response /= ok200 then throwErrorStatusCodes request response else-            readStream (responseBody response) dataSourceUpdates-    case status of-        (Right ()) -> liftIO (getTime Monotonic) >>= \now -> if now >= startTime + (TimeSpec 60 0)-            then do-                $(logError) "streaming connection closed after 60 seconds, retrying instantly"-                pure FailureReset-            else do-                $(logError) "streaming connection closed before 60 seconds, retrying after backoff"-                pure FailureTemporary-        (Left err) -> do-            $(logError) (T.intercalate " " ["HTTP Exception", T.pack $ show err])-            pure $ case err of-                (InvalidUrlException _ _)                                 -> FailurePermanent-                (HttpExceptionRequest _ (StatusCodeException response _)) ->-                    let code = statusCode (responseStatus response) in if code >= 400 && code < 500-                        then if elem code [400, 408, 429] then FailureTemporary else FailurePermanent-                        else FailureTemporary-                _                                                         -> FailureTemporary+    -- Calculate the next delay period following a backoff + jitter + max delay algorithm.+    --+    -- See https://aws.amazon.com/blogs/architecture/exponential-backoff-and-jitter/+    calculateDelay :: (MonadIO m, MonadLogger m, MonadMask m) => StreamingState -> m Int+    calculateDelay StreamingState {initialRetryDelay, attempt = att} = do+        liftIO $+            newStdGen >>= \gen ->+                let timespan = min (30 * 1_000_000) ((initialRetryDelay * 1_000) * (2 ^ (att - 1)))+                    jitter = fst $ randomR (0, timespan `div` 2) gen+                 in pure $ (timespan - jitter) -streamingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> ClientContext -> DataSourceUpdates -> m ()-streamingThread streamURI clientContext dataSourceUpdates = do+data StreamingState = StreamingState+    { initialConnection :: Bool -- Marker used to determine the first time the streamer connects.+    , initialRetryDelay :: Int -- The base duration used for the retry delay calculation+    , activeSince :: Maybe TimeSpec -- TimeSpec to denote the last time the SDK successfully connected to the stream+    , attempt :: Int -- A number representing the attempt # of this connection+    , cancel :: Bool -- A marker to shortcut logic and halt the streaming process+    }+    deriving (Generic, Show)++-- Start a thread for streaming events back from LaunchDarkly services.+streamingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> Int -> ClientContext -> DataSourceUpdates -> m ()+streamingThread streamURI initialRetryDelay clientContext dataSourceUpdates = do     let manager = tlsManager $ httpConfiguration clientContext-    req <- prepareRequest (httpConfiguration clientContext) (T.unpack streamURI  ++ "/all")-    handleUnauthorized dataSourceUpdates $ fix $ \loop ->-        retrying retryPolicy (\_ status -> pure $ status == FailureTemporary) (handleStream manager req dataSourceUpdates) >>=-            \case FailureReset -> loop; _ -> pure ()+    req <- prepareRequest (httpConfiguration clientContext) (T.unpack streamURI ++ "/all")+    handleUnauthorized dataSourceUpdates (processStream manager req)+  where+    processStream :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> Request -> m ()+    processStream manager req = do+        void $ iterateUntilM (cancel) (\state -> startNewConnection manager req dataSourceUpdates state) StreamingState {initialConnection = True, initialRetryDelay, activeSince = Nothing, attempt = 0, cancel = False}
src/LaunchDarkly/Server/Operators.hs view
@@ -1,29 +1,29 @@ {-# LANGUAGE NoPatternSynonyms #-}  module LaunchDarkly.Server.Operators-    ( Op(..)+    ( Op (..)     , getOperation     ) where -import Data.Maybe            (fromMaybe, isJust)-import Data.Either           (fromRight)-import Data.Text as          T-import Data.Text             (Text, isPrefixOf, isInfixOf, isSuffixOf, unpack)-import Data.Char             (isDigit)-import Data.Text.Encoding    (encodeUtf8)-import Data.Scientific       (Scientific, toRealFloat)-import Data.Aeson.Types      (Value(..), FromJSON, ToJSON(..), withText, parseJSON)-import Data.Time.ISO8601     (parseISO8601)-import Data.Time.Clock       (UTCTime)+import Control.Lens ((.~))+import Control.Monad (liftM2)+import Data.Aeson.Types (FromJSON, ToJSON (..), Value (..), parseJSON, withText)+import Data.Char (isDigit)+import Data.Either (fromRight)+import Data.Maybe (fromMaybe, isJust)+import Data.Scientific (Scientific, toRealFloat)+import Data.SemVer (Version, fromText, metadata, toText)+import Data.Text (Text, isInfixOf, isPrefixOf, isSuffixOf, unpack)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)-import Data.SemVer           (Version, fromText, toText, metadata)-import Control.Monad         (liftM2)-import Control.Lens          ((.~))-import GHC.Generics          (Generic)+import Data.Time.ISO8601 (parseISO8601)+import GHC.Generics (Generic) import Text.Regex.PCRE.Light (compileM, match) -data Op =-      OpIn+data Op+    = OpIn     | OpEndsWith     | OpStartsWith     | OpMatches@@ -43,49 +43,49 @@  instance FromJSON Op where     parseJSON = withText "Op" $ \v -> case v of-        "in"                 -> pure OpIn-        "endsWith"           -> pure OpEndsWith-        "startsWith"         -> pure OpStartsWith-        "matches"            -> pure OpMatches-        "contains"           -> pure OpContains-        "lessThan"           -> pure OpLessThan-        "lessThanOrEqual"    -> pure OpLessThanOrEqual-        "greaterThan"        -> pure OpGreaterThan+        "in" -> pure OpIn+        "endsWith" -> pure OpEndsWith+        "startsWith" -> pure OpStartsWith+        "matches" -> pure OpMatches+        "contains" -> pure OpContains+        "lessThan" -> pure OpLessThan+        "lessThanOrEqual" -> pure OpLessThanOrEqual+        "greaterThan" -> pure OpGreaterThan         "greaterThanOrEqual" -> pure OpGreaterThanOrEqual-        "before"             -> pure OpBefore-        "after"              -> pure OpAfter-        "semVerEqual"        -> pure OpSemVerEqual-        "semVerLessThan"     -> pure OpSemVerLessThan-        "semVerGreaterThan"  -> pure OpSemVerGreaterThan-        "segmentMatch"       -> pure OpSegmentMatch-        _                    -> pure OpUnknown+        "before" -> pure OpBefore+        "after" -> pure OpAfter+        "semVerEqual" -> pure OpSemVerEqual+        "semVerLessThan" -> pure OpSemVerLessThan+        "semVerGreaterThan" -> pure OpSemVerGreaterThan+        "segmentMatch" -> pure OpSegmentMatch+        _ -> pure OpUnknown  instance ToJSON Op where     toJSON op = String $ case op of-        OpIn                 -> "in"-        OpEndsWith           -> "endsWith"-        OpStartsWith         -> "startsWith"-        OpMatches            -> "matches"-        OpContains           -> "contains"-        OpLessThan           -> "lessThan"-        OpLessThanOrEqual    -> "lessThanOrEqual"-        OpGreaterThan        -> "greaterThan"+        OpIn -> "in"+        OpEndsWith -> "endsWith"+        OpStartsWith -> "startsWith"+        OpMatches -> "matches"+        OpContains -> "contains"+        OpLessThan -> "lessThan"+        OpLessThanOrEqual -> "lessThanOrEqual"+        OpGreaterThan -> "greaterThan"         OpGreaterThanOrEqual -> "greaterThanOrEqual"-        OpBefore             -> "before"-        OpAfter              -> "after"-        OpSemVerEqual        -> "semVerEqual"-        OpSemVerLessThan     -> "semVerLessThan"-        OpSemVerGreaterThan  -> "semVerGreaterThan"-        OpSegmentMatch       -> "segmentMatch"-        OpUnknown            -> "unknown"+        OpBefore -> "before"+        OpAfter -> "after"+        OpSemVerEqual -> "semVerEqual"+        OpSemVerLessThan -> "semVerLessThan"+        OpSemVerGreaterThan -> "semVerGreaterThan"+        OpSegmentMatch -> "segmentMatch"+        OpUnknown -> "unknown"  checkString :: (Text -> Text -> Bool) -> Value -> Value -> Bool checkString op (String x) (String y) = op x y-checkString _ _ _                    = False+checkString _ _ _ = False  checkNumber :: (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool checkNumber op (Number x) (Number y) = op x y-checkNumber _ _ _                    = False+checkNumber _ _ _ = False  doubleToPOSIXTime :: Double -> POSIXTime doubleToPOSIXTime = realToFrac@@ -93,44 +93,47 @@ parseTime :: Value -> Maybe UTCTime parseTime (Number x) = Just $ posixSecondsToUTCTime $ doubleToPOSIXTime $ (toRealFloat x) / 1000 parseTime (String x) = parseISO8601 $ unpack x-parseTime _          = Nothing+parseTime _ = Nothing  compareTime :: (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool compareTime op x y = fromMaybe False $ liftM2 op (parseTime x) (parseTime y)  padSemVer :: Text -> Text-padSemVer text = T.concat [l, padding, r] where+padSemVer text = T.concat [l, padding, r]+  where     (l, r) = T.span (\c -> isDigit c || c == '.') text     dots = T.count "." l     padding = if dots < 2 then T.replicate (2 - dots) ".0" else ""  parseSemVer :: Text -> Either String Version-parseSemVer raw = fmap (metadata .~ []) (fromText $ padSemVer raw) >>= \x ->-    if T.isPrefixOf (toText x) (padSemVer raw) then Right x else Left "mismatch" where+parseSemVer raw =+    fmap (metadata .~ []) (fromText $ padSemVer raw) >>= \x ->+        if T.isPrefixOf (toText x) (padSemVer raw) then Right x else Left "mismatch"+  where  compareSemVer :: (Version -> Version -> Bool) -> Text -> Text -> Bool compareSemVer op x y = fromRight False $ liftM2 op (parseSemVer x) (parseSemVer y)  matches :: Text -> Text -> Bool matches text pattern = case compileM (encodeUtf8 pattern) [] of-    Left _         -> False+    Left _ -> False     Right compiled -> isJust $ match compiled (encodeUtf8 text) []  getOperation :: Op -> (Value -> Value -> Bool) getOperation op = case op of-    OpIn                 -> (==)-    OpEndsWith           -> checkString (flip isSuffixOf)-    OpStartsWith         -> checkString (flip isPrefixOf)-    OpContains           -> checkString (flip isInfixOf)-    OpMatches            -> checkString matches-    OpLessThan           -> checkNumber (<)-    OpLessThanOrEqual    -> checkNumber (<=)-    OpGreaterThan        -> checkNumber (>)+    OpIn -> (==)+    OpEndsWith -> checkString (flip isSuffixOf)+    OpStartsWith -> checkString (flip isPrefixOf)+    OpContains -> checkString (flip isInfixOf)+    OpMatches -> checkString matches+    OpLessThan -> checkNumber (<)+    OpLessThanOrEqual -> checkNumber (<=)+    OpGreaterThan -> checkNumber (>)     OpGreaterThanOrEqual -> checkNumber (>=)-    OpBefore             -> compareTime (<)-    OpAfter              -> compareTime (>)-    OpSemVerEqual        -> checkString $ compareSemVer (==)-    OpSemVerLessThan     -> checkString $ compareSemVer (<)-    OpSemVerGreaterThan  -> checkString $ compareSemVer (>)-    OpSegmentMatch       -> error "cannot get operation for OpSegmentMatch"-    OpUnknown            -> const $ const False+    OpBefore -> compareTime (<)+    OpAfter -> compareTime (>)+    OpSemVerEqual -> checkString $ compareSemVer (==)+    OpSemVerLessThan -> checkString $ compareSemVer (<)+    OpSemVerGreaterThan -> checkString $ compareSemVer (>)+    OpSegmentMatch -> error "cannot get operation for OpSegmentMatch"+    OpUnknown -> const $ const False
+ src/LaunchDarkly/Server/Reference.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Reference is an attribute name or path expression identifying a value within+-- a Context.+--+-- This type is mainly intended to be used internally by LaunchDarkly SDK and+-- service code, where efficiency is a major concern so it's desirable to do+-- any parsing or preprocessing just once. Applications are unlikely to need to+-- use the Reference type directly.+--+-- It can be used to retrieve a value with+-- 'LaunchDarkly.Server.Context.getValueForReference' or to identify an+-- attribute or nested value that should be considered private.+--+-- Parsing and validation are done at the time that the Reference is+-- constructed. If a Reference instance was created from an invalid string, it+-- is considered invalid. The error can be inspected with 'getError'.+--+-- == Syntax+--+-- The string representation of an attribute reference in LaunchDarkly JSON+-- data uses the following syntax:+--+-- If the first character is not a slash, the string is interpreted literally+-- as an attribute name. An attribute name can contain any characters, but must+-- not be empty.+--+-- If the first character is a slash, the string is interpreted as a+-- slash-delimited path where the first path component is an attribute name,+-- and each subsequent path component is the name of a property in a JSON+-- object. Any instances of the characters "/" or "~" in a path component are+-- escaped as "~1" or "~0" respectively. This syntax deliberately resembles+-- JSON Pointer, but no JSON Pointer behaviors other than those mentioned here+-- are supported.+--+-- == Examples+--+-- Suppose there is a context whose JSON implementation looks like this:+--+-- 	{+-- 	  "kind": "user",+-- 	  "key": "value1",+-- 	  "address": {+-- 	    "street": {+-- 	      "line1": "value2",+-- 	      "line2": "value3"+-- 	    },+-- 	    "city": "value4"+-- 	  },+-- 	  "good/bad": "value5"+-- 	}+--+-- The attribute references "key" and "/key" would both point to "value1".+--+-- The attribute reference "/address/street/line1" would point to "value2".+--+-- The attribute references "good/bad" and "/good~1bad" would both point to+-- "value5".+module LaunchDarkly.Server.Reference+    ( Reference+    , makeReference+    , makeLiteral+    , isValid+    , getError+    , getComponents+    , getRawPath+    )+where++import Data.Aeson (ToJSON, Value (String), toJSON)+import Data.Text (Text)+import qualified Data.Text as T++-- | data record for the Reference type.+data Reference+    = Valid {rawPath :: !Text, components :: ![Text]}+    | Invalid {rawPath :: !Text, error :: !Text}+    deriving (Show, Eq)++instance Ord Reference where+    compare (Invalid _ _) (Valid _ _) = LT+    compare (Valid _ _) (Invalid _ _) = GT+    compare (Valid lhsRaw lhsComponents) (Valid rhsRaw rhsComponents)+        | lhsComponents == rhsComponents = compare lhsRaw rhsRaw+        | otherwise = compare lhsComponents rhsComponents+    compare (Invalid lhsRaw lhsError) (Invalid rhsRaw rhsError)+        | lhsRaw == rhsRaw = compare lhsError rhsError+        | otherwise = compare lhsRaw rhsRaw++instance ToJSON Reference where+    toJSON = String . rawPath++-- |+-- Creates a Reference from a string. For the supported syntax and examples,+-- see comments on the "LaunchDarkly.Server.Reference" module.+--+-- This function always returns a Reference that preserves the original string,+-- even if validation fails, so that accessing 'getRawPath' (or serializing the+-- Reference to JSON) will produce the original string. If validation fails,+-- 'getError' will return an error and any SDK method that takes this Reference+-- as a parameter will consider it invalid.+makeReference :: Text -> Reference+makeReference "" = Invalid {rawPath = "", error = "empty reference"}+makeReference "/" = Invalid {rawPath = "/", error = "empty reference"}+makeReference value@(T.stripPrefix "/" -> Nothing) = Valid {rawPath = value, components = [value]}+makeReference value@(T.stripSuffix "/" -> Just _) = Invalid {rawPath = value, error = "trailing slash"}+makeReference value = foldr addComponentToReference (Valid {rawPath = value, components = []}) (T.splitOn "/" $ T.drop 1 value)++-- |+-- makeLiteral is similar to 'makeReference' except that it always interprets+-- the string as a literal attribute name, never as a slash-delimited path+-- expression. There is no escaping or unescaping, even if the name contains+-- literal '/' or '~' characters. Since an attribute name can contain any+-- characters, this method always returns a valid Reference unless the name is+-- empty.+--+-- For example: @makeLiteral "name"@ is exactly equivalent to @makeReference+-- "name"@. @makeLiteral "a/b"@ is exactly equivalent to @makeReference "a/b"@+-- (since the syntax used by 'makeReference' treats the whole string as a+-- literal as long as it does not start with a slash), or to @makeReference+-- "/a~1b"@.+makeLiteral :: Text -> Reference+makeLiteral "" = Invalid {rawPath = "", error = "empty reference"}+makeLiteral value@(T.stripPrefix "/" -> Nothing) = Valid {rawPath = value, components = [value]}+makeLiteral value = Valid {rawPath = "/" <> (T.replace "/" "~1" $ T.replace "~" "~0" value), components = [value]}++-- |+-- Returns True for a valid Reference; False otherwise.+--+-- A Reference is invalid if the input string is empty, or starts with a slash+-- but is not a valid slash-delimited path, or starts with a slash and contains+-- an invalid escape sequence.+--+-- Otherwise, the Reference is valid, but that does not guarantee that such an+-- attribute exists in any given Context. For instance, @makeReference "name"@+-- is a valid Reference, but a specific Context might or might not have a name.+--+-- See comments on the "LaunchDarkly.Server.Reference" module for more details+-- of the attribute reference syntax.+isValid :: Reference -> Bool+isValid (Invalid _ _) = False+isValid _ = True++-- |+-- Returns an empty string for a valid Reference, or a Text error description+-- for an invalid Reference.+--+-- See comments on the "LaunchDarkly.Server.Reference" module for more details+-- of the attribute reference syntax.+getError :: Reference -> Text+getError (Invalid {error = e}) = e+getError _ = ""++-- |+-- Retrieves path components from the attribute reference.+--+-- Invalid references will return an empty list.+--+-- > makeReference "" & getComponents     -- returns []+-- > makeReference "a" & getComponents    -- returns ["a"]+-- > makeReference "/a/b" & getComponents -- returns ["a", "b"]+getComponents :: Reference -> [Text]+getComponents (Valid {components}) = components+getComponents _ = []++-- |+-- Returns the attribute reference as a string, in the same format provided+-- to 'makeReference'.+--+-- If the Reference was created with 'makeReference', this value is identical+-- to the original string. If it was created with 'makeLiteral', the value may+-- be different due to unescaping (for instance, an attribute whose name is+-- "/a" would be represented as "~1a").+getRawPath :: Reference -> Text+getRawPath = rawPath++-- Method intended to be used with a foldr. If you do not use this with a+-- foldr, the components will be in the wrong order as this method does+-- prepending.+--+-- This function helps assist in the construction of a Valid reference by+-- incrementally adding a new component to the Reference. If the component+-- cannot be added, or if the Reference is already invalid, we return an+-- Invalid reference with the appropriate error description.+addComponentToReference :: Text -> Reference -> Reference+addComponentToReference _ r@(Invalid _ _) = r+addComponentToReference "" (Valid {rawPath}) = Invalid {rawPath, error = "double slash"}+addComponentToReference component (Valid {rawPath, components}) = case unescapePath component of+    Left c -> Valid {rawPath, components = (c : components)}+    Right e -> Invalid {rawPath, error = e}++-- Performs unescaping of attribute reference path components:+--+-- "~1" becomes "/"+-- "~0" becomes "~"+-- "~" followed by any character other than "0" or "1" is invalid+--+-- This method returns an Either. Left Text is the path if unescaping was+-- valid; otherwise, Right Text will be a description error message.+unescapePath :: Text -> Either Text Text+unescapePath value@(T.isInfixOf "~" -> False) = Left value+unescapePath (T.stripSuffix "~" -> Just _) = Right "invalid escape sequence"+unescapePath value =+    let component = T.foldl unescapeComponent (ComponentState {acc = [], valid = True, inEscape = False}) value+     in case component of+            ComponentState {acc = acc, valid = True} -> Left $ T.pack $ reverse acc+            _ -> Right "invalid escape sequence"++-- Component state is a helper record to assist with unescaping a string.+--+-- When we are processing a string, we have to ensure that ~ is followed by 0+-- or 1. Any other value is invalid. To track this, we update this component+-- state through a fold operation.+data ComponentState = ComponentState+    { acc :: ![Char] -- Container to hold the piece of the input that has been successfully parsed.+    , valid :: !Bool -- Is the state currently valid?+    , inEscape :: !Bool -- Was the last character seen a tilde?+    }++-- Intended to be used in a foldl operation to apply unescaping rules as+-- defined in 'unescapePath'.+--+-- Note that the 'ComponentState.acc' will be built backwards. This is because+-- prepending is faster in Haskell. Calling functions should reverse+-- accordingly.+unescapeComponent :: ComponentState -> Char -> ComponentState+-- Short circuit if we are already invalid+unescapeComponent component@(ComponentState {valid = False}) _ = component+-- Escape mode with a 0 or 1 means a valid escape sequence. We can append this+-- to the state's accumulator.+unescapeComponent component@(ComponentState {acc, inEscape = True}) '0' = component {acc = '~' : acc, valid = True, inEscape = False}+unescapeComponent component@(ComponentState {acc, inEscape = True}) '1' = component {acc = '/' : acc, valid = True, inEscape = False}+-- Any other character during an escape sequence isn't valid+unescapeComponent component@(ComponentState {inEscape = True}) _ = component {valid = False}+-- ~ means we should start escaping+unescapeComponent component '~' = component {inEscape = True}+-- Regular characters can be added without issue+unescapeComponent component@(ComponentState {acc}) c = component {acc = c : acc}
src/LaunchDarkly/Server/Store.hs view
@@ -1,11 +1,12 @@ -- | This module contains details for external store implementations.- module LaunchDarkly.Server.Store     ( StoreResult     , FeatureKey     , FeatureNamespace-    , StoreInterface(..)-    , RawFeature(..)+    , PersistentDataStore (..)+    , SerializedItemDescriptor (..)+    , serializeWithPlaceholder+    , byteStringToVersionedData     ) where  import LaunchDarkly.Server.Store.Internal
src/LaunchDarkly/Server/Store/Internal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE NamedFieldPuns #-}+ module LaunchDarkly.Server.Store.Internal     ( isInitialized     , getAllFlags@@ -8,305 +10,416 @@     , initialize     , StoreResult     , StoreResultM-    , StoreInterface(..)-    , RawFeature(..)-    , StoreHandle(..)-    , LaunchDarklyStoreRead(..)-    , LaunchDarklyStoreWrite(..)-    , Versioned(..)+    , PersistentDataStore (..)+    , SerializedItemDescriptor (..)+    , StoreHandle (..)+    , LaunchDarklyStoreRead (..)+    , LaunchDarklyStoreWrite (..)+    , ItemDescriptor (..)     , makeStoreIO     , insertFlag     , deleteFlag     , insertSegment     , deleteSegment     , initializeStore-    , versionedToRaw+    , createSerializedItemDescriptor     , FeatureKey     , FeatureNamespace+    , serializeWithPlaceholder+    , byteStringToVersionedData     ) where -import           Control.Monad                (void)-import           Control.Lens                 (Lens', (%~), (^.))-import           Data.Aeson                   (ToJSON, FromJSON, encode, decode)-import           Data.IORef                   (IORef, readIORef, atomicModifyIORef', newIORef)-import           Data.ByteString              (ByteString)-import           Data.ByteString.Lazy         (toStrict, fromStrict)-import           Data.Text                    (Text)-import           Data.Function                ((&))-import           Data.Maybe                   (isJust)-import           Data.Generics.Product        (setField, getField, field)-import           System.Clock                 (TimeSpec, Clock(Monotonic), getTime)-import           GHC.Generics                 (Generic)-import           GHC.Natural                  (Natural)+import Control.Lens (Lens', (%~), (^.))+import Control.Monad (void)+import Data.Aeson (FromJSON, ToJSON (toJSON), decode, encode)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.Function ((&))+import Data.Generics.Product (HasField', field, getField, setField)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Maybe (isJust)+import Data.Text (Text)+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import System.Clock (Clock (Monotonic), TimeSpec, getTime) -import           LaunchDarkly.Server.Features (Segment, Flag)-import           LaunchDarkly.AesonCompat     (KeyMap, mapValues, emptyObject, insertKey, lookupKey, insertKey, deleteKey, mapMaybeValues)+import Data.Aeson.Types (Value (Bool))+import Data.Either.Extra (eitherToMaybe)+import LaunchDarkly.AesonCompat (KeyMap, deleteKey, emptyObject, insertKey, lookupKey, mapMaybeValues, mapValues, singleton)+import LaunchDarkly.Server.Features (Flag, Segment)  -- Store result not defined in terms of StoreResultM so we dont have to export. type StoreResultM m a = m (Either Text a) --- | The result type for every `StoreInterface` function. Instead of throwing+-- |+-- The result type for every `PersistentDataStore` function. Instead of throwing -- an exception, any store related error should return `Left`. Exceptions -- unrelated to the store should not be caught. type StoreResult a = IO (Either Text a)  class LaunchDarklyStoreRead store m where-    getFlagC        :: store -> Text -> StoreResultM m (Maybe Flag)-    getSegmentC     :: store -> Text -> StoreResultM m (Maybe Segment)-    getAllFlagsC    :: store -> StoreResultM m (KeyMap Flag)+    getFlagC :: store -> Text -> StoreResultM m (Maybe Flag)+    getSegmentC :: store -> Text -> StoreResultM m (Maybe Segment)+    getAllFlagsC :: store -> StoreResultM m (KeyMap Flag)     getInitializedC :: store -> StoreResultM m Bool  class LaunchDarklyStoreWrite store m where-    storeInitializeC :: store -> KeyMap (Versioned Flag) -> KeyMap (Versioned Segment) -> StoreResultM m ()-    upsertSegmentC   :: store -> Text -> Versioned (Maybe Segment) -> StoreResultM m ()-    upsertFlagC      :: store -> Text -> Versioned (Maybe Flag) -> StoreResultM m ()+    storeInitializeC :: store -> KeyMap (ItemDescriptor Flag) -> KeyMap (ItemDescriptor Segment) -> StoreResultM m ()+    upsertSegmentC :: store -> Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ()+    upsertFlagC :: store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ()  data StoreHandle m = StoreHandle-    { storeHandleGetFlag       :: !(Text -> StoreResultM m (Maybe Flag))-    , storeHandleGetSegment    :: !(Text -> StoreResultM m (Maybe Segment))-    , storeHandleAllFlags      :: !(StoreResultM m (KeyMap Flag))-    , storeHandleInitialized   :: !(StoreResultM m Bool)-    , storeHandleInitialize    :: !(KeyMap (Versioned Flag) -> KeyMap (Versioned Segment) -> StoreResultM m ())-    , storeHandleUpsertSegment :: !(Text -> Versioned (Maybe Segment) -> StoreResultM m ())-    , storeHandleUpsertFlag    :: !(Text -> Versioned (Maybe Flag) -> StoreResultM m ())-    , storeHandleExpireAll     :: !(StoreResultM m ())-    } deriving (Generic)+    { storeHandleGetFlag :: !(Text -> StoreResultM m (Maybe Flag))+    , storeHandleGetSegment :: !(Text -> StoreResultM m (Maybe Segment))+    , storeHandleAllFlags :: !(StoreResultM m (KeyMap Flag))+    , storeHandleInitialized :: !(StoreResultM m Bool)+    , storeHandleInitialize :: !(KeyMap (ItemDescriptor Flag) -> KeyMap (ItemDescriptor Segment) -> StoreResultM m ())+    , storeHandleUpsertSegment :: !(Text -> ItemDescriptor (Maybe Segment) -> StoreResultM m ())+    , storeHandleUpsertFlag :: !(Text -> ItemDescriptor (Maybe Flag) -> StoreResultM m ())+    , storeHandleExpireAll :: !(StoreResultM m ())+    }+    deriving (Generic)  instance Monad m => LaunchDarklyStoreRead (StoreHandle m) m where-    getFlagC        = storeHandleGetFlag-    getSegmentC     = storeHandleGetSegment-    getAllFlagsC    = storeHandleAllFlags+    getFlagC = storeHandleGetFlag+    getSegmentC = storeHandleGetSegment+    getAllFlagsC = storeHandleAllFlags     getInitializedC = storeHandleInitialized  instance Monad m => LaunchDarklyStoreWrite (StoreHandle m) m where     storeInitializeC = storeHandleInitialize-    upsertSegmentC   = storeHandleUpsertSegment-    upsertFlagC      = storeHandleUpsertFlag+    upsertSegmentC = storeHandleUpsertSegment+    upsertFlagC = storeHandleUpsertFlag -initializeStore :: (LaunchDarklyStoreWrite store m, Monad m) => store-    -> KeyMap Flag -> KeyMap Segment -> StoreResultM m ()+initializeStore ::+    (LaunchDarklyStoreWrite store m, Monad m) =>+    store ->+    KeyMap Flag ->+    KeyMap Segment ->+    StoreResultM m () initializeStore store flags segments = storeInitializeC store (makeVersioned flags) (makeVersioned segments)-    where makeVersioned = mapValues (\f -> Versioned f (getField @"version" f))+  where+    makeVersioned = mapValues (\f -> ItemDescriptor f (getField @"version" f))  insertFlag :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Flag -> StoreResultM m ()-insertFlag store flag = upsertFlagC store (getField @"key" flag) $ Versioned (pure flag) (getField @"version" flag)+insertFlag store flag = upsertFlagC store (getField @"key" flag) $ ItemDescriptor (pure flag) (getField @"version" flag)  deleteFlag :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Text -> Natural -> StoreResultM m ()-deleteFlag store key version = upsertFlagC store key $ Versioned Nothing version+deleteFlag store key version = upsertFlagC store key $ ItemDescriptor Nothing version  insertSegment :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Segment -> StoreResultM m ()-insertSegment store segment = upsertSegmentC store (getField @"key" segment) $ Versioned (pure segment) (getField @"version" segment)+insertSegment store segment = upsertSegmentC store (getField @"key" segment) $ ItemDescriptor (pure segment) (getField @"version" segment)  deleteSegment :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Text -> Natural -> StoreResultM m ()-deleteSegment store key version = upsertSegmentC store key $ Versioned Nothing version+deleteSegment store key version = upsertSegmentC store key $ ItemDescriptor Nothing version -makeStoreIO :: Maybe StoreInterface -> TimeSpec -> IO (StoreHandle IO)+makeStoreIO :: Maybe PersistentDataStore -> TimeSpec -> IO (StoreHandle IO) makeStoreIO backend ttl = do-    state <- newIORef State-        { allFlags    = Expirable emptyObject True 0-        , flags       = emptyObject-        , segments    = emptyObject-        , initialized = Expirable False True 0-        }+    state <-+        newIORef+            State+                { allFlags = Expirable emptyObject True 0+                , features = emptyObject+                , segments = emptyObject+                , initialized = Expirable False True 0+                }     let store = Store state backend ttl-    pure StoreHandle-        { storeHandleGetFlag       = getFlag        store-        , storeHandleGetSegment    = getSegment     store-        , storeHandleAllFlags      = getAllFlags    store-        , storeHandleInitialized   = isInitialized  store-        , storeHandleInitialize    = initialize     store-        , storeHandleUpsertSegment = upsertSegment  store-        , storeHandleUpsertFlag    = upsertFlag     store-        , storeHandleExpireAll     = expireAllItems store >> (pure $ Right ())-        }+    pure+        StoreHandle+            { storeHandleGetFlag = getFlag store+            , storeHandleGetSegment = getSegment store+            , storeHandleAllFlags = getAllFlags store+            , storeHandleInitialized = isInitialized store+            , storeHandleInitialize = initialize store+            , storeHandleUpsertSegment = upsertSegment store+            , storeHandleUpsertFlag = upsertFlag store+            , storeHandleExpireAll = expireAllItems store >> (pure $ Right ())+            }  data Expirable a = Expirable-    { value       :: !a+    { value :: !a     , forceExpire :: !Bool-    , updatedOn   :: !TimeSpec-    } deriving (Generic)+    , updatedOn :: !TimeSpec+    }+    deriving (Generic) -data Versioned a = Versioned-    { value   :: !a+data ItemDescriptor a = ItemDescriptor+    { value :: !a     , version :: !Natural-    } deriving (Generic)+    }+    deriving (Generic) +-- The CacheableItem is used to store results from a persistent store.+--+-- The type is a Maybe because it is possible that a persistent store will not+-- have a record of a flag requested. We can store that result as a Nothing and+-- prevent subsequent evaluations from reaching across the network.+type CacheableItem a = Maybe (ItemDescriptor (Maybe a))+ data State = State-    { allFlags    :: !(Expirable (KeyMap Flag))-    , flags       :: !(KeyMap (Expirable (Versioned (Maybe Flag))))-    , segments    :: !(KeyMap (Expirable (Versioned (Maybe Segment))))+    { allFlags :: !(Expirable (KeyMap Flag))+    , features :: !(KeyMap (Expirable (CacheableItem Flag)))+    , segments :: !(KeyMap (Expirable (CacheableItem Segment)))     , initialized :: !(Expirable Bool)-    } deriving (Generic)+    }+    deriving (Generic)  -- | Represents the key for a given feature.-type FeatureKey       = Text--- | Represents a namespace such as flags or segments+type FeatureKey = Text++-- | Represents a namespace such as features or segments type FeatureNamespace = Text  -- | The interface implemented by external stores for use by the SDK.-data StoreInterface = StoreInterface-    { storeInterfaceAllFeatures   :: !(FeatureNamespace -> StoreResult (KeyMap RawFeature))-      -- ^ A map of all features in a given namespace including deleted.-    , storeInterfaceGetFeature    :: !(FeatureNamespace -> FeatureKey -> StoreResult RawFeature)-      -- ^ Return the value of a key in a namespace.-    , storeInterfaceUpsertFeature :: !(FeatureNamespace -> FeatureKey -> RawFeature -> StoreResult Bool)-      -- ^ Upsert a given feature. Versions should be compared before upsert.-      -- The result should indicate if the feature was replaced or not.-    , storeInterfaceIsInitialized :: !(StoreResult Bool)-      -- ^ Checks if the external store has been initialized, which may-      -- have been done by another instance of the SDK.-    , storeInterfaceInitialize    :: !(KeyMap (KeyMap RawFeature) -> StoreResult ())-      -- ^ A map of namespaces, and items in namespaces. The entire store state-      -- should be replaced with these values.+data PersistentDataStore = PersistentDataStore+    { persistentDataStoreAllFeatures :: !(FeatureNamespace -> StoreResult (KeyMap SerializedItemDescriptor))+    -- ^ A map of all features in a given namespace including deleted.+    , persistentDataStoreGetFeature :: !(FeatureNamespace -> FeatureKey -> StoreResult (Maybe SerializedItemDescriptor))+    -- ^ Return the value of a key in a namespace.+    , persistentDataStoreUpsertFeature :: !(FeatureNamespace -> FeatureKey -> SerializedItemDescriptor -> StoreResult Bool)+    -- ^ Upsert a given feature. Versions should be compared before upsert.+    -- The result should indicate if the feature was replaced or not.+    , persistentDataStoreIsInitialized :: !(StoreResult Bool)+    -- ^ Checks if the external store has been initialized, which may+    -- have been done by another instance of the SDK.+    , persistentDataStoreInitialize :: !(KeyMap (KeyMap SerializedItemDescriptor) -> StoreResult ())+    -- ^ A map of namespaces, and items in namespaces. The entire store state+    -- should be replaced with these values.     } --- | An abstract representation of a store object.-data RawFeature = RawFeature-    { rawFeatureBuffer  :: !(Maybe ByteString)-      -- ^ A serialized item. If the item is deleted or does not exist this-      -- should be `Nothing`.-    , rawFeatureVersion :: !Natural-      -- ^ The version of a given item. If the item does not exist this should-      -- be zero.+-- | A record representing an object that can be persisted in an external store.+data SerializedItemDescriptor = SerializedItemDescriptor+    { item :: !(Maybe ByteString)+    -- ^ A serialized item. If the item is deleted or does not exist this+    -- should be `Nothing`.+    , version :: !Natural+    -- ^ The version of a given item. If the item does not exist this should+    -- be zero.+    , deleted :: !Bool+    -- ^ True if this is a placeholder (tombstone) for a deleted item.     }+    deriving (Generic, Eq, Show) +-- |+-- Generate a 'ByteString' representation of the 'SerializedItemDescriptor'.+--+-- If the 'SerializedItemDescriptor' has either a 'Nothing' value, or is marked+-- as deleted, the ByteString representation will be a tombstone marker containing the version and deletion status.+--+-- Otherwise, the internal item representation is returned.+serializeWithPlaceholder :: SerializedItemDescriptor -> ByteString+serializeWithPlaceholder SerializedItemDescriptor {item = Nothing, version = version} = tombstonePlaceholder version+serializeWithPlaceholder SerializedItemDescriptor {deleted = True, version = version} = tombstonePlaceholder version+serializeWithPlaceholder SerializedItemDescriptor {item = Just item} = item++-- Generate the tombstone placeholder ByteString representation.+tombstonePlaceholder :: Natural -> ByteString+tombstonePlaceholder version = singleton "deleted" (Bool True) & insertKey "version" (toJSON version) & encode & toStrict++-- |+-- Partially decode the provided ByteString into a 'VersionedData' struct.+--+-- This is useful for persistent stores who need to perform version comparsions+-- before persisting data.+byteStringToVersionedData :: ByteString -> Maybe VersionedData+byteStringToVersionedData byteString = decode $ fromStrict byteString++data VersionedData = VersionedData+    { version :: !Natural+    , deleted :: !Bool+    }+    deriving (Generic, ToJSON, FromJSON)+ data Store = Store-    { state      :: !(IORef State)-    , backend    :: !(Maybe StoreInterface)+    { state :: !(IORef State)+    , backend :: !(Maybe PersistentDataStore)     , timeToLive :: !TimeSpec-    } deriving (Generic)+    }+    deriving (Generic)  expireAllItems :: Store -> IO ()-expireAllItems store = atomicModifyIORef' (getField @"state" store) $ \state -> (, ()) $ state-    & field @"allFlags"    %~ expire-    & field @"initialized" %~ expire-    & field @"flags"       %~ mapValues expire-    & field @"segments"    %~ mapValues expire-    where expire = setField @"forceExpire" True+expireAllItems store = atomicModifyIORef' (getField @"state" store) $ \state ->+    (,()) $+        state+            & field @"allFlags" %~ expire+            & field @"initialized" %~ expire+            & field @"features" %~ mapValues expire+            & field @"segments" %~ mapValues expire+  where+    expire = setField @"forceExpire" True  isExpired :: Store -> TimeSpec -> Expirable a -> Bool-isExpired store now item = (isJust $ getField @"backend" store) && ((getField @"forceExpire" item)-    || (getField @"timeToLive" store) + (getField @"updatedOn" item) < now)+isExpired store now item =+    (isJust $ getField @"backend" store)+        && ( (getField @"forceExpire" item)+                || (getField @"timeToLive" store) + (getField @"updatedOn" item) < now+           )  getMonotonicTime :: IO TimeSpec getMonotonicTime = getTime Monotonic -initialize :: Store -> KeyMap (Versioned Flag) -> KeyMap (Versioned Segment) -> StoreResult ()+initialize :: Store -> KeyMap (ItemDescriptor Flag) -> KeyMap (ItemDescriptor Segment) -> StoreResult () initialize store flags segments = case getField @"backend" store of-    Nothing      -> do-        atomicModifyIORef' (getField @"state" store) $ \state -> (, ()) $ state-            & setField @"flags"       (mapValues (\f -> Expirable f True 0) $ c flags)-            & setField @"segments"    (mapValues (\f -> Expirable f True 0) $ c segments)-            & setField @"allFlags"    (Expirable (mapValues (getField @"value") flags) True 0)-            & setField @"initialized" (Expirable True False 0)+    Nothing -> do+        atomicModifyIORef' (getField @"state" store) $ \state ->+            (,()) $+                state+                    & setField @"features" (mapValues (\f -> Expirable (Just f) True 0) $ c flags)+                    & setField @"segments" (mapValues (\f -> Expirable (Just f) True 0) $ c segments)+                    & setField @"allFlags" (Expirable (mapValues (getField @"value") flags) True 0)+                    & setField @"initialized" (Expirable True False 0)         pure $ Right ()-    Just backend -> (storeInterfaceInitialize backend) raw >>= \case-        Left err -> pure $ Left err-        Right () -> expireAllItems store >> pure (Right ())-    where-        raw = emptyObject-            & insertKey "flags"    (mapValues versionedToRaw $ c flags)-            & insertKey "segments" (mapValues versionedToRaw $ c segments)-        c x = mapValues (\f -> f & field @"value" %~ Just) x+    Just backend ->+        (persistentDataStoreInitialize backend) serializedItemMap >>= \case+            Left err -> pure $ Left err+            Right () -> expireAllItems store >> pure (Right ())+  where+    serializedItemMap =+        emptyObject+            & insertKey "features" (mapValues createSerializedItemDescriptor $ c flags)+            & insertKey "segments" (mapValues createSerializedItemDescriptor $ c segments)+    c x = mapValues (\f -> f & field @"value" %~ Just) x -rawToVersioned :: (FromJSON a) => RawFeature -> Maybe (Versioned (Maybe a))-rawToVersioned raw = case rawFeatureBuffer raw of-    Nothing     -> pure $ Versioned Nothing (rawFeatureVersion raw)-    Just buffer -> case decode $ fromStrict buffer of-        Nothing      -> Nothing-        Just decoded -> pure $ Versioned decoded (rawFeatureVersion raw)+serializedToItemDescriptor :: (FromJSON a, HasField' "version" a Natural) => SerializedItemDescriptor -> Either Text (ItemDescriptor (Maybe a))+serializedToItemDescriptor serializedItem = case getField @"item" serializedItem of+    Nothing -> pure $ ItemDescriptor Nothing (getField @"version" serializedItem)+    Just buffer -> do+        let versionedData = byteStringToVersionedData buffer+         in case versionedData of+                Nothing -> Left "failed decoding into VersionedData"+                Just VersionedData {deleted = True, version = version} -> pure $ ItemDescriptor Nothing version+                Just _ ->+                    let decodeResult = decode $ fromStrict buffer+                     in case decodeResult of+                            Nothing -> Left "failed decoding into ItemDescriptor"+                            Just decoded -> pure $ ItemDescriptor (Just decoded) (getField @"version" decoded) -versionedToRaw :: (ToJSON a) => Versioned (Maybe a) -> RawFeature-versionedToRaw versioned = case getField @"value" versioned of-    Nothing -> RawFeature Nothing $ getField @"version" versioned-    Just x  -> RawFeature (pure $ toStrict $ encode x) $ getField @"version" versioned+createSerializedItemDescriptor :: (ToJSON a) => ItemDescriptor (Maybe a) -> SerializedItemDescriptor+createSerializedItemDescriptor ItemDescriptor {value = Nothing, version} = SerializedItemDescriptor {item = Nothing, version, deleted = True}+createSerializedItemDescriptor ItemDescriptor {value = Just item, version} = SerializedItemDescriptor {item = Just $ toStrict $ encode item, version, deleted = False} -tryGetBackend :: (FromJSON a) => StoreInterface -> Text -> Text -> StoreResult (Versioned (Maybe a))+tryGetBackend :: (FromJSON a, HasField' "version" a Natural) => PersistentDataStore -> Text -> Text -> StoreResult (Maybe (ItemDescriptor (Maybe a))) tryGetBackend backend namespace key =-    ((storeInterfaceGetFeature backend) namespace key) >>= \case-        Left err  -> pure $ Left err-        Right raw -> case rawToVersioned raw of-            Nothing        -> pure $ Left "failed to decode from external store"-            Just versioned -> pure $ Right versioned+    ((persistentDataStoreGetFeature backend) namespace key) >>= \case+        Left err -> pure $ Left err+        Right Nothing -> pure $ Right Nothing+        Right (Just serializedItem) -> case serializedToItemDescriptor serializedItem of+            Left err -> pure $ Left err+            Right versioned -> pure $ Right $ Just versioned -getGeneric :: FromJSON a => Store -> Text -> Text-    -> Lens' State (KeyMap (Expirable (Versioned (Maybe a))))-    -> StoreResult (Maybe a)+getGeneric ::+    (FromJSON a, HasField' "version" a Natural) =>+    Store ->+    Text ->+    Text ->+    Lens' State (KeyMap (Expirable (CacheableItem a))) ->+    StoreResult (Maybe a) getGeneric store namespace key lens = do     state <- readIORef $ getField @"state" store     case getField @"backend" store of-        Nothing      -> case lookupKey key (state ^. lens) of+        Nothing -> case lookupKey key (state ^. lens) of             Nothing -> pure $ Right Nothing-            Just x  -> pure $ Right $ getField @"value" $ getField @"value" x+            Just cacheItem -> pure $ Right $ (getField @"value") =<< (getField @"value" cacheItem)         Just backend -> do             now <- getMonotonicTime             case lookupKey key (state ^. lens) of                 Nothing -> updateFromBackend backend now-                Just x  -> if isExpired store now x-                    then updateFromBackend backend now-                    else pure $ Right $ getField @"value" $ getField @"value" x-    where-        updateFromBackend backend now = tryGetBackend backend namespace key >>= \case+                Just cacheItem ->+                    if isExpired store now cacheItem+                        then updateFromBackend backend now+                        else pure $ Right $ (getField @"value") =<< (getField @"value" cacheItem)+  where+    updateFromBackend backend now =+        tryGetBackend backend namespace key >>= \case             Left err -> pure $ Left err-            Right v  -> do-                atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $ stateRef & lens %~-                    (insertKey key (Expirable v False now))+            Right Nothing -> do+                atomicModifyIORef' (getField @"state" store) $ \stateRef ->+                    (,()) $+                        stateRef+                            & lens+                                %~ (insertKey key (Expirable Nothing False now))+                pure $ Right Nothing+            Right (Just v) -> do+                atomicModifyIORef' (getField @"state" store) $ \stateRef ->+                    (,()) $+                        stateRef+                            & lens+                                %~ (insertKey key (Expirable (Just v) False now))                 pure $ Right $ getField @"value" v  getFlag :: Store -> Text -> StoreResult (Maybe Flag)-getFlag store key = getGeneric store "flags" key (field @"flags")+getFlag store key = getGeneric store "features" key (field @"features")  getSegment :: Store -> Text -> StoreResult (Maybe Segment) getSegment store key = getGeneric store "segments" key (field @"segments") -upsertGeneric :: (ToJSON a) => Store -> Text -> Text -> Versioned (Maybe a)-    -> Lens' State (KeyMap (Expirable (Versioned (Maybe a))))-    -> (Bool -> State -> State)-    -> StoreResult ()+upsertGeneric ::+    (ToJSON a) =>+    Store ->+    Text ->+    Text ->+    ItemDescriptor (Maybe a) ->+    Lens' State (KeyMap (Expirable (CacheableItem a))) ->+    (Bool -> State -> State) ->+    StoreResult () upsertGeneric store namespace key versioned lens action = do     case getField @"backend" store of-        Nothing      -> do-            void $ atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $ upsertMemory stateRef+        Nothing -> do+            void $ atomicModifyIORef' (getField @"state" store) $ \stateRef -> (,()) $ upsertMemory stateRef             pure $ Right ()         Just backend -> do-            result <- (storeInterfaceUpsertFeature backend) namespace key (versionedToRaw versioned)+            result <- (persistentDataStoreUpsertFeature backend) namespace key (createSerializedItemDescriptor versioned)             case result of-                Left err      -> pure $ Left err-                Right updated -> if not updated then pure (Right ()) else do-                    now <- getMonotonicTime-                    void $ atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $ stateRef-                        & lens %~ (insertKey key (Expirable versioned False now))-                        & action True-                    pure $ Right ()-    where-        upsertMemory state = case lookupKey key (state ^. lens) of-            Nothing       -> updateMemory state-            Just existing -> if (getField @"version" $ getField @"value" existing) < getField @"version" versioned-                then updateMemory state else state-        updateMemory state = state-            & lens %~ (insertKey key (Expirable versioned False 0))+                Left err -> pure $ Left err+                Right updated ->+                    if not updated+                        then pure (Right ())+                        else do+                            now <- getMonotonicTime+                            void $ atomicModifyIORef' (getField @"state" store) $ \stateRef ->+                                (,()) $+                                    stateRef+                                        & lens %~ (insertKey key (Expirable (Just versioned) False now))+                                        & action True+                            pure $ Right ()+  where+    upsertMemory state = case lookupKey key (state ^. lens) of+        Nothing -> updateMemory state+        Just cacheItem -> case getField @"value" cacheItem of+            Nothing -> updateMemory state+            Just existing ->+                if (getField @"version" existing) < getField @"version" versioned+                    then updateMemory state+                    else state+    updateMemory state =+        state+            & lens %~ (insertKey key (Expirable (Just versioned) False 0))             & action False -upsertFlag :: Store -> Text -> Versioned (Maybe Flag) -> StoreResult ()-upsertFlag store key versioned = upsertGeneric store "flags" key versioned (field @"flags") postAction where-    postAction external state = if external-        then state & field @"allFlags" %~ (setField @"forceExpire" True)-        else state & (field @"allFlags" . field @"value") %~ updateAllFlags+upsertFlag :: Store -> Text -> ItemDescriptor (Maybe Flag) -> StoreResult ()+upsertFlag store key versioned = upsertGeneric store "features" key versioned (field @"features") postAction+  where+    postAction external state =+        if external+            then state & field @"allFlags" %~ (setField @"forceExpire" True)+            else state & (field @"allFlags" . field @"value") %~ updateAllFlags     updateAllFlags allFlags = case getField @"value" versioned of-        Nothing   -> deleteKey key allFlags+        Nothing -> deleteKey key allFlags         Just flag -> insertKey key flag allFlags -upsertSegment :: Store -> Text -> Versioned (Maybe Segment) -> StoreResult ()-upsertSegment store key versioned = upsertGeneric store "segments" key versioned (field @"segments") postAction where+upsertSegment :: Store -> Text -> ItemDescriptor (Maybe Segment) -> StoreResult ()+upsertSegment store key versioned = upsertGeneric store "segments" key versioned (field @"segments") postAction+  where     postAction _ state = state -filterAndCacheFlags :: Store -> TimeSpec -> KeyMap RawFeature -> IO (KeyMap Flag)-filterAndCacheFlags store now raw = do-    let decoded  = mapMaybeValues rawToVersioned raw+filterAndCacheFlags :: Store -> TimeSpec -> KeyMap SerializedItemDescriptor -> IO (KeyMap Flag)+filterAndCacheFlags store now serializedMap = do+    let decoded = mapMaybeValues (eitherToMaybe . serializedToItemDescriptor) serializedMap         allFlags = mapMaybeValues (getField @"value") decoded-    atomicModifyIORef' (getField @"state" store) $ \state -> (, ()) $-        setField @"allFlags" (Expirable allFlags False now) $-            setField @"flags" (mapValues (\x -> Expirable x False now) decoded) state+    atomicModifyIORef' (getField @"state" store) $ \state ->+        (,()) $+            setField @"allFlags" (Expirable allFlags False now) $+                setField @"features" (mapValues (\x -> Expirable (Just x) False now) decoded) state     pure allFlags  getAllFlags :: Store -> StoreResult (KeyMap Flag)@@ -314,17 +427,17 @@     state <- readIORef $ getField @"state" store     let memoryFlags = pure $ Right $ getField @"value" $ getField @"allFlags" state     case getField @"backend" store of-        Nothing      -> memoryFlags+        Nothing -> memoryFlags         Just backend -> do             now <- getMonotonicTime             if not (isExpired store now $ getField @"allFlags" state)                 then memoryFlags                 else do-                    result <- (storeInterfaceAllFeatures backend) "flags"+                    result <- (persistentDataStoreAllFeatures backend) "features"                     case result of-                        Left err  -> pure (Left err)-                        Right raw -> do-                            filtered <- filterAndCacheFlags store now raw+                        Left err -> pure (Left err)+                        Right serializedMap -> do+                            filtered <- filterAndCacheFlags store now serializedMap                             pure (Right filtered)  isInitialized :: Store -> StoreResult Bool@@ -334,16 +447,17 @@     if getField @"value" initialized         then pure $ Right True         else case getField @"backend" store of-            Nothing      -> pure $ Right False+            Nothing -> pure $ Right False             Just backend -> do                 now <- getMonotonicTime                 if isExpired store now initialized                     then do-                        result <- storeInterfaceIsInitialized backend+                        result <- persistentDataStoreIsInitialized backend                         case result of                             Left err -> pure $ Left err-                            Right i  -> do-                                atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $-                                    setField @"initialized" (Expirable i False now) stateRef+                            Right i -> do+                                atomicModifyIORef' (getField @"state" store) $ \stateRef ->+                                    (,()) $+                                        setField @"initialized" (Expirable i False now) stateRef                                 pure $ Right i                     else pure $ Right False
− src/LaunchDarkly/Server/User.hs 
@@ -1,94 +0,0 @@--- | This module is for configuration of the user object.--module LaunchDarkly.Server.User-    ( User-    , makeUser-    , userSetKey-    , userSetSecondary-    , userSetIP-    , userSetCountry-    , userSetEmail-    , userSetFirstName-    , userSetLastName-    , userSetAvatar-    , userSetName-    , userSetAnonymous-    , userSetCustom-    , userSetPrivateAttributeNames-    ) where--import Data.Aeson                        (Value)-import Data.Generics.Product             (setField)-import Data.HashMap.Strict               (HashMap)-import Data.Set                          (Set)-import Data.Text                         (Text)--import LaunchDarkly.Server.User.Internal (User(..), mapUser, UserI(..))---- | Creates a new user identified by the given key.-makeUser :: Text -> User-makeUser key = User $ UserI-    { key                   = key-    , secondary             = mempty-    , ip                    = mempty-    , country               = mempty-    , email                 = mempty-    , firstName             = mempty-    , lastName              = mempty-    , avatar                = mempty-    , name                  = mempty-    , anonymous             = False-    , custom                = mempty-    , privateAttributeNames = mempty-    }---- | Set the primary key for a user.-userSetKey :: Text -> User -> User-userSetKey = mapUser . setField @"key"---- | Set the secondary key for a user.-userSetSecondary :: Maybe Text -> User -> User-userSetSecondary = mapUser . setField @"secondary"---- | Set the IP for a user.-userSetIP :: Maybe Text -> User -> User-userSetIP = mapUser . setField @"ip"---- | Set the country for a user.-userSetCountry :: Maybe Text -> User -> User-userSetCountry = mapUser . setField @"country"---- | Set the email for a user.-userSetEmail :: Maybe Text -> User -> User-userSetEmail = mapUser . setField @"email"---- | Set the first name for a user.-userSetFirstName :: Maybe Text -> User -> User-userSetFirstName = mapUser . setField @"firstName"---- | Set the last name for a user.-userSetLastName :: Maybe Text -> User -> User-userSetLastName = mapUser . setField @"lastName"---- | Set the avatar for a user.-userSetAvatar :: Maybe Text -> User -> User-userSetAvatar = mapUser . setField @"avatar"---- | Set the name for a user.-userSetName :: Maybe Text -> User -> User-userSetName = mapUser . setField @"name"---- | Set if the user is anonymous or not.-userSetAnonymous :: Bool -> User -> User-userSetAnonymous = mapUser . setField @"anonymous"---- | Set custom fields for a user.-userSetCustom :: HashMap Text Value -> User -> User-userSetCustom = mapUser . setField @"custom"---- | This contains list of attributes to keep private, whether they appear at--- the top-level or Custom The attribute "key" is always sent regardless of--- whether it is in this list, and "custom" cannot be used to eliminate all--- custom attributes-userSetPrivateAttributeNames :: Set Text -> User -> User-userSetPrivateAttributeNames = mapUser . setField @"privateAttributeNames"
− src/LaunchDarkly/Server/User/Internal.hs 
@@ -1,128 +0,0 @@-module LaunchDarkly.Server.User.Internal-    ( User(..)-    , mapUser-    , UserI(..)-    , valueOf-    , userSerializeRedacted-    ) where--import           Data.Aeson                          (FromJSON, ToJSON, Value(..), (.:), (.:?), withObject, object, parseJSON, toJSON)-import           Data.Foldable                       (fold)-import           Data.Generics.Product               (getField)-import qualified Data.HashMap.Strict as              HM-import           Data.HashMap.Strict                 (HashMap)-import qualified Data.Set as                         S-import           Data.Set                            (Set)-import           Data.Text                           (Text)-import           Data.Vector                         ()-import           GHC.Generics                        (Generic)--import           LaunchDarkly.AesonCompat            (KeyMap, adjustKey, keyToText, deleteKey, filterKeys, insertKey, objectKeys)-import           LaunchDarkly.Server.Config.Internal (ConfigI)--mapUser :: (UserI -> UserI) -> User -> User-mapUser f (User c) = User $ f c---- | User contains specific attributes of a user of your application------ The only mandatory property is the Key, which must uniquely identify--- each user. For authenticated users, this may be a username or e-mail address.--- For anonymous users, this could be an IP address or session ID.-newtype User = User { unwrapUser :: UserI }--data UserI = UserI-    { key                   :: !Text-    , secondary             :: !(Maybe Text)-    , ip                    :: !(Maybe Text)-    , country               :: !(Maybe Text)-    , email                 :: !(Maybe Text)-    , firstName             :: !(Maybe Text)-    , lastName              :: !(Maybe Text)-    , avatar                :: !(Maybe Text)-    , name                  :: !(Maybe Text)-    , anonymous             :: !Bool-    , custom                :: !(HashMap Text Value)-    , privateAttributeNames :: !(Set Text)-    } deriving (Generic)--falseToNothing :: Bool -> Maybe Bool-falseToNothing x = if x then pure x else Nothing--emptyToNothing :: (Eq m, Monoid m) => m -> Maybe m-emptyToNothing x = if x == mempty then mempty else pure x--instance FromJSON UserI where-    parseJSON = withObject "User" $ \o -> UserI-        <$> o .:  "key"-        <*> o .:? "secondary"-        <*> o .:? "ip"-        <*> o .:? "country"-        <*> o .:? "email"-        <*> o .:? "firstName"-        <*> o .:? "lastName"-        <*> o .:? "avatar"-        <*> o .:? "name"-        <*> fmap or (o .:? "anonymous")-        <*> fmap fold (o .:? "custom")-        <*> fmap fold (o .:? "privateAttributeNames")--instance ToJSON UserI where-    toJSON user = object $ filter ((/=) Null . snd)-        [ ("key",                   toJSON $                  getField @"key"                   user)-        , ("secondary",             toJSON $                  getField @"secondary"             user)-        , ("ip",                    toJSON $                  getField @"ip"                    user)-        , ("country",               toJSON $                  getField @"country"               user)-        , ("email",                 toJSON $                  getField @"email"                 user)-        , ("firstName",             toJSON $                  getField @"firstName"             user)-        , ("lastName",              toJSON $                  getField @"lastName"              user)-        , ("avatar",                toJSON $                  getField @"avatar"                user)-        , ("name",                  toJSON $                  getField @"name"                  user)-        , ("anonymous",             toJSON $ falseToNothing $ getField @"anonymous"             user)-        , ("custom",                toJSON $ emptyToNothing $ getField @"custom"                user)-        , ("privateAttributeNames", toJSON $ emptyToNothing $ getField @"privateAttributeNames" user)-        ]--valueOf :: UserI -> Text -> Maybe Value-valueOf user attribute = case attribute of-    "key"       -> pure $ String $ getField @"key" user-    "secondary" -> String <$> getField @"secondary" user-    "ip"        -> String <$> getField @"ip" user-    "country"   -> String <$> getField @"country" user-    "email"     -> String <$> getField @"email" user-    "firstName" -> String <$> getField @"firstName" user-    "lastName"  -> String <$> getField @"lastName" user-    "avatar"    -> String <$> getField @"avatar" user-    "name"      -> String <$> getField @"name" user-    "anonymous" -> pure $ Bool $ getField @"anonymous" user-    x           -> HM.lookup x $ getField @"custom" user--userSerializeRedacted :: ConfigI -> UserI -> Value-userSerializeRedacted config user = if getField @"allAttributesPrivate" config-    then userSerializeAllPrivate user-    else userSerializeRedactedNotAllPrivate (getField @"privateAttributeNames" config) user--fromObject :: Value -> KeyMap Value-fromObject x = case x of (Object o) -> o; _ -> error "expected object"--keysToSet :: KeyMap v -> Set Text-keysToSet = S.fromList . objectKeys--setPrivateAttrs :: Set Text -> KeyMap Value -> Value-setPrivateAttrs private redacted-  | S.null private = Object redacted-  | otherwise = Object $ insertKey "privateAttrs" (toJSON private) redacted--redact :: Set Text -> KeyMap Value -> KeyMap Value-redact private = filterKeys (\k -> S.notMember (keyToText k) private)--userSerializeAllPrivate :: UserI -> Value-userSerializeAllPrivate user = setPrivateAttrs private (redact private raw) where-    raw     = deleteKey "custom" $ deleteKey "privateAttributeNames" $ fromObject $ toJSON user-    private = S.delete "anonymous" $ S.delete "key" $ S.union (keysToSet raw) (S.fromList $ HM.keys $ getField @"custom" user)--userSerializeRedactedNotAllPrivate :: Set Text -> UserI -> Value-userSerializeRedactedNotAllPrivate globalPrivate user = setPrivateAttrs private redacted where-    raw      = deleteKey "privateAttributeNames" $ fromObject $ toJSON user-    keys     = S.union (keysToSet raw) (keysToSet $ fromObject $ toJSON $ getField @"custom" user)-    private  = S.intersection keys (S.union globalPrivate $ getField @"privateAttributeNames" user)-    redacted = adjustKey (Object . redact private . fromObject) "custom" $ redact private raw
− stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis.hs 
@@ -1,8 +0,0 @@-module LaunchDarkly.Server.Store.Redis-    ( RedisStoreConfig-    , makeRedisStoreConfig-    , redisConfigSetNamespace-    , makeRedisStore-    ) where--import LaunchDarkly.Server.Store.Redis.Internal
− stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs 
@@ -1,134 +0,0 @@--- | The public interface for the LaunchDarkly Haskell Redis integration--module LaunchDarkly.Server.Store.Redis.Internal-    ( RedisStoreConfig-    , makeRedisStoreConfig-    , redisConfigSetNamespace-    , makeRedisStore-    , redisUpsertInternal-    ) where--import           Data.Maybe                 (isJust)-import           Control.Monad              (forM_, void)-import           Control.Monad.Catch        (MonadCatch, Exception, catches, Handler(..))-import           Control.Exception          (throwIO)-import           Control.Monad.IO.Class     (MonadIO, liftIO)-import           Data.Aeson                 (FromJSON, ToJSON, decode, encode)-import           Data.ByteString            (ByteString)-import           Data.ByteString.Lazy       (toStrict, fromStrict)-import           Data.Text                  (Text)-import qualified Data.Text as               T-import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)-import           Data.Typeable              (Typeable)-import           Data.Generics.Product      (getField, setField)-import           Database.Redis             (ConnectionLostException, Reply, multiExec, runRedis, del, get-                                            , set, hget, hgetall, hset, watch, Redis, Connection, TxResult(..))-import           GHC.Natural                (Natural)-import           GHC.Generics               (Generic)--import           LaunchDarkly.Server.Store  (StoreInterface(..), RawFeature(..), StoreResult(..))-import           LaunchDarkly.AesonCompat   (KeyMap, mapValues, toList, fromList, objectKeys)--data MinimalFeature = MinimalFeature-    { key     :: Text-    , version :: Natural-    , deleted :: Bool-    } deriving (Generic, ToJSON, FromJSON)---- | Opaque type used to configure the Redis store integration.-data RedisStoreConfig = RedisStoreConfig-    { namespace  :: Text-    , connection :: Connection-    }---- | Create a default config from a given connection pool.-makeRedisStoreConfig :: Connection -> RedisStoreConfig-makeRedisStoreConfig connection = RedisStoreConfig-    { namespace  = "LaunchDarkly"-    , connection = connection-    }---- | Configure the Redis key prefix. All keys are prefixed by default before--- being inserted into Redis. The default prefix is "LaunchDarkly".-redisConfigSetNamespace :: Text -> RedisStoreConfig -> RedisStoreConfig-redisConfigSetNamespace namespace' config = config { namespace = namespace' }---- | Construct a `StoreInterface` that can then be used during SDK--- configuration.-makeRedisStore :: RedisStoreConfig -> IO StoreInterface-makeRedisStore config = pure StoreInterface-    { storeInterfaceUpsertFeature = redisUpsert        config-    , storeInterfaceGetFeature    = redisGetFeature    config-    , storeInterfaceInitialize    = redisInitialize    config-    , storeInterfaceIsInitialized = redisIsInitialized config-    , storeInterfaceAllFeatures   = redisGetAll        config-    }--data RedisError = RedisError Text deriving (Typeable, Show, Exception)--makeKey :: RedisStoreConfig -> Text -> ByteString-makeKey config key = encodeUtf8 $ T.concat [namespace config, ":", key]--exceptOnReply :: (MonadIO m) => Either Reply a -> m a-exceptOnReply =  \case-    Left err -> liftIO $ throwIO $ RedisError $ T.pack $ show err-    Right x  -> pure x--run :: RedisStoreConfig -> Redis a -> StoreResult a-run config action = catches (runRedis (connection config) action >>= pure . pure)-    [ Handler $ \(e :: ConnectionLostException) -> pure $ Left $ T.pack $ show e-    , Handler $ \(RedisError err) -> pure $ Left err-    ]--decodeMinimal :: ByteString -> Maybe MinimalFeature-decodeMinimal = decode . fromStrict--rawToOpaque :: ByteString -> RawFeature-rawToOpaque raw = case decodeMinimal raw of-    Nothing      -> RawFeature Nothing 0-    Just decoded -> RawFeature (if getField @"deleted" decoded then Nothing else pure raw)-        (getField @"version" decoded)--opaqueToRep :: Text -> RawFeature -> ByteString-opaqueToRep key opaque = case rawFeatureBuffer opaque of-    Just buffer -> buffer-    Nothing     -> toStrict $ encode $ MinimalFeature key (rawFeatureVersion opaque) True--redisInitialize :: RedisStoreConfig -> KeyMap (KeyMap RawFeature) -> StoreResult ()-redisInitialize config values = run config $ do-    del (map (makeKey config) $ objectKeys values) >>= void . exceptOnReply-    forM_ (toList values) $ \(kind, features) -> forM_ (toList features) $ \(key, feature) ->-        (hset (makeKey config kind) (encodeUtf8 key) $ opaqueToRep key feature) >>= void . exceptOnReply-    set (makeKey config "$inited") "" >>= void . exceptOnReply--redisUpsert :: RedisStoreConfig -> Text -> Text -> RawFeature -> StoreResult Bool-redisUpsert = redisUpsertInternal (pure ())--redisUpsertInternal :: IO () -> RedisStoreConfig -> Text -> Text -> RawFeature -> StoreResult Bool-redisUpsertInternal hook config kind key opaque = run config tryUpsert where-    tryUpsert = watch [space] >>= void . exceptOnReply >>-        hget space (encodeUtf8 key) >>= exceptOnReply >>= \x -> (liftIO hook) >> case x of-            Nothing    -> doInsert-            (Just raw) -> case decodeMinimal raw of-                Nothing      -> pure True-                Just decoded -> if getField @"version" decoded >= rawFeatureVersion opaque-                    then pure False else doInsert-    space     = makeKey config kind-    doInsert  = multiExec (hset space (encodeUtf8 key) (opaqueToRep key opaque)) >>= \case-        TxSuccess _ -> pure True-        TxError err -> liftIO $ throwIO $ RedisError $ T.pack $ show err-        TxAborted   -> tryUpsert--redisGetFeature :: RedisStoreConfig -> Text -> Text -> StoreResult RawFeature-redisGetFeature config kind key = run config $ hget (makeKey config kind) (encodeUtf8 key)-    >>= exceptOnReply >>= \case-        Nothing    -> pure $ RawFeature Nothing 0-        (Just raw) -> pure $ rawToOpaque raw--redisIsInitialized :: RedisStoreConfig -> StoreResult Bool-redisIsInitialized config = run config $ get (makeKey config "$inited")-    >>= exceptOnReply >>= pure . isJust--redisGetAll :: RedisStoreConfig -> Text -> StoreResult (KeyMap RawFeature)-redisGetAll config kind = run config $ hgetall (makeKey config kind)-    >>= exceptOnReply >>= pure . mapValues rawToOpaque . fromList . map (\(k, v) -> (decodeUtf8 k, v))
+ test-data/filesource/targets.json view
@@ -0,0 +1,32 @@+{+  "flags": {+    "flag1": {+      "key": "flag1",+      "on": true,+      "targets": [+          {+              "values": ["user1"],+              "variation": 0+          }+      ],+      "contextTargets": [+          {+              "values": [],+              "variation": 0,+              "contextKind": "user"+          },+          {+              "values": ["org1"],+              "variation": 1,+              "contextKind": "org"+          }+      ],+      "fallthrough": {+        "variation": 3+      },+	  "variations": [ "user", "org", "fall" ]+    }+  },+  "flagValues": {},+  "segments": {}+}
test/Spec.hs view
@@ -1,39 +1,44 @@ module Main where -import           Control.Monad (void)-import           Test.HUnit    (runTestTT, Test(TestList, TestLabel))+import Test.HUnit (Counts (..), Test (TestLabel, TestList), runTestTT) +import Control.Monad.Cont (when) import qualified Spec.Bucket+import qualified Spec.Client import qualified Spec.Config+import qualified Spec.Context+import qualified Spec.DataSource import qualified Spec.Evaluate import qualified Spec.Features+import qualified Spec.Integrations.FileData+import qualified Spec.Integrations.TestData import qualified Spec.Operators-import qualified Spec.Redis+import qualified Spec.PersistentDataStore+import qualified Spec.Reference import qualified Spec.Segment import qualified Spec.Store-import qualified Spec.StoreInterface-import qualified Spec.Redis-import qualified Spec.DataSource-import qualified Spec.Integrations.FileData import qualified Spec.Streaming-import qualified Spec.User-import qualified Spec.Integrations.TestData+import System.Exit (ExitCode (ExitFailure), exitWith)  main :: IO ()-main = void $ runTestTT $ TestList-    [ Spec.Bucket.allTests-    , Spec.Config.allTests-    , Spec.Evaluate.allTests-    , Spec.Features.allTests-    , Spec.Operators.allTests-    , Spec.Redis.allTests-    , Spec.Segment.allTests-    , Spec.Store.allTests-    , Spec.StoreInterface.allTests-    , Spec.DataSource.allTests-    , Spec.Redis.allTests-    , Spec.Streaming.allTests-    , Spec.User.allTests-    , TestLabel "Integration.FileData" Spec.Integrations.FileData.allTests-    , TestLabel "Integration.TestData" Spec.Integrations.TestData.allTests-    ]+main = do+    Counts {..} <-+        runTestTT $+            TestList+                [ Spec.Bucket.allTests+                , Spec.Client.allTests+                , Spec.Config.allTests+                , Spec.Context.allTests+                , Spec.DataSource.allTests+                , Spec.Evaluate.allTests+                , Spec.Features.allTests+                , Spec.Operators.allTests+                , Spec.Reference.allTests+                , Spec.Segment.allTests+                , Spec.Store.allTests+                , Spec.PersistentDataStore.allTests+                , Spec.Streaming.allTests+                , TestLabel "Integration.FileData" Spec.Integrations.FileData.allTests+                , TestLabel "Integration.TestData" Spec.Integrations.TestData.allTests+                ]+    when (errors + failures > 0) $ exitWith (ExitFailure 1)
test/Spec/Bucket.hs view
@@ -1,82 +1,89 @@ module Spec.Bucket (allTests) where -import           Test.HUnit-import           Data.Aeson.Types                  (Value(..))-import qualified Data.HashMap.Strict as            HM-import           Data.HashMap.Strict               (HashMap)-import           Data.Function                     ((&))+import Data.Aeson.Types (Value (..))+import Data.Function ((&))+import Test.HUnit -import           LaunchDarkly.Server.User-import           LaunchDarkly.Server.User.Internal-import           LaunchDarkly.Server.Client-import           LaunchDarkly.Server.Features-import           LaunchDarkly.Server.Evaluate+import LaunchDarkly.Server.Context (makeContext, withAttribute)+import LaunchDarkly.Server.Evaluate+import LaunchDarkly.Server.Features  testBucketUserByKey :: Test-testBucketUserByKey = TestList-    [ 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)-    ]+testBucketUserByKey =+    TestList+        [ TestCase $ assertEqual "bucket one" (Just 0.42157587) (bucketContext (makeContext "userKeyA" "user") (Just "user") "hashKey" "key" "saltyA" Nothing)+        , TestCase $ assertEqual "bucket two" (Just 0.6708485) (bucketContext (makeContext "userKeyB" "user") (Just "user") "hashKey" "key" "saltyA" Nothing)+        , TestCase $ assertEqual "bucket three" (Just 0.10343106) (bucketContext (makeContext "userKeyC" "user") (Just "user") "hashKey" "key" "saltyA" Nothing)+        ] +testBucketUserByUnknownKind :: Test+testBucketUserByUnknownKind =+    TestList+        [ TestCase $ assertEqual "bucket one" (Just 0.42157587) (bucketContext (makeContext "userKeyA" "user") (Just "user") "hashKey" "key" "saltyA" Nothing)+        , TestCase $ assertEqual "bucket one" Nothing (bucketContext (makeContext "userKeyA" "org") (Just "user") "hashKey" "key" "saltyA" Nothing)+        , TestCase $ assertEqual "bucket one" Nothing (bucketContext (makeContext "userKeyA" "user") (Just "org") "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))-    ]+testBucketUserWithSeed =+    TestList+        [ TestCase $ assertEqual "bucket one" (Just 0.09801207) (bucketContext (makeContext "userKeyA" "user") (Just "user") "hashKey" "key" "saltyA" (Just 61))+        , TestCase $ assertEqual "bucket two" (Just 0.14483777) (bucketContext (makeContext "userKeyB" "user") (Just "user") "hashKey" "key" "saltyA" (Just 61))+        , TestCase $ assertEqual "bucket three" (Just 0.9242641) (bucketContext (makeContext "userKeyC" "user") (Just "user") "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" Nothing-    , TestCase $ assertEqual "stringAttr" 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyD")-        & userSetCustom (HM.singleton "stringAttr" (String "33333"))) "hashKey" "stringAttr" "saltyA" Nothing-    ]+testBucketUserByIntAttr =+    TestList+        [ TestCase $ assertEqual "intAttr" (Just 0.54771423) $ bucketContext (makeContext "userKeyD" "user" & withAttribute "intAttr" (Number 33333)) (Just "user") "hashKey" "intAttr" "saltyA" Nothing+        , TestCase $ assertEqual "stringAttr" (Just 0.54771423) $ bucketContext (makeContext "userKeyD" "user" & withAttribute "stringAttr" (String "33333")) (Just "user") "hashKey" "stringAttr" "saltyA" Nothing+        ]  testBucketUserByFloatAttrNotAllowed :: Test-testBucketUserByFloatAttrNotAllowed = (~=?) 0 $ bucketUser (unwrapUser $ (makeUser "userKeyE")-    & userSetCustom (HM.singleton "floatAttr" (Number 999.999))) "hashKey" "floatAttr" "saltyA" Nothing+testBucketUserByFloatAttrNotAllowed = (~=?) (Just 0) $ bucketContext (makeContext "userKeyE" "user" & withAttribute "floatAttr" (Number 999.999)) (Just "user") "hashKey" "floatAttr" "saltyA" Nothing  testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed :: Test-testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed = (~=?) 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyE")-    & userSetCustom (HM.singleton "floatAttr" (Number 33333))) "hashKey" "floatAttr" "saltyA" Nothing+testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed = (~=?) (Just 0.54771423) $ bucketContext (makeContext "userKeyE" "user" & withAttribute "floatAttr" (Number 33333)) (Just "user") "hashKey" "floatAttr" "saltyA" Nothing  testVariationIndexForUser :: Test testVariationIndexForUser = TestCase $ do-    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--    rollout = VariationOrRollout-        { 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-                    }-                ]+    assertEqual "test" (Just 0, False) $ variationIndexForContext rollout (makeContext "userKeyA" "user") "hashKey" "saltyA"+    assertEqual "test" (Just 1, True) $ variationIndexForContext rollout (makeContext "userKeyB" "user") "hashKey" "saltyA"+    assertEqual "test" (Just 0, False) $ variationIndexForContext rollout (makeContext "userKeyC" "user") "hashKey" "saltyA"+  where+    rollout =+        VariationOrRollout+            { variation = Nothing+            , rollout =+                Just+                    Rollout+                        { bucketBy = Nothing+                        , seed = Nothing+                        , kind = RolloutKindExperiment+                        , contextKind = Just "user"+                        , variations =+                            [ WeightedVariation+                                { variation = 0+                                , weight = 60000+                                , untracked = True+                                }+                            , WeightedVariation+                                { variation = 1+                                , weight = 40000+                                , untracked = False+                                }+                            ]+                        }             }-        }  allTests :: Test-allTests = TestList-    [ testBucketUserByKey-    , testBucketUserWithSeed-    , testBucketUserByIntAttr-    , testBucketUserByFloatAttrNotAllowed-    , testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed-    , testVariationIndexForUser-    ]+allTests =+    TestList+        [ testBucketUserByKey+        , testBucketUserByUnknownKind+        , testBucketUserWithSeed+        , testBucketUserByIntAttr+        , testBucketUserByFloatAttrNotAllowed+        , testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed+        , testVariationIndexForUser+        ]
+ test/Spec/Client.hs view
@@ -0,0 +1,39 @@+module Spec.Client (allTests) where++import Data.Function ((&))+import Data.Generics.Product (getField)+import Test.HUnit++import LaunchDarkly.Server.Client+import LaunchDarkly.Server.Config+import LaunchDarkly.Server.Context+import LaunchDarkly.Server.Store.Internal++import Data.Text (Text)++makeEmptyStore :: IO (StoreHandle IO)+makeEmptyStore = do+    handle <- makeStoreIO Nothing 0+    initializeStore handle mempty mempty+    pure handle++testSecureModeHashIsGeneratedCorrectly :: Test+testSecureModeHashIsGeneratedCorrectly = TestCase $ do+    client <- makeTestClient "secret"+    assertEqual "" "aa747c502a898200f9e4fa21bac68136f886a0e27aec70ba06daf2e2a5cb5597" (secureModeHash client userContext)+    assertEqual "" "a045e65c6d23bda4559ed4f2371a2508ce63016ceff58b00aa07b435e2bfedaa" (secureModeHash client orgContext)+  where+    userContext = makeContext "Message" "user"+    orgContext = makeContext "Message" "org"++makeTestClient :: Text -> IO Client+makeTestClient sdkKey = do+    client <- makeClient $ (makeConfig sdkKey) & configSetOffline True+    initializeStore (getField @"store" client) mempty mempty+    pure client++allTests :: Test+allTests =+    TestList+        [ testSecureModeHashIsGeneratedCorrectly+        ]
test/Spec/Config.hs view
@@ -1,8 +1,9 @@ module Spec.Config (allTests) where-import Test.HUnit-import LaunchDarkly.Server (makeApplicationInfo)-import LaunchDarkly.Server.Config.Internal (makeApplicationInfo, withApplicationValue, getApplicationInfoHeader)+ import Control.Lens ((&))+import LaunchDarkly.Server (makeApplicationInfo)+import LaunchDarkly.Server.Config.Internal (getApplicationInfoHeader, withApplicationValue)+import Test.HUnit  testEmptyApplicationInfoGeneratesNoHeader :: Test testEmptyApplicationInfoGeneratesNoHeader = TestCase $ do@@ -11,41 +12,39 @@ testEmptyApplicationInfoIgnoresInvalidKeys :: Test testEmptyApplicationInfoIgnoresInvalidKeys = TestCase $ do     assertEqual "" emptyInfo modified--    where-+  where     emptyInfo = makeApplicationInfo-    modified = withApplicationValue "invalid-key" "value" emptyInfo-        & withApplicationValue "another-invalid-key" "value"+    modified =+        withApplicationValue "invalid-key" "value" emptyInfo+            & withApplicationValue "another-invalid-key" "value"  testEmptyApplicationInfoIgnoresInvalidValues :: Test testEmptyApplicationInfoIgnoresInvalidValues = TestCase $ do     assertEqual "" emptyInfo modified--    where-+  where     emptyInfo = makeApplicationInfo-    modified = withApplicationValue "id" " " emptyInfo-        & withApplicationValue "id" "&"-        & withApplicationValue "id" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789._-a"+    modified =+        withApplicationValue "id" " " emptyInfo+            & withApplicationValue "id" "&"+            & withApplicationValue "id" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789._-a"  testCorrectlyGeneratesHeaderText :: Test testCorrectlyGeneratesHeaderText = TestCase $ do     assertEqual "" (Just "application-id/my-id application-version/my-version") value     assertEqual "" (Just "application-id/my-id application-version/my-version") ignoreError--    where--    info = makeApplicationInfo-        & withApplicationValue "id" "my-id"-        & withApplicationValue "version" "my-version"+  where+    info =+        makeApplicationInfo+            & withApplicationValue "id" "my-id"+            & withApplicationValue "version" "my-version"     value = getApplicationInfoHeader info     ignoreError = withApplicationValue "version" "should-ignore-@me" info & getApplicationInfoHeader  allTests :: Test-allTests = TestList-    [ testEmptyApplicationInfoGeneratesNoHeader-    , testEmptyApplicationInfoIgnoresInvalidKeys-    , testEmptyApplicationInfoIgnoresInvalidValues-    , testCorrectlyGeneratesHeaderText-    ]+allTests =+    TestList+        [ testEmptyApplicationInfoGeneratesNoHeader+        , testEmptyApplicationInfoIgnoresInvalidKeys+        , testEmptyApplicationInfoIgnoresInvalidValues+        , testCorrectlyGeneratesHeaderText+        ]
+ test/Spec/Context.hs view
@@ -0,0 +1,333 @@+module Spec.Context (allTests) where++import Test.HUnit++import Control.Monad.Cont (liftIO)+import Data.Aeson (Value (..), decode, encode)+import Data.Function ((&))+import Data.Maybe (fromJust)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Vector as V+import LaunchDarkly.AesonCompat (fromList, lookupKey)+import LaunchDarkly.Server.Config (configSetAllAttributesPrivate, makeConfig)+import LaunchDarkly.Server.Context+import LaunchDarkly.Server.Context.Internal (redactContext)+import qualified LaunchDarkly.Server.Reference as R++confirmInvalidContext :: Context -> Text -> Assertion+confirmInvalidContext context expectedError =+    liftIO $+        ( do+            assertEqual "" False $ isValid context+            assertEqual "" expectedError $ getError context+        )++invalidKey :: Test+invalidKey =+    TestCase $+        confirmInvalidContext (makeContext "" "user") "context key must not be empty"++invalidKinds :: Test+invalidKinds =+    TestCase $+        ( do+            confirmInvalidContext (makeContext "user-key" "") "context kind must not be empty"+            confirmInvalidContext (makeContext "user-key" "kind") "context kind cannot be 'kind'"+            confirmInvalidContext (makeContext "user-key" "multi") "context kind cannot be 'multi'"+            confirmInvalidContext (makeContext "user-key" "invalid*characters") "context kind contains disallowed characters"+        )++multiKindRequiresOne :: Test+multiKindRequiresOne =+    TestCase $+        confirmInvalidContext (makeMultiContext []) "multi-kind contexts require at least one single-kind context"++multiKindRequiresUnique :: Test+multiKindRequiresUnique =+    TestCase $+        confirmInvalidContext (makeMultiContext [user1, user2]) "multi-kind contexts cannot contain two single-kind contexts with the same kind"+  where+    user1 = makeContext "user-key1" "user"+    user2 = makeContext "user-key2" "user"++multiKindRequiresSingleContextsOnly :: Test+multiKindRequiresSingleContextsOnly =+    TestCase $+        confirmInvalidContext (makeMultiContext [user, org, multi]) "multi-kind contexts can only contain single-kind contexts"+  where+    user = makeContext "user-key" "user"+    org = makeContext "org-key" "org"+    multi = makeMultiContext [user, org]++multiKindWithSingleKindWillReturnSingleKind :: Test+multiKindWithSingleKindWillReturnSingleKind =+    TestCase $+        assertEqual "" user (makeMultiContext [user])+  where+    user = makeContext "user-key" "user"++multiKindCanOnlyRetrieveKindAttribute :: Test+multiKindCanOnlyRetrieveKindAttribute =+    TestCase $+        let user = makeContext "user-key" "user"+            org = makeContext "org-key" "org"+            multi = makeMultiContext [user, org]+         in ( do+                assertEqual "" "multi" $ getValue "kind" multi+                assertEqual "" Null $ getValue "key" multi++                assertEqual "" "multi" $ getValueForReference (R.makeReference "kind") multi+                assertEqual "" Null $ getValueForReference (R.makeReference "key") multi+            )++canRetrievalIndividualContextsFromMultiKindContext :: Test+canRetrievalIndividualContextsFromMultiKindContext =+    TestCase $+        let user = makeContext "user-key" "user"+            org = makeContext "org-key" "org"+            multi = makeMultiContext [user, org]+         in ( do+                assertEqual "" (Just user) $ getIndividualContext "user" multi+                assertEqual "" (Just org) $ getIndividualContext "org" multi+                assertEqual "" Nothing $ getIndividualContext "device" multi+            )++canRetrievalIndividualContextsFromSingleKindContext :: Test+canRetrievalIndividualContextsFromSingleKindContext =+    TestCase $+        let context = makeContext "user-key" "user"+         in ( do+                assertEqual "" (Just context) $ getIndividualContext "user" context+                assertEqual "" Nothing $ getIndividualContext "org" context+            )++singleContextSupportsValueRetrieval :: Test+singleContextSupportsValueRetrieval =+    TestCase $+        let address = Object $ fromList [("city", "Chicago"), ("state", "IL")]+            favorites = Object $ fromList [("food", "Pizza"), ("sport", "baseball")]+            preferences = Object $ fromList [("favorites", favorites)]+            user =+                makeContext "user-key" "user"+                    & withName "Example"+                    & withAnonymous False+                    & withAttribute "groups" (Array $ V.fromList ["beta_testers"])+                    & withAttribute "address" address+                    & withAttribute "preferences" preferences+                    & withAttribute "complex/and-weird~attribute" "nailed it"+         in ( do+                assertEqual "" "user-key" $ getValue "key" user+                assertEqual "" "user" $ getValue "kind" user+                assertEqual "" "Example" $ getValue "name" user+                assertEqual "" (Bool False) $ getValue "anonymous" user+                assertEqual "" Null $ getValue "/address/city" user+                assertEqual "" Null $ getValue "/preferences/favorites/sport" user+                assertEqual "" Null $ getValue "/groups" user+                assertEqual "" Null $ getValue "/groups/0" user+                assertEqual "" "nailed it" $ getValue "complex/and-weird~attribute" user++                assertEqual "" "user-key" $ getValueForReference (R.makeReference "key") user+                assertEqual "" "user" $ getValueForReference (R.makeReference "kind") user+                assertEqual "" "Example" $ getValueForReference (R.makeReference "name") user+                assertEqual "" (Bool False) $ getValueForReference (R.makeReference "anonymous") user+                assertEqual "" "Chicago" $ getValueForReference (R.makeReference "/address/city") user+                assertEqual "" "baseball" $ getValueForReference (R.makeReference "/preferences/favorites/sport") user+                assertEqual "" (Array $ V.fromList ["beta_testers"]) $ getValueForReference (R.makeReference "/groups") user+                assertEqual "" Null $ getValueForReference (R.makeReference "/groups/0") user+                assertEqual "" "nailed it" $ getValueForReference (R.makeReference "/complex~1and-weird~0attribute") user+            )++invalidKindCannotRetrieveAnything :: Test+invalidKindCannotRetrieveAnything =+    TestCase $+        let invalid = makeContext "user-key" "multi" & withName "Sandy" & withAttribute "nickname" "Sam"+         in ( do+                assertEqual "" Null $ getValue "kind" invalid+                assertEqual "" Null $ getValue "key" invalid+                assertEqual "" Null $ getValue "name" invalid+                assertEqual "" Null $ getValue "nickname" invalid++                assertEqual "" Null $ getValueForReference (R.makeReference "kind") invalid+                assertEqual "" Null $ getValueForReference (R.makeReference "key") invalid+                assertEqual "" Null $ getValueForReference (R.makeReference "name") invalid+                assertEqual "" Null $ getValueForReference (R.makeReference "nickname") invalid+            )++setAndVerifyAttribute :: Text -> Value -> Value -> Context -> Assertion+setAndVerifyAttribute attribute attempted expected context =+    assertEqual "" expected (withAttribute attribute attempted context & getValue attribute)++cannotUseWithAttributeToSetRestrictedAttributes :: Test+cannotUseWithAttributeToSetRestrictedAttributes =+    TestCase $+        let user =+                makeContext "user-key" "user"+                    & withName "Sandy"+                    & withAnonymous True+                    & withAttribute "testing" "something"+            invalid = makeContext "invalid-key" "kind"+            multi = makeMultiContext [makeContext "org-key" "org", user]+         in ( do+                setAndVerifyAttribute "kind" "org" "user" user+                setAndVerifyAttribute "key" "new-key" "user-key" user+                setAndVerifyAttribute "name" "Jim" "Jim" user+                setAndVerifyAttribute "name" (Bool True) "Sandy" user+                setAndVerifyAttribute "anonymous" (Bool False) (Bool False) user+                setAndVerifyAttribute "anonymous" "false" (Bool True) user+                setAndVerifyAttribute "_meta" "anything" Null user+                setAndVerifyAttribute "privateAttributeNames" (Array $ V.fromList ["name"]) Null user++                setAndVerifyAttribute "kind" "org" "multi" multi+                setAndVerifyAttribute "key" "new-key" Null multi+                setAndVerifyAttribute "name" "Jim" Null multi+                setAndVerifyAttribute "name" (Bool True) Null multi+                setAndVerifyAttribute "anonymous" (Bool False) Null multi+                setAndVerifyAttribute "anonymous" "false" Null multi+                setAndVerifyAttribute "_meta" "anything" Null multi+                setAndVerifyAttribute "privateAttributeNames" (Array $ V.fromList ["name"]) Null multi++                setAndVerifyAttribute "kind" "org" Null invalid+                setAndVerifyAttribute "key" "new-key" Null invalid+                setAndVerifyAttribute "name" "Jim" Null invalid+                setAndVerifyAttribute "name" (Bool True) Null invalid+                setAndVerifyAttribute "anonymous" (Bool False) Null invalid+                setAndVerifyAttribute "anonymous" "false" Null invalid+                setAndVerifyAttribute "_meta" "anything" Null invalid+                setAndVerifyAttribute "privateAttributeNames" (Array $ V.fromList ["name"]) Null invalid+            )++canParseFromLegacyUserFormat :: Test+canParseFromLegacyUserFormat =+    TestCase $+        let jsonString = "{\"key\": \"user-key\", \"ip\": \"127.0.0.1\", \"custom\": {\"address\": {\"street\": \"123 Easy St\", \"city\": \"Anytown\"}, \"language\": \"Haskell\"}}"+            context :: Context = fromJust $ decode jsonString+         in ( do+                assertBool "" $ isValid context+                assertEqual "" "user" $ getValue "kind" context+                assertEqual "" "user-key" $ getValue "key" context+                assertEqual "" "127.0.0.1" $ getValue "ip" context+                assertEqual "" "Haskell" $ getValue "language" context+                assertEqual "" "123 Easy St" $ getValueForReference (R.makeReference "/address/street") context+                assertEqual "" "Anytown" $ getValueForReference (R.makeReference "/address/city") context+            )++canParseSingleKindFormat :: Test+canParseSingleKindFormat =+    TestCase $+        let jsonString = "{\"key\": \"org-key\", \"kind\": \"org\", \"ip\": \"127.0.0.1\", \"custom\": {\"address\": {\"street\": \"123 Easy St\", \"city\": \"Anytown\"}, \"language\": \"Haskell\"}}"+            context :: Context = fromJust $ decode jsonString+         in ( do+                assertBool "" $ isValid context+                assertEqual "" "org" $ getValue "kind" context+                assertEqual "" "org-key" $ getValue "key" context+                assertEqual "" "127.0.0.1" $ getValue "ip" context+                assertEqual "" Null $ getValue "language" context+                assertEqual "" "Haskell" $ getValueForReference (R.makeReference "/custom/language") context+                assertEqual "" Null $ getValueForReference (R.makeReference "/address/street") context+                assertEqual "" Null $ getValueForReference (R.makeReference "/address/city") context+                assertEqual "" "123 Easy St" $ getValueForReference (R.makeReference "/custom/address/street") context+                assertEqual "" "Anytown" $ getValueForReference (R.makeReference "/custom/address/city") context+            )++canParseMultiKindFormat :: Test+canParseMultiKindFormat =+    TestCase $+        let jsonString = "{\"kind\": \"multi\", \"user\": {\"key\": \"user-key\", \"name\": \"Sandy\"}, \"org\": {\"key\": \"org-key\", \"name\": \"LaunchDarkly\"}}"+            context :: Context = fromJust $ decode jsonString+            userContext = fromJust $ getIndividualContext "user" context+            orgContext = fromJust $ getIndividualContext "org" context+         in ( do+                assertBool "" $ isValid context+                assertEqual "" "multi" $ getValue "kind" context++                assertEqual "" "user" $ getValue "kind" userContext+                assertEqual "" "user-key" $ getValue "key" userContext+                assertEqual "" "Sandy" $ getValue "name" userContext++                assertEqual "" "org" $ getValue "kind" orgContext+                assertEqual "" "org-key" $ getValue "key" orgContext+                assertEqual "" "LaunchDarkly" $ getValue "name" orgContext+            )++canRedactAttributesCorrectly :: Test+canRedactAttributesCorrectly = TestCase $ do+    assertEqual "" expectedRedacted (fromJust $ lookupKey "redactedAttributes" meta)+    assertEqual "" "user" (fromJust $ lookupKey "kind" decodedIntoMap)+    assertEqual "" "user-key" (fromJust $ lookupKey "key" decodedIntoMap)+    assertEqual "" "Sandy" (fromJust $ lookupKey "firstName" decodedIntoMap)+    assertEqual "" "Beaches" (fromJust $ lookupKey "lastName" decodedIntoMap)+    assertEqual "" hobbies (fromJust $ lookupKey "hobbies" decodedIntoMap)+    assertEqual "" expectedAddress (fromJust $ lookupKey "address" decodedIntoMap)+  where+    config = makeConfig "sdk-key"++    address = Object $ fromList [("city", "Chicago"), ("state", "IL")]+    hobbies = (Array $ V.fromList ["coding", "reading"])++    context =+        makeContext "user-key" "user"+            & withAttribute "name" "Sandy"+            & withAttribute "firstName" "Sandy"+            & withAttribute "lastName" "Beaches"+            & withAttribute "address" address+            & withAttribute "hobbies" hobbies+            & withPrivateAttributes (S.fromList [R.makeLiteral "key", R.makeLiteral "kind", R.makeLiteral "anonymous", R.makeLiteral "name", R.makeReference "/address/city", R.makeReference "/hobbies/0"])++    jsonByteString = encode $ redactContext config context+    decodedAsValue = fromJust $ decode jsonByteString :: Value+    decodedIntoMap = case decodedAsValue of (Object o) -> o; _ -> error "expected object"+    meta = case lookupKey "_meta" decodedIntoMap of (Just (Object o)) -> o; _ -> error "expected object"+    expectedRedacted = Array $ V.fromList ["/address/city", "name"]+    expectedAddress = Object $ fromList [("state", "IL")]++canRedactAllAttributesCorrectly :: Test+canRedactAllAttributesCorrectly = TestCase $ do+    assertEqual "" expectedRedacted (fromJust $ lookupKey "redactedAttributes" meta)+    assertEqual "" "user" (fromJust $ lookupKey "kind" decodedIntoMap)+    assertEqual "" "user-key" (fromJust $ lookupKey "key" decodedIntoMap)+    assertEqual "" Nothing (lookupKey "firstName" decodedIntoMap)+    assertEqual "" Nothing (lookupKey "lastName" decodedIntoMap)+    assertEqual "" Nothing (lookupKey "hobbies" decodedIntoMap)+    assertEqual "" Nothing (lookupKey "address" decodedIntoMap)+  where+    config = makeConfig "sdk-key" & configSetAllAttributesPrivate True++    address = Object $ fromList [("city", "Chicago"), ("state", "IL")]++    context =+        makeContext "user-key" "user"+            & withAttribute "name" "Sandy"+            & withAttribute "firstName" "Sandy"+            & withAttribute "lastName" "Beaches"+            & withAttribute "address" address+            & withAttribute "hobbies" (Array $ V.fromList ["coding", "reading"])++    jsonByteString = encode $ redactContext config context+    decodedAsValue = fromJust $ decode jsonByteString :: Value+    decodedIntoMap = case decodedAsValue of (Object o) -> o; _ -> error "expected object"+    meta = case lookupKey "_meta" decodedIntoMap of (Just (Object o)) -> o; _ -> error "expected object"+    expectedRedacted = Array $ V.fromList ["address", "firstName", "hobbies", "lastName", "name"]+    expectedAddress = Object $ fromList [("state", "IL")]++allTests :: Test+allTests =+    TestList+        [ invalidKey+        , invalidKinds+        , multiKindRequiresOne+        , multiKindRequiresUnique+        , multiKindRequiresSingleContextsOnly+        , multiKindWithSingleKindWillReturnSingleKind+        , multiKindCanOnlyRetrieveKindAttribute+        , canRetrievalIndividualContextsFromMultiKindContext+        , canRetrievalIndividualContextsFromSingleKindContext+        , singleContextSupportsValueRetrieval+        , invalidKindCannotRetrieveAnything+        , cannotUseWithAttributeToSetRestrictedAttributes+        , canParseFromLegacyUserFormat+        , canParseSingleKindFormat+        , canParseMultiKindFormat+        , canRedactAttributesCorrectly+        , canRedactAllAttributesCorrectly+        ]
test/Spec/DataSource.hs view
@@ -1,11 +1,7 @@ module Spec.DataSource (allTests) where -import           Test.HUnit-import LaunchDarkly.Server.Client-import LaunchDarkly.Server.Config-import LaunchDarkly.Server.DataSource.Internal-import Data.Generics.Product               (getField)+import Test.HUnit -allTests :: Test +allTests :: Test allTests =     TestList []
test/Spec/Evaluate.hs view
@@ -1,445 +1,839 @@ module Spec.Evaluate (allTests) where -import           Test.HUnit-import           Data.Aeson-import           Data.Aeson.Types                  (Value(..))-import qualified Data.HashMap.Strict as            HM-import           Data.HashMap.Strict               (HashMap)-import           Data.Function                     ((&))-import           Data.Generics.Product             (getField)--import           LaunchDarkly.Server.Store-import           LaunchDarkly.Server.Store.Internal-import           LaunchDarkly.Server.Client-import           LaunchDarkly.Server.Client.Internal-import           LaunchDarkly.Server.User-import           LaunchDarkly.Server.User.Internal-import           LaunchDarkly.Server.Features-import           LaunchDarkly.Server.Operators-import           LaunchDarkly.Server.Details-import           LaunchDarkly.Server.Store.Internal-import           LaunchDarkly.Server.Evaluate-import           LaunchDarkly.Server.Config--import           Util.Features--makeEmptyStore :: IO (StoreHandle IO)-makeEmptyStore = do-    handle <- makeStoreIO Nothing 0-    initializeStore handle mempty mempty-    pure handle--testFlagReturnsOffVariationIfFlagIsOff :: Test-testFlagReturnsOffVariationIfFlagIsOff = TestCase $ do-    store <- makeEmptyStore-    x <- evaluateDetail flag user store-    assertEqual "test" expected x--    where--    expected = (EvaluationDetail-        { value          = String "off"-        , variationIndex = pure 1-        , reason         = EvaluationReasonOff-        }, [])--    user = unwrapUser $ makeUser "x"--    flag = Flag-        { key                    = "feature"-        , version                = 1-        , on                     = False-        , trackEvents            = False-        , trackEventsFallthrough = False-        , deleted                = False-        , prerequisites          = []-        , salt                   = ""-        , targets                = []-        , rules                  = []-        , fallthrough            = VariationOrRollout-            { variation = Just 0-            , rollout   = Nothing-            }-        , offVariation           = Just 1-        , variations             = [String "fall", String "off", String "on"]-        , debugEventsUntilDate   = Nothing-        , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False,  explicit = True }-        }--testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules :: Test-testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules = TestCase $ do-    store <- makeEmptyStore-    x <- evaluateDetail flag user store-    assertEqual "test" expected x--    where--    expected = (EvaluationDetail-        { value          = String "fall"-        , variationIndex = pure 0-        , reason         = EvaluationReasonFallthrough-            { inExperiment = False-            }-        }, [])--    user = unwrapUser $ makeUser "x"--    flag = Flag-        { key                    = "feature"-        , version                = 1-        , on                     = True-        , trackEvents            = False-        , trackEventsFallthrough = False-        , deleted                = False-        , prerequisites          = []-        , salt                   = ""-        , targets                = []-        , rules                  = []-        , fallthrough            = VariationOrRollout-            { variation = Just 0-            , rollout   = Nothing-            }-        , offVariation           = Just 1-        , variations             = [String "fall", String "off", String "on"]-        , debugEventsUntilDate   = Nothing-        , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False, explicit = True }-        }--testFlagReturnsErrorIfFallthroughHasTooHighVariation :: Test-testFlagReturnsErrorIfFallthroughHasTooHighVariation = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag >>= (pure () @=?)-    stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)-    where-        flag = (makeTestFlag "a" 52)-            { on           = True-            , offVariation = Nothing-            , fallthrough  = VariationOrRollout-                { variation = Just 999-                , rollout   = Nothing-                }-            , variations   =-                [ String "abc"-                , String "123"-                , String "456"-                ]-            }-        expected = EvaluationDetail-            { value          = "default"-            , variationIndex = Nothing-            , reason         = EvaluationReasonError EvalErrorKindMalformedFlag-            }--testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout :: Test-testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag >>= (pure () @=?)-    stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)-    where-        flag = (makeTestFlag "a" 52)-            { on           = True-            , offVariation = Nothing-            , fallthrough  = VariationOrRollout-                { variation = Nothing-                , rollout   = Nothing-                }-            , variations   = [String "abc"]-            }-        expected = EvaluationDetail-            { value          = "default"-            , variationIndex = Nothing-            , reason         = EvaluationReasonError EvalErrorKindMalformedFlag-            }--testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList :: Test-testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag >>= (pure () @=?)-    stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)-    where-        flag = (makeTestFlag "a" 52)-            { on           = True-            , offVariation = Nothing-            , fallthrough  = VariationOrRollout-                { variation = Nothing-                , rollout   = pure Rollout-                    { variations = []-                    , seed       = Nothing-                    , kind       = RolloutKindRollout-                    , bucketBy   = pure "key"-                    }-                }-            , variations   = [String "abc"]-            }-        expected = EvaluationDetail-            { value          = "default"-            , variationIndex = Nothing-            , reason         = EvaluationReasonError EvalErrorKindMalformedFlag-            }--testFlagReturnsOffVariationIfPrerequisiteIsNotFound :: Test-testFlagReturnsOffVariationIfPrerequisiteIsNotFound = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag >>= (pure () @=?)-    stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)-    where-        flag = (makeTestFlag "a" 52)-            { on            = True-            , offVariation  = pure 1-            , fallthrough   = VariationOrRollout-                { variation = pure 0-                , rollout   = Nothing-                }-            , variations    = [String "fall", String "off", String "on"]-            , prerequisites =-                [ Prerequisite-                    { key       = "feature1"-                    , variation = 1-                    }-                ]-            }-        expected = EvaluationDetail-            { value          = "off"-            , variationIndex = pure 1-            , reason         = EvaluationReasonPrerequisiteFailed "feature1"-            }--testFlagReturnsOffVariationIfPrerequisiteIsOff :: Test-testFlagReturnsOffVariationIfPrerequisiteIsOff = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag0                     >>= (pure () @=?)-    insertFlag (getField @"store" clientI) flag1                     >>= (pure () @=?)-    stringVariationDetail client "feature0" (makeUser "b") "default" >>= (expected @=?)-    where-        flag0 = (makeTestFlag "feature0" 52)-            { on            = True-            , offVariation  = pure 1-            , fallthrough   = VariationOrRollout-                { variation = pure 0-                , rollout   = Nothing-                }-            , variations    = [String "fall", String "off", String "on"]-            , prerequisites =-                [ Prerequisite-                    { key       = "feature1"-                    , variation = 1-                    }-                ]-            }-        flag1 = (makeTestFlag "feature1" 52)-            { on            = False-            , offVariation  = pure 1-            , fallthrough   = VariationOrRollout-                { variation = pure 0-                , rollout   = Nothing-                }-            , variations    = [String "nogo", String "go"]-            }-        expected = EvaluationDetail-            { value          = "off"-            , variationIndex = pure 1-            , reason         = EvaluationReasonPrerequisiteFailed "feature1"-            }--testFlagReturnsOffVariationIfPrerequisiteIsNotMet :: Test-testFlagReturnsOffVariationIfPrerequisiteIsNotMet = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag0                     >>= (pure () @=?)-    insertFlag (getField @"store" clientI) flag1                     >>= (pure () @=?)-    stringVariationDetail client "feature0" (makeUser "b") "default" >>= (expected @=?)-    where-        flag0 = (makeTestFlag "feature0" 52)-            { on            = True-            , offVariation  = pure 1-            , fallthrough   = VariationOrRollout-                { variation = pure 0-                , rollout   = Nothing-                }-            , variations    = [String "fall", String "off", String "on"]-            , prerequisites =-                [ Prerequisite-                    { key       = "feature1"-                    , variation = 1-                    }-                ]-            }-        flag1 = (makeTestFlag "feature1" 52)-            { on            = True-            , offVariation  = pure 1-            , fallthrough   = VariationOrRollout-                { variation = pure 0-                , rollout   = Nothing-                }-            , variations    = [String "nogo", String "go"]-            }-        expected = EvaluationDetail-            { value          = "off"-            , variationIndex = pure 1-            , reason         = EvaluationReasonPrerequisiteFailed "feature1"-            }--testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules :: Test-testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag0                     >>= (pure () @=?)-    insertFlag (getField @"store" clientI) flag1                     >>= (pure () @=?)-    stringVariationDetail client "feature0" (makeUser "b") "default" >>= (expected @=?)-    where-        flag0 = (makeTestFlag "feature0" 52)-            { on            = True-            , offVariation  = pure 1-            , fallthrough   = VariationOrRollout-                { variation = pure 0-                , rollout   = Nothing-                }-            , variations    = [String "fall", String "off", String "on"]-            , prerequisites =-                [ Prerequisite-                    { key       = "feature1"-                    , variation = 1-                    }-                ]-            }-        flag1 = (makeTestFlag "feature1" 52)-            { on            = True-            , offVariation  = pure 1-            , fallthrough   = VariationOrRollout-                { variation = pure 1-                , rollout   = Nothing-                }-            , variations    = [String "nogo", String "go"]-            }-        expected = EvaluationDetail-            { value          = "fall"-            , variationIndex = pure 0-            , reason         = EvaluationReasonFallthrough-                { inExperiment = False-                }-            }--testClauseCanMatchCustomAttribute :: Test-testClauseCanMatchCustomAttribute = TestCase $ do-    store <- makeStoreIO Nothing 0-    x <- evaluateDetail flag user store-    assertEqual "test" expected x--    where--    expected = (EvaluationDetail-        { value          = Bool True-        , variationIndex = pure 1-        , reason         = EvaluationReasonRuleMatch-            { ruleIndex    = 0-            , ruleId       = "clause"-            , inExperiment = False-            }-        }, [])--    user = unwrapUser $ (makeUser "x")-        & userSetName   (pure "bob")-        & userSetCustom (HM.fromList [("legs", Number 4)])--    flag = Flag-        { key                    = "feature"-        , version                = 1-        , on                     = True-        , trackEvents            = False-        , trackEventsFallthrough = False-        , deleted                = False-        , prerequisites          = []-        , salt                   = ""-        , targets                = []-        , rules                  =-            [ Rule-                { clauses            =-                    [ Clause-                        { attribute = "name"-                        , op        = OpIn-                        , values    = [String "bob"]-                        , negate    = False-                        }-                    ]-                , variationOrRollout = VariationOrRollout-                    { variation = Just 1-                    , rollout   = Nothing-                    }-                , id                 = "clause"-                , trackEvents        = False-                }-            ]-        , fallthrough            = VariationOrRollout-            { variation = Just 0-            , rollout   = Nothing-            }-        , offVariation           = Just 0-        , variations             = [Bool False, Bool True]-        , debugEventsUntilDate   = Nothing-        , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False, explicit = True }-        }--makeTestClient :: IO Client-makeTestClient = do-    (Client client) <- makeClient $ (makeConfig "") & configSetOffline True-    initializeStore (getField @"store" client) mempty mempty-    pure (Client client)--testEvaluatingUnknownFlagReturnsDefault :: Test-testEvaluatingUnknownFlagReturnsDefault = TestCase $ do-    client <- makeTestClient-    boolVariation client "a" (makeUser "b") False >>= (False @=?)--testEvaluatingUnknownFlagReturnsDefaultWithDetail :: Test-testEvaluatingUnknownFlagReturnsDefaultWithDetail = TestCase $ do-    client <- makeTestClient-    boolVariationDetail client "a" (makeUser "b") False >>= (expected @=?)-    where-        expected = EvaluationDetail-            { value          = False-            , variationIndex = Nothing-            , reason         = EvaluationReasonError EvalErrorFlagNotFound-            }--testDefaultIsReturnedIfFlagEvaluatesToNil :: Test-testDefaultIsReturnedIfFlagEvaluatesToNil = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag >>= (pure () @=?)-    boolVariation client "a" (makeUser "b") False >>= (False @=?)-    where-        flag = (makeTestFlag "a" 52)-            { on           = False-            , offVariation = Nothing-            }--testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail :: Test-testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail = TestCase $ do-    client@(Client clientI) <- makeTestClient-    insertFlag (getField @"store" clientI) flag >>= (pure () @=?)-    boolVariationDetail client "a" (makeUser "b") False >>= (expected @=?)-    where-        flag = (makeTestFlag "a" 52)-            { on           = False-            , offVariation = Nothing-            }-        expected = EvaluationDetail-            { value          = False-            , variationIndex = Nothing-            , reason         = EvaluationReasonOff-            }--allTests :: Test-allTests = TestList-    [ testFlagReturnsOffVariationIfFlagIsOff-    , testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules-    , testFlagReturnsErrorIfFallthroughHasTooHighVariation-    , testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout-    , testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList-    , testFlagReturnsOffVariationIfPrerequisiteIsNotFound-    , testFlagReturnsOffVariationIfPrerequisiteIsOff-    , testFlagReturnsOffVariationIfPrerequisiteIsNotMet-    , testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules-    , testClauseCanMatchCustomAttribute-    , testEvaluatingUnknownFlagReturnsDefault-    , testEvaluatingUnknownFlagReturnsDefaultWithDetail-    , testDefaultIsReturnedIfFlagEvaluatesToNil-    , testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail-    ]+import Data.Aeson (Value (..))+import Data.Function ((&))+import Data.Generics.Product (getField)+import qualified Data.HashSet as HS+import Test.HUnit++import LaunchDarkly.Server.Client+import LaunchDarkly.Server.Config+import LaunchDarkly.Server.Context+import LaunchDarkly.Server.Evaluate+import LaunchDarkly.Server.Features+import LaunchDarkly.Server.Operators+import LaunchDarkly.Server.Store.Internal++import LaunchDarkly.Server.Reference (makeLiteral, makeReference)+import Util.Features++makeEmptyStore :: IO (StoreHandle IO)+makeEmptyStore = do+    handle <- makeStoreIO Nothing 0+    initializeStore handle mempty mempty+    pure handle++testFlagReturnsOffVariationIfFlagIsOff :: Test+testFlagReturnsOffVariationIfFlagIsOff = TestCase $ do+    store <- makeEmptyStore+    x <- evaluateDetail flag context HS.empty store+    assertEqual "test" expected x+  where+    expected =+        ( EvaluationDetail+            { value = String "off"+            , variationIndex = pure 1+            , reason = EvaluationReasonOff+            }+        , []+        )++    context = makeContext "x" "user"++    flag =+        Flag+            { key = "feature"+            , version = 1+            , on = False+            , trackEvents = False+            , trackEventsFallthrough = False+            , deleted = False+            , prerequisites = []+            , salt = ""+            , targets = []+            , contextTargets = []+            , rules = []+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            , offVariation = Just 1+            , variations = [String "fall", String "off", String "on"]+            , debugEventsUntilDate = Nothing+            , clientSideAvailability = ClientSideAvailability {usingEnvironmentId = True, usingMobileKey = False, explicit = True}+            }++testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules :: Test+testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules = TestCase $ do+    store <- makeEmptyStore+    x <- evaluateDetail flag context HS.empty store+    assertEqual "test" expected x+  where+    expected =+        ( EvaluationDetail+            { value = String "fall"+            , variationIndex = pure 0+            , reason =+                EvaluationReasonFallthrough+                    { inExperiment = False+                    }+            }+        , []+        )++    context = makeContext "x" "user"++    flag =+        Flag+            { key = "feature"+            , version = 1+            , on = True+            , trackEvents = False+            , trackEventsFallthrough = False+            , deleted = False+            , prerequisites = []+            , salt = ""+            , targets = []+            , contextTargets = []+            , rules = []+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            , offVariation = Just 1+            , variations = [String "fall", String "off", String "on"]+            , debugEventsUntilDate = Nothing+            , clientSideAvailability = ClientSideAvailability {usingEnvironmentId = True, usingMobileKey = False, explicit = True}+            }++testFlagReturnsErrorIfFallthroughHasTooHighVariation :: Test+testFlagReturnsErrorIfFallthroughHasTooHighVariation = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    stringVariationDetail client "a" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag =+        (makeTestFlag "a" 52)+            { on = True+            , offVariation = Nothing+            , fallthrough =+                VariationOrRollout+                    { variation = Just 999+                    , rollout = Nothing+                    }+            , variations =+                [ String "abc"+                , String "123"+                , String "456"+                ]+            }+    expected =+        EvaluationDetail+            { value = "default"+            , variationIndex = Nothing+            , reason = EvaluationReasonError EvalErrorKindMalformedFlag+            }++testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout :: Test+testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    stringVariationDetail client "a" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag =+        (makeTestFlag "a" 52)+            { on = True+            , offVariation = Nothing+            , fallthrough =+                VariationOrRollout+                    { variation = Nothing+                    , rollout = Nothing+                    }+            , variations = [String "abc"]+            }+    expected =+        EvaluationDetail+            { value = "default"+            , variationIndex = Nothing+            , reason = EvaluationReasonError EvalErrorKindMalformedFlag+            }++testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList :: Test+testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    stringVariationDetail client "a" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag =+        (makeTestFlag "a" 52)+            { on = True+            , offVariation = Nothing+            , fallthrough =+                VariationOrRollout+                    { variation = Nothing+                    , rollout =+                        pure+                            Rollout+                                { variations = []+                                , seed = Nothing+                                , kind = RolloutKindRollout+                                , bucketBy = pure "key"+                                , contextKind = Just "user"+                                }+                    }+            , variations = [String "abc"]+            }+    expected =+        EvaluationDetail+            { value = "default"+            , variationIndex = Nothing+            , reason = EvaluationReasonError EvalErrorKindMalformedFlag+            }++testFlagReturnsErrorIfThereIsAPrerequisiteCycle :: Test+testFlagReturnsErrorIfThereIsAPrerequisiteCycle = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag0 >>= (pure () @=?)+    insertFlag (getField @"store" client) flag1 >>= (pure () @=?)+    stringVariationDetail client "feature0" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag0 =+        (makeTestFlag "feature0" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "fall", String "off", String "on"]+            , prerequisites =+                [ Prerequisite+                    { key = "feature1"+                    , variation = 1+                    }+                ]+            }+    flag1 =+        (makeTestFlag "feature1" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "nogo", String "go"]+            , prerequisites =+                [ Prerequisite+                    { key = "feature0"+                    , variation = 1+                    }+                ]+            }+    expected =+        EvaluationDetail+            { value = "default"+            , variationIndex = Nothing+            , reason = EvaluationReasonError EvalErrorKindMalformedFlag+            }++testFlagReturnsOffVariationIfPrerequisiteIsNotFound :: Test+testFlagReturnsOffVariationIfPrerequisiteIsNotFound = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    stringVariationDetail client "a" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag =+        (makeTestFlag "a" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "fall", String "off", String "on"]+            , prerequisites =+                [ Prerequisite+                    { key = "feature1"+                    , variation = 1+                    }+                ]+            }+    expected =+        EvaluationDetail+            { value = "off"+            , variationIndex = pure 1+            , reason = EvaluationReasonPrerequisiteFailed "feature1"+            }++testFlagReturnsOffVariationIfPrerequisiteIsOff :: Test+testFlagReturnsOffVariationIfPrerequisiteIsOff = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag0 >>= (pure () @=?)+    insertFlag (getField @"store" client) flag1 >>= (pure () @=?)+    stringVariationDetail client "feature0" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag0 =+        (makeTestFlag "feature0" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "fall", String "off", String "on"]+            , prerequisites =+                [ Prerequisite+                    { key = "feature1"+                    , variation = 1+                    }+                ]+            }+    flag1 =+        (makeTestFlag "feature1" 52)+            { on = False+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "nogo", String "go"]+            }+    expected =+        EvaluationDetail+            { value = "off"+            , variationIndex = pure 1+            , reason = EvaluationReasonPrerequisiteFailed "feature1"+            }++testFlagReturnsOffVariationIfPrerequisiteIsNotMet :: Test+testFlagReturnsOffVariationIfPrerequisiteIsNotMet = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag0 >>= (pure () @=?)+    insertFlag (getField @"store" client) flag1 >>= (pure () @=?)+    stringVariationDetail client "feature0" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag0 =+        (makeTestFlag "feature0" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "fall", String "off", String "on"]+            , prerequisites =+                [ Prerequisite+                    { key = "feature1"+                    , variation = 1+                    }+                ]+            }+    flag1 =+        (makeTestFlag "feature1" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "nogo", String "go"]+            }+    expected =+        EvaluationDetail+            { value = "off"+            , variationIndex = pure 1+            , reason = EvaluationReasonPrerequisiteFailed "feature1"+            }++testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules :: Test+testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag0 >>= (pure () @=?)+    insertFlag (getField @"store" client) flag1 >>= (pure () @=?)+    stringVariationDetail client "feature0" (makeContext "b" "user") "default" >>= (expected @=?)+  where+    flag0 =+        (makeTestFlag "feature0" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 0+                    , rollout = Nothing+                    }+            , variations = [String "fall", String "off", String "on"]+            , prerequisites =+                [ Prerequisite+                    { key = "feature1"+                    , variation = 1+                    }+                ]+            }+    flag1 =+        (makeTestFlag "feature1" 52)+            { on = True+            , offVariation = pure 1+            , fallthrough =+                VariationOrRollout+                    { variation = pure 1+                    , rollout = Nothing+                    }+            , variations = [String "nogo", String "go"]+            }+    expected =+        EvaluationDetail+            { value = "fall"+            , variationIndex = pure 0+            , reason =+                EvaluationReasonFallthrough+                    { inExperiment = False+                    }+            }++testFlagCanTargetUserKeys :: Test+testFlagCanTargetUserKeys = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    boolVariationDetail client "feature0" (makeContext "user-key" "user") False >>= (expected @=?)+  where+    flag :: Flag =+        (makeTestFlag "feature0" 52)+            { on = True+            , targets = [Target {values = HS.singleton "user-key", variation = 1, contextKind = "user"}]+            , variations = [Bool False, Bool True]+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            }+    expected :: EvaluationDetail Bool =+        EvaluationDetail+            { value = True+            , variationIndex = pure 1+            , reason = EvaluationReasonTargetMatch+            }++testFlagCanTargetContextKeys :: Test+testFlagCanTargetContextKeys = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    boolVariationDetail client "feature0" (makeContext "match-key" "user") False >>= (fallthrough @=?)+    boolVariationDetail client "feature0" (makeContext "match-key" "org") False >>= (match @=?)+  where+    flag :: Flag =+        (makeTestFlag "feature0" 52)+            { on = True+            , contextTargets = [Target {values = HS.singleton "match-key", variation = 1, contextKind = "org"}]+            , variations = [Bool False, Bool True]+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            }+    match :: EvaluationDetail Bool =+        EvaluationDetail+            { value = True+            , variationIndex = pure 1+            , reason = EvaluationReasonTargetMatch+            }+    fallthrough :: EvaluationDetail Bool =+        EvaluationDetail+            { value = False+            , variationIndex = pure 0+            , reason = EvaluationReasonFallthrough {inExperiment = False}+            }++testFlagCanTargetContextFallsbackToUserTargets :: Test+testFlagCanTargetContextFallsbackToUserTargets = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    boolVariationDetail client "feature0" (makeContext "match-key" "user") False >>= (match @=?)+  where+    flag :: Flag =+        (makeTestFlag "feature0" 52)+            { on = True+            , targets = [Target {values = HS.singleton "match-key", variation = 1, contextKind = "user"}]+            , contextTargets = [Target {values = HS.empty, variation = 1, contextKind = "user"}]+            , variations = [Bool False, Bool True]+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            }+    match :: EvaluationDetail Bool =+        EvaluationDetail+            { value = True+            , variationIndex = pure 1+            , reason = EvaluationReasonTargetMatch+            }++testFlagChecksTargetsBeforeRules :: Test+testFlagChecksTargetsBeforeRules = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    boolVariationDetail client "feature0" (makeContext "match-key" "user") False >>= (match @=?)+  where+    flag :: Flag =+        (makeTestFlag "feature0" 52)+            { on = True+            , targets = [Target {values = HS.singleton "match-key", variation = 0, contextKind = "user"}]+            , rules =+                [ Rule+                    { clauses =+                        [ Clause+                            { attribute = makeLiteral "kind"+                            , contextKind = "user"+                            , op = OpIn+                            , values = [String "user"]+                            , negate = False+                            }+                        ]+                    , variationOrRollout =+                        VariationOrRollout+                            { variation = Just 1+                            , rollout = Nothing+                            }+                    , id = "clause"+                    , trackEvents = False+                    }+                ]+            , variations = [Bool False, Bool True]+            , fallthrough =+                VariationOrRollout+                    { variation = Just 1+                    , rollout = Nothing+                    }+            }+    match :: EvaluationDetail Bool =+        EvaluationDetail+            { value = False+            , variationIndex = pure 0+            , reason = EvaluationReasonTargetMatch+            }++testClauseCanMatchOnKind :: Test+testClauseCanMatchOnKind = TestCase $ do+    store <- makeStoreIO Nothing 0+    orgDetail <- evaluateDetail flag orgContext HS.empty store+    userDetail <- evaluateDetail flag userContext HS.empty store+    multiDetail <- evaluateDetail flag multiContext HS.empty store++    assertEqual "test" expectedMatch orgDetail+    assertEqual "test" expectedFailure userDetail+    assertEqual "test" expectedMatch multiDetail+  where+    expectedMatch =+        ( EvaluationDetail+            { value = Bool True+            , variationIndex = pure 1+            , reason =+                EvaluationReasonRuleMatch+                    { ruleIndex = 0+                    , ruleId = "clause"+                    , inExperiment = False+                    }+            }+        , []+        )++    expectedFailure =+        ( EvaluationDetail+            { value = Bool False+            , variationIndex = pure 0+            , reason = EvaluationReasonFallthrough {inExperiment = False}+            }+        , []+        )++    orgContext = makeContext "x" "org"+    userContext = makeContext "x" "user"+    multiContext = makeMultiContext [orgContext, userContext]++    flag =+        Flag+            { key = "feature"+            , version = 1+            , on = True+            , trackEvents = False+            , trackEventsFallthrough = False+            , deleted = False+            , prerequisites = []+            , salt = ""+            , targets = []+            , contextTargets = []+            , rules =+                [ Rule+                    { clauses =+                        [ Clause+                            { attribute = makeLiteral "kind"+                            , contextKind = "user"+                            , op = OpIn+                            , values = [String "org"]+                            , negate = False+                            }+                        ]+                    , variationOrRollout =+                        VariationOrRollout+                            { variation = Just 1+                            , rollout = Nothing+                            }+                    , id = "clause"+                    , trackEvents = False+                    }+                ]+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            , offVariation = Just 0+            , variations = [Bool False, Bool True]+            , debugEventsUntilDate = Nothing+            , clientSideAvailability = ClientSideAvailability {usingEnvironmentId = True, usingMobileKey = False, explicit = True}+            }++testClauseCanMatchCustomAttribute :: Test+testClauseCanMatchCustomAttribute = TestCase $ do+    store <- makeStoreIO Nothing 0+    userDetail <- evaluateDetail flag userContext HS.empty store+    orgDetail <- evaluateDetail flag orgContext HS.empty store+    assertEqual "test" expectedMatch userDetail+    assertEqual "test" expectedFailure orgDetail+  where+    expectedMatch =+        ( EvaluationDetail+            { value = Bool True+            , variationIndex = pure 1+            , reason =+                EvaluationReasonRuleMatch+                    { ruleIndex = 0+                    , ruleId = "clause"+                    , inExperiment = False+                    }+            }+        , []+        )++    expectedFailure =+        ( EvaluationDetail+            { value = Bool False+            , variationIndex = pure 0+            , reason = EvaluationReasonFallthrough {inExperiment = False}+            }+        , []+        )++    userContext = makeContext "x" "user" & withAttribute "legs" (Number 4)+    orgContext = makeContext "x" "org" & withAttribute "legs" (Number 4)++    flag =+        Flag+            { key = "feature"+            , version = 1+            , on = True+            , trackEvents = False+            , trackEventsFallthrough = False+            , deleted = False+            , prerequisites = []+            , salt = ""+            , targets = []+            , contextTargets = []+            , rules =+                [ Rule+                    { clauses =+                        [ Clause+                            { attribute = makeLiteral "legs"+                            , contextKind = "user"+                            , op = OpIn+                            , values = [Number 4]+                            , negate = False+                            }+                        ]+                    , variationOrRollout =+                        VariationOrRollout+                            { variation = Just 1+                            , rollout = Nothing+                            }+                    , id = "clause"+                    , trackEvents = False+                    }+                ]+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            , offVariation = Just 0+            , variations = [Bool False, Bool True]+            , debugEventsUntilDate = Nothing+            , clientSideAvailability = ClientSideAvailability {usingEnvironmentId = True, usingMobileKey = False, explicit = True}+            }++testClauseCanMatchCustomAttributeReference :: Test+testClauseCanMatchCustomAttributeReference = TestCase $ do+    store <- makeStoreIO Nothing 0+    userDetail <- evaluateDetail flag userContext HS.empty store+    orgDetail <- evaluateDetail flag orgContext HS.empty store+    assertEqual "test" expectedMatch userDetail+  where+    -- assertEqual "test" expectedFailure orgDetail++    expectedMatch =+        ( EvaluationDetail+            { value = Bool True+            , variationIndex = pure 1+            , reason =+                EvaluationReasonRuleMatch+                    { ruleIndex = 0+                    , ruleId = "clause"+                    , inExperiment = False+                    }+            }+        , []+        )++    expectedFailure =+        ( EvaluationDetail+            { value = Bool False+            , variationIndex = pure 0+            , reason = EvaluationReasonFallthrough {inExperiment = False}+            }+        , []+        )++    userContext = makeContext "x" "user" & withAttribute "attr~1a" (String "right")+    orgContext = makeContext "x" "org" & withAttribute "attr~1a" (String "right")++    flag =+        Flag+            { key = "feature"+            , version = 1+            , on = True+            , trackEvents = False+            , trackEventsFallthrough = False+            , deleted = False+            , prerequisites = []+            , salt = ""+            , targets = []+            , contextTargets = []+            , rules =+                [ Rule+                    { clauses =+                        [ Clause+                            { attribute = makeReference "/attr~01a"+                            , contextKind = "user"+                            , op = OpIn+                            , values = [String "right"]+                            , negate = False+                            }+                        ]+                    , variationOrRollout =+                        VariationOrRollout+                            { variation = Just 1+                            , rollout = Nothing+                            }+                    , id = "clause"+                    , trackEvents = False+                    }+                ]+            , fallthrough =+                VariationOrRollout+                    { variation = Just 0+                    , rollout = Nothing+                    }+            , offVariation = Just 0+            , variations = [Bool False, Bool True]+            , debugEventsUntilDate = Nothing+            , clientSideAvailability = ClientSideAvailability {usingEnvironmentId = True, usingMobileKey = False, explicit = True}+            }++makeTestClient :: IO Client+makeTestClient = do+    client <- makeClient $ (makeConfig "") & configSetOffline True+    initializeStore (getField @"store" client) mempty mempty+    pure client++testEvaluatingUnknownFlagReturnsDefault :: Test+testEvaluatingUnknownFlagReturnsDefault = TestCase $ do+    client <- makeTestClient+    boolVariation client "a" (makeContext "b" "user") False >>= (False @=?)++testEvaluatingUnknownFlagReturnsDefaultWithDetail :: Test+testEvaluatingUnknownFlagReturnsDefaultWithDetail = TestCase $ do+    client <- makeTestClient+    boolVariationDetail client "a" (makeContext "b" "user") False >>= (expected @=?)+  where+    expected =+        EvaluationDetail+            { value = False+            , variationIndex = Nothing+            , reason = EvaluationReasonError EvalErrorFlagNotFound+            }++testDefaultIsReturnedIfFlagEvaluatesToNil :: Test+testDefaultIsReturnedIfFlagEvaluatesToNil = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    boolVariation client "a" (makeContext "b" "user") False >>= (False @=?)+  where+    flag =+        (makeTestFlag "a" 52)+            { on = False+            , offVariation = Nothing+            }++testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail :: Test+testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    boolVariationDetail client "a" (makeContext "b" "user") False >>= (expected @=?)+  where+    flag =+        (makeTestFlag "a" 52)+            { on = False+            , offVariation = Nothing+            }+    expected =+        EvaluationDetail+            { value = False+            , variationIndex = Nothing+            , reason = EvaluationReasonOff+            }++allTests :: Test+allTests =+    TestList+        [ testFlagReturnsOffVariationIfFlagIsOff+        , testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules+        , testFlagReturnsErrorIfFallthroughHasTooHighVariation+        , testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout+        , testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList+        , testFlagReturnsErrorIfThereIsAPrerequisiteCycle+        , testFlagReturnsOffVariationIfPrerequisiteIsNotFound+        , testFlagReturnsOffVariationIfPrerequisiteIsOff+        , testFlagReturnsOffVariationIfPrerequisiteIsNotMet+        , testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules+        , testFlagCanTargetUserKeys+        , testFlagCanTargetContextKeys+        , testFlagCanTargetContextFallsbackToUserTargets+        , testFlagChecksTargetsBeforeRules+        , testClauseCanMatchCustomAttribute+        , testClauseCanMatchCustomAttributeReference+        , testClauseCanMatchOnKind+        , testEvaluatingUnknownFlagReturnsDefault+        , testEvaluatingUnknownFlagReturnsDefaultWithDetail+        , testDefaultIsReturnedIfFlagEvaluatesToNil+        , testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail+        ]
test/Spec/Features.hs view
@@ -1,7 +1,7 @@ module Spec.Features (allTests) where -import Data.ByteString.Lazy import Data.Aeson+import Data.ByteString.Lazy import Data.Text as T import LaunchDarkly.Server.Features import Test.HUnit@@ -9,73 +9,76 @@ assertFlagClientAvailabilityValues :: ByteString -> Bool -> Bool -> Bool -> IO () assertFlagClientAvailabilityValues jsonString expectedExplicit expectedUsingMobileKey expectedUsingEnvironmentId =     case (decode jsonString) of-      Just Flag { clientSideAvailability = ClientSideAvailability { usingMobileKey = usingMobileKey, usingEnvironmentId = usingEnvironmentId, explicit = explicit }, .. } -> do-          assertEqual "explicit did not match expected value" expectedExplicit explicit-          assertEqual "usingEnvironmentId did not match expected value" expectedUsingEnvironmentId usingEnvironmentId-          assertEqual "usingMobileKey did not match expected value" expectedUsingMobileKey usingMobileKey-      Nothing -> assertFailure "Failed to decode into flag"+        Just Flag {clientSideAvailability = ClientSideAvailability {usingMobileKey = usingMobileKey, usingEnvironmentId = usingEnvironmentId, explicit = explicit}, ..} -> do+            assertEqual "explicit did not match expected value" expectedExplicit explicit+            assertEqual "usingEnvironmentId did not match expected value" expectedUsingEnvironmentId usingEnvironmentId+            assertEqual "usingMobileKey did not match expected value" expectedUsingMobileKey usingMobileKey+        Nothing -> assertFailure "Failed to decode into flag"  testCanDecodeOldSchema :: Test testCanDecodeOldSchema = TestCase $ do-    let json = "{\-        \\"trackEventsFallthrough\":false,\-        \\"rules\":[],\-        \\"offVariation\":null,\-        \\"fallthrough\":{\"rollout\":null,\-        \\"variation\":null},\-        \\"key\":\"flag-key\",\-        \\"version\":1,\-        \\"variations\":[],\-        \\"salt\":\"\",\-        \\"targets\":[],\-        \\"prerequisites\":[],\-        \\"deleted\":false,\-        \\"trackEvents\":false,\-        \\"debugEventsUntilDate\":null,\-        \\"on\":true,\-        \\"clientSide\": true\-    \}"+    let json =+            "{\+            \\"trackEventsFallthrough\":false,\+            \\"rules\":[],\+            \\"offVariation\":null,\+            \\"fallthrough\":{\"rollout\":null,\+            \\"variation\":null},\+            \\"key\":\"flag-key\",\+            \\"version\":1,\+            \\"variations\":[],\+            \\"salt\":\"\",\+            \\"targets\":[],\+            \\"prerequisites\":[],\+            \\"deleted\":false,\+            \\"trackEvents\":false,\+            \\"debugEventsUntilDate\":null,\+            \\"on\":true,\+            \\"clientSide\": true\+            \}"     assertFlagClientAvailabilityValues json False True True     case decode json :: Maybe Flag of-      Just flag -> do-          assertBool "Re-encoding retains clientSide" ("clientSide\": true" `T.isInfixOf` json)-          assertBool "Re-encoding does not include new clientSideAvailability" (not $ "clientSideAvailability" `T.isInfixOf` json)-      Nothing -> assertFailure "Failed to decode into flag"+        Just flag -> do+            assertBool "Re-encoding retains clientSide" ("clientSide\": true" `T.isInfixOf` json)+            assertBool "Re-encoding does not include new clientSideAvailability" (not $ "clientSideAvailability" `T.isInfixOf` json)+        Nothing -> assertFailure "Failed to decode into flag"  testCanDecodeNewSchema :: Test testCanDecodeNewSchema = TestCase $ do-    let json = "{\-        \\"trackEventsFallthrough\":false,\-        \\"rules\":[],\-        \\"offVariation\":null,\-        \\"fallthrough\":{\"rollout\":null,\-        \\"variation\":null},\-        \\"key\":\"flag-key\",\-        \\"version\":1,\-        \\"variations\":[],\-        \\"salt\":\"\",\-        \\"targets\":[],\-        \\"prerequisites\":[],\-        \\"deleted\":false,\-        \\"trackEvents\":false,\-        \\"debugEventsUntilDate\":null,\-        \\"on\":true,\-        \\"clientSideAvailability\": {\+    let json =+            "{\+            \\"trackEventsFallthrough\":false,\+            \\"rules\":[],\+            \\"offVariation\":null,\+            \\"fallthrough\":{\"rollout\":null,\+            \\"variation\":null},\+            \\"key\":\"flag-key\",\+            \\"version\":1,\+            \\"variations\":[],\+            \\"salt\":\"\",\+            \\"targets\":[],\+            \\"prerequisites\":[],\+            \\"deleted\":false,\+            \\"trackEvents\":false,\+            \\"debugEventsUntilDate\":null,\+            \\"on\":true,\+            \\"clientSideAvailability\": {\             \\"usingMobileKey\": false,\             \\"usingEnvironmentId\": false\-        \}\-    \}"+            \}\+            \}"     assertFlagClientAvailabilityValues json True False False     case decode json :: Maybe Flag of-      Just flag -> do-          assertBool "Re-encoding does not include clientSide" (not $ ("clientSide\": true" `T.isInfixOf` json))-          assertBool "Re-encoding does include new clientSideAvailability" ("clientSideAvailability" `T.isInfixOf` json)-          assertBool "Re-encoding sets usingMobileKey correctly" ("usingMobileKey\": false" `T.isInfixOf` json)-          assertBool "Re-encoding sets usingEnvironmentId correctly" ("usingEnvironmentId\": false" `T.isInfixOf` json)-      Nothing -> assertFailure "Failed to decode into flag"+        Just flag -> do+            assertBool "Re-encoding does not include clientSide" (not $ ("clientSide\": true" `T.isInfixOf` json))+            assertBool "Re-encoding does include new clientSideAvailability" ("clientSideAvailability" `T.isInfixOf` json)+            assertBool "Re-encoding sets usingMobileKey correctly" ("usingMobileKey\": false" `T.isInfixOf` json)+            assertBool "Re-encoding sets usingEnvironmentId correctly" ("usingEnvironmentId\": false" `T.isInfixOf` json)+        Nothing -> assertFailure "Failed to decode into flag"  allTests :: Test-allTests = TestList-    [ testCanDecodeNewSchema-    , testCanDecodeOldSchema-    ]+allTests =+    TestList+        [ testCanDecodeNewSchema+        , testCanDecodeOldSchema+        ]
test/Spec/Integrations/FileData.hs view
@@ -1,30 +1,32 @@-module Spec.Integrations.FileData-    (allTests)-    where+module Spec.Integrations.FileData (allTests)+where -import           Test.HUnit+import Test.HUnit -import           LaunchDarkly.Server-import           LaunchDarkly.Server.Features (Segment(..))-import           LaunchDarkly.Server.DataSource.Internal-import           LaunchDarkly.Server.Integrations.FileData-import           LaunchDarkly.Server.Client.Status-import           LaunchDarkly.Server.Client.Internal-import           LaunchDarkly.Server.Store.Internal (storeHandleGetSegment)-import           LaunchDarkly.Server.User+import Control.Exception+import Control.Monad.Logger+import Data.Generics.Product (getField) import qualified Data.HashSet as HS-import           Control.Exception-import           Control.Monad.Logger+import LaunchDarkly.AesonCompat (emptyObject)+import LaunchDarkly.Server+import LaunchDarkly.Server.Client.Internal+import LaunchDarkly.Server.DataSource.Internal+import LaunchDarkly.Server.Features (Segment (..))+import LaunchDarkly.Server.Integrations.FileData+import LaunchDarkly.Server.Store.Internal (storeHandleGetSegment)  allTests :: Test-allTests = TestList-    [ TestLabel "testAllProperties" testAllProperties-    , TestLabel "testMultiFileFlagDuplicate" testMultiFileFlagDuplicate-    , TestLabel "testMalformedFile" testMalformedFile-    , TestLabel "testNoDataFile" testNoDataFile-    , TestLabel "testSegmentFile" testSegmentFile-    , TestLabel "testAllPropertiesYaml" testAllPropertiesYaml-    ]+allTests =+    TestList+        [ TestLabel "testAllProperties" testAllProperties+        , TestLabel "testTargettingJson" testTargettingJson+        , TestLabel "testTargettingYaml" testTargettingYaml+        , TestLabel "testMultiFileFlagDuplicate" testMultiFileFlagDuplicate+        , TestLabel "testMalformedFile" testMalformedFile+        , TestLabel "testNoDataFile" testNoDataFile+        , TestLabel "testSegmentFile" testSegmentFile+        , TestLabel "testAllPropertiesYaml" testAllPropertiesYaml+        ]  withClient :: Config -> (Client -> IO a) -> IO a withClient config = bracket (makeClient config) close@@ -32,16 +34,16 @@ testConfig :: DataSourceFactory -> Config testConfig factory =     configSetSendEvents False $-    configSetDataSourceFactory (Just factory) $-    configSetLogger (runStdoutLoggingT . filterLogger (\_ lvl -> lvl /= LevelDebug)) $-    makeConfig "sdk-key"+        configSetDataSourceFactory (Just factory) $+            configSetLogger (runStdoutLoggingT . filterLogger (\_ lvl -> lvl /= LevelDebug)) $+                makeConfig "sdk-key"  testAllProperties :: Test testAllProperties = TestCase $ do     let factory = dataSourceFactory ["test-data/filesource/all-properties.json"]         config = testConfig factory-        user1 = makeUser "user1"-        user2 = makeUser "user2"+        user1 = makeContext "user1" "user"+        user2 = makeContext "user2" "user"     withClient config $ \client -> do         status <- getStatus client         assertEqual "status initialized" Initialized status@@ -52,13 +54,63 @@         flag2 <- stringVariation client "flag2" user1 "fallback"         assertEqual "flag2 value" "value2" flag2 +testTargettingJson :: Test+testTargettingJson = TestCase $ do+    let factory = dataSourceFactory ["test-data/filesource/targets.json"]+        config = testConfig factory+        user1 = makeContext "user1" "user"+        user2 = makeContext "user2" "user"+        org1 = makeContext "org1" "org"+        org2 = makeContext "org2" "org"+    withClient config $ \client -> do+        status <- getStatus client+        assertEqual "status initialized" Initialized status++        flag1 <- stringVariation client "flag1" user1 "fall"+        assertEqual "flag1 user1" "user" flag1++        flag1 <- stringVariation client "flag1" user2 "fall"+        assertEqual "flag1 user2" "fall" flag1++        flag1 <- stringVariation client "flag1" org1 "fall"+        assertEqual "flag1 org1" "org" flag1++        flag1 <- stringVariation client "flag1" org2 "fall"+        assertEqual "flag1 org2" "fall" flag1++testTargettingYaml :: Test+testTargettingYaml = TestCase $ do+    let factory = dataSourceFactory ["test-data/filesource/targets.yml"]+        config = testConfig factory+        user1 = makeContext "user1" "user"+        user2 = makeContext "user2" "user"+        org1 = makeContext "org1" "org"+        org2 = makeContext "org2" "org"+    withClient config $ \client -> do+        status <- getStatus client+        assertEqual "status initialized" Initialized status++        flag1 <- stringVariation client "flag1" user1 "fall"+        assertEqual "flag1 user1" "user" flag1++        flag1 <- stringVariation client "flag1" user2 "fall"+        assertEqual "flag1 user2" "fall" flag1++        flag1 <- stringVariation client "flag1" org1 "fall"+        assertEqual "flag1 org1" "org" flag1++        flag1 <- stringVariation client "flag1" org2 "fall"+        assertEqual "flag1 org2" "fall" flag1+ testMultiFileFlagDuplicate :: Test testMultiFileFlagDuplicate = TestCase $ do-    let factory = dataSourceFactory [ "test-data/filesource/flag-only.json"-                                    , "test-data/filesource/flag-with-duplicate-key.json"-                                    ]+    let factory =+            dataSourceFactory+                [ "test-data/filesource/flag-only.json"+                , "test-data/filesource/flag-with-duplicate-key.json"+                ]         config = testConfig factory-        user1 = makeUser "user1"+        user1 = makeContext "user1" "user"     withClient config $ \client -> do         status <- getStatus client         assertEqual "status initialized" Initialized status@@ -71,25 +123,27 @@  testMalformedFile :: Test testMalformedFile = TestCase $ do-    let factory = dataSourceFactory [ "test-data/filesource/malformed.json" ]+    let factory = dataSourceFactory ["test-data/filesource/malformed.json"]         config = testConfig factory-        user1 = makeUser "user1"+        user1 = makeContext "user1" "user"     withClient config $ \client -> do-        assertEqual "No Flags set" mempty =<< allFlags client user1+        (\state -> assertEqual "No Flags set" emptyObject (getField @"evaluations" state))+            =<< allFlagsState client user1 False False False  testNoDataFile :: Test testNoDataFile = TestCase $ do-    let factory = dataSourceFactory [ "test-data/filesource/no-data.json" ]+    let factory = dataSourceFactory ["test-data/filesource/no-data.json"]         config = testConfig factory-        user1 = makeUser "user1"+        user1 = makeContext "user1" "user"     withClient config $ \client -> do-        assertEqual "No Flags set" mempty =<< allFlags client user1+        (\state -> assertEqual "No Flags set" emptyObject (getField @"evaluations" state))+            =<< allFlagsState client user1 False False False  testSegmentFile :: Test testSegmentFile = TestCase $ do-    let factory = dataSourceFactory [ "test-data/filesource/segment-only.json" ]+    let factory = dataSourceFactory ["test-data/filesource/segment-only.json"]         config = testConfig factory-    withClient config $ \(Client client) -> do+    withClient config $ \client -> do         eSeg1 <- storeHandleGetSegment (store client) "seg1"         mSeg1 <- either (assertFailure . show) pure eSeg1         seg1 <- maybe (assertFailure "Segment Not Found") pure mSeg1@@ -99,13 +153,12 @@         mSeg2 <- either (assertFailure . show) pure eSeg2         assertEqual "No Segment" Nothing mSeg2 - testAllPropertiesYaml :: Test testAllPropertiesYaml = TestCase $ do     let factory = dataSourceFactory ["test-data/filesource/all-properties.yml"]         config = testConfig factory-        user1 = makeUser "user1"-        user2 = makeUser "user2"+        user1 = makeContext "user1" "user"+        user2 = makeContext "user2" "user"     withClient config $ \client -> do         status <- getStatus client         assertEqual "status initialized" Initialized status@@ -115,4 +168,3 @@          flag2 <- stringVariation client "flag2" user1 "fallback"         assertEqual "flag2 value" "value2" flag2-
test/Spec/Integrations/TestData.hs view
@@ -1,207 +1,229 @@-module Spec.Integrations.TestData-    (allTests)-    where+module Spec.Integrations.TestData (allTests)+where -import           Test.HUnit+import Test.HUnit -import           Data.Aeson                                            (ToJSON, toJSON)-import           Data.Function                                         ((&))-import           Data.Functor                                          ((<&>))-import           Data.Text                                             (Text)-import           GHC.Generics                                          (Generic)+import Data.Aeson (ToJSON, toJSON)+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Text (Text)+import GHC.Generics (Generic) -import           Control.Monad.Logger-import           LaunchDarkly.Server-import           LaunchDarkly.Server.DataSource.Internal-import qualified LaunchDarkly.Server.Integrations.TestData             as TestData-import qualified LaunchDarkly.Server.Integrations.TestData.FlagBuilder as FlagBuilder+import Control.Monad.Logger+import LaunchDarkly.Server+import LaunchDarkly.Server.DataSource.Internal+import qualified LaunchDarkly.Server.Integrations.TestData as TestData  allTests :: Test-allTests = TestList-    [ testVariationForAllUsers-    , testMultipleFlags-    , testModifyFlags-    , testMultipleClients-    , testTargeting-    , testRules-    , testValueForAllUsers-    ]+allTests =+    TestList+        [ testVariationForAll+        , testMultipleFlags+        , testModifyFlags+        , testMultipleClients+        , testTargeting+        , testRules+        , testValueForAll+        ]  testConfig :: DataSourceFactory -> Config testConfig factory =     configSetSendEvents False $-    configSetDataSourceFactory (Just factory) $-    configSetLogger (runStdoutLoggingT . filterLogger (\_ lvl -> lvl /= LevelDebug)) $-    makeConfig "sdk-key"+        configSetDataSourceFactory (Just factory) $+            configSetLogger (runStdoutLoggingT . filterLogger (\_ lvl -> lvl /= LevelDebug)) $+                makeConfig "sdk-key" -testVariationForAllUsers :: Test-testVariationForAllUsers = TestCase $ do-  td <- TestData.newTestData-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variationForAllUsers True)-  let config = testConfig (TestData.dataSourceFactory td)-  client <- makeClient config-  let user1 = makeUser "user1"-      user2 = makeUser "user2"-  assertEqual "user1 set" True =<< boolVariation client "flag-key-1" user1 False-  assertEqual "user2 set" True =<< boolVariation client "flag-key-1" user2 False-  assertEqual "user not set for another flag" False =<< boolVariation client "another-key" user1 False-  close client+testVariationForAll :: Test+testVariationForAll = TestCase $ do+    td <- TestData.newTestData+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variationForAll True+            )+    let config = testConfig (TestData.dataSourceFactory td)+    client <- makeClient config+    let user1 = makeContext "user1" "user"+        user2 = makeContext "user2" "user"+    assertEqual "user1 set" True =<< boolVariation client "flag-key-1" user1 False+    assertEqual "user2 set" True =<< boolVariation client "flag-key-1" user2 False+    assertEqual "user not set for another flag" False =<< boolVariation client "another-key" user1 False+    close client  testModifyFlags :: Test testModifyFlags = TestCase $ do-  td <- TestData.newTestData-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variations [ toJSON ("blue" :: Text)-                                  , toJSON ("red" :: Text)-                                  , toJSON ("green" :: Text)-                                  ]-          <&> TestData.variationForAllUsers (0 :: TestData.VariationIndex))-  let config = testConfig (TestData.dataSourceFactory td)-  client <- makeClient config-  let user = makeUser "user"-  assertEqual "user set" "blue" =<< stringVariation client "flag-key-1" user "none"+    td <- TestData.newTestData+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variations+                    [ toJSON ("blue" :: Text)+                    , toJSON ("red" :: Text)+                    , toJSON ("green" :: Text)+                    ]+                <&> TestData.variationForAll (0 :: TestData.VariationIndex)+            )+    let config = testConfig (TestData.dataSourceFactory td)+    client <- makeClient config+    let user = makeContext "user" "user"+    assertEqual "user set" "blue" =<< stringVariation client "flag-key-1" user "none" -  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variationForAllUsers (2 :: TestData.VariationIndex))+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variationForAll (2 :: TestData.VariationIndex)+            ) -  assertEqual "user set to green after update" "green" =<< stringVariation client "flag-key-1" user "none"-  close client+    assertEqual "user set to green after update" "green" =<< stringVariation client "flag-key-1" user "none"+    close client  testMultipleFlags :: Test testMultipleFlags = TestCase $ do-  td <- TestData.newTestData-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variations [ toJSON ("blue" :: Text)-                                  , toJSON ("red" :: Text)-                                  , toJSON ("green" :: Text)-                                  ]-          <&> TestData.variationForAllUsers (0 :: TestData.VariationIndex))-  TestData.update td =<<-      (TestData.flag td "flag-key-2"-          <&> TestData.variationForAllUsers True)-  let config = testConfig (TestData.dataSourceFactory td)-  client <- makeClient config-  let user = makeUser "user"-  assertEqual "flag 1" "blue" =<< stringVariation client "flag-key-1" user "none"-  assertEqual "flag 2" True =<< boolVariation client "flag-key-2" user False-  close client+    td <- TestData.newTestData+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variations+                    [ toJSON ("blue" :: Text)+                    , toJSON ("red" :: Text)+                    , toJSON ("green" :: Text)+                    ]+                <&> TestData.variationForAll (0 :: TestData.VariationIndex)+            )+    TestData.update td+        =<< ( TestData.flag td "flag-key-2"+                <&> TestData.variationForAll True+            )+    let config = testConfig (TestData.dataSourceFactory td)+    client <- makeClient config+    let user = makeContext "user" "user"+    assertEqual "flag 1" "blue" =<< stringVariation client "flag-key-1" user "none"+    assertEqual "flag 2" True =<< boolVariation client "flag-key-2" user False+    close client  testMultipleClients :: Test testMultipleClients = TestCase $ do-  td <- TestData.newTestData-  let config = testConfig (TestData.dataSourceFactory td)-  client1 <- makeClient config-  client2 <- makeClient config-  let user = makeUser "user"-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variations [ toJSON ("blue" :: Text)-                                  , toJSON ("red" :: Text)-                                  , toJSON ("green" :: Text)-                                  ]-          <&> TestData.variationForAllUsers (0 :: TestData.VariationIndex))-  assertEqual "client1 recieved update" "blue" =<< stringVariation client1 "flag-key-1" user "none"-  assertEqual "client2 recieved update" "blue" =<< stringVariation client2 "flag-key-1" user "none"-  close client2-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variationForAllUsers (2 :: TestData.VariationIndex))+    td <- TestData.newTestData+    let config = testConfig (TestData.dataSourceFactory td)+    client1 <- makeClient config+    client2 <- makeClient config+    let user = makeContext "user" "user"+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variations+                    [ toJSON ("blue" :: Text)+                    , toJSON ("red" :: Text)+                    , toJSON ("green" :: Text)+                    ]+                <&> TestData.variationForAll (0 :: TestData.VariationIndex)+            )+    assertEqual "client1 recieved update" "blue" =<< stringVariation client1 "flag-key-1" user "none"+    assertEqual "client2 recieved update" "blue" =<< stringVariation client2 "flag-key-1" user "none"+    close client2+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variationForAll (2 :: TestData.VariationIndex)+            ) -  assertEqual "client1 recieved update to green" "green" =<< stringVariation client1 "flag-key-1" user "none"-  assertEqual "client2 no update after close" "none" =<< stringVariation client2 "flag-key-1" user "none"-  close client1+    assertEqual "client1 recieved update to green" "green" =<< stringVariation client1 "flag-key-1" user "none"+    assertEqual "client2 no update after close" "none" =<< stringVariation client2 "flag-key-1" user "none"+    close client1  testTargeting :: Test testTargeting = TestCase $ do-  td <- TestData.newTestData-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variations [ toJSON ("blue" :: Text)-                                  , toJSON ("red" :: Text)-                                  , toJSON ("green" :: Text)-                                  ]-          <&> TestData.variationForUser "ben" (0 :: TestData.VariationIndex)-          <&> TestData.variationForUser "todd" (0 :: TestData.VariationIndex)-          <&> TestData.offVariation (1 :: TestData.VariationIndex)-          <&> TestData.fallthroughVariation (2 :: TestData.VariationIndex))-  let config = testConfig (TestData.dataSourceFactory td)-      ben = makeUser "ben"-      todd = makeUser "todd"-      evelyn = makeUser "evelyn"--  client <- makeClient config+    td <- TestData.newTestData+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variations+                    [ toJSON ("blue" :: Text)+                    , toJSON ("red" :: Text)+                    , toJSON ("green" :: Text)+                    ]+                <&> TestData.variationForUser "ben" (0 :: TestData.VariationIndex)+                <&> TestData.variationForUser "todd" (0 :: TestData.VariationIndex)+                <&> TestData.variationForKey "org" "ben" (0 :: TestData.VariationIndex)+                <&> TestData.offVariation (1 :: TestData.VariationIndex)+                <&> TestData.fallthroughVariation (2 :: TestData.VariationIndex)+            )+    let config = testConfig (TestData.dataSourceFactory td)+        ben = makeContext "ben" "user"+        todd = makeContext "todd" "user"+        evelyn = makeContext "evelyn" "user"+        benAsOrg = makeContext "ben" "org"+        toddAsOrg = makeContext "todd" "org" -  assertEqual "ben recieves blue" "blue" =<< stringVariation client "flag-key-1" ben "none"-  assertEqual "todd recieves blue" "blue" =<< stringVariation client "flag-key-1" todd "none"-  assertEqual "evelyn recieves green" "green" =<< stringVariation client "flag-key-1" evelyn "none"-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.on False)+    client <- makeClient config -  assertEqual "targeting off ben recieves red" "red" =<< stringVariation client "flag-key-1" ben "none"-  assertEqual "targeting off todd recieves red" "red" =<< stringVariation client "flag-key-1" todd "none"-  assertEqual "targeting off evelyn recieves red" "red" =<< stringVariation client "flag-key-1" evelyn "none"+    assertEqual "ben receives blue" "blue" =<< stringVariation client "flag-key-1" ben "none"+    assertEqual "todd receives blue" "blue" =<< stringVariation client "flag-key-1" todd "none"+    assertEqual "evelyn receives green" "green" =<< stringVariation client "flag-key-1" evelyn "none"+    assertEqual "ben as org receives blue" "blue" =<< stringVariation client "flag-key-1" benAsOrg "none"+    assertEqual "todd as org receives green" "green" =<< stringVariation client "flag-key-1" toddAsOrg "none"+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.on False+            ) -  close client+    assertEqual "targeting off ben receives red" "red" =<< stringVariation client "flag-key-1" ben "none"+    assertEqual "targeting off todd receives red" "red" =<< stringVariation client "flag-key-1" todd "none"+    assertEqual "targeting off evelyn receives red" "red" =<< stringVariation client "flag-key-1" evelyn "none"+    assertEqual "targeting off ben as org receives red" "red" =<< stringVariation client "flag-key-1" benAsOrg "none"+    assertEqual "targeting off todd as org receives red" "red" =<< stringVariation client "flag-key-1" toddAsOrg "none" +    close client  testRules :: Test testRules = TestCase $ do-  td <- TestData.newTestData-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-          <&> TestData.variations [ toJSON ("blue" :: Text)-                                  , toJSON ("red" :: Text)-                                  , toJSON ("green" :: Text)-                                  ]-          <&> TestData.ifMatch "country" [toJSON ("gb" :: Text), toJSON ("usa" :: Text)]-          <&> TestData.andMatch "name" [toJSON ("Todd" :: Text)]-          <&> TestData.thenReturn (1 :: TestData.VariationIndex)-          <&> TestData.ifNotMatch "name" [toJSON ("Todd" :: Text)]-          <&> TestData.andMatch "country" [toJSON ("gb" :: Text), toJSON ("usa" :: Text)]-          <&> TestData.thenReturn (2 :: TestData.VariationIndex)-          <&> TestData.fallthroughVariation (0 :: TestData.VariationIndex))-  let config = testConfig (TestData.dataSourceFactory td)-      ben = makeUser "ben"-                & userSetCountry (Just "usa")-                & userSetName (Just "Ben")-      todd = makeUser "todd"-                & userSetCountry (Just "gb")-                & userSetName (Just "Todd")-      evelyn = makeUser "evelyn"+    td <- TestData.newTestData+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.variations+                    [ toJSON ("blue" :: Text)+                    , toJSON ("red" :: Text)+                    , toJSON ("green" :: Text)+                    ]+                <&> TestData.ifMatch "country" [toJSON ("gb" :: Text), toJSON ("usa" :: Text)]+                <&> TestData.andMatch "name" [toJSON ("Todd" :: Text)]+                <&> TestData.thenReturn (1 :: TestData.VariationIndex)+                <&> TestData.ifNotMatch "name" [toJSON ("Todd" :: Text)]+                <&> TestData.andMatch "country" [toJSON ("gb" :: Text), toJSON ("usa" :: Text)]+                <&> TestData.thenReturn (2 :: TestData.VariationIndex)+                <&> TestData.fallthroughVariation (0 :: TestData.VariationIndex)+            )+    let config = testConfig (TestData.dataSourceFactory td)+        ben =+            makeContext "ben" "user"+                & withAttribute "country" "usa"+                & withAttribute "name" "Ben"+        todd =+            makeContext "todd" "user"+                & withAttribute "country" "gb"+                & withAttribute "name" "Todd"+        evelyn = makeContext "evelyn" "user" -  client <- makeClient config+    client <- makeClient config -  assertEqual "ben recieves green" "green" =<< stringVariation client "flag-key-1" ben "none"-  assertEqual "todd recieves red" "red" =<< stringVariation client "flag-key-1" todd "none"-  assertEqual "evelyn recieves blue" "blue" =<< stringVariation client "flag-key-1" evelyn "none"+    assertEqual "ben receives green" "green" =<< stringVariation client "flag-key-1" ben "none"+    assertEqual "todd receives red" "red" =<< stringVariation client "flag-key-1" todd "none"+    assertEqual "evelyn receives blue" "blue" =<< stringVariation client "flag-key-1" evelyn "none" -  close client+    close client  data CustomType     = CustomType1     | CustomType2     deriving (Generic, Eq, Show, ToJSON) -testValueForAllUsers :: Test-testValueForAllUsers = TestCase $ do-  td <- TestData.newTestData-  TestData.update td =<<-      (TestData.flag td "flag-key-1"-        <&> TestData.valueForAllUsers CustomType1)-  let config = testConfig (TestData.dataSourceFactory td)-      ben = makeUser "ben"-      todd = makeUser "todd"--  client <- makeClient config+testValueForAll :: Test+testValueForAll = TestCase $ do+    td <- TestData.newTestData+    TestData.update td+        =<< ( TestData.flag td "flag-key-1"+                <&> TestData.valueForAll CustomType1+            )+    let config = testConfig (TestData.dataSourceFactory td)+        ben = makeContext "ben" "user"+        todd = makeContext "todd" "user" -  assertEqual "ben recieves CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" ben "CustomType2"-  assertEqual "todd recieves CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" todd "CustomType2"+    client <- makeClient config -  close client+    assertEqual "ben receives CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" ben "CustomType2"+    assertEqual "todd receives CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" todd "CustomType2" +    close client
test/Spec/Operators.hs view
@@ -1,7 +1,7 @@ module Spec.Operators (allTests) where +import Data.Aeson.Types (Value (..)) import Test.HUnit-import Data.Aeson.Types              (Value(..))  import LaunchDarkly.Server.Operators @@ -24,77 +24,80 @@ makeTest f@(o, x, y, e) = TestCase $ assertEqual (show f) e $ (getOperation o) x y  allTests :: Test-allTests = TestList $ map makeTest-    -- numeric operators-    [ (OpIn, Number $ fromInteger 50, Number $ fromInteger 50, True)-    , (OpIn, Number $ fromRational 99.0001, Number $ fromRational 99.0001, True)-    , (OpLessThan, Number $ fromInteger 1, Number $ fromRational 1.99999, True)-    , (OpLessThan, Number $ fromRational 1.99999, Number $ fromInteger 1, False)-    , (OpLessThan, Number $ fromInteger 1, Number $ fromInteger 2, True)-    , (OpLessThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True)-    , (OpGreaterThan, Number $ fromInteger 2, Number $ fromRational 1.99999, True)-    , (OpGreaterThan, Number $ fromRational 1.99999, Number $ fromInteger 2, False)-    , (OpGreaterThan, Number $ fromInteger 2, Number $ fromInteger 1, True)-    , (OpGreaterThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True)-    -- string operators-    , (OpIn, String "x", String "x", True)-    , (OpIn, String "x", String "xyz", False)-    , (OpStartsWith, String "xyz", String "x", True)-    , (OpStartsWith, String "x", String "xyz", False)-    , (OpEndsWith, String "xyz", String "z", True)-    , (OpEndsWith, String "z", String "xyz", False)-    , (OpContains, String "xyz", String "y", True)-    , (OpContains, String "y", String "yz", False)-    -- mixed strings and numbers-    , (OpIn, String "99", Number $ fromInteger 99, False)-    , (OpIn, Number $ fromInteger 99, String "99", False)-    , (OpContains, String "99", Number $ fromInteger 99, False)-    , (OpStartsWith, String "99", Number $ fromInteger 99, False)-    , (OpEndsWith, String "99", Number $ fromInteger 99, False)-    , (OpLessThanOrEqual, String "99", Number $ fromInteger 99, False)-    , (OpLessThanOrEqual, Number $ fromInteger 99, String "99", False)-    , (OpGreaterThanOrEqual, String "99", Number $ fromInteger 99, False)-    , (OpGreaterThanOrEqual, Number $ fromInteger 99, String "99", False)-    -- date operators-    , (OpBefore, dateStr1, dateStr2, True)-    , (OpBefore, dateMs1, dateMs2, True)-    , (OpBefore, dateStr2, dateStr1, False)-    , (OpBefore, dateMs2, dateMs1, False)-    , (OpBefore, dateStr1, dateStr1, False)-    , (OpBefore, dateMs1, dateMs1, False)-    , (OpBefore, String "", dateStr1, False)-    , (OpBefore, dateStr1, invalidDate, False)-    , (OpAfter, dateStr2, dateStr1, True)-    , (OpAfter, dateMs2, dateMs1, True)-    , (OpAfter, dateStr1, dateStr2, False)-    , (OpAfter, dateMs1, dateMs2, False)-    , (OpAfter, dateStr1, dateStr1, False)-    , (OpAfter, dateMs1, dateMs1, False)-    , (OpAfter, String "", dateStr1, False)-    , (OpAfter, dateStr1, invalidDate, False)-    -- regex-    , (OpMatches, String "hello world", String "hello.*rld", True)-    , (OpMatches, String "hello world", String "hello.*orl", True)-    , (OpMatches, String "hello world", String "l+", True)-    , (OpMatches, String "hello world", String "(world|planet)", True)-    , (OpMatches, String "hello world", String "aloha", False)-    , (OpMatches, String "hello world", String "***bad rg", False)-    -- semver operators-    , (OpSemVerEqual, String "2.0.0", String "2.0.0", True)-    , (OpSemVerEqual, String "2.0", String "2.0.0", True)-    , (OpSemVerEqual, String "2.0-rc1", String "2.0.0-rc1", True)-    , (OpSemVerEqual, String "2+build2", String "2.0.0+build2", True)-    , (OpSemVerEqual, String "2.0.0", String "2.0.1", False)-    , (OpSemVerEqual, String "02.0.0", String "2.0.0", False)-    , (OpSemVerLessThan, String "2.0.0", String "2.0.1", True)-    , (OpSemVerLessThan, String "2.0", String "2.0.1", True)-    , (OpSemVerLessThan, String "2.0.1", String "2.0.0", False)-    , (OpSemVerLessThan, String "2.0.1", String "2.0", False)-    , (OpSemVerLessThan, String "2.0.1", String "xbad%ver", False)-    , (OpSemVerLessThan, String "2.0.0-rc", String "2.0.0-rc.beta", True)-    , (OpSemVerGreaterThan, String "2.0.1", String "2.0", True)-    , (OpSemVerGreaterThan, String "2.0.0", String "2.0.1", False)-    , (OpSemVerGreaterThan, String "2.0", String "2.0.1", False)-    , (OpSemVerGreaterThan, String "2.0.1", String "xbad%ver", False)-    , (OpSemVerGreaterThan, String "2.0.0-rc.1", String "2.0.0-rc.0", True)-    ]+allTests =+    TestList $+        map+            makeTest+            -- numeric operators+            [ (OpIn, Number $ fromInteger 50, Number $ fromInteger 50, True)+            , (OpIn, Number $ fromRational 99.0001, Number $ fromRational 99.0001, True)+            , (OpLessThan, Number $ fromInteger 1, Number $ fromRational 1.99999, True)+            , (OpLessThan, Number $ fromRational 1.99999, Number $ fromInteger 1, False)+            , (OpLessThan, Number $ fromInteger 1, Number $ fromInteger 2, True)+            , (OpLessThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True)+            , (OpGreaterThan, Number $ fromInteger 2, Number $ fromRational 1.99999, True)+            , (OpGreaterThan, Number $ fromRational 1.99999, Number $ fromInteger 2, False)+            , (OpGreaterThan, Number $ fromInteger 2, Number $ fromInteger 1, True)+            , (OpGreaterThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True)+            , -- string operators+              (OpIn, String "x", String "x", True)+            , (OpIn, String "x", String "xyz", False)+            , (OpStartsWith, String "xyz", String "x", True)+            , (OpStartsWith, String "x", String "xyz", False)+            , (OpEndsWith, String "xyz", String "z", True)+            , (OpEndsWith, String "z", String "xyz", False)+            , (OpContains, String "xyz", String "y", True)+            , (OpContains, String "y", String "yz", False)+            , -- mixed strings and numbers+              (OpIn, String "99", Number $ fromInteger 99, False)+            , (OpIn, Number $ fromInteger 99, String "99", False)+            , (OpContains, String "99", Number $ fromInteger 99, False)+            , (OpStartsWith, String "99", Number $ fromInteger 99, False)+            , (OpEndsWith, String "99", Number $ fromInteger 99, False)+            , (OpLessThanOrEqual, String "99", Number $ fromInteger 99, False)+            , (OpLessThanOrEqual, Number $ fromInteger 99, String "99", False)+            , (OpGreaterThanOrEqual, String "99", Number $ fromInteger 99, False)+            , (OpGreaterThanOrEqual, Number $ fromInteger 99, String "99", False)+            , -- date operators+              (OpBefore, dateStr1, dateStr2, True)+            , (OpBefore, dateMs1, dateMs2, True)+            , (OpBefore, dateStr2, dateStr1, False)+            , (OpBefore, dateMs2, dateMs1, False)+            , (OpBefore, dateStr1, dateStr1, False)+            , (OpBefore, dateMs1, dateMs1, False)+            , (OpBefore, String "", dateStr1, False)+            , (OpBefore, dateStr1, invalidDate, False)+            , (OpAfter, dateStr2, dateStr1, True)+            , (OpAfter, dateMs2, dateMs1, True)+            , (OpAfter, dateStr1, dateStr2, False)+            , (OpAfter, dateMs1, dateMs2, False)+            , (OpAfter, dateStr1, dateStr1, False)+            , (OpAfter, dateMs1, dateMs1, False)+            , (OpAfter, String "", dateStr1, False)+            , (OpAfter, dateStr1, invalidDate, False)+            , -- regex+              (OpMatches, String "hello world", String "hello.*rld", True)+            , (OpMatches, String "hello world", String "hello.*orl", True)+            , (OpMatches, String "hello world", String "l+", True)+            , (OpMatches, String "hello world", String "(world|planet)", True)+            , (OpMatches, String "hello world", String "aloha", False)+            , (OpMatches, String "hello world", String "***bad rg", False)+            , -- semver operators+              (OpSemVerEqual, String "2.0.0", String "2.0.0", True)+            , (OpSemVerEqual, String "2.0", String "2.0.0", True)+            , (OpSemVerEqual, String "2.0-rc1", String "2.0.0-rc1", True)+            , (OpSemVerEqual, String "2+build2", String "2.0.0+build2", True)+            , (OpSemVerEqual, String "2.0.0", String "2.0.1", False)+            , (OpSemVerEqual, String "02.0.0", String "2.0.0", False)+            , (OpSemVerLessThan, String "2.0.0", String "2.0.1", True)+            , (OpSemVerLessThan, String "2.0", String "2.0.1", True)+            , (OpSemVerLessThan, String "2.0.1", String "2.0.0", False)+            , (OpSemVerLessThan, String "2.0.1", String "2.0", False)+            , (OpSemVerLessThan, String "2.0.1", String "xbad%ver", False)+            , (OpSemVerLessThan, String "2.0.0-rc", String "2.0.0-rc.beta", True)+            , (OpSemVerGreaterThan, String "2.0.1", String "2.0", True)+            , (OpSemVerGreaterThan, String "2.0.0", String "2.0.1", False)+            , (OpSemVerGreaterThan, String "2.0", String "2.0.1", False)+            , (OpSemVerGreaterThan, String "2.0.1", String "xbad%ver", False)+            , (OpSemVerGreaterThan, String "2.0.0-rc.1", String "2.0.0-rc.0", True)+            ]
+ test/Spec/PersistentDataStore.hs view
@@ -0,0 +1,232 @@+module Spec.PersistentDataStore (allTests) where++import Data.ByteString ()+import Data.Either (isLeft)+import Data.Function ((&))+import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)+import System.Clock (TimeSpec (..))+import Test.HUnit++import Util.Features (makeTestFlag)++import LaunchDarkly.AesonCompat (emptyObject, insertKey, singleton)+import LaunchDarkly.Server.Store.Internal++makeTestStore :: Maybe PersistentDataStore -> IO (StoreHandle IO)+makeTestStore backend = makeStoreIO backend $ TimeSpec 10 0++makeStoreInterface :: PersistentDataStore+makeStoreInterface =+    PersistentDataStore+        { persistentDataStoreAllFeatures = const $ assertFailure "allFeatures should not be called"+        , persistentDataStoreGetFeature = const $ const $ assertFailure "getFeatures should not be called"+        , persistentDataStoreUpsertFeature = const $ const $ const $ assertFailure "upsertFeature should not be called"+        , persistentDataStoreIsInitialized = assertFailure "isInitialized should not be called"+        , persistentDataStoreInitialize = const $ assertFailure "initialize should not be called"+        }++testFailInit :: Test+testFailInit = TestCase $ do+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreInitialize = \_ -> pure $ Left "err"+                    }+    initializeStore store emptyObject emptyObject >>= (Left "err" @?=)++testFailGet :: Test+testFailGet = TestCase $ do+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreGetFeature = \_ _ -> pure $ Left "err"+                    }+    getFlagC store "abc" >>= (Left "err" @?=)++testFailAll :: Test+testFailAll = TestCase $ do+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreAllFeatures = \_ -> pure $ Left "err"+                    }+    getAllFlagsC store >>= (Left "err" @?=)++testFailIsInitialized :: Test+testFailIsInitialized = TestCase $ do+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreIsInitialized = pure $ Left "err"+                    }+    getInitializedC store >>= (Left "err" @?=)++testFailUpsert :: Test+testFailUpsert = TestCase $ do+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreUpsertFeature = \_ _ _ -> pure $ Left "err"+                    }+    insertFlag store (makeTestFlag "test" 123) >>= (Left "err" @?=)++testFailGetInvalidJSON :: Test+testFailGetInvalidJSON = TestCase $ do+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreGetFeature = \_ _ -> pure $ Right $ Just $ SerializedItemDescriptor (pure "invalid json") 0 False+                    }+    getFlagC store "abc" >>= (\v -> True @?= isLeft v)++testGetAllInvalidJSON :: Test+testGetAllInvalidJSON = TestCase $ do+    let flag = makeTestFlag "abc" 52+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreAllFeatures = \_ ->+                        pure $+                            Right $+                                emptyObject+                                    & insertKey "abc" (createSerializedItemDescriptor $ ItemDescriptor (pure flag) 52)+                                    & insertKey "xyz" (SerializedItemDescriptor (pure "invalid json") 64 False)+                    }+    getAllFlagsC store >>= (Right (singleton "abc" flag) @?=)++testInitializedCache :: Test+testInitializedCache = TestCase $ do+    counter <- newIORef 0+    value <- newIORef False+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreIsInitialized = do+                        atomicModifyIORef' counter (\c -> (c + 1, ()))+                        Right <$> readIORef value+                    }+    getInitializedC store >>= (Right False @=?)+    readIORef counter >>= (1 @=?)+    getInitializedC store >>= (Right False @=?)+    readIORef counter >>= (1 @=?)+    storeHandleExpireAll store >>= (Right () @=?)+    getInitializedC store >>= (Right False @=?)+    readIORef counter >>= (2 @=?)+    writeIORef value True+    storeHandleExpireAll store >>= (Right () @=?)+    getInitializedC store >>= (Right True @=?)+    readIORef counter >>= (3 @=?)+    getInitializedC store >>= (Right True @=?)+    readIORef counter >>= (3 @=?)++testGetCache :: Test+testGetCache = TestCase $ do+    counter <- newIORef 0+    value <- newIORef $ Just $ SerializedItemDescriptor Nothing 0 False+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreGetFeature = \_ _ -> do+                        atomicModifyIORef' counter (\c -> (c + 1, ()))+                        Right <$> readIORef value+                    }+    getFlagC store "abc" >>= (Right Nothing @?=)+    readIORef counter >>= (1 @=?)+    getFlagC store "abc" >>= (Right Nothing @?=)+    readIORef counter >>= (1 @=?)+    storeHandleExpireAll store >>= (Right () @=?)+    let flag = pure $ makeTestFlag "abc" 12+    writeIORef value $ Just $ createSerializedItemDescriptor $ ItemDescriptor flag 12+    getFlagC store "abc" >>= (Right flag @=?)+    readIORef counter >>= (2 @=?)+    getFlagC store "abc" >>= (Right flag @=?)+    readIORef counter >>= (2 @=?)++testUpsertInvalidatesAllFlags :: Test+testUpsertInvalidatesAllFlags = TestCase $ do+    allCounter <- newIORef 0+    upsertCounter <- newIORef 0+    upsertResult <- newIORef $ Right True+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreUpsertFeature = \_ _ _ -> do+                        atomicModifyIORef' upsertCounter (\c -> (c + 1, ()))+                        readIORef upsertResult+                    , persistentDataStoreAllFeatures = \_ -> do+                        atomicModifyIORef' allCounter (\c -> (c + 1, ()))+                        pure $ Right emptyObject+                    }+    getAllFlagsC store >>= (Right emptyObject @=?)+    readIORef allCounter >>= (1 @=?)+    deleteFlag store "abc" 52 >>= (Right () @=?)+    readIORef upsertCounter >>= (1 @=?)+    getAllFlagsC store >>= (Right emptyObject @=?)+    readIORef allCounter >>= (2 @=?)+    writeIORef upsertResult $ Right False+    deleteFlag store "abc" 53 >>= (Right () @=?)+    readIORef upsertCounter >>= (2 @=?)+    getAllFlagsC store >>= (Right emptyObject @=?)+    readIORef allCounter >>= (2 @=?)++testAllFlagsCache :: Test+testAllFlagsCache = TestCase $ do+    counter <- newIORef 0+    value <- newIORef emptyObject+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreAllFeatures = \_ -> do+                        atomicModifyIORef' counter (\c -> (c + 1, ()))+                        pure $ Right emptyObject+                    }+    getAllFlagsC store >>= (Right emptyObject @=?)+    readIORef counter >>= (1 @=?)+    getAllFlagsC store >>= (Right emptyObject @=?)+    readIORef counter >>= (1 @=?)+    storeHandleExpireAll store >>= (Right () @=?)+    getAllFlagsC store >>= (Right emptyObject @=?)+    readIORef counter >>= (2 @=?)++testAllFlagsUpdatesRegularCache :: Test+testAllFlagsUpdatesRegularCache = TestCase $ do+    let flag = makeTestFlag "abc" 12+    store <-+        makeTestStore $+            pure $+                makeStoreInterface+                    { persistentDataStoreAllFeatures = \_ ->+                        pure $+                            Right $+                                singleton "abc" (createSerializedItemDescriptor $ ItemDescriptor (pure flag) 12)+                    }+    getAllFlagsC store >>= (Right (singleton "abc" flag) @=?)+    getFlagC store "abc" >>= (Right (pure flag) @=?)++allTests :: Test+allTests =+    TestList+        [ testFailInit+        , testFailGet+        , testFailAll+        , testFailIsInitialized+        , testFailUpsert+        , testFailGetInvalidJSON+        , testGetAllInvalidJSON+        , testInitializedCache+        , testGetCache+        , testUpsertInvalidatesAllFlags+        , testAllFlagsCache+        , testAllFlagsUpdatesRegularCache+        ]
− test/Spec/Redis.hs 
@@ -1,49 +0,0 @@-module Spec.Redis (allTests) where--import           Test.HUnit-import           Data.Text                                (Text)-import qualified Database.Redis as                        R-import           Data.HashMap.Strict                      (HashMap)-import qualified Data.HashMap.Strict as                   HM-import           Control.Monad                            (void)-import           GHC.Natural                              (Natural)-import           GHC.Int                                  (Int64)-import           System.Clock                             (TimeSpec(..))--import           Util.Features                            (makeTestFlag)--import           Spec.Store                               (testWithStore)--import           LaunchDarkly.Server.Features             (Flag(..), VariationOrRollout(..))-import           LaunchDarkly.Server.Store.Internal-import           LaunchDarkly.Server.Store.Redis.Internal--freshConnection :: IO R.Connection-freshConnection = do-    con <- R.checkedConnect R.defaultConnectInfo-    void $ R.runRedis con $ R.flushall-    pure con--testUpsertRace :: Test-testUpsertRace = TestCase $ do-    con <- freshConnection-    let config = makeRedisStoreConfig con-    backend <- makeRedisStore config-    store <- makeStoreIO (pure backend) $ TimeSpec 0 0-    let hook = (insertFlag store $ makeTestFlag "a" 2) >>= (Right () @=?)-    redisUpsertInternal hook config "flags" "a" (versionedToRaw $ Versioned (pure $ makeTestFlag "a" 1) 1)-        >>= (Right False @=?)-    getFlagC store "a" >>= (Right (pure $ makeTestFlag "a" 2) @=?)--prepareRedisStore :: Int64 -> IO (StoreHandle IO)-prepareRedisStore ttl = do-    con <- freshConnection-    backend <- makeRedisStore $ makeRedisStoreConfig con-    makeStoreIO (pure backend) $ TimeSpec ttl 0--allTests :: Test-allTests = TestList-    [ testWithStore $ prepareRedisStore 10-    , testWithStore $ prepareRedisStore 0-    , testUpsertRace-    ]
+ test/Spec/Reference.hs view
@@ -0,0 +1,108 @@+module Spec.Reference (allTests) where++import LaunchDarkly.Server.Reference (getComponents, getError, getRawPath, makeLiteral, makeReference)+import Test.HUnit++invalidReferences :: Test+invalidReferences =+    TestCase $+        ( do+            confirm "empty reference" ""+            confirm "empty reference" "/"++            confirm "trailing slash" "//"+            confirm "trailing slash" "/a/b/"+            confirm "double slash" "/a//b"++            confirm "invalid escape sequence" "/a~x"+            confirm "invalid escape sequence" "/a~"+            confirm "invalid escape sequence" "/a/b~x"+            confirm "invalid escape sequence" "/a/b~"+        )+  where+    confirm err reference = assertEqual "" err $ getError $ makeReference reference++validReferencesWithoutLeadingSlash :: Test+validReferencesWithoutLeadingSlash =+    TestCase $+        ( do+            confirm "key"+            confirm "kind"+            confirm "name"+            confirm "name/with/slashes"+            confirm "name~0~1with-what-looks-like-escape-sequences"+        )+  where+    confirm ref =+        let reference = makeReference ref+         in ( do+                assertEqual "" "" $ getError reference+                assertEqual "" ref $ getRawPath reference+                assertEqual "" [ref] $ getComponents reference+            )++validReferencesWithLeadingSlash :: Test+validReferencesWithLeadingSlash =+    TestCase $+        ( do+            confirm "/key" "key"+            confirm "/0" "0"+            confirm "/name~1with~1slashes~0and~0tildes" "name/with/slashes~and~tildes"+        )+  where+    confirm ref component =+        let reference = makeReference ref+         in ( do+                assertEqual "" "" $ getError reference+                assertEqual "" [component] $ getComponents reference+                assertEqual "" ref $ getRawPath reference+            )++canAccessSubcomponents :: Test+canAccessSubcomponents =+    TestCase $+        ( do+            confirm "/key" ["key"]+            confirm "/a/b" ["a", "b"]+            confirm "/a~1b/c" ["a/b", "c"]+            confirm "/a~0b/c" ["a~b", "c"]+            confirm "/a/10/20/30x" ["a", "10", "20", "30x"]++            confirm "" []+            confirm "key" ["key"]+            confirm "/key" ["key"]+            confirm "/a/b" ["a", "b"]+        )+  where+    confirm ref components =+        let reference = makeReference ref+         in assertEqual "" components $ getComponents reference++validLiteralReferences :: Test+validLiteralReferences =+    TestCase $+        ( do+            confirm "name" "name"+            confirm "a/b" "a/b"+            confirm "/a/b~c" "/~1a~1b~0c"+            confirm "/" "/~1"+        )+  where+    confirm ref path =+        let literal = makeLiteral ref+            reference = makeReference path+         in assertEqual "" (getRawPath literal) (getRawPath reference)++invalidLiteralReferences :: Test+invalidLiteralReferences = TestCase $ assertEqual "" "empty reference" $ getError $ makeLiteral ""++allTests :: Test+allTests =+    TestList+        [ invalidReferences+        , validReferencesWithoutLeadingSlash+        , validReferencesWithLeadingSlash+        , canAccessSubcomponents+        , validLiteralReferences+        , invalidLiteralReferences+        ]
test/Spec/Segment.hs view
@@ -1,209 +1,449 @@ module Spec.Segment (allTests) where -import           Test.HUnit-import           Data.Aeson.Types        (Value(..))-import           Data.Function           ((&))-import qualified Data.HashSet as         HS+import Data.Aeson.Types (Value (..))+import Data.Function ((&))+import Data.Generics.Product (getField)+import qualified Data.HashSet as HS+import Test.HUnit+import Util.Features  import LaunchDarkly.Server.Client+import LaunchDarkly.Server.Config+import LaunchDarkly.Server.Context (makeContext, withAttribute)+import LaunchDarkly.Server.Evaluate import LaunchDarkly.Server.Features-import LaunchDarkly.Server.User-import LaunchDarkly.Server.User.Internal import LaunchDarkly.Server.Operators-import LaunchDarkly.Server.Evaluate+import LaunchDarkly.Server.Reference (makeLiteral)+import LaunchDarkly.Server.Store.Internal +makeEmptyStore = do+    handle <- makeStoreIO Nothing 0+    initializeStore handle mempty mempty+    pure handle++makeTestClient :: IO Client+makeTestClient = do+    client <- makeClient $ (makeConfig "") & configSetOffline True+    initializeStore (getField @"store" client) mempty mempty+    pure client+ testExplicitIncludeUser :: Test-testExplicitIncludeUser = True ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.fromList ["foo"]-        , excluded = HS.empty-        , salt     = "abcdef"-        , rules    = []-        , version  = 1-        , deleted  = False-        }+testExplicitIncludeUser = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)+    segmentContainsContext store segment org HS.empty >>= assertEqual "" (Right False)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.fromList ["foo"]+            , includedContexts = mempty+            , excluded = HS.empty+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules = []+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ makeUser "foo"+    user = makeContext "foo" "user"+    org = makeContext "foo" "org" +testExplicitIncludeContextKind :: Test+testExplicitIncludeContextKind = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)+    segmentContainsContext store segment org HS.empty >>= assertEqual "" (Right False)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]+            , excluded = HS.empty+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules = []+            , version = 1+            , deleted = False+            }++    user = makeContext "foo" "user"+    org = makeContext "foo" "org"+ testExplicitExcludeUser :: Test-testExplicitExcludeUser = False ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.empty-        , excluded = HS.fromList ["foo"]-        , salt     = "abcdef"-        , rules    = []-        , version  = 1-        , deleted  = False-        }+testExplicitExcludeUser = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right False)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = mempty+            , excluded = HS.fromList ["foo"]+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules = []+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ makeUser "foo"+    user = makeContext "foo" "user" +testExplicitExcludeContextKind :: Test+testExplicitExcludeContextKind = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right False)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = mempty+            , excluded = HS.empty+            , excludedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]+            , salt = "abcdef"+            , rules = []+            , version = 1+            , deleted = False+            }++    user = makeContext "foo" "user"+ testExplicitIncludeHasPrecedence :: Test-testExplicitIncludeHasPrecedence = True ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.fromList ["foo"]-        , excluded = HS.fromList ["foo"]-        , salt     = "abcdef"-        , rules    = []-        , version  = 1-        , deleted  = False-        }+testExplicitIncludeHasPrecedence = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.fromList ["foo"]+            , includedContexts = mempty+            , excluded = HS.fromList ["foo"]+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules = []+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ makeUser "foo"+    user = makeContext "foo" "user" +testExplicitIncludeContextsHasPrecedence :: Test+testExplicitIncludeContextsHasPrecedence = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right True)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]+            , excluded = HS.fromList ["foo"]+            , excludedContexts = [SegmentTarget {values = HS.fromList ["foo"], contextKind = "user"}]+            , salt = "abcdef"+            , rules = []+            , version = 1+            , deleted = False+            }++    user = makeContext "foo" "user"+ testNeitherIncludedNorExcluded :: Test-testNeitherIncludedNorExcluded = False ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.fromList [""]-        , excluded = HS.fromList [""]-        , salt     = "abcdef"-        , rules    = []-        , version  = 1-        , deleted  = False-        }+testNeitherIncludedNorExcluded = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment user HS.empty >>= assertEqual "" (Right False)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.fromList [""]+            , includedContexts = mempty+            , excluded = HS.fromList [""]+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules = []+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ makeUser "foo"+    user = makeContext "foo" "user"  testMatchingRuleWithFullRollout :: Test-testMatchingRuleWithFullRollout = True ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.empty-        , excluded = HS.empty-        , salt     = "abcdef"-        , rules    =-            [ SegmentRule-                { id       = "rule"-                , clauses  =-                    [ Clause-                        { attribute = "email"-                        , negate    = False-                        , op        = OpIn-                        , values    = [String "test@example.com"]-                        }-                    ]-                , weight   = Just 100000-                , bucketBy = Nothing-                }-            ]-        , version  = 1-        , deleted  = False-        }+testMatchingRuleWithFullRollout = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right True)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = mempty+            , excluded = HS.empty+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules =+                [ SegmentRule+                    { id = "rule"+                    , clauses =+                        [ Clause+                            { attribute = makeLiteral "email"+                            , contextKind = "user"+                            , negate = False+                            , op = OpIn+                            , values = [String "test@example.com"]+                            }+                        ]+                    , weight = Just 100000+                    , bucketBy = Nothing+                    , rolloutContextKind = Just "user"+                    }+                ]+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ (makeUser "foo") & userSetEmail (pure "test@example.com")+    context = makeContext "foo" "user" & withAttribute "email" "test@example.com"  testMatchingRuleWithZeroRollout :: Test-testMatchingRuleWithZeroRollout = False ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.empty-        , excluded = HS.empty-        , salt     = "abcdef"-        , rules    =-            [ SegmentRule-                { id       = "rule"-                , clauses  =-                    [ Clause-                        { attribute = "email"-                        , negate    = False-                        , op        = OpIn-                        , values    = [String "test@example.com"]-                        }-                    ]-                , weight   = Just 0-                , bucketBy = Nothing-                }-            ]-        , version  = 1-        , deleted  = False-        }+testMatchingRuleWithZeroRollout = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right False)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = mempty+            , excluded = HS.empty+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules =+                [ SegmentRule+                    { id = "rule"+                    , clauses =+                        [ Clause+                            { attribute = makeLiteral "email"+                            , contextKind = "user"+                            , negate = False+                            , op = OpIn+                            , values = [String "test@example.com"]+                            }+                        ]+                    , weight = Just 0+                    , bucketBy = Nothing+                    , rolloutContextKind = Just "user"+                    }+                ]+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ (makeUser "foo") & userSetEmail (pure "test@example.com")+    context = makeContext "foo" "user" & withAttribute "email" "test@example.com"  testMatchingRuleWithMultipleClauses :: Test-testMatchingRuleWithMultipleClauses = True ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.empty-        , excluded = HS.empty-        , salt     = "abcdef"-        , rules    =-            [ SegmentRule-                { id       = "rule"-                , clauses  =-                    [ Clause-                        { attribute = "email"-                        , negate    = False-                        , op        = OpIn-                        , values    = [String "test@example.com"]-                        }-                    , Clause-                        { attribute = "name"-                        , negate    = False-                        , op        = OpIn-                        , values    = ["bob"]-                        }-                    ]-                , weight   = Nothing-                , bucketBy = Nothing-                }-            ]-        , version  = 1-        , deleted  = False-        }+testMatchingRuleWithMultipleClauses = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right True)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = mempty+            , excluded = HS.empty+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules =+                [ SegmentRule+                    { id = "rule"+                    , clauses =+                        [ Clause+                            { attribute = makeLiteral "email"+                            , contextKind = "user"+                            , negate = False+                            , op = OpIn+                            , values = [String "test@example.com"]+                            }+                        , Clause+                            { attribute = makeLiteral "name"+                            , contextKind = "user"+                            , negate = False+                            , op = OpIn+                            , values = ["bob"]+                            }+                        ]+                    , weight = Nothing+                    , bucketBy = Nothing+                    , rolloutContextKind = Just "user"+                    }+                ]+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ (makeUser "foo")-        & userSetEmail (pure "test@example.com")-        & userSetName  (pure "bob")+    context =+        makeContext "foo" "user"+            & withAttribute "email" "test@example.com"+            & withAttribute "name" "bob"  testNonMatchingRuleWithMultipleClauses :: Test-testNonMatchingRuleWithMultipleClauses = False ~=? (segmentContainsUser segment user) where-    segment = Segment-        { key      = "test"-        , included = HS.empty-        , excluded = HS.empty-        , salt     = "abcdef"-        , rules    =-            [ SegmentRule-                { id       = "rule"-                , clauses  =-                    [ Clause-                        { attribute = "email"-                        , negate    = False-                        , op        = OpIn-                        , values    = [String "test@example.com"]-                        }-                    , Clause-                        { attribute = "name"-                        , negate    = False-                        , op        = OpIn-                        , values    = ["bill"]-                        }-                    ]-                , weight   = Nothing-                , bucketBy = Nothing-                }-            ]-        , version  = 1-        , deleted  = False-        }+testNonMatchingRuleWithMultipleClauses = TestCase $ do+    store <- makeEmptyStore+    segmentContainsContext store segment context HS.empty >>= assertEqual "" (Right False)+  where+    segment =+        Segment+            { key = "test"+            , included = HS.empty+            , includedContexts = mempty+            , excluded = HS.empty+            , excludedContexts = mempty+            , salt = "abcdef"+            , rules =+                [ SegmentRule+                    { id = "rule"+                    , clauses =+                        [ Clause+                            { attribute = makeLiteral "email"+                            , contextKind = "user"+                            , negate = False+                            , op = OpIn+                            , values = [String "test@example.com"]+                            }+                        , Clause+                            { attribute = makeLiteral "name"+                            , contextKind = "user"+                            , negate = False+                            , op = OpIn+                            , values = ["bill"]+                            }+                        ]+                    , weight = Nothing+                    , bucketBy = Nothing+                    , rolloutContextKind = Just "user"+                    }+                ]+            , version = 1+            , deleted = False+            } -    user = unwrapUser $ (makeUser "foo")-        & userSetEmail (pure "test@example.com")-        & userSetName  (pure "bob")+    context =+        makeContext "foo" "user"+            & withAttribute "email" "test@example.com"+            & withAttribute "name" "bob" +testCanDetectRecursiveSegments :: Test+testCanDetectRecursiveSegments = TestCase $ do+    client <- makeTestClient+    insertFlag (getField @"store" client) flag >>= (pure () @=?)+    insertSegment (getField @"store" client) segmentA >>= (pure () @=?)+    insertSegment (getField @"store" client) segmentB >>= (pure () @=?)+    boolVariationDetail client "a" (makeContext "b" "user") False >>= (expected @=?)+  where+    flag =+        (makeTestFlag "a" 1)+            { on = True+            , rules =+                [ Rule+                    { clauses =+                        [ Clause+                            { attribute = makeLiteral "key"+                            , contextKind = "user"+                            , op = OpSegmentMatch+                            , values = [String "segmentA"]+                            , negate = False+                            }+                        ]+                    , variationOrRollout =+                        VariationOrRollout+                            { variation = Just 0+                            , rollout = Nothing+                            }+                    , id = "rule-1"+                    , trackEvents = False+                    }+                ]+            , offVariation = Nothing+            }+    segmentA =+        Segment+            { key = "segmentA"+            , version = 1+            , deleted = False+            , included = mempty+            , includedContexts = mempty+            , excluded = mempty+            , excludedContexts = mempty+            , salt = ""+            , rules =+                [ SegmentRule+                    { clauses =+                        [ Clause+                            { attribute = makeLiteral "rule-1"+                            , contextKind = "user"+                            , op = OpSegmentMatch+                            , values = [String "segmentB"]+                            , negate = False+                            }+                        ]+                    , id = "rule-1"+                    , weight = Nothing+                    , bucketBy = Nothing+                    , rolloutContextKind = Just "user"+                    }+                ]+            }+    segmentB =+        Segment+            { key = "segmentB"+            , version = 1+            , deleted = False+            , included = mempty+            , includedContexts = mempty+            , excluded = mempty+            , excludedContexts = mempty+            , salt = ""+            , rules =+                [ SegmentRule+                    { clauses =+                        [ Clause+                            { attribute = makeLiteral "rule-1"+                            , contextKind = "user"+                            , op = OpSegmentMatch+                            , values = [String "segmentA"]+                            , negate = False+                            }+                        ]+                    , id = "rule-1"+                    , weight = Nothing+                    , bucketBy = Nothing+                    , rolloutContextKind = Just "user"+                    }+                ]+            }+    expected =+        EvaluationDetail+            { value = False+            , variationIndex = Nothing+            , reason = EvaluationReasonError {errorKind = EvalErrorKindMalformedFlag}+            }+ allTests :: Test-allTests = TestList-    [ testExplicitIncludeUser-    , testExplicitExcludeUser-    , testExplicitIncludeHasPrecedence-    , testNeitherIncludedNorExcluded-    , testMatchingRuleWithFullRollout-    , testMatchingRuleWithZeroRollout-    , testMatchingRuleWithMultipleClauses-    , testNonMatchingRuleWithMultipleClauses-    ]+allTests =+    TestList+        [ testExplicitIncludeUser+        , testExplicitIncludeContextKind+        , testExplicitExcludeUser+        , testExplicitExcludeContextKind+        , testExplicitIncludeHasPrecedence+        , testExplicitIncludeContextsHasPrecedence+        , testNeitherIncludedNorExcluded+        , testMatchingRuleWithFullRollout+        , testMatchingRuleWithZeroRollout+        , testMatchingRuleWithMultipleClauses+        , testNonMatchingRuleWithMultipleClauses+        , testCanDetectRecursiveSegments+        ]
test/Spec/Store.hs view
@@ -1,85 +1,82 @@ module Spec.Store (allTests, testWithStore) where -import           Test.HUnit-import           Data.Text                          (Text)-import           Control.Monad                      (void)-import           GHC.Natural                        (Natural)-import           GHC.Int                            (Int64)-import           System.Clock                       (TimeSpec(..))+import Test.HUnit -import           Util.Features                      (makeTestFlag, makeTestSegment)+import Util.Features (makeTestFlag, makeTestSegment) -import           LaunchDarkly.AesonCompat           (emptyObject, singleton)-import           LaunchDarkly.Server.Features       (Flag(..), VariationOrRollout(..))-import           LaunchDarkly.Server.Store.Internal-import           LaunchDarkly.Server.Store.Redis+import LaunchDarkly.AesonCompat (emptyObject, singleton)+import LaunchDarkly.Server.Store.Internal -testInitializationEmpty ::  IO (StoreHandle IO) -> Test+testInitializationEmpty :: IO (StoreHandle IO) -> Test testInitializationEmpty makeStore = TestCase $ do     store <- makeStore-    getInitializedC store                                >>= (pure False @=?)-    storeHandleInitialize store emptyObject emptyObject  >>= (pure () @=?)-    getInitializedC store                                >>= (pure True @=?)+    getInitializedC store >>= (pure False @=?)+    storeHandleInitialize store emptyObject emptyObject >>= (pure () @=?)+    getInitializedC store >>= (pure True @=?)  testInitializationWithFeatures :: IO (StoreHandle IO) -> Test testInitializationWithFeatures makeStore = TestCase $ do     store <- makeStore-    getInitializedC store                        >>= (pure False @=?)+    getInitializedC store >>= (pure False @=?)     storeHandleInitialize store flagsV segmentsV >>= (pure () @=?)-    getInitializedC store                        >>= (pure True @=?)-    storeHandleGetFlag store "a"                 >>= (pure (pure flagA) @=?)-    storeHandleAllFlags store                    >>= (pure flagsR @=?)-    storeHandleGetSegment store "a"              >>= (pure (pure segmentA) @=?)-    where-        segmentA  = makeTestSegment "a" 50-        flagA     = makeTestFlag "a" 52-        flagsR    = singleton "a" flagA-        flagsV    = singleton "a" (Versioned flagA 52)-        segmentsV = singleton "a" (Versioned segmentA 50)+    getInitializedC store >>= (pure True @=?)+    storeHandleGetFlag store "a" >>= (pure (pure flagA) @=?)+    storeHandleAllFlags store >>= (pure flagsR @=?)+    storeHandleGetSegment store "a" >>= (pure (pure segmentA) @=?)+  where+    segmentA = makeTestSegment "a" 50+    flagA = makeTestFlag "a" 52+    flagsR = singleton "a" flagA+    flagsV = singleton "a" (ItemDescriptor flagA 52)+    segmentsV = singleton "a" (ItemDescriptor segmentA 50)  testGetAndUpsertAndGetAndGetAllFlags :: IO (StoreHandle IO) -> Test testGetAndUpsertAndGetAndGetAllFlags makeStore = TestCase $ do     store <- makeStore-    getFlagC store "a"                               >>= (pure Nothing @=?)-    upsertFlagC store "a" (Versioned (pure flag) 52) >>= (pure () @=?)-    getFlagC store "a"                               >>= (pure (pure flag) @=?)-    getAllFlagsC store                               >>= (pure (singleton "a" flag) @=?)-    where-        flag = makeTestFlag "a" 52+    getFlagC store "a" >>= (pure Nothing @=?)+    upsertFlagC store "a" (ItemDescriptor (pure flag) 52) >>= (pure () @=?)+    getFlagC store "a" >>= (pure (pure flag) @=?)+    getAllFlagsC store >>= (pure (singleton "a" flag) @=?)+  where+    flag = makeTestFlag "a" 52  testGetAndUpsertAndGetSegment :: IO (StoreHandle IO) -> Test testGetAndUpsertAndGetSegment makeStore = TestCase $ do     store <- makeStore-    getSegmentC store "a"                                  >>= (pure Nothing        @=?)-    upsertSegmentC store "a" (Versioned (pure segment) 52) >>= (pure ()             @=?)-    getSegmentC store "a"                                  >>= (pure (pure segment) @=?)-    where-        segment = makeTestSegment "a" 52+    getSegmentC store "a" >>= (pure Nothing @=?)+    upsertSegmentC store "a" (ItemDescriptor (pure segment) 52) >>= (pure () @=?)+    getSegmentC store "a" >>= (pure (pure segment) @=?)+  where+    segment = makeTestSegment "a" 52  testUpsertRespectsVersion :: IO (StoreHandle IO) -> Test testUpsertRespectsVersion makeStore = TestCase $ do     store <- makeStore-    upsertFlagC store "a" (Versioned (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?)-    upsertFlagC store "a" (Versioned (pure $ makeTestFlag "a" 2) 2) >>= (pure () @=?)-    getFlagC store "a"                                              >>= (pure (pure $ makeTestFlag "a" 2) @=?)-    getAllFlagsC store                                              >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?)-    upsertFlagC store "a" (Versioned (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?)-    getFlagC store "a"                                              >>= (pure (pure $ makeTestFlag "a" 2) @=?)-    getAllFlagsC store                                              >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?)-    upsertFlagC store "a" (Versioned Nothing 3)                     >>= (pure () @=?)-    getFlagC store "a"                                              >>= (pure Nothing @=?)-    getAllFlagsC store                                              >>= (pure mempty @=?)+    upsertFlagC store "a" (ItemDescriptor (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?)+    upsertFlagC store "a" (ItemDescriptor (pure $ makeTestFlag "a" 2) 2) >>= (pure () @=?)+    getFlagC store "a" >>= (pure (pure $ makeTestFlag "a" 2) @=?)+    getAllFlagsC store >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?)+    upsertFlagC store "a" (ItemDescriptor (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?)+    getFlagC store "a" >>= (pure (pure $ makeTestFlag "a" 2) @=?)+    getAllFlagsC store >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?)+    upsertFlagC store "a" (ItemDescriptor Nothing 3) >>= (pure () @=?)+    getFlagC store "a" >>= (pure Nothing @=?)+    getAllFlagsC store >>= (pure mempty @=?)  testWithStore :: IO (StoreHandle IO) -> Test-testWithStore makeStore = TestList $ map (\f -> f makeStore)-    [ testInitializationEmpty-    , testInitializationWithFeatures-    , testGetAndUpsertAndGetAndGetAllFlags-    , testUpsertRespectsVersion-    , testGetAndUpsertAndGetSegment-    ]+testWithStore makeStore =+    TestList $+        map+            (\f -> f makeStore)+            [ testInitializationEmpty+            , testInitializationWithFeatures+            , testGetAndUpsertAndGetAndGetAllFlags+            , testUpsertRespectsVersion+            , testGetAndUpsertAndGetSegment+            ]  allTests :: Test-allTests = TestList-    [ testWithStore $ makeStoreIO Nothing 0-    ]+allTests =+    TestList+        [ testWithStore $ makeStoreIO Nothing 0+        ]
− test/Spec/StoreInterface.hs 
@@ -1,190 +0,0 @@-module Spec.StoreInterface (allTests) where--import           Control.Monad                      (void)-import           Data.Function                      ((&))-import           Data.IORef                         (newIORef, readIORef, atomicModifyIORef', writeIORef)-import           Data.Either                        (isLeft)-import           Data.ByteString                    ()-import           Test.HUnit-import           System.Clock                       (TimeSpec(..))--import           Util.Features                      (makeTestFlag)--import           LaunchDarkly.Server.Store.Internal-import           LaunchDarkly.AesonCompat           (emptyObject, insertKey, singleton)--makeTestStore :: Maybe StoreInterface -> IO (StoreHandle IO)-makeTestStore backend = makeStoreIO backend $ TimeSpec 10 0--makeStoreInterface :: StoreInterface-makeStoreInterface = StoreInterface-    { storeInterfaceAllFeatures   = const $ assertFailure "allFeatures should not be called"-    , storeInterfaceGetFeature    = const $ const $ assertFailure "getFeatures should not be called"-    , storeInterfaceUpsertFeature = const $ const $ const $ assertFailure "upsertFeature should not be called"-    , storeInterfaceIsInitialized = assertFailure "isInitialized should not be called"-    , storeInterfaceInitialize    = const $ assertFailure "initialize should not be called"-    }--testFailInit :: Test-testFailInit = TestCase $ do-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceInitialize = \_ -> pure $ Left "err"-        }-    initializeStore store emptyObject emptyObject >>= (Left "err" @?=)--testFailGet :: Test-testFailGet = TestCase $ do-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceGetFeature = \_ _ -> pure $ Left "err"-        }-    getFlagC store "abc" >>= (Left "err" @?=)--testFailAll :: Test-testFailAll = TestCase $ do-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceAllFeatures = \_ -> pure $ Left "err"-        }-    getAllFlagsC store >>= (Left "err" @?=)--testFailIsInitialized :: Test-testFailIsInitialized = TestCase $ do-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceIsInitialized = pure $ Left "err"-        }-    getInitializedC store >>= (Left "err" @?=)--testFailUpsert :: Test-testFailUpsert = TestCase $ do-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceUpsertFeature = \_ _ _ -> pure $ Left "err"-        }-    insertFlag store (makeTestFlag "test" 123) >>= (Left "err" @?=)--testFailGetInvalidJSON :: Test-testFailGetInvalidJSON = TestCase $ do-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceGetFeature = \_ _ -> pure $ Right $ RawFeature (pure "invalid json") 0-        }-    getFlagC store "abc" >>= (\v -> True @?= isLeft v)--testGetAllInvalidJSON :: Test-testGetAllInvalidJSON = TestCase $ do-    let flag = makeTestFlag "abc" 52-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceAllFeatures = \_ -> pure $ Right $ emptyObject-            & insertKey "abc" (versionedToRaw $ Versioned (pure flag) 52)-            & insertKey "xyz" (RawFeature (pure "invalid json") 64)-        }-    getAllFlagsC store >>= (Right (singleton "abc" flag) @?=)--testInitializedCache :: Test-testInitializedCache = TestCase $ do-    counter <- newIORef 0-    value   <- newIORef False-    store   <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceIsInitialized = do-            atomicModifyIORef' counter (\c -> (c + 1, ()))-            Right <$> readIORef value-        }-    getInitializedC store      >>= (Right False @=?)-    readIORef counter          >>= (1 @=?)-    getInitializedC store      >>= (Right False @=?)-    readIORef counter          >>= (1 @=?)-    storeHandleExpireAll store >>= (Right () @=?)-    getInitializedC store      >>= (Right False @=?)-    readIORef counter          >>= (2 @=?)-    writeIORef value True-    storeHandleExpireAll store >>= (Right () @=?)-    getInitializedC store      >>= (Right True @=?)-    readIORef counter          >>= (3 @=?)-    getInitializedC store      >>= (Right True @=?)-    readIORef counter          >>= (3 @=?)--testGetCache :: Test-testGetCache = TestCase $ do-    counter <- newIORef 0-    value   <- newIORef $ RawFeature Nothing 0-    store   <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceGetFeature = \_ _ -> do-            atomicModifyIORef' counter (\c -> (c + 1, ()))-            Right <$> readIORef value-        }-    getFlagC store "abc"       >>= (Right Nothing @?=)-    readIORef counter          >>= (1 @=?)-    getFlagC store "abc"       >>= (Right Nothing @?=)-    readIORef counter          >>= (1 @=?)-    storeHandleExpireAll store >>= (Right () @=?)-    let flag = pure $ makeTestFlag "abc" 12-    writeIORef value $ versionedToRaw $ Versioned flag 12-    getFlagC store "abc"       >>= (Right flag @=?)-    readIORef counter          >>= (2 @=?)-    getFlagC store "abc"       >>= (Right flag @=?)-    readIORef counter          >>= (2 @=?)--testUpsertInvalidatesAllFlags :: Test-testUpsertInvalidatesAllFlags = TestCase $ do-    allCounter    <- newIORef 0-    upsertCounter <- newIORef 0-    upsertResult  <- newIORef $ Right True-    store         <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceUpsertFeature = \_ _ _ -> do-            atomicModifyIORef' upsertCounter (\c -> (c + 1, ()))-            readIORef upsertResult-        , storeInterfaceAllFeatures = \_ -> do-            atomicModifyIORef' allCounter (\c -> (c + 1, ()))-            pure $ Right emptyObject-        }-    getAllFlagsC store        >>= (Right emptyObject @=?)-    readIORef allCounter      >>= (1 @=?)-    deleteFlag store "abc" 52 >>= (Right () @=?)-    readIORef upsertCounter   >>= (1 @=?)-    getAllFlagsC store        >>= (Right emptyObject @=?)-    readIORef allCounter      >>= (2 @=?)-    writeIORef upsertResult $ Right False-    deleteFlag store "abc" 53 >>= (Right () @=?)-    readIORef upsertCounter   >>= (2 @=?)-    getAllFlagsC store        >>= (Right emptyObject @=?)-    readIORef allCounter      >>= (2 @=?)--testAllFlagsCache :: Test-testAllFlagsCache = TestCase $ do-    counter <- newIORef 0-    value   <- newIORef emptyObject-    store   <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceAllFeatures = \_ -> do-            atomicModifyIORef' counter (\c -> (c + 1, ()))-            pure $ Right emptyObject-        }-    getAllFlagsC store         >>= (Right emptyObject @=?)-    readIORef counter          >>= (1 @=?)-    getAllFlagsC store         >>= (Right emptyObject @=?)-    readIORef counter          >>= (1 @=?)-    storeHandleExpireAll store >>= (Right () @=?)-    getAllFlagsC store         >>= (Right emptyObject @=?)-    readIORef counter          >>= (2 @=?)--testAllFlagsUpdatesRegularCache :: Test-testAllFlagsUpdatesRegularCache = TestCase $ do-    let flag = makeTestFlag "abc" 12-    store <- makeTestStore $ pure $ makeStoreInterface-        { storeInterfaceAllFeatures = \_ -> pure $ Right $-            singleton "abc" (versionedToRaw $ Versioned (pure flag) 12)-        }-    getAllFlagsC store   >>= (Right (singleton "abc" flag) @=?)-    getFlagC store "abc" >>= (Right (pure flag) @=?)--allTests :: Test-allTests = TestList-    [ testFailInit-    , testFailGet-    , testFailAll-    , testFailIsInitialized-    , testFailUpsert-    , testFailGetInvalidJSON-    , testGetAllInvalidJSON-    , testInitializedCache-    , testGetCache-    , testUpsertInvalidatesAllFlags-    , testAllFlagsCache-    , testAllFlagsUpdatesRegularCache-    ]
test/Spec/Streaming.hs view
@@ -1,10 +1,6 @@ module Spec.Streaming (allTests) where  import Test.HUnit-import Data.Attoparsec.ByteString-import Control.Monad                         (mzero)--import LaunchDarkly.Server.Network.Streaming  allTests :: Test allTests = TestList []
− test/Spec/User.hs 
@@ -1,22 +0,0 @@-module Spec.User (allTests) where--import           GHC.Exts (fromList)-import           Test.HUnit-import           Data.Aeson-import           Data.Aeson.Types                  (Value(..))-import qualified Data.HashMap.Strict as            HM-import           Data.HashMap.Strict               (HashMap)-import           Data.Function                     ((&))--import           LaunchDarkly.Server.User-import           LaunchDarkly.Server.User.Internal--serializeEmpty :: Test-serializeEmpty = expected ~=? actual where-    actual = decode $ encode $ unwrapUser $ makeUser "abc"-    expected = pure $ Object $ fromList [("key", String "abc")]--allTests :: Test-allTests = TestList-    [ serializeEmpty-    ]
test/Util/Features.hs view
@@ -1,39 +1,45 @@ module Util.Features (makeTestFlag, makeTestSegment) where -import Data.Text                    (Text)-import GHC.Natural                  (Natural)+import Data.Text (Text)+import GHC.Natural (Natural)  import LaunchDarkly.Server.Features  makeTestFlag :: Text -> Natural -> Flag-makeTestFlag key version = Flag-    { key                    = key-    , version                = version-    , on                     = True-    , trackEvents            = False-    , trackEventsFallthrough = False-    , deleted                = False-    , prerequisites          = []-    , salt                   = ""-    , targets                = []-    , rules                  = []-    , fallthrough            = VariationOrRollout-        { variation = Nothing-        , rollout   = Nothing+makeTestFlag key version =+    Flag+        { key = key+        , version = version+        , on = True+        , trackEvents = False+        , trackEventsFallthrough = False+        , deleted = False+        , prerequisites = []+        , salt = ""+        , targets = []+        , contextTargets = []+        , rules = []+        , fallthrough =+            VariationOrRollout+                { variation = Nothing+                , rollout = Nothing+                }+        , offVariation = Nothing+        , variations = []+        , debugEventsUntilDate = Nothing+        , clientSideAvailability = ClientSideAvailability {usingEnvironmentId = True, usingMobileKey = False, explicit = True}         }-    , offVariation           = Nothing-    , variations             = []-    , debugEventsUntilDate   = Nothing-    , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False, explicit = True }-    }  makeTestSegment :: Text -> Natural -> Segment-makeTestSegment key version = Segment-    { key      = key-    , included = mempty-    , excluded = mempty-    , salt     = ""-    , rules    = mempty-    , version  = version-    , deleted  = False-    }+makeTestSegment key version =+    Segment+        { key = key+        , included = mempty+        , includedContexts = mempty+        , excluded = mempty+        , excludedContexts = mempty+        , salt = ""+        , rules = mempty+        , version = version+        , deleted = False+        }