packages feed

launchdarkly-server-sdk 2.2.0 → 3.0.0

raw patch · 42 files changed

+2149/−254 lines, 42 filesdep +yamldep −bytestring-conversiondep ~aesondep ~bytestring

Dependencies added: yaml

Dependencies removed: bytestring-conversion

Dependency ranges changed: aeson, bytestring

Files

CHANGELOG.md view
@@ -2,12 +2,26 @@  All notable changes to the LaunchDarkly Haskell Server-side SDK will be documented in this file. This project adheres to [Semantic Versioning](http://semver.org). -## [2.2.0] - 2021-06-17+## [3.0.0] - 2022-06-27 ### Added:-- The SDK now supports the ability to control the proportion of traffic allocation to an experiment. This works in conjunction with a new platform feature now available to early access customers.+- Add flag support for the client side availability property, as well+as the older the ability to decode from the older clientSide format.+- The new allFlagsState function should be used instead of allFlags if you are passing flag data to the front end for use with the JavaScript SDK. It preserves some flag metadata that the front end requires in order to send analytics events correctly. Versions 2.5.0 and above of the JavaScript SDK are able to use this metadata, but the output of allFlagsState will still work with older versions.+- It is now possible to inject feature flags into the client from local JSON files, replacing the normal LaunchDarkly connection. This would typically be for testing purposes. See LaunchDarkly.Server.Integrations.FileData.+- LaunchDarkly.Server.Integrations.TestData is another new way to inject feature flag data programmatically into the SDK for testing—either with fixed values for each flag, or with targets and/or rules that can return different values for different users. Unlike FileData, this mechanism does not use any external resources, only the data that your test code has provided. +### Changed:+- CI builds now include a cross-platform test suite implemented in https://github.com/launchdarkly/sdk-test-harness. This covers many test cases that are also implemented in unit tests, but may be extended in the future to ensure consistent behavior across SDKs in other areas.+- The SDK will track the last known server time as specified in the Date header when sending events. This value, along with the current system time, will be used to determine if debug event should still be sent.+- VariationIndex has been changed from Natural to Integer. +### Fixed:+- When evaluating against a user attribute, if the attribute is null, it should always be treated as a non-match. +## [2.2.0] - 2021-06-17+### Added:+- The SDK now supports the ability to control the proportion of traffic allocation to an experiment. This works in conjunction with a new platform feature now available to early access customers.+ ## [2.1.1] - 2021-03-05 ### Changed: - Updated dependency ranges. Thanks @dbaynard !@@ -65,7 +79,7 @@ ### Added: - Added support for utilizing external features stores. See `LaunchDarkly.Server.Store` for details on implementing a store. You can configure usage of a specific store with `configSetStoreBackend`. - Added support for Redis as an external feature store. See the `launchdarkly-server-sdk-redis` package for details.-- Added support for LaunchDarkly daemon mode configurable with `configSetUseLdd`.+- Added support for LaunchDarkly daemon mode configurable with `configSetUseLdd`. To learn more, read [Using daemon mode](https://docs.launchdarkly.com/home/relay-proxy/using#using-daemon-mode). ### Fixed: - Incorrect ToJSON instances for flag rules and operators. - Updated bucketing logic to fallback to last variation instead of producing an error.
README.md view
@@ -6,17 +6,17 @@  ## LaunchDarkly overview -[LaunchDarkly](https://www.launchdarkly.com) is a feature management platform that serves over 100 billion feature flags daily to help teams build better software, faster. [Get started](https://docs.launchdarkly.com/docs/getting-started) using LaunchDarkly today!+[LaunchDarkly](https://www.launchdarkly.com) is a feature management platform that serves over 100 billion feature flags daily to help teams build better software, faster. [Get started](https://docs.launchdarkly.com/home/getting-started) using LaunchDarkly today!  [![Twitter Follow](https://img.shields.io/twitter/follow/launchdarkly.svg?style=social&label=Follow&maxAge=2592000)](https://twitter.com/intent/follow?screen_name=launchdarkly)  ## Getting started -Download a release archive from the [GitHub Releases](https://github.com/launchdarkly/haskell-server-sdk/releases) for use in your project. Refer to the [SDK documentation](https://docs.launchdarkly.com/docs/haskell-server-sdk-reference#section-getting-started) for complete instructions on getting started with using the SDK.+Download a release archive from the [GitHub Releases](https://github.com/launchdarkly/haskell-server-sdk/releases) for use in your project. Refer to the [SDK documentation](https://docs.launchdarkly.com/sdk/server-side/haskell#getting-started) for complete instructions on getting started with using the SDK.  ## Learn more -Check out our [documentation](https://docs.launchdarkly.com) for in-depth instructions on configuring and using LaunchDarkly. You can also head straight to the [complete reference guide for this SDK](https://docs.launchdarkly.com/docs/haskell-server-sdk-reference).+Check out our [documentation](https://docs.launchdarkly.com) for in-depth instructions on configuring and using LaunchDarkly. You can also head straight to the [complete reference guide for this SDK](https://docs.launchdarkly.com/sdk/server-side/haskell).  ## Testing @@ -33,7 +33,7 @@     * Gradually roll out a feature to an increasing percentage of users, and track the effect that the feature has on key metrics (for instance, how likely is a user to complete a purchase if they have feature A versus feature B?).     * Turn off a feature that you realize is causing performance problems in production, without needing to re-deploy, or even restart the application with a changed configuration file.     * Grant access to certain features based on user attributes, like payment plan (eg: users on the ‘gold’ plan get access to more features than users in the ‘silver’ plan). Disable parts of your application to facilitate maintenance, without taking everything offline.-* LaunchDarkly provides feature flag SDKs for a wide variety of languages and technologies. Check out [our documentation](https://docs.launchdarkly.com/docs) for a complete list.+* LaunchDarkly provides feature flag SDKs for a wide variety of languages and technologies. Read [our documentation](https://docs.launchdarkly.com/sdk) for a complete list. * Explore LaunchDarkly     * [launchdarkly.com](https://www.launchdarkly.com/ "LaunchDarkly Main Website") for more information     * [docs.launchdarkly.com](https://docs.launchdarkly.com/  "LaunchDarkly Documentation") for our documentation and SDK reference guides
launchdarkly-server-sdk.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           launchdarkly-server-sdk-version:        2.2.0+version:        3.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@@ -21,6 +21,15 @@     README.md     CHANGELOG.md     LICENSE+    test-data/filesource/all-properties.json+    test-data/filesource/flag-only.json+    test-data/filesource/flag-with-duplicate-key.json+    test-data/filesource/malformed.json+    test-data/filesource/no-data.json+    test-data/filesource/segment-only.json+    test-data/filesource/segment-with-duplicate-key.json+    test-data/filesource/value-only.json+    test-data/filesource/value-with-duplicate-key.json  source-repository head   type: git@@ -33,13 +42,21 @@       LaunchDarkly.Server.Config       LaunchDarkly.Server.User       LaunchDarkly.Server.Store+      LaunchDarkly.Server.Integrations.FileData+      LaunchDarkly.Server.Integrations.TestData   other-modules:+      LaunchDarkly.AesonCompat       LaunchDarkly.Server.Client.Internal+      LaunchDarkly.Server.Client.Status+      LaunchDarkly.Server.Config.ClientContext+      LaunchDarkly.Server.Config.HttpConfiguration       LaunchDarkly.Server.Config.Internal+      LaunchDarkly.Server.DataSource.Internal       LaunchDarkly.Server.Details       LaunchDarkly.Server.Evaluate       LaunchDarkly.Server.Events       LaunchDarkly.Server.Features+      LaunchDarkly.Server.Integrations.TestData.FlagBuilder       LaunchDarkly.Server.Network.Common       LaunchDarkly.Server.Network.Eventing       LaunchDarkly.Server.Network.Polling@@ -75,12 +92,11 @@       TypeOperators   ghc-options: -fwarn-unused-imports -Wall -Wno-name-shadowing   build-depends:-      aeson >=1.4.4.0 && <1.6+      aeson >=1.4.4.0 && <1.6 || >=2.0.1.0 && <2.1     , attoparsec >=0.13.2.2 && <0.14     , base >=4.7 && <5     , base16-bytestring >=0.1.1.6 && <1.1-    , bytestring >=0.10.8.2 && <0.11-    , bytestring-conversion >=0.3.1 && <0.4+    , bytestring >=0.10.8.2 && <0.12     , clock ==0.8.*     , containers >=0.6.0.1 && <0.7     , cryptohash >=0.11.9 && <0.12@@ -107,6 +123,7 @@     , 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   default-language: Haskell2010  test-suite haskell-server-sdk-test@@ -114,7 +131,11 @@   main-is: Spec.hs   other-modules:       Spec.Bucket+      Spec.DataSource       Spec.Evaluate+      Spec.Features+      Spec.Integrations.FileData+      Spec.Integrations.TestData       Spec.Operators       Spec.Redis       Spec.Segment@@ -123,15 +144,23 @@       Spec.Streaming       Spec.User       Util.Features+      LaunchDarkly.AesonCompat       LaunchDarkly.Server       LaunchDarkly.Server.Client       LaunchDarkly.Server.Client.Internal+      LaunchDarkly.Server.Client.Status       LaunchDarkly.Server.Config+      LaunchDarkly.Server.Config.ClientContext+      LaunchDarkly.Server.Config.HttpConfiguration       LaunchDarkly.Server.Config.Internal+      LaunchDarkly.Server.DataSource.Internal       LaunchDarkly.Server.Details       LaunchDarkly.Server.Evaluate       LaunchDarkly.Server.Events       LaunchDarkly.Server.Features+      LaunchDarkly.Server.Integrations.FileData+      LaunchDarkly.Server.Integrations.TestData+      LaunchDarkly.Server.Integrations.TestData.FlagBuilder       LaunchDarkly.Server.Network.Common       LaunchDarkly.Server.Network.Eventing       LaunchDarkly.Server.Network.Polling@@ -174,12 +203,11 @@   ghc-options: -rtsopts -threaded -with-rtsopts=-N -Wno-name-shadowing   build-depends:       HUnit-    , aeson >=1.4.4.0 && <1.6+    , aeson >=1.4.4.0 && <1.6 || >=2.0.1.0 && <2.1     , attoparsec >=0.13.2.2 && <0.14     , base >=4.7 && <5     , base16-bytestring >=0.1.1.6 && <1.1-    , bytestring >=0.10.8.2 && <0.11-    , bytestring-conversion >=0.3.1 && <0.4+    , bytestring >=0.10.8.2 && <0.12     , clock ==0.8.*     , containers >=0.6.0.1 && <0.7     , cryptohash >=0.11.9 && <0.12@@ -206,4 +234,5 @@     , 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   default-language: Haskell2010
+ src/LaunchDarkly/AesonCompat.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP #-}+module LaunchDarkly.AesonCompat where++#if MIN_VERSION_aeson(2,0,0)+import           Data.Aeson        (Key)+import qualified Data.Aeson.Key    as Key+import qualified Data.Aeson.KeyMap as KeyMap+import           Data.Functor.Identity      (Identity(..), runIdentity)+#else+import qualified Data.HashMap.Strict as HM+#endif+import qualified Data.Text                  as T++#if MIN_VERSION_aeson(2,0,0)+type KeyMap = KeyMap.KeyMap++deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v+deleteKey = KeyMap.delete++objectKeys :: KeyMap.KeyMap v -> [T.Text]+objectKeys = map Key.toText . KeyMap.keys++keyToText :: Key -> T.Text+keyToText = Key.toText++insertKey :: T.Text -> v -> KeyMap.KeyMap v -> KeyMap.KeyMap v+insertKey key = KeyMap.insert (Key.fromText key)++filterKeys :: (Key -> Bool) -> KeyMap.KeyMap a -> KeyMap.KeyMap a+filterKeys p = KeyMap.filterWithKey (\key _ -> p key)++adjustKey :: (v -> v) -> Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v+adjustKey f k = runIdentity . KeyMap.alterF (Identity . fmap f) k++keyMapUnion :: KeyMap.KeyMap v -> KeyMap.KeyMap v -> KeyMap.KeyMap v+keyMapUnion = KeyMap.union +#else+type KeyMap = HM.HashMap T.Text++deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v+deleteKey = HM.delete++objectKeys :: HM.HashMap T.Text v -> [T.Text]+objectKeys = HM.keys++keyToText :: T.Text -> T.Text+keyToText = id++insertKey :: T.Text -> v -> HM.HashMap T.Text v -> HM.HashMap T.Text v+insertKey = HM.insert++filterKeys :: (T.Text -> Bool) -> HM.HashMap T.Text a -> HM.HashMap T.Text a+filterKeys p = HM.filterWithKey (\key _ -> p key)++adjustKey :: (v -> v) -> T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v+adjustKey = HM.adjust++keyMapUnion :: HM.HashMap T.Text v -> HM.HashMap T.Text v -> HM.HashMap T.Text v+keyMapUnion = HM.union +#endif
src/LaunchDarkly/Server.hs view
@@ -16,12 +16,14 @@     , configSetInlineUsersInEvents     , configSetEventsCapacity     , configSetLogger+    , configSetManager     , configSetSendEvents     , configSetOffline     , configSetRequestTimeoutSeconds     , configSetStoreBackend     , configSetStoreTTL     , configSetUseLdd+    , configSetDataSourceFactory     , User     , makeUser     , userSetKey@@ -53,6 +55,8 @@     , EvaluationReason(..)     , EvalErrorKind(..)     , allFlags+    , allFlagsState+    , AllFlagsState     , close     , flushEvents     , identify
src/LaunchDarkly/Server/Client.hs view
@@ -18,6 +18,8 @@     , EvaluationReason(..)     , EvalErrorKind(..)     , allFlags+    , allFlagsState+    , AllFlagsState     , close     , flushEvents     , identify@@ -29,60 +31,118 @@  import           Control.Concurrent                    (forkFinally, killThread) import           Control.Concurrent.MVar               (putMVar, takeMVar, newEmptyMVar)-import           Control.Monad                         (void, forM_)+import           Control.Monad                         (void, forM_, unless) import           Control.Monad.IO.Class                (liftIO)-import           Control.Monad.Logger                  (LoggingT, logDebug)-import           Data.IORef                            (newIORef, writeIORef)+import           Control.Monad.Logger                  (LoggingT, logDebug, logWarn)+import           Control.Monad.Fix                     (mfix)+import           Data.IORef                            (newIORef, writeIORef, readIORef) import           Data.HashMap.Strict                   (HashMap) import qualified Data.HashMap.Strict as                HM+import           Data.Maybe                            (fromMaybe) import           Data.Text                             (Text)-import           Data.Aeson                            (Value(..))-import           Data.Generics.Product                 (getField, setField)+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           LaunchDarkly.Server.Config.Internal   (Config(..), shouldSendEvents)-import           LaunchDarkly.Server.Client.Internal-import           LaunchDarkly.Server.User.Internal     (User(..), userSerializeRedacted)-import           LaunchDarkly.Server.Details           (EvaluationDetail(..), EvaluationReason(..), EvalErrorKind(..))-import           LaunchDarkly.Server.Events            (IdentifyEvent(..), CustomEvent(..), AliasEvent(..), EventType(..), makeBaseEvent, queueEvent, makeEventState, addUserToEvent, userGetContextKind)-import           LaunchDarkly.Server.Network.Eventing  (eventThread)-import           LaunchDarkly.Server.Network.Streaming (streamingThread)-import           LaunchDarkly.Server.Network.Polling   (pollingThread)-import           LaunchDarkly.Server.Store.Internal    (makeStoreIO, getAllFlagsC)-import           LaunchDarkly.Server.Evaluate          (evaluateTyped, evaluateDetail)+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)+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) +networkDataSourceFactory :: (ClientContext -> DataSourceUpdates -> LoggingT IO ()) -> DataSourceFactory+networkDataSourceFactory threadF clientContext dataSourceUpdates = do+    initialized <- liftIO $ newIORef False+    thread <- liftIO newEmptyMVar+    sync <- liftIO newEmptyMVar++    let dataSourceIsInitialized = readIORef initialized++        dataSourceStart = do+            putMVar thread =<< forkFinally (runLogger clientContext $ threadF clientContext dataSourceUpdates) (\_ -> putMVar sync ())+            writeIORef initialized True++        dataSourceStop = runLogger clientContext $ do+            $(logDebug) "Killing download thread"+            liftIO $ killThread =<< takeMVar thread+            $(logDebug) "Waiting on download thread to die"+            liftIO $ void $ takeMVar sync++    pure $ DataSource{..}++makeHttpConfiguration :: ConfigI -> IO HttpConfiguration+makeHttpConfiguration config = do+    tlsManager <- newManager tlsManagerSettings+    let defaultRequestHeaders = [ ("Authorization", encodeUtf8 $ getField @"key" config)+                                , ("User-Agent" , "HaskellServerClient/" <> encodeUtf8 clientVersion)+                                ]+        defaultRequestTimeout = Http.responseTimeoutMicro $ fromIntegral $ getField @"requestTimeoutSeconds" config * 1000000+    pure $ HttpConfiguration{..}++makeClientContext :: ConfigI -> IO ClientContext+makeClientContext config = do+    let runLogger = getField @"logger" config+    httpConfiguration <- makeHttpConfiguration config+    pure $ ClientContext{..}+ -- | Create a new instance of the LaunchDarkly client. makeClient :: Config -> IO Client-makeClient (Config config) = do-    let runLogger          = getField @"logger" config-        eventThreadPair    = Nothing-        downloadThreadPair = Nothing-+makeClient (Config config) = mfix $ \(Client client) -> do     status  <- newIORef Uninitialized     store   <- makeStoreIO (getField @"storeBackend" config) (TimeSpec (fromIntegral $ getField @"storeTTLSeconds" config) 0)-    manager <- newManager tlsManagerSettings+    manager <- case getField @"manager" config of+      Just manager -> pure manager+      Nothing      -> newManager tlsManagerSettings     events  <- makeEventState config -    let client          = ClientI {..}-        downloadThreadF = if getField @"streaming" config then streamingThread else pollingThread+    clientContext <- makeClientContext config -    eventThreadPair'    <- if not (shouldSendEvents config) then pure Nothing else do+    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 $ eventThread manager client) (\_ -> putMVar sync ())+        thread <- forkFinally (runLogger clientContext $ eventThread manager client) (\_ -> putMVar sync ())         pure $ pure (thread, sync) -    downloadThreadPair' <- if (getField @"offline" config) || (getField @"useLdd" config) then pure Nothing else do-        sync   <- newEmptyMVar-        thread <- forkFinally (runLogger $ downloadThreadF manager client) (\_ -> putMVar sync ())-        pure $ pure (thread, sync)+    dataSourceStart dataSource -    pure $ Client-        $ setField @"downloadThreadPair" downloadThreadPair'-        $ setField @"eventThreadPair"    eventThreadPair' client+    pure $ Client $ ClientI{..} ++dataSourceFactory :: ConfigI -> DataSourceFactory+dataSourceFactory config =+    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+ clientRunLogger :: ClientI -> (LoggingT IO () -> IO ()) clientRunLogger client = getField @"logger" $ getField @"config" client @@ -90,6 +150,89 @@ getStatus :: Client -> IO Status getStatus (Client client) = getStatusI client +-- TODO(mmk) This method exists in multiple places. Should we move this into a util file?+fromObject :: Value -> HashMap Text 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.+data AllFlagsState = AllFlagsState+    { evaluations :: !(HashMap Text Value)+    , state :: !(HashMap Text FlagState)+    , valid :: !Bool+    } deriving (Show, Generic)++instance ToJSON AllFlagsState where+    toJSON state = Object $+        HM.insert "$flagsState" (toJSON $ getField @"state" state) $+        HM.insert "$valid" (toJSON $ getField @"valid" state)+        (fromObject $ toJSON $ getField @"evaluations" state)++data FlagState = FlagState+    { version :: !(Maybe Natural)+    , variation :: !(Maybe Integer)+    , reason :: !(Maybe EvaluationReason)+    , trackEvents :: !Bool+    , trackReason :: !Bool+    , debugEventsUntilDate :: !(Maybe Natural)+    } 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+        ]++-- | 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+-- used on the front end.+--+-- The most common use case for this method is to bootstrap a set of+-- client-side feature flags from a back-end service.+--+-- The first parameter will limit to only flags that are marked for use with+-- the client-side SDK (by default, all flags are included).+--+-- The second parameter will include evaluation reasons in the state.+--+-- The third parameter will omit any metadata that is normally only used for+-- event generation, such as flag versions and evaluation reasons, unless the+-- flag has event tracking or debugging turned on+--+-- 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+    status <- getAllFlagsC $ getField @"store" client+    case status of+        Left _      -> pure AllFlagsState { evaluations = HM.empty, state = HM.empty, valid = False }+        Right flags -> do+            filtered <- pure $ (HM.filter (\flag -> (not client_side_only) || isClientSideOnlyFlag flag) flags)+            details <- mapM (\flag -> (\detail -> (flag, fst detail)) <$> (evaluateDetail flag user $ getField @"store" client)) filtered+            evaluations <- pure $ HM.map (getField @"value" . snd) details+            now <- unixMilliseconds+            state <- pure $ HM.map (\(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@@ -103,12 +246,15 @@             evals <- mapM (\flag -> evaluateDetail flag user $ getField @"store" client) flags             pure $ HM.map (getField @"value" . fst) evals --- | Identify reports details about a a user.+-- | Identify reports details about a user. identify :: Client -> User -> IO ()-identify (Client client) (User user) = do-    let user' = userSerializeRedacted (getField @"config" client) user-    x <- makeBaseEvent $ IdentifyEvent { key = getField @"key" user, user = user' }-    queueEvent (getField @"config" client) (getField @"events" client) (EventTypeIdentify x)+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+        queueEvent (getField @"config" client) (getField @"events" client) (EventTypeIdentify x)  -- | Track reports that a user has performed an event. Custom data can be -- attached to the event, and / or a numeric value.@@ -126,7 +272,11 @@         , value       = value         , contextKind = userGetContextKind user         }-    queueEvent (getField @"config" client) (getField @"events" client) (EventTypeCustom x)+    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  -- | Alias associates two users for analytics purposes with an alias event. --@@ -155,11 +305,7 @@ close outer@(Client client) = clientRunLogger client $ do     $(logDebug) "Setting client status to ShuttingDown"     liftIO $ writeIORef (getField @"status" client) ShuttingDown-    forM_ (getField @"downloadThreadPair" client) $ \(thread, sync) -> do-        $(logDebug) "Killing download thread"-        liftIO $ killThread thread-        $(logDebug) "Waiting on download thread to die"-        liftIO $ void $ takeMVar sync+    liftIO $ dataSourceStop $ getField @"dataSource" client     forM_ (getField @"eventThreadPair" client) $ \(_, sync) -> do         $(logDebug) "Triggering event flush"         liftIO $ flushEvents outer@@ -194,7 +340,7 @@ boolVariation :: Client -> Text -> User -> Bool -> IO Bool boolVariation = dropReason . reorderStuff boolConverter False --- | Evaluate a Boolean typed flag, and return an explation.+-- | Evaluate a Boolean typed flag, and return an explanation. boolVariationDetail :: Client -> Text -> User -> Bool -> IO (EvaluationDetail Bool) boolVariationDetail = reorderStuff boolConverter True
src/LaunchDarkly/Server/Client/Internal.hs view
@@ -14,9 +14,11 @@ import Control.Concurrent.MVar             (MVar) import Data.Generics.Product               (getField) -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     (ConfigI)+import LaunchDarkly.Server.Store.Internal      (StoreHandle, getInitializedC)+import LaunchDarkly.Server.Events              (EventState)+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@@ -25,27 +27,11 @@  -- | The version string for this library. clientVersion :: Text-clientVersion = "2.2.0"---- | 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-    deriving (Eq)+clientVersion = "3.0.0"  setStatus :: ClientI -> Status -> IO ()-setStatus client status' = atomicModifyIORef' (getField @"status" client) $ \status ->-    case status' of-        -- Only allow setting Initialized if Uninitialized-        Initialized   -> (if status == Uninitialized then Initialized  else status, ())-        -- Only allow setting status if not ShuttingDown-        _             -> (if status == ShuttingDown  then ShuttingDown else status', ())+setStatus client status' = +    atomicModifyIORef' (getField @"status" client) (fmap (,()) (transitionStatus status'))  getStatusI :: ClientI -> IO Status getStatusI client = readIORef (getField @"status" client) >>= \case@@ -60,6 +46,6 @@     , store              :: !(StoreHandle IO)     , status             :: !(IORef Status)     , events             :: !EventState-    , downloadThreadPair :: !(Maybe (ThreadId, MVar ()))     , eventThreadPair    :: !(Maybe (ThreadId, MVar ()))+    , dataSource         :: !DataSource     } deriving (Generic)
+ src/LaunchDarkly/Server/Client/Status.hs view
@@ -0,0 +1,25 @@+module LaunchDarkly.Server.Client.Status+    ( Status(..)+    , transitionStatus+    )+    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+    deriving (Show, Eq)++transitionStatus :: Status -> Status -> Status+transitionStatus requestedStatus oldStatus = +    case requestedStatus of+        -- Only allow setting Initialized if Uninitialized+        Initialized   -> if oldStatus == Uninitialized then Initialized  else oldStatus+        -- Only allow setting status if not ShuttingDown+        _             -> if oldStatus == ShuttingDown  then ShuttingDown else requestedStatus
src/LaunchDarkly/Server/Config.hs view
@@ -16,27 +16,32 @@     , configSetInlineUsersInEvents     , configSetEventsCapacity     , configSetLogger+    , configSetManager     , configSetSendEvents     , configSetOffline     , configSetRequestTimeoutSeconds     , configSetStoreBackend     , configSetStoreTTL     , configSetUseLdd+    , configSetDataSourceFactory     ) where  import Control.Monad.Logger                (LoggingT, runStdoutLoggingT) import Data.Generics.Product               (setField) import Data.Set                            (Set)-import Data.Text                           (Text)+import Data.Text                           (Text, dropWhileEnd) import Data.Monoid                         (mempty) import GHC.Natural                         (Natural)+import Network.HTTP.Client                 (Manager)  import LaunchDarkly.Server.Config.Internal (Config(..), mapConfig, ConfigI(..)) import LaunchDarkly.Server.Store           (StoreInterface)+import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory)  -- | Create a default configuration from a given SDK key. makeConfig :: Text -> Config-makeConfig key = Config $ ConfigI+makeConfig key = +    Config $ ConfigI     { key                   = key     , baseURI               = "https://app.launchdarkly.com"     , streamURI             = "https://stream.launchdarkly.com"@@ -56,6 +61,8 @@     , offline               = False     , requestTimeoutSeconds = 30     , useLdd                = False+    , dataSourceFactory     = Nothing +    , manager               = Nothing     }  -- | Set the SDK key used to authenticate with LaunchDarkly.@@ -65,17 +72,17 @@ -- | 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"+configSetBaseURI = mapConfig . setField @"baseURI" . dropWhileEnd ((==) '/')  -- | 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"+configSetStreamURI = mapConfig . setField @"streamURI" . dropWhileEnd ((==) '/')  -- | 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"+configSetEventsURI = mapConfig . setField @"eventsURI" . dropWhileEnd ((==) '/')  -- | Configures a handle to an external store such as Redis. configSetStoreBackend :: Maybe StoreInterface -> Config -> Config@@ -147,9 +154,19 @@ configSetRequestTimeoutSeconds :: Natural -> Config -> Config configSetRequestTimeoutSeconds = mapConfig . setField @"requestTimeoutSeconds" --- | Sets whether this client should use the LaunchDarkly relay 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/docs/the-relay-proxy+-- | 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"++-- | 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"++-- | 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
+ src/LaunchDarkly/Server/Config/ClientContext.hs view
@@ -0,0 +1,13 @@+module LaunchDarkly.Server.Config.ClientContext+    (ClientContext(..))+    where++import Control.Monad.Logger (LoggingT)++import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration)++data ClientContext = ClientContext +    { runLogger :: !(LoggingT IO () -> IO ())+    , httpConfiguration :: !HttpConfiguration+    }+
+ src/LaunchDarkly/Server/Config/HttpConfiguration.hs view
@@ -0,0 +1,24 @@+module LaunchDarkly.Server.Config.HttpConfiguration+    ( HttpConfiguration(..)+    , prepareRequest+    )+    where++import Network.HTTP.Client (Manager, ResponseTimeout, Request, requestHeaders, responseTimeout, setRequestIgnoreStatus, parseRequest)+import Network.HTTP.Types  (Header)+import Control.Monad.Catch (MonadThrow)++data HttpConfiguration = HttpConfiguration +    { defaultRequestHeaders :: ![Header]+    , defaultRequestTimeout :: !ResponseTimeout+    , tlsManager :: !Manager+    }++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 +        } +
src/LaunchDarkly/Server/Config/Internal.hs view
@@ -11,8 +11,10 @@ import Data.Set                           (Set) import GHC.Natural                        (Natural) import GHC.Generics                       (Generic)+import Network.HTTP.Client                (Manager) -import LaunchDarkly.Server.Store          (StoreInterface)+import LaunchDarkly.Server.Store               (StoreInterface)+import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory)  mapConfig :: (ConfigI -> ConfigI) -> Config -> Config mapConfig f (Config c) = Config $ f c@@ -43,4 +45,6 @@     , offline               :: !Bool     , requestTimeoutSeconds :: !Natural     , useLdd                :: !Bool+    , dataSourceFactory     :: !(Maybe DataSourceFactory)+    , manager               :: !(Maybe Manager)     } deriving (Generic)
+ src/LaunchDarkly/Server/DataSource/Internal.hs view
@@ -0,0 +1,51 @@+module LaunchDarkly.Server.DataSource.Internal+    ( DataSourceFactory+    , nullDataSourceFactory+    , DataSource(..)+    , DataSourceUpdates(..)+    , defaultDataSourceUpdates+    )+    where++import Data.IORef          (IORef, atomicModifyIORef')+import Data.HashMap.Strict (HashMap)+import Data.Text           (Text)+import GHC.Natural         (Natural)++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)++type DataSourceFactory = ClientContext -> DataSourceUpdates -> IO DataSource++nullDataSourceFactory :: DataSourceFactory+nullDataSourceFactory _ _ =+    pure $ DataSource (pure False) (pure ()) (pure ())++data DataSource = DataSource+    { dataSourceIsInitialized :: IO Bool+    , dataSourceStart :: IO ()+    , dataSourceStop :: IO ()+    }++data DataSourceUpdates = DataSourceUpdates+    { dataSourceUpdatesInit :: !(HashMap Text Flag -> HashMap Text Segment -> IO (Either Text ()))+    , dataSourceUpdatesInsertFlag :: !(Flag -> IO (Either Text ()))+    , dataSourceUpdatesInsertSegment :: !(Segment -> IO (Either Text ()))+    , dataSourceUpdatesDeleteFlag :: !(Text -> Natural -> IO (Either Text ()))+    , dataSourceUpdatesDeleteSegment :: !(Text -> Natural -> IO (Either Text ()))+    , dataSourceUpdatesSetStatus :: Status -> IO ()+    }++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 +        }
src/LaunchDarkly/Server/Details.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE OverloadedLists #-} module LaunchDarkly.Server.Details where  import           Data.Aeson.Types       (Value(..), ToJSON, toJSON)-import qualified Data.HashMap.Strict as HM import           Data.Text              (Text)+import           GHC.Exts               (fromList) import           GHC.Natural            (Natural) import           GHC.Generics           (Generic) @@ -12,7 +13,7 @@     { 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 Natural)+    , 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.@@ -68,17 +69,27 @@ instance ToJSON EvaluationReason where     toJSON x = case x of         EvaluationReasonOff                                        ->-            Object $ HM.fromList [("kind", "OFF")]+            Object $ fromList [("kind", "OFF")]         EvaluationReasonTargetMatch                                ->-            Object $ HM.fromList [("kind", "TARGET_MATCH")]-        (EvaluationReasonRuleMatch ruleIndex ruleId inExperiment)  ->-            Object $ HM.fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId), ("inExperiment", toJSON inExperiment)]+            Object $ fromList [("kind", "TARGET_MATCH")]+        (EvaluationReasonRuleMatch ruleIndex ruleId True)  ->+            Object $ fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId), ("inExperiment", toJSON True)]+        (EvaluationReasonRuleMatch ruleIndex ruleId False)  ->+            Object $ fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId)]         (EvaluationReasonPrerequisiteFailed prerequisiteKey)       ->-            Object $ HM.fromList [("kind", "PREREQUISITE_FAILED"), ("prerequisiteKey", toJSON prerequisiteKey)]-        EvaluationReasonFallthrough inExperiment                   ->-            Object $ HM.fromList [("kind", "FALLTHROUGH"), ("inExperiment", toJSON inExperiment)]+            Object $ fromList [("kind", "PREREQUISITE_FAILED"), ("prerequisiteKey", toJSON prerequisiteKey)]+        EvaluationReasonFallthrough True                   ->+            Object $ fromList [("kind", "FALLTHROUGH"), ("inExperiment", toJSON True)]+        EvaluationReasonFallthrough False                   ->+            Object $ fromList [("kind", "FALLTHROUGH")]         (EvaluationReasonError errorKind)                          ->-            Object $ HM.fromList [("kind", "ERROR"), ("errorKind", toJSON errorKind)]+            Object $ fromList [("kind", "ERROR"), ("errorKind", toJSON errorKind)]++isInExperiment :: EvaluationReason -> Bool+isInExperiment reason = case reason of+    EvaluationReasonRuleMatch _ _ inExperiment -> inExperiment+    EvaluationReasonFallthrough inExperiment -> inExperiment+    _ -> False  -- | Defines the possible values of the errorKind property of EvaluationReason. data EvalErrorKind
src/LaunchDarkly/Server/Evaluate.hs view
@@ -17,7 +17,7 @@ import qualified Data.ByteString as                  B import qualified Data.ByteString.Base16 as           B16 import           Data.Text.Encoding                  (encodeUtf8)-import           GHC.Natural                         (Natural, naturalToInt)+import           GHC.Natural                         (Natural) import           Data.Word                           (Word8) import           Data.ByteString                     (ByteString) @@ -55,7 +55,7 @@             pure (errorDetail $ EvalErrorExternalStore err, True, pure event)         Right Nothing     -> do             let event = newUnknownFlagEvent key fallback (EvaluationReasonError EvalErrorFlagNotFound)-            pure (errorDetail EvalErrorFlagNotFound, True, pure event)+            pure (errorDefault EvalErrorFlagNotFound fallback, True, pure event)         Right (Just flag) -> do             (reason, events) <- evaluateDetail flag user $ getField @"store" client             let reason' = setFallback reason fallback@@ -67,13 +67,15 @@ 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 -> Natural -> EvaluationReason -> EvaluationDetail Value-getVariation flag index reason = let variations = getField @"variations" flag in-    if naturalToInt index >= length variations-        then EvaluationDetail { value = Null, variationIndex = mzero, reason = EvaluationReasonError EvalErrorKindMalformedFlag }-        else EvaluationDetail { value = genericIndex variations index, variationIndex = pure index, 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  evaluateDetail :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> UserI -> store     -> m (EvaluationDetail Value, [EvalEvent])@@ -123,8 +125,11 @@         targetMatch = return . checkTarget <$> getField @"targets" flag         in fromMaybe fallthrough <$> firstJustM Prelude.id (ruleMatch ++ targetMatch) +errorDefault :: EvalErrorKind -> Value -> EvaluationDetail Value+errorDefault kind v = EvaluationDetail { value = v, variationIndex = mzero, reason = EvaluationReasonError kind }+ errorDetail :: EvalErrorKind -> EvaluationDetail Value-errorDetail kind = EvaluationDetail { value = Null, variationIndex = mzero, reason = EvaluationReasonError kind }+errorDetail kind = errorDefault kind Null  getValueForVariationOrRollout :: Flag -> VariationOrRollout -> UserI -> EvaluationReason -> EvaluationDetail Value getValueForVariationOrRollout flag vr user reason =@@ -142,7 +147,7 @@ ruleMatchesUser rule user store =     allM (\clause -> clauseMatchesUser store clause user) (getField @"clauses" rule) -variationIndexForUser :: VariationOrRollout -> UserI -> Text -> Text -> (Maybe Natural, Bool)+variationIndexForUser :: VariationOrRollout -> UserI -> Text -> Text -> (Maybe Integer, Bool) variationIndexForUser vor user key salt     | (Just variation) <- getField @"variation" vor = (pure variation, False)     | (Just rollout) <- getField @"rollout" vor = let@@ -197,6 +202,7 @@ 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
src/LaunchDarkly/Server/Events.hs view
@@ -1,21 +1,23 @@ module LaunchDarkly.Server.Events where -import           Data.Aeson                          (ToJSON, Value(..), toJSON, object)+import           Data.Aeson                          (ToJSON, Value(..), toJSON, object, (.=)) import           Data.Text                           (Text)-import           GHC.Natural                         (Natural)+import           GHC.Exts                            (fromList)+import           GHC.Natural                         (Natural, intToNatural) 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_)+import           Control.Concurrent.MVar             (MVar, putMVar, swapMVar, newEmptyMVar, newMVar, tryTakeMVar, modifyMVar_, modifyMVar, readMVar) import qualified Data.HashMap.Strict as              HM import           Data.HashMap.Strict                 (HashMap) import           Data.Time.Clock.POSIX               (getPOSIXTime) import           Control.Lens                        ((&), (%~)) import           Data.Maybe                          (fromMaybe) import           Data.Cache.LRU                      (LRU, newLRU)-import           Control.Monad                       (when)+import           Control.Monad                       (when, unless) import qualified Data.Cache.LRU as                   LRU +import           LaunchDarkly.AesonCompat            (KeyMap, keyMapUnion) import           LaunchDarkly.Server.Config.Internal (ConfigI, shouldSendEvents) import           LaunchDarkly.Server.User.Internal   (UserI, userSerializeRedacted) import           LaunchDarkly.Server.Details         (EvaluationReason(..))@@ -26,7 +28,7 @@  instance ToJSON ContextKind where   toJSON contextKind = String $ case contextKind of-      ContextKindUser          -> "user" +      ContextKindUser          -> "user"       ContextKindAnonymousUser -> "anonymousUser"  userGetContextKind :: UserI -> ContextKind@@ -35,7 +37,7 @@  data EvalEvent = EvalEvent     { key                  :: !Text-    , variation            :: !(Maybe Natural)+    , variation            :: !(Maybe Integer)     , value                :: !Value     , defaultValue         :: !(Maybe Value)     , version              :: !(Maybe Natural)@@ -48,20 +50,22 @@     } deriving (Generic, Eq, Show)  data EventState = EventState-    { events     :: !(MVar [EventType])-    , flush      :: !(MVar ())-    , summary    :: !(MVar (HashMap Text (FlagSummaryContext (HashMap Text CounterContext))))-    , startDate  :: !(MVar Natural)-    , userKeyLRU :: !(MVar (LRU Text ()))+    { events              :: !(MVar [EventType])+    , lastKnownServerTime :: !(MVar Int)+    , flush               :: !(MVar ())+    , summary             :: !(MVar (HashMap Text (FlagSummaryContext (HashMap Text CounterContext))))+    , startDate           :: !(MVar Natural)+    , userKeyLRU          :: !(MVar (LRU Text ()))     } deriving (Generic)  makeEventState :: ConfigI -> IO EventState makeEventState config = do-    events     <- newMVar []-    flush      <- newEmptyMVar-    summary    <- newMVar mempty-    startDate  <- newEmptyMVar-    userKeyLRU <- newMVar $ newLRU $ pure $ fromIntegral $ getField @"userKeyLRUCapacity" config+    events              <- newMVar []+    lastKnownServerTime <- newMVar 0+    flush               <- newEmptyMVar+    summary             <- newMVar mempty+    startDate           <- newEmptyMVar+    userKeyLRU          <- newMVar $ newLRU $ pure $ fromIntegral $ getField @"userKeyLRUCapacity" config     pure EventState{..}  convertFeatures :: HashMap Text (FlagSummaryContext (HashMap Text CounterContext))@@ -71,7 +75,10 @@ queueEvent :: ConfigI -> EventState -> EventType -> IO () queueEvent config state event = if not (shouldSendEvents config) then pure () else     modifyMVar_ (getField @"events" state) $ \events ->-    if length events < fromIntegral (getField @"eventsCapacity" config) then pure (event : events) else pure events+        pure $ case event of+          EventTypeSummary _ -> (event : events)+          _ | length events < fromIntegral (getField @"eventsCapacity" config) -> (event : events)+          _ -> events  unixMilliseconds :: IO Natural unixMilliseconds = (round . (* 1000)) <$> getPOSIXTime@@ -85,7 +92,7 @@     (Just startDate) -> do         endDate  <- unixMilliseconds         features <- convertFeatures <$> swapMVar (getField @"summary" state) mempty-        makeBaseEvent SummaryEvent {..} >>= queueEvent config state . EventTypeSummary+        queueEvent config state $ EventTypeSummary $ SummaryEvent {..}  class EventKind a where     eventKind :: a -> Text@@ -113,11 +120,21 @@ data CounterContext = CounterContext     { count     :: !Natural     , version   :: !(Maybe Natural)-    , variation :: !(Maybe Natural)+    , variation :: !(Maybe Integer)     , value     :: !Value     , unknown   :: !Bool-    } deriving (Generic, Show, ToJSON)+    } 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+        ]+ data IdentifyEvent = IdentifyEvent     { key  :: !Text     , user :: !Value@@ -138,7 +155,7 @@     , value        :: !Value     , defaultValue :: !(Maybe Value)     , version      :: !(Maybe Natural)-    , variation    :: !(Maybe Natural)+    , variation    :: !(Maybe Integer)     , reason       :: !(Maybe EvaluationReason)     , contextKind  :: !ContextKind     } deriving (Generic, Show)@@ -173,6 +190,9 @@     then setField @"user" (pure $ userSerializeRedacted config user) event     else setField @"userKey" (pure $ getField @"key" user) event +forceUserInlineInEvent :: ConfigI -> UserI -> FeatureEvent -> FeatureEvent+forceUserInlineInEvent config user event = setField @"userKey" Nothing $ setField @"user" (pure $ userSerializeRedacted config user) event+ makeFeatureEvent :: ConfigI -> UserI -> Bool -> EvalEvent -> FeatureEvent makeFeatureEvent config user includeReason event = addUserToEvent config user $ FeatureEvent     { key          = getField @"key" event@@ -234,11 +254,11 @@     , event        :: event     } deriving (Generic, Show) -fromObject :: Value -> HashMap Text Value+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 $ HM.union (fromObject $ toJSON $ getField @"event" event) $ HM.fromList+    toJSON event = Object $ keyMapUnion (fromObject $ toJSON $ getField @"event" event) $ fromList         [ ("creationDate", toJSON $ getField @"creationDate" event)         , ("kind",         String $ eventKind $ getField @"event" event)         ]@@ -246,7 +266,7 @@ data EventType =       EventTypeIdentify !(BaseEvent IdentifyEvent)     | EventTypeFeature  !(BaseEvent FeatureEvent)-    | EventTypeSummary  !(BaseEvent SummaryEvent)+    | EventTypeSummary  !(SummaryEvent)     | EventTypeCustom   !(BaseEvent CustomEvent)     | EventTypeIndex    !(BaseEvent IndexEvent)     | EventTypeDebug    !(BaseEvent DebugEvent)@@ -256,8 +276,8 @@     toJSON event = case event of         EventTypeIdentify x -> toJSON x         EventTypeFeature  x -> toJSON x-        EventTypeSummary  x -> toJSON x-        EventTypeCustom   x -> toJSON x+        EventTypeSummary  x -> Object $ HM.insert "kind" (String "summary") (fromObject $ toJSON x)+        EventTypeCustom   x -> toJSON $ x         EventTypeIndex    x -> toJSON x         EventTypeDebug    x -> toJSON x         EventTypeAlias    x -> toJSON x@@ -277,7 +297,7 @@     , debugEventsUntilDate = Nothing     } -newSuccessfulEvalEvent :: Flag -> Maybe Natural -> Value -> Maybe Value -> EvaluationReason -> Maybe Text -> EvalEvent+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@@ -335,21 +355,31 @@ 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-    when (getField @"trackEvents" event) $+        trackEvents = (getField @"trackEvents" event)+        inlineUsers = (getField @"inlineUsersInEvents" config)+        debugEventsUntilDate = fromMaybe 0 (getField @"debugEventsUntilDate" event)+    lastKnownServerTime <- intToNatural <$> (* 1000) <$> readMVar (getField @"lastKnownServerTime" state)+    when trackEvents $         queueEvent config state $ EventTypeFeature $ BaseEvent now $ featureEvent-    when (now < fromMaybe 0 (getField @"debugEventsUntilDate" event)) $-        queueEvent config state $ EventTypeDebug $ BaseEvent now $ DebugEvent featureEvent+    when (now < debugEventsUntilDate && lastKnownServerTime < debugEventsUntilDate) $+        queueEvent config state $ EventTypeDebug $ BaseEvent now $ DebugEvent $ forceUserInlineInEvent config user featureEvent     runSummary now state event unknown-    maybeIndexUser now config user state+    unless (trackEvents && inlineUsers) $+        maybeIndexUser now config user 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  maybeIndexUser :: Natural -> ConfigI -> UserI -> EventState -> IO ()-maybeIndexUser now config user state = modifyMVar_ (getField @"userKeyLRU" state) $ \cache ->-    let key = getField @"key" user in case LRU.lookup key cache of-        (cache', Just _)  -> pure cache'-        (cache', Nothing) -> do-            queueEvent config state (EventTypeIndex $ BaseEvent now $ IndexEvent { user = userSerializeRedacted config user })-            pure $ LRU.insert key () cache'+maybeIndexUser now config user state = do+    noticedUser <- noticeUser state user+    when noticedUser $+        queueEvent config state (EventTypeIndex $ BaseEvent now $ IndexEvent { user = userSerializeRedacted config user })++noticeUser :: EventState -> UserI -> IO Bool+noticeUser state user = modifyMVar (getField @"userKeyLRU" state) $ \cache -> do+    let key = getField @"key" user+    case LRU.lookup key cache of+        (cache', Just _)  -> pure (cache', False)+        (cache', Nothing) -> pure (LRU.insert key () cache', True)
src/LaunchDarkly/Server/Features.hs view
@@ -1,7 +1,9 @@ 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)@@ -9,10 +11,12 @@ import GHC.Generics                  (Generic)  import LaunchDarkly.Server.Operators (Op)+import LaunchDarkly.Server.Details (EvaluationReason (..))+import qualified LaunchDarkly.Server.Details as D  data Target = Target     { values    :: ![Text]-    , variation :: !Natural+    , variation :: !Integer     } deriving (Generic, FromJSON, ToJSON, Show, Eq)  data Rule = Rule@@ -49,7 +53,7 @@         ]  data WeightedVariation = WeightedVariation-    { variation :: !Natural+    { variation :: !Integer     , weight    :: !Float     , untracked :: !Bool     } deriving (Generic, ToJSON, Show, Eq)@@ -66,7 +70,7 @@  instance ToJSON RolloutKind where     toJSON x = String $ case x of-        RolloutKindExperiment -> "experiment" +        RolloutKindExperiment -> "experiment"         RolloutKindRollout    -> "rollout"  instance FromJSON RolloutKind where@@ -91,10 +95,26 @@         pure Rollout { .. }  data VariationOrRollout = VariationOrRollout-    { variation :: !(Maybe Natural)+    { variation :: !(Maybe Integer)     , rollout   :: !(Maybe Rollout)     } deriving (Generic, FromJSON, ToJSON, Show, Eq) +data ClientSideAvailability = ClientSideAvailability+    { 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++instance ToJSON ClientSideAvailability where+    toJSON (ClientSideAvailability env mob _) =+        object [ "usingEnvironmentId" .= env, "usingMobileKey" .= mob ]+ data Flag = Flag     { key                    :: !Text     , version                :: !Natural@@ -107,14 +127,74 @@     , targets                :: ![Target]     , rules                  :: ![Rule]     , fallthrough            :: !VariationOrRollout-    , offVariation           :: !(Maybe Natural)+    , offVariation           :: !(Maybe Integer)     , variations             :: ![Value]     , debugEventsUntilDate   :: !(Maybe Natural)-    } deriving (Generic, ToJSON, FromJSON, Show, Eq)+    , clientSideAvailability :: !ClientSideAvailability+    } 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 -> [ ]++instance FromJSON Flag where+    parseJSON = withObject "Flag" $ \obj -> do+        key <- obj .: "key"+        version <- obj .: "version"+        on <- obj .: "on"+        trackEvents <- obj .: "trackEvents"+        trackEventsFallthrough <- obj .: "trackEventsFallthrough"+        deleted <- obj .: "deleted"+        prerequisites <- obj .: "prerequisites"+        salt <- obj .: "salt"+        targets <- obj .: "targets"+        rules <- obj .: "rules"+        fallthrough <- obj .: "fallthrough"+        offVariation <- obj .:? "offVariation"+        variations <- obj .: "variations"+        debugEventsUntilDate <- obj .:? "debugEventsUntilDate"+        clientSide <- obj .:? "clientSide" .!= False+        clientSideAvailability <- obj .:? "clientSideAvailability" .!= ClientSideAvailability clientSide True False+        pure Flag { .. }++isClientSideOnlyFlag :: Flag -> Bool+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+-- or if it's a rule match and the rule that matched has track events turned on+-- otherwise false+isInExperiment :: Flag -> EvaluationReason -> Bool+isInExperiment _ reason+  | 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+isInExperiment _ _ = False+ data Prerequisite = Prerequisite     { key       :: !Text-    , variation :: !Natural+    , variation :: !Integer     } deriving (Generic, FromJSON, ToJSON, Show, Eq)  data SegmentRule = SegmentRule
+ src/LaunchDarkly/Server/Integrations/FileData.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE BangPatterns #-}+-- | 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.+--+--  @since 2.2.1+--+module LaunchDarkly.Server.Integrations.FileData+    ( dataSourceFactory+    )+    where++import           LaunchDarkly.Server.DataSource.Internal (DataSourceFactory, DataSource(..), DataSourceUpdates(..))+import qualified LaunchDarkly.Server.Features as F+import           LaunchDarkly.Server.Client.Status+import           Data.Maybe (fromMaybe)+import qualified Data.ByteString.Lazy as BSL+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+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 qualified Data.Yaml as Yaml+import           Control.Applicative ((<|>))++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)++expandSimpleFlag :: Value -> FileFlag+expandSimpleFlag value =+    FileFlag+        { version = Nothing+        , on = Nothing+        , targets = Nothing+        , rules = Nothing+        , fallthrough = Just (F.VariationOrRollout (Just 0) Nothing)+        , offVariation = Just 0+        , variations = [value]+        }++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+          }++noFallthrough :: F.VariationOrRollout+noFallthrough =+    F.VariationOrRollout Nothing Nothing++data FileSegment = FileSegment+    { included :: Maybe (HashSet Text)+    , excluded :: Maybe (HashSet Text)+    , 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+             }++data FileBody = FileBody+    { flags      :: Maybe (HashMap Text FileFlag)+    , flagValues :: Maybe (HashMap Text Value)+    , segments   :: Maybe (HashMap Text FileSegment)+    } deriving (Generic, Show, FromJSON)++instance Semigroup FileBody where+    f1 <> f2 =+        FileBody+            { flags = flags f1 <> flags f2+            , flagValues = flagValues f1 <> flagValues f2+            , segments = segments f1 <> segments f2+            }+instance Monoid FileBody where+    mempty =+        FileBody+            { flags = mempty+            , flagValues = mempty+            , segments = mempty+            }+    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.+--+-- 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/.+--+-- 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.+--+-- 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+-- @+--+-- The output will look something like this (but with many more properties):+--+-- @+-- {+--     "flags": {+--         "flag-key-1": {+--             "key": "flag-key-1",+--             "on": true,+--             "variations": [ "a", "b" ]+--         },+--         "flag-key-2": {+--             "key": "flag-key-2",+--             "on": true,+--             "variations": [ "c", "d" ]+--         }+--     },+--     "segments": {+--         "segment-key-1": {+--             "key": "segment-key-1",+--             "includes": [ "user-key-1" ]+--         }+--     }+-- }+-- @+--+-- 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:+--+-- @+-- {+--     "flagValues": {+--         "my-string-flag-key": "value-1",+--         "my-boolean-flag-key": true,+--         "my-integer-flag-key": 3+--     }+-- }+-- @+--+-- Or, in YAML:+--+-- @+-- flagValues:+--   my-string-flag-key: "value-1"+--   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.+--+-- 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+dataSourceFactory sources _clientContext dataSourceUpdates = do+    inited <- newIORef False+    let dataSourceIsInitialized =+            readIORef inited+        dataSourceStart = do+            FileBody mFlags mFlagValues mSegments <- mconcat <$> traverse loadFile sources+            let mSimpleFlags = fmap (fmap expandSimpleFlag) mFlagValues+                flags' = maybe mempty (HM.mapWithKey fromFileFlag) (mFlags <> mSimpleFlags)+                segments' = maybe mempty (HM.mapWithKey fromFileSegment) mSegments+            _ <- dataSourceUpdatesInit dataSourceUpdates flags' segments'+            dataSourceUpdatesSetStatus dataSourceUpdates Initialized+            writeIORef inited True+        dataSourceStop = pure ()+    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
+ src/LaunchDarkly/Server/Integrations/TestData.hs view
@@ -0,0 +1,183 @@+-- |+-- 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.+--+-- @+-- td <- TestData.newTestData+-- update td =<< (flag td "flag-key-1"+--                 \<&\> booleanFlag+--                 \<&\> variationForAllUsers True)+--+-- let config = makeConfig "sdkKey"+--                 & configSetDataSourceFactory (dataSourceFactory td)+-- client <- makeClient config+--+-- -- flags can be updated at any time:+-- update td =<<+--    (flag td "flag-key-2"+--          \<&\> variationForUser "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:+--+--      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.+--+-- see "LaunchDarkly.Server.Integrations.FileData"+--+-- @since 2.2.1+module LaunchDarkly.Server.Integrations.TestData+    ( TestData+    , newTestData+    , flag+    , update+    , dataSourceFactory++    -- * FlagBuilder+    , FlagBuilder+    , booleanFlag+    , on+    , fallthroughVariation+    , offVariation+    , variationForAllUsers+    , valueForAllUsers+    , variationForUser+    , variations+    , ifMatch+    , ifNotMatch+    , VariationIndex++    -- * FlagRuleBuilder+    , FlagRuleBuilder+    , andMatch+    , andNotMatch+    , thenReturn+    )+    where++import           Control.Concurrent.MVar                               (MVar, modifyMVar_, newMVar, newEmptyMVar, readMVar, putMVar)+import           Control.Monad                                         (void)+import           Data.Foldable                                         (traverse_)+import           Data.HashMap.Strict                                   (HashMap)+import qualified Data.HashMap.Strict                                   as HM+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.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+    listenerIdRef <- newEmptyMVar+    let upsert flag = void $ dataSourceUpdatesInsertFlag dataSourceUpdates flag+        dataSourceStart = do+            modifyMVar_ ref $ \td -> do+                void $ dataSourceUpdatesInit dataSourceUpdates (currentFlags td) mempty+                let (td', listenerId) = addDataSourceListener td upsert+                putMVar listenerIdRef listenerId+                pure td'+        dataSourceIsInitialized =+            pure True+        dataSourceStop =+            modifyMVar_ ref $ \td ->+                removeDataSourceListener td <$> readMVar listenerIdRef+    pure $ DataSource {..}++newtype TestData = TestData (MVar TestData')++type TestDataListener = Features.Flag -> IO ()++data TestData' = TestData'+    { flagBuilders             :: Map Text FlagBuilder+    , currentFlags             :: HashMap Text Features.Flag+    , nextDataSourceListenerId :: Int+    , dataSourceListeners      :: IntMap TestDataListener+    }++-- | Creates a new instance of the test data source.+newTestData :: IO TestData -- ^ a new configurable test data source+newTestData =+    TestData <$> newMVar (TestData' mempty mempty 0 mempty)++addDataSourceListener :: TestData' -> TestDataListener -> (TestData', Int)+addDataSourceListener td listener =+    ( td{ nextDataSourceListenerId = nextDataSourceListenerId td + 1+        , dataSourceListeners = IntMap.insert (nextDataSourceListenerId td) listener (dataSourceListeners td)+        }+    , nextDataSourceListenerId td+    )++removeDataSourceListener :: TestData' -> Int -> TestData'+removeDataSourceListener td listenerId =+    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.+--+--  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 ref) key = do+    td <- readMVar ref+    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.+--+--  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 ref) fb =+    modifyMVar_ ref $ \td -> do+        let key = fbKey fb+            mOldFlag = HM.lookup key (currentFlags td)+            oldFlagVersion = maybe 0 (getField @"version") mOldFlag+            newFlag = buildFlag (oldFlagVersion + 1) fb+            td' = td{ flagBuilders = Map.insert key fb (flagBuilders td)+                    , currentFlags = HM.insert key newFlag (currentFlags td)+                    }+        notifyListeners td newFlag+        pure td'+ where+     notifyListeners td newFlag =+        traverse_ ($ newFlag) (dataSourceListeners td)
+ src/LaunchDarkly/Server/Integrations/TestData/FlagBuilder.hs view
@@ -0,0 +1,408 @@+module LaunchDarkly.Server.Integrations.TestData.FlagBuilder+    ( FlagBuilder(..)+    , UserKey+    , VariationIndex+    , newFlagBuilder+    , booleanFlag+    , on+    , fallthroughVariation+    , offVariation+    , variationForAllUsers+    , valueForAllUsers+    , variationForUser+    , variations+    , buildFlag+    , UserAttribute+    , ifMatch+    , ifNotMatch+    , FlagRuleBuilder+    , andMatch+    , andNotMatch+    , thenReturn+    , Variation+    )+    where++import qualified Data.Aeson as Aeson+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Text (Text)+import qualified Data.Text as T+import           GHC.Natural (Natural)+import qualified LaunchDarkly.Server.Features as F+import qualified LaunchDarkly.Server.Operators as Op+import           Data.Function ((&))++type UserKey = Text+type VariationIndex = Integer++trueVariationForBoolean, falseVariationForBoolean :: VariationIndex+trueVariationForBoolean = 0+falseVariationForBoolean = 1++variationForBoolean :: Bool -> VariationIndex+variationForBoolean True = trueVariationForBoolean+variationForBoolean False = falseVariationForBoolean++-- |+-- 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+    { fbKey :: Text+    , fbOffVariation :: Maybe VariationIndex+    , fbOn :: Bool+    , fbFallthroughVariation :: Maybe VariationIndex+    , fbVariations :: [Aeson.Value]+    , fbTargetMap :: Map UserKey VariationIndex+    , fbRules :: [FlagRule]+    } deriving (Show)++fbTargets :: FlagBuilder -> [F.Target]+fbTargets flagBuilder =+    Map.elems $+    Map.mapWithKey (flip F.Target) $+    Map.foldrWithKey go mempty (fbTargetMap flagBuilder)+  where+    go userKey variation =+        Map.insertWith (<>) variation [userKey]++buildFlag :: Natural -> FlagBuilder -> F.Flag+buildFlag version flagBuilder =+    F.Flag+        { F.key = fbKey flagBuilder+        , F.version = version+        , F.on = fbOn flagBuilder+        , F.trackEvents = False+        , F.trackEventsFallthrough = False+        , F.deleted = False+        , F.prerequisites = []+        , F.salt = "salt"+        , F.targets = fbTargets flagBuilder+        , F.rules = mapWithIndex convertFlagRule (fbRules flagBuilder)+        , F.fallthrough = F.VariationOrRollout (fbFallthroughVariation flagBuilder) Nothing+        , F.offVariation = fbOffVariation flagBuilder+        , F.variations = fbVariations flagBuilder+        , F.debugEventsUntilDate = Nothing+        , F.clientSideAvailability = F.ClientSideAvailability False False False+        }++mapWithIndex :: Integral num => (num -> a -> b) -> [a] -> [b]+mapWithIndex f l =+    fmap (uncurry f) (zip [0..] l)++newFlagBuilder :: Text -> FlagBuilder+newFlagBuilder key =+    FlagBuilder+        { fbKey = key+        , fbOffVariation = Nothing+        , fbOn = True+        , fbFallthroughVariation = Nothing+        , fbVariations = mempty+        , fbTargetMap = mempty+        , fbRules = mempty+        }++booleanFlagVariations :: [Aeson.Value]+booleanFlagVariations = [Aeson.Bool True, Aeson.Bool False]++isBooleanFlag :: FlagBuilder -> Bool+isBooleanFlag flagBuilder+  | 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+-- settings specify otherwise.+booleanFlag :: FlagBuilder -> FlagBuilder+booleanFlag flagBuilder+    | isBooleanFlag flagBuilder =+        flagBuilder+    | otherwise =+        flagBuilder+            & 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+on isOn fb =+    fb{ fbOn = isOn }++-- |+-- 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 }++-- |+-- Removes any existing user targets from the flag. +-- This undoes the effect of methods like 'variationForUser'+clearUserTargets :: FlagBuilder -> FlagBuilder+clearUserTargets fb =+    fb{ fbTargetMap = mempty }++-- |+-- 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)++-- |+-- 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+variations values fb =+    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.+    --+    -- 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++    -- | +    -- 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++    -- |+    -- 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.+    --+    -- 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++    -- |+    -- 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 :: 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+    +    -- |+    -- 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++instance Variation Integer where+    fallthroughVariation variationIndex fb =+        fb{ fbFallthroughVariation = Just variationIndex }++    offVariation variationIndex fb =+        fb{ fbOffVariation = Just variationIndex }++    variationForAllUsers variationIndex fb =+        fb & on True+           & clearRules+           & clearUserTargets+           & fallthroughVariation variationIndex++    variationForUser userKey variationIndex fb =+        fb{ fbTargetMap = Map.insert userKey variationIndex (fbTargetMap fb) }++    thenReturn variationIndex ruleBuilder =+        let fb = frbBaseBuilder ruleBuilder+        in fb{ fbRules = FlagRule (frbClauses ruleBuilder) variationIndex : fbRules fb }++instance Variation Bool where+    fallthroughVariation value fb =+        fb & booleanFlag+           & fallthroughVariation (variationForBoolean value)+    offVariation value fb =+        fb & booleanFlag+           & offVariation (variationForBoolean value)+    variationForAllUsers value fb =+        fb & booleanFlag+           & variationForAllUsers (variationForBoolean value)+    variationForUser userKey value fb =+        fb & booleanFlag+           & variationForUser userKey (variationForBoolean value)+    thenReturn value 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"+--     & 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 =+    newFlagRuleBuilder fb+     & andMatch userAttribute values++-- |+-- 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"+--     & 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++data Clause = Clause+    { clauseAttribute :: UserAttribute+    , clauseValues    :: [Aeson.Value]+    , clauseNegate    :: Bool+    } deriving (Show)++data FlagRule = FlagRule+    { frClauses :: [Clause]+    , frVariation :: VariationIndex+    } deriving (Show)++convertFlagRule :: Integer -> FlagRule -> F.Rule+convertFlagRule idx flagRule =+    F.Rule+        { F.id = T.pack $ "rule" <> show idx+        , F.variationOrRollout = F.VariationOrRollout (Just $ frVariation flagRule) Nothing+        , F.clauses = fmap convertClause (frClauses flagRule)+        , F.trackEvents = False+        }++convertClause :: Clause -> F.Clause+convertClause clause =+    F.Clause+        { F.attribute = clauseAttribute 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.+--+-- 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)++newFlagRuleBuilder :: FlagBuilder -> FlagRuleBuilder+newFlagRuleBuilder baseBuilder =+    FlagRuleBuilder+        { 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\":+-- +-- @+-- 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 }++-- |+-- 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\":+-- +-- @+-- 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 }
src/LaunchDarkly/Server/Network/Common.hs view
@@ -3,23 +3,31 @@     , withResponseGeneric     , tryAuthorized     , checkAuthorization+    , getServerTime     , tryHTTP     , addToAL+    , handleUnauthorized      ) where  import Data.ByteString                     (append)+import Data.ByteString.Internal            (unpackChars) import Network.HTTP.Client                 (HttpException, Manager, Request(..), Response(..), BodyReader, setRequestIgnoreStatus, responseOpen, responseTimeout, responseTimeoutMicro, responseClose)+import Network.HTTP.Types.Header           (hDate) import Network.HTTP.Types.Status           (unauthorized401, forbidden403) import Data.Generics.Product               (getField) import Data.Text.Encoding                  (encodeUtf8)+import Data.Time.Format                    (parseTimeM, defaultTimeLocale, rfc822DateFormat)+import Data.Time.Clock.POSIX               (utcTimeToPOSIXSeconds) import Data.Function                       ((&))+import Data.Maybe                          (fromMaybe) import Control.Monad                       (when)-import Control.Monad.Catch                 (Exception, MonadCatch, MonadMask, MonadThrow, try, bracket, throwM)+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 LaunchDarkly.Server.Client.Internal (ClientI, Status(Unauthorized), clientVersion, setStatus)-import LaunchDarkly.Server.Config.Internal (ConfigI)+import LaunchDarkly.Server.Client.Internal     (ClientI, Status(Unauthorized), clientVersion, setStatus)+import LaunchDarkly.Server.Config.Internal     (ConfigI)+import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..))  tryHTTP :: MonadCatch m => m a -> m (Either HttpException a) tryHTTP = try@@ -40,6 +48,11 @@  data UnauthorizedE = UnauthorizedE deriving (Show, Exception) +handleUnauthorized :: (MonadIO m, MonadLogger m, MonadCatch m) => DataSourceUpdates -> m () -> m ()+handleUnauthorized dataSourceUpdates = handle $ \UnauthorizedE -> do+    $(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@@ -49,3 +62,11 @@  checkAuthorization :: (MonadThrow m) => Response body -> m () checkAuthorization response = when (elem (responseStatus response) [unauthorized401, forbidden403]) $ throwM UnauthorizedE++getServerTime :: Response body -> Int+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)
src/LaunchDarkly/Server/Network/Eventing.hs view
@@ -13,7 +13,7 @@ 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)+import           Control.Concurrent.MVar             (takeMVar, readMVar, swapMVar, modifyMVar_) import           System.Timeout                      (timeout) import           System.Random                       (newStdGen, random) import           Data.Text.Encoding                  (decodeUtf8)@@ -21,16 +21,23 @@ import           Network.HTTP.Types.Status           (status400, status408, status429, status500)  import           LaunchDarkly.Server.Client.Internal (ClientI, Status(ShuttingDown))-import           LaunchDarkly.Server.Network.Common  (tryAuthorized, checkAuthorization, prepareRequest, tryHTTP, addToAL)-import           LaunchDarkly.Server.Events          (processSummary)+import           LaunchDarkly.Server.Network.Common  (tryAuthorized, checkAuthorization, getServerTime, prepareRequest, tryHTTP, addToAL)+import           LaunchDarkly.Server.Events          (processSummary, EventState)  -- 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+processSend :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> Request -> m (Bool, Int) processSend manager req = (liftIO $ tryHTTP $ httpLbs req manager) >>= \case-    (Left err)       -> $(logError) (T.pack $ show err) >> pure False-    (Right response) -> checkAuthorization response     >> let code = responseStatus response in-        if code < status400 then pure True else if (elem code [status400, status408, status429]) || code >= status500 then pure False else-            $(logWarn) (T.append "got non recoverable event post response dropping payload: " $ T.pack $ show code) >> pure True+    (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)  setEventHeaders :: Request -> Request setEventHeaders request = request@@ -40,6 +47,9 @@     , method         = "POST"     } +updateLastKnownServerTime :: EventState -> Int -> IO ()+updateLastKnownServerTime state serverTime = modifyMVar_ (getField @"lastKnownServerTime" state) (\lastKnown -> pure $ max serverTime lastKnown)+ eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> m () eventThread manager client = do     let state = getField @"events" client; config = getField @"config" client;@@ -57,13 +67,17 @@                     , 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-            success <- processSend manager thisReq-            unless success $ do+            _ <- 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' <- processSend manager thisReq-                unless success' $ $(logWarn) "failed sending events on retry, dropping event batch"+                (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
@@ -4,7 +4,7 @@ import           Data.HashMap.Strict                     (HashMap) import           Data.Text                               (Text) import qualified Data.Text as                            T-import           Network.HTTP.Client                     (Manager, Request(..), Response(..), httpLbs, parseRequest)+import           Network.HTTP.Client                     (Manager, Request(..), Response(..), httpLbs) import           Data.Generics.Product                   (getField) import           Control.Monad                           (forever) import           Control.Concurrent                      (threadDelay)@@ -14,35 +14,41 @@ import           Control.Monad.Catch                     (MonadMask, MonadThrow) import           Network.HTTP.Types.Status               (ok200) -import           LaunchDarkly.Server.Client.Internal     (ClientI)-import           LaunchDarkly.Server.Network.Common      (tryAuthorized, checkAuthorization, prepareRequest, tryHTTP)+import           LaunchDarkly.Server.Network.Common      (checkAuthorization, tryHTTP, handleUnauthorized) import           LaunchDarkly.Server.Features            (Flag, Segment)-import           LaunchDarkly.Server.Store.Internal      (StoreHandle, initializeStore) +import GHC.Natural (Natural)+import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..))+import LaunchDarkly.Server.Config.ClientContext+import LaunchDarkly.Server.Client.Internal (Status(..))+import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..), prepareRequest)+ data PollingResponse = PollingResponse     { flags    :: !(HashMap Text Flag)     , segments :: !(HashMap Text Segment)     } deriving (Generic, FromJSON, Show) -processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> StoreHandle IO -> Request -> m ()-processPoll manager store request = liftIO (tryHTTP $ httpLbs request manager) >>= \case+processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m ()+processPoll manager dataSourceUpdates request = liftIO (tryHTTP $ httpLbs request manager) >>= \case     (Left err)       -> $(logError) (T.pack $ show err)     (Right response) -> checkAuthorization response >> if responseStatus response /= ok200         then $(logError) "unexpected polling status code"         else case (eitherDecode (responseBody response) :: Either String PollingResponse) of             (Left err)   -> $(logError) (T.pack $ show err)             (Right body) -> do-                status <- liftIO (initializeStore store (getField @"flags" body) (getField @"segments" body))+                status <- liftIO $ dataSourceUpdatesInit dataSourceUpdates (getField @"flags" body) (getField @"segments" body)                 case status of-                    Right () -> pure ()-                    Left err -> $(logError) $ T.append "store failed put: " err+                  Right () -> liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Initialized+                  Left err ->+                    $(logError) $ T.append "store failed put: " err -pollingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> m ()-pollingThread manager client = do-    let config = getField @"config" client; store = getField @"store" client;-    req <- (liftIO $ parseRequest $ (T.unpack $ getField @"baseURI" config) ++ "/sdk/latest-all") >>= pure . prepareRequest config-    tryAuthorized client $ forever $ do++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 $ forever $ do         $(logInfo) "starting poll"-        processPoll manager store req+        processPoll (tlsManager $ httpConfiguration clientContext) dataSourceUpdates req         $(logInfo) "finished poll"-        liftIO $ threadDelay $ (*) 1000000 $ fromIntegral $ getField @"pollIntervalSeconds" config+        liftIO $ threadDelay pollingMicroseconds
src/LaunchDarkly/Server/Network/Streaming.hs view
@@ -5,31 +5,31 @@ import           Data.Attoparsec.Text as             P hiding (Result, try) import           Data.Function                       (fix) import           Control.Monad                       (void, mzero)-import           Control.Monad.Catch                 (Exception, MonadCatch, try)+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           Data.HashMap.Strict                 (HashMap)-import           Network.HTTP.Client                 (Manager, Response(..), Request, HttpException(..), HttpExceptionContent(..), parseRequest, brRead, throwErrorStatusCodes)+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.Generics.Product               (getField)-import           Data.Aeson                          (FromJSON, parseJSON, withObject, eitherDecode, (.:), fromJSON, Result(..))+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.Monad.Catch                 (MonadMask) 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)) -import           LaunchDarkly.Server.Client.Internal (ClientI)-import           LaunchDarkly.Server.Store.Internal  (StoreHandle, StoreResult, initializeStore, insertFlag, deleteFlag, deleteSegment, insertSegment)-import           LaunchDarkly.Server.Features        (Flag, Segment)-import           LaunchDarkly.Server.Network.Common  (tryAuthorized, checkAuthorization, prepareRequest, withResponseGeneric, tryHTTP)+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)  data PutBody = PutBody     { flags    :: !(HashMap Text Flag)@@ -49,7 +49,7 @@ instance FromJSON a => FromJSON (PathData a) where     parseJSON = withObject "Put" $ \o -> do         pathData <- o .: "data"-        path     <- o .: "path"+        path     <- o .:? "path" .!= "/"         pure $ PathData { path = path, pathData = pathData }  data SSE = SSE@@ -95,48 +95,48 @@     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) => StoreHandle IO -> L.ByteString -> m ()-processPut store value = case eitherDecode value of+processPut :: (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m ()+processPut dataSourceUpdates value = case eitherDecode value of     Right (PathData _ (PutBody flags segments)) -> do-        $(logInfo) "initializing store with put"-        liftIO (initializeStore store flags segments) >>= \case-            Left err -> $(logError) $ T.append "store failed put: " err+        $(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) -processPatch :: forall m. (MonadIO m, MonadLogger m) => StoreHandle IO -> L.ByteString -> m ()-processPatch store value = case eitherDecode value of+processPatch :: forall m. (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m ()+processPatch dataSourceUpdates value = case eitherDecode value of     Right (PathData path body)-        | T.isPrefixOf "/flags/" path    -> insPatch "flag" path insertFlag (fromJSON body)-        | T.isPrefixOf "/segments/" path -> insPatch "segment" path insertSegment (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 -> (StoreHandle IO -> a -> StoreResult ()) -> Result a -> m ()+      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         $(logInfo) $ T.concat ["patching ", name, " with path: ", path]-        status <- liftIO $ insert store item-        either (\err -> $(logError) $ T.concat ["store failed ", name, " patch: ", err]) pure status+        status <- liftIO $ insert dataSourceUpdates item+        either (\err -> $(logError) $ T.concat ["dataSourceUpdates failed ", name, " patch: ", err]) pure status -processDelete :: forall m. (MonadIO m, MonadLogger m) => StoreHandle IO -> L.ByteString -> m ()-processDelete store value = case eitherDecode value :: Either String PathVersion of+processDelete :: forall m. (MonadIO m, MonadLogger m) => DataSourceUpdates -> L.ByteString -> m ()+processDelete dataSourceUpdates value = case eitherDecode value :: Either String PathVersion of     Right (PathVersion path version)-        | T.isPrefixOf "/flags/" path    -> logDelete "flag" path (deleteFlag store (T.drop 7 path) version)-        | T.isPrefixOf "/segments/" path -> logDelete "segment" path (deleteSegment store (T.drop 10 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 ["store failed ", name, " delete: ", err]) pure status+            either (\err -> $(logError) $ T.concat ["dataSourceUpdates failed ", name, " delete: ", err]) pure status -processEvent :: (MonadIO m, MonadLogger m) => StoreHandle IO -> Text -> L.ByteString -> m ()-processEvent store name value = case name of-    "put"    -> processPut store value-    "patch"  -> processPatch store value-    "delete" -> processDelete store value+processEvent :: (MonadIO m, MonadLogger m) => DataSourceUpdates -> Text -> L.ByteString -> m ()+processEvent dataSourceUpdates name value = case name of+    "put"    -> processPut dataSourceUpdates value+    "patch"  -> processPatch dataSourceUpdates value+    "delete" -> processDelete dataSourceUpdates value     _        -> $(logWarn) "unknown event type"  data ReadE = ReadETimeout | ReadEClosed deriving (Show, Exception)@@ -150,14 +150,14 @@     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 -> StoreHandle IO -> m ()-readStream body store = loop "" where+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 store (name event) (L.fromStrict $ encodeUtf8 $ buffer event)+                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]@@ -169,13 +169,13 @@  data Failure = FailurePermanent | FailureTemporary | FailureReset deriving (Eq) -handleStream :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> Request -> StoreHandle IO -> RetryStatus -> m Failure-handleStream manager request store _ = do+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) store+            readStream (responseBody response) dataSourceUpdates     case status of         (Right ()) -> liftIO (getTime Monotonic) >>= \now -> if now >= startTime + (TimeSpec 60 0)             then do@@ -194,10 +194,10 @@                         else FailureTemporary                 _                                                         -> FailureTemporary -streamingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> m ()-streamingThread manager client = do-    let config = getField @"config" client; store = getField @"store" client;-    req <- prepareRequest config <$> liftIO (parseRequest $ T.unpack (getField @"streamURI" config) ++ "/all")-    tryAuthorized client $ fix $ \loop ->-        retrying retryPolicy (\_ status -> pure $ status == FailureTemporary) (handleStream manager req store) >>=+streamingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> ClientContext -> DataSourceUpdates -> m ()+streamingThread streamURI 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 ()
src/LaunchDarkly/Server/User/Internal.hs view
@@ -7,16 +7,17 @@     ) where  import           Data.Aeson                          (FromJSON, ToJSON, Value(..), (.:), (.:?), withObject, object, parseJSON, toJSON)-import           Data.Foldable                       (fold, or)+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 qualified Data.Vector as                      V+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@@ -100,26 +101,28 @@     then userSerializeAllPrivate user     else userSerializeRedactedNotAllPrivate (getField @"privateAttributeNames" config) user -fromObject :: Value -> HashMap Text Value+fromObject :: Value -> KeyMap Value fromObject x = case x of (Object o) -> o; _ -> error "expected object" -keysToSet :: (Ord k) => HashMap k v -> Set k-keysToSet = S.fromList . HM.keys+keysToSet :: KeyMap v -> Set Text+keysToSet = S.fromList . objectKeys -setPrivateAttrs :: Set Text -> HashMap Text Value -> Value-setPrivateAttrs private redacted = Object $ HM.insert "privateAttrs" (Array $ V.fromList $ map String $ S.toList private) redacted+setPrivateAttrs :: Set Text -> KeyMap Value -> Value+setPrivateAttrs private redacted+  | S.null private = Object $ redacted+  | otherwise = Object $ insertKey "privateAttrs" (toJSON private) redacted -redact :: Set Text -> HashMap Text Value -> HashMap Text Value-redact private = HM.filterWithKey (\k _ -> S.notMember k private)+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     = HM.delete "custom" $ HM.delete "privateAttributeNames" $ fromObject $ toJSON user-    private = S.delete "anonymous" $ S.delete "key" $ S.union (keysToSet raw) (keysToSet $ getField @"custom" user)+    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      = HM.delete "privateAttributeNames" $ fromObject $ toJSON user+    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 = HM.adjust (Object . redact private . fromObject) "custom" $ redact private raw+    redacted = adjustKey (Object . redact private . fromObject) "custom" $ redact private raw
+ test-data/filesource/all-properties.json view
@@ -0,0 +1,21 @@+{+  "flags": {+    "flag1": {+      "key": "flag1",+      "on": true,+      "fallthrough": {+        "variation": 2+      },+	  "variations": [ "fall", "off", "on" ]+    }+  },+  "flagValues": {+    "flag2": "value2"+  },+  "segments": {+  	"seg1": {+  	  "key": "seg1",+  	  "included": ["user1"]+  	}+  }+}
+ test-data/filesource/flag-only.json view
@@ -0,0 +1,12 @@+{+  "flags": {+    "flag1": {+      "key": "flag1",+      "on": true,+      "fallthrough": {+        "variation": 2+      },+	  "variations": [ "fall", "off", "on" ]+    }+  }+}
+ test-data/filesource/flag-with-duplicate-key.json view
@@ -0,0 +1,28 @@+{+    "flags": {+        "another": {+            "key": "another",+            "on": true,+            "fallthrough": {+                "variation": 0+            },+            "variations": [+                "fall",+                "off",+                "on"+            ]+        },+        "flag1": {+            "key": "flag1",+            "on": false,+            "fallthrough": {+                "variation": 0+            },+            "variations": [+                "fall",+                "off",+                "on"+            ]+        }+    }+}
+ test-data/filesource/malformed.json view
@@ -0,0 +1,1 @@+{
+ test-data/filesource/no-data.json view
+ test-data/filesource/segment-only.json view
@@ -0,0 +1,8 @@+{+  "segments": {+  	"seg1": {+  	  "key": "seg1",+  	  "included": ["user1"]+  	}+  }+}
+ test-data/filesource/segment-with-duplicate-key.json view
@@ -0,0 +1,12 @@+{+  "segments": {+    "another": {+      "key": "another",+      "included": []+    },+  	"seg1": {+  	  "key": "seg1",+  	  "included": ["user1a"]+  	}+  }+}
+ test-data/filesource/value-only.json view
@@ -0,0 +1,6 @@++{+  "flagValues": {+    "flag2": "value2"+  }+}
+ test-data/filesource/value-with-duplicate-key.json view
@@ -0,0 +1,6 @@+{+  "flagValues": {+    "flag1": "value1",+    "flag2": "value2a"+  }+}
test/Spec.hs view
@@ -1,27 +1,37 @@ module Main where  import           Control.Monad (void)-import           Test.HUnit    (runTestTT, Test(TestList))+import           Test.HUnit    (runTestTT, Test(TestList, TestLabel)) -import qualified Spec.Operators-import qualified Spec.Segment import qualified Spec.Bucket-import qualified Spec.Streaming-import qualified Spec.User import qualified Spec.Evaluate+import qualified Spec.Features+import qualified Spec.Operators+import qualified Spec.Redis+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  main :: IO () main = void $ runTestTT $ TestList-    [ Spec.Operators.allTests-    , Spec.Bucket.allTests-    , Spec.Segment.allTests-    , Spec.Streaming.allTests-    , Spec.User.allTests+    [ Spec.Bucket.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     ]
+ test/Spec/DataSource.hs view
@@ -0,0 +1,11 @@+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)++allTests :: Test +allTests =+    TestList []
test/Spec/Evaluate.hs view
@@ -63,6 +63,7 @@         , offVariation           = Just 1         , variations             = [String "fall", String "off", String "on"]         , debugEventsUntilDate   = Nothing+        , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False,  explicit = True }         }  testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules :: Test@@ -101,6 +102,7 @@         , offVariation           = Just 1         , variations             = [String "fall", String "off", String "on"]         , debugEventsUntilDate   = Nothing+        , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False, explicit = True }         }  testFlagReturnsErrorIfFallthroughHasTooHighVariation :: Test@@ -372,6 +374,7 @@         , offVariation           = Just 0         , variations             = [Bool False, Bool True]         , debugEventsUntilDate   = Nothing+        , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False, explicit = True }         }  makeTestClient :: IO Client
+ test/Spec/Features.hs view
@@ -0,0 +1,81 @@+module Spec.Features (allTests) where++import Data.ByteString.Lazy+import Data.Aeson+import Data.Text as T+import LaunchDarkly.Server.Features+import Test.HUnit++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"++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\+    \}"+    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"++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\": {\+            \\"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"++allTests :: Test+allTests = TestList+    [ testCanDecodeNewSchema+    , testCanDecodeOldSchema+    ]
+ test/Spec/Integrations/FileData.hs view
@@ -0,0 +1,118 @@+module Spec.Integrations.FileData+    (allTests)+    where++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 qualified Data.HashSet as HS+import           Control.Exception+import           Control.Monad.Logger++allTests :: Test+allTests = TestList+    [ TestLabel "testAllProperties" testAllProperties+    , 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++testConfig :: DataSourceFactory -> Config+testConfig factory =+    configSetSendEvents False $+    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"+    withClient config $ \client -> do+        status <- getStatus client+        assertEqual "status initialized" Initialized status++        flag1 <- stringVariation client "flag1" user1 "fallback"+        assertEqual "flag1 value" "on" flag1++        flag2 <- stringVariation client "flag2" user1 "fallback"+        assertEqual "flag2 value" "value2" flag2++testMultiFileFlagDuplicate :: Test+testMultiFileFlagDuplicate = TestCase $ do+    let factory = dataSourceFactory [ "test-data/filesource/flag-only.json"+                                    , "test-data/filesource/flag-with-duplicate-key.json"+                                    ]+        config = testConfig factory+        user1 = makeUser "user1"+    withClient config $ \client -> do+        status <- getStatus client+        assertEqual "status initialized" Initialized status++        flag1 <- stringVariation client "flag1" user1 "fallback"+        assertEqual "flag1 value" "on" flag1++        anotherFlag <- stringVariation client "another" user1 "fallback"+        assertEqual "flag2 value" "fall" anotherFlag++testMalformedFile :: Test+testMalformedFile = TestCase $ do+    let factory = dataSourceFactory [ "test-data/filesource/malformed.json" ]+        config = testConfig factory+        user1 = makeUser "user1"+    withClient config $ \client -> do+        assertEqual "No Flags set" mempty =<< allFlags client user1++testNoDataFile :: Test+testNoDataFile = TestCase $ do+    let factory = dataSourceFactory [ "test-data/filesource/no-data.json" ]+        config = testConfig factory+        user1 = makeUser "user1"+    withClient config $ \client -> do+        assertEqual "No Flags set" mempty =<< allFlags client user1++testSegmentFile :: Test+testSegmentFile = TestCase $ do+    let factory = dataSourceFactory [ "test-data/filesource/segment-only.json" ]+        config = testConfig factory+    withClient config $ \(Client client) -> do+        eSeg1 <- storeHandleGetSegment (store client) "seg1"+        mSeg1 <- either (assertFailure . show) pure eSeg1+        seg1 <- maybe (assertFailure "Segment Not Found") pure mSeg1+        assertEqual "Segment" (included seg1) (HS.fromList ["user1"])++        eSeg2 <- storeHandleGetSegment (store client) "seg2"+        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"+    withClient config $ \client -> do+        status <- getStatus client+        assertEqual "status initialized" Initialized status++        flag1 <- stringVariation client "flag1" user1 "fallback"+        assertEqual "flag1 value" "on" flag1++        flag2 <- stringVariation client "flag2" user1 "fallback"+        assertEqual "flag2 value" "value2" flag2+
+ test/Spec/Integrations/TestData.hs view
@@ -0,0 +1,207 @@+module Spec.Integrations.TestData+    (allTests)+    where++import           Test.HUnit++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++allTests :: Test+allTests = TestList+    [ testVariationForAllUsers+    , testMultipleFlags+    , testModifyFlags+    , testMultipleClients+    , testTargeting+    , testRules+    , testValueForAllUsers+    ]++testConfig :: DataSourceFactory -> Config+testConfig factory =+    configSetSendEvents False $+    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++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"++  TestData.update td =<<+      (TestData.flag td "flag-key-1"+          <&> TestData.variationForAllUsers (2 :: TestData.VariationIndex))++  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++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))++  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++  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)++  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"++  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"++  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"++  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++  assertEqual "ben recieves CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" ben "CustomType2"+  assertEqual "todd recieves CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" todd "CustomType2"++  close client+
test/Spec/User.hs view
@@ -1,5 +1,6 @@ module Spec.User (allTests) where +import           GHC.Exts (fromList) import           Test.HUnit import           Data.Aeson import           Data.Aeson.Types                  (Value(..))@@ -13,7 +14,7 @@ serializeEmpty :: Test serializeEmpty = expected ~=? actual where     actual = decode $ encode $ unwrapUser $ makeUser "abc"-    expected = pure $ Object $ HM.fromList [("key", String "abc")]+    expected = pure $ Object $ fromList [("key", String "abc")]  allTests :: Test allTests = TestList
test/Util/Features.hs view
@@ -24,6 +24,7 @@     , offVariation           = Nothing     , variations             = []     , debugEventsUntilDate   = Nothing+    , clientSideAvailability  = ClientSideAvailability { usingEnvironmentId = True, usingMobileKey = False, explicit = True }     }  makeTestSegment :: Text -> Natural -> Segment