launchdarkly-server-sdk (empty) → 1.0.0
raw patch · 36 files changed
+3964/−0 lines, 36 filesdep +HUnitdep +aesondep +attoparsecsetup-changed
Dependencies added: HUnit, aeson, attoparsec, base, base16-bytestring, bytestring, bytestring-conversion, clock, containers, cryptohash, exceptions, extra, generic-lens, hashtables, hedis, http-client, http-client-tls, http-types, iso8601-time, lens, lrucache, monad-logger, mtl, pcre-light, random, retry, scientific, semver, text, time, unordered-containers, uuid, vector
Files
- CHANGELOG.md +31/−0
- LICENSE +13/−0
- README.md +42/−0
- Setup.hs +2/−0
- launchdarkly-server-sdk.cabal +167/−0
- src/LaunchDarkly/Server.hs +66/−0
- src/LaunchDarkly/Server/Client.hs +212/−0
- src/LaunchDarkly/Server/Client/Internal.hs +56/−0
- src/LaunchDarkly/Server/Config.hs +155/−0
- src/LaunchDarkly/Server/Config/Internal.hs +46/−0
- src/LaunchDarkly/Server/Details.hs +102/−0
- src/LaunchDarkly/Server/Evaluate.hs +224/−0
- src/LaunchDarkly/Server/Events.hs +313/−0
- src/LaunchDarkly/Server/Features.hs +110/−0
- src/LaunchDarkly/Server/Network/Common.hs +51/−0
- src/LaunchDarkly/Server/Network/Eventing.hs +70/−0
- src/LaunchDarkly/Server/Network/Polling.hs +50/−0
- src/LaunchDarkly/Server/Network/Streaming.hs +163/−0
- src/LaunchDarkly/Server/Operators.hs +134/−0
- src/LaunchDarkly/Server/Store.hs +11/−0
- src/LaunchDarkly/Server/Store/Internal.hs +350/−0
- src/LaunchDarkly/Server/User.hs +94/−0
- src/LaunchDarkly/Server/User/Internal.hs +125/−0
- stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis.hs +8/−0
- stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs +135/−0
- test/Spec.hs +27/−0
- test/Spec/Bucket.hs +70/−0
- test/Spec/Evaluate.hs +432/−0
- test/Spec/Operators.hs +100/−0
- test/Spec/Redis.hs +49/−0
- test/Spec/Segment.hs +209/−0
- test/Spec/Store.hs +86/−0
- test/Spec/StoreInterface.hs +191/−0
- test/Spec/Streaming.hs +10/−0
- test/Spec/User.hs +21/−0
- test/Util/Features.hs +39/−0
+ CHANGELOG.md view
@@ -0,0 +1,31 @@+# Change log++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).++## [1.0.0] - 2020-02-24+### Fixed:+- Several haddock typos.+- Added `configSetStoreTTL`, and `configSetUseLdd` to `LaunchDarkly.Server` export list.+- Added `package.yaml` version constraints.++## [0.2.1] - 2020-02-21+### Fixed:+- Added an event delivery retry mechanism. The SDK will now try to deliver events again after one second before dropping them.+- Added a payload identity header for event delivery to prevent duplication in certain edge cases.+- Made many fields strict for more deterministic memory usage.++## [0.2.0] - 2020-02-10+### 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`.+### Fixed:+- Incorrect ToJSON instances for flag rules and operators.+- Updated bucketing logic to fallback to last variation instead of producing an error.+- Refactored streaming implementation.+- Stopped sending empty event payloads.+++## [0.1.1] - 2019-12-10+### Fixed+- Corrected internal HTTP client user agent format.
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2019 Catamorphic, Co.++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ README.md view
@@ -0,0 +1,42 @@+# LaunchDarkly Server-side SDK for Haskell++[](https://circleci.com/gh/launchdarkly/haskell-server-sdk)++The LaunchDarkly Server-side SDK for Haskell is designed primarily for use in multi-user systems such as web servers and applications. It follows the server-side LaunchDarkly model for multi-user contexts. It is not intended for use in desktop and embedded systems applications.++## 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!++[](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.++## 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).++## Testing++We run integration tests for all our SDKs using a centralized test harness. This approach gives us the ability to test for consistency across SDKs, as well as test networking behavior in a long-running application. These tests cover each method in the SDK, and verify that event sending, flag evaluation, stream reconnection, and other aspects of the SDK all behave correctly.++## Contributing++We encourage pull requests and other contributions from the community. Check out our [contributing guidelines](CONTRIBUTING.md) for instructions on how to contribute to this SDK.++## About LaunchDarkly++* LaunchDarkly is a continuous delivery platform that provides feature flags as a service and allows developers to iterate quickly and safely. We allow you to easily flag your features and manage them from the LaunchDarkly dashboard. With LaunchDarkly, you can:+ * Roll out a new feature to a subset of your users (like a group of users who opt-in to a beta tester group), gathering feedback and bug reports from real-world use cases.+ * 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.+* 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+ * [apidocs.launchdarkly.com](https://apidocs.launchdarkly.com/ "LaunchDarkly API Documentation") for our API documentation+ * [blog.launchdarkly.com](https://blog.launchdarkly.com/ "LaunchDarkly Blog Documentation") for the latest product updates+ * [Feature Flagging Guide](https://github.com/launchdarkly/featureflags/ "Feature Flagging Guide") for best practices and strategies
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ launchdarkly-server-sdk.cabal view
@@ -0,0 +1,167 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 097672c91258a84d615c98671799907c9358e36465ce385e0c77307bb2505a9a++name: launchdarkly-server-sdk+version: 1.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+homepage: https://github.com/launchdarkly/haskell-server-sdk#readme+bug-reports: https://github.com/launchdarkly/haskell-server-sdk/issues+author: LaunchDarkly+maintainer: dev@launchdarkly.com+copyright: 2019 Catamorphic, Co+license: Apache-2.0+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md+ LICENSE++source-repository head+ type: git+ location: https://github.com/launchdarkly/haskell-server-sdk++library+ exposed-modules:+ LaunchDarkly.Server+ LaunchDarkly.Server.Client+ LaunchDarkly.Server.Config+ LaunchDarkly.Server.User+ LaunchDarkly.Server.Store+ other-modules:+ LaunchDarkly.Server.Client.Internal+ LaunchDarkly.Server.Config.Internal+ LaunchDarkly.Server.Details+ LaunchDarkly.Server.Evaluate+ LaunchDarkly.Server.Events+ LaunchDarkly.Server.Features+ LaunchDarkly.Server.Network.Common+ LaunchDarkly.Server.Network.Eventing+ LaunchDarkly.Server.Network.Polling+ LaunchDarkly.Server.Network.Streaming+ LaunchDarkly.Server.Operators+ LaunchDarkly.Server.Store.Internal+ LaunchDarkly.Server.User.Internal+ Paths_launchdarkly_server_sdk+ hs-source-dirs:+ src+ default-extensions: AllowAmbiguousTypes DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MonoLocalBinds MultiParamTypeClasses MultiWayIf NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections TypeApplications TypeOperators+ ghc-options: -fwarn-unused-imports -Wall -Wno-name-shadowing+ build-depends:+ aeson >=1.4.4.0 && <1.5+ , attoparsec >=0.13.2.2 && <0.14+ , base >=4.7 && <5+ , base16-bytestring >=0.1.1.6 && <0.2+ , bytestring >=0.10.8.2 && <0.11+ , bytestring-conversion >=0.3.1 && <0.4+ , clock ==0.8.*+ , containers >=0.6.0.1 && <0.7+ , cryptohash >=0.11.9 && <0.12+ , exceptions >=0.10.2 && <0.11+ , extra >=1.6.17 && <1.7+ , generic-lens >=1.1.0.0 && <1.2+ , hashtables >=1.2.3.4 && <1.3+ , hedis >=0.12.7 && <0.13+ , http-client >=0.6.4 && <0.7+ , http-client-tls >=0.3.5.3 && <0.4+ , http-types >=0.12.3 && <0.13+ , iso8601-time >=0.1.5 && <0.2+ , lens >=4.17.1 && <4.18+ , lrucache >=1.2.0.1 && <1.3+ , monad-logger >=0.3.30 && <0.4+ , mtl >=2.2.2 && <2.3+ , pcre-light >=0.4.0.4 && <0.5+ , random ==1.1.*+ , retry >=0.8.0.1 && <0.9+ , scientific >=0.3.6.2 && <0.4+ , semver >=0.3.4 && <0.4+ , text >=1.2.3.1 && <1.3+ , time >=1.8.0.2 && <1.9+ , unordered-containers >=0.2.10.0 && <0.3+ , uuid >=1.3.13 && <1.4+ , vector >=0.12.0.3 && <0.13+ default-language: Haskell2010++test-suite haskell-server-sdk-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Spec.Bucket+ Spec.Evaluate+ Spec.Operators+ Spec.Redis+ Spec.Segment+ Spec.Store+ Spec.StoreInterface+ Spec.Streaming+ Spec.User+ Util.Features+ LaunchDarkly.Server+ LaunchDarkly.Server.Client+ LaunchDarkly.Server.Client.Internal+ LaunchDarkly.Server.Config+ LaunchDarkly.Server.Config.Internal+ LaunchDarkly.Server.Details+ LaunchDarkly.Server.Evaluate+ LaunchDarkly.Server.Events+ LaunchDarkly.Server.Features+ LaunchDarkly.Server.Network.Common+ LaunchDarkly.Server.Network.Eventing+ LaunchDarkly.Server.Network.Polling+ LaunchDarkly.Server.Network.Streaming+ LaunchDarkly.Server.Operators+ LaunchDarkly.Server.Store+ LaunchDarkly.Server.Store.Internal+ LaunchDarkly.Server.User+ LaunchDarkly.Server.User.Internal+ LaunchDarkly.Server.Store.Redis+ LaunchDarkly.Server.Store.Redis.Internal+ Paths_launchdarkly_server_sdk+ hs-source-dirs:+ test+ src+ stores/launchdarkly-server-sdk-redis/src+ default-extensions: AllowAmbiguousTypes DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MonoLocalBinds MultiParamTypeClasses MultiWayIf NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections TypeApplications TypeOperators+ ghc-options: -rtsopts -threaded -with-rtsopts=-N -Wno-name-shadowing+ build-depends:+ HUnit+ , aeson >=1.4.4.0 && <1.5+ , attoparsec >=0.13.2.2 && <0.14+ , base >=4.7 && <5+ , base16-bytestring >=0.1.1.6 && <0.2+ , bytestring >=0.10.8.2 && <0.11+ , bytestring-conversion >=0.3.1 && <0.4+ , clock ==0.8.*+ , containers >=0.6.0.1 && <0.7+ , cryptohash >=0.11.9 && <0.12+ , exceptions >=0.10.2 && <0.11+ , extra >=1.6.17 && <1.7+ , generic-lens >=1.1.0.0 && <1.2+ , hashtables >=1.2.3.4 && <1.3+ , hedis >=0.12.7 && <0.13+ , http-client >=0.6.4 && <0.7+ , http-client-tls >=0.3.5.3 && <0.4+ , http-types >=0.12.3 && <0.13+ , iso8601-time >=0.1.5 && <0.2+ , lens >=4.17.1 && <4.18+ , lrucache >=1.2.0.1 && <1.3+ , monad-logger >=0.3.30 && <0.4+ , mtl >=2.2.2 && <2.3+ , pcre-light >=0.4.0.4 && <0.5+ , random ==1.1.*+ , retry >=0.8.0.1 && <0.9+ , scientific >=0.3.6.2 && <0.4+ , semver >=0.3.4 && <0.4+ , text >=1.2.3.1 && <1.3+ , time >=1.8.0.2 && <1.9+ , unordered-containers >=0.2.10.0 && <0.3+ , uuid >=1.3.13 && <1.4+ , vector >=0.12.0.3 && <0.13+ default-language: Haskell2010
+ src/LaunchDarkly/Server.hs view
@@ -0,0 +1,66 @@+-- | This module re-exports the User, Client, and Config modules.++module LaunchDarkly.Server+ ( Config+ , makeConfig+ , configSetKey+ , configSetBaseURI+ , configSetStreamURI+ , configSetEventsURI+ , configSetStreaming+ , configSetAllAttributesPrivate+ , configSetPrivateAttributeNames+ , configSetFlushIntervalSeconds+ , configSetPollIntervalSeconds+ , configSetUserKeyLRUCapacity+ , configSetInlineUsersInEvents+ , configSetEventsCapacity+ , configSetLogger+ , configSetSendEvents+ , configSetOffline+ , configSetRequestTimeoutSeconds+ , configSetStoreBackend+ , configSetStoreTTL+ , configSetUseLdd+ , User+ , makeUser+ , userSetKey+ , userSetSecondary+ , userSetIP+ , userSetCountry+ , userSetEmail+ , userSetFirstName+ , userSetLastName+ , userSetAvatar+ , userSetName+ , userSetAnonymous+ , userSetCustom+ , userSetPrivateAttributeNames+ , Client+ , makeClient+ , clientVersion+ , boolVariation+ , boolVariationDetail+ , stringVariation+ , stringVariationDetail+ , intVariation+ , intVariationDetail+ , doubleVariation+ , doubleVariationDetail+ , jsonVariation+ , jsonVariationDetail+ , EvaluationDetail(..)+ , EvaluationReason(..)+ , EvalErrorKind(..)+ , allFlags+ , close+ , flushEvents+ , identify+ , track+ , Status(..)+ , getStatus+ ) where++import LaunchDarkly.Server.User+import LaunchDarkly.Server.Config+import LaunchDarkly.Server.Client
+ src/LaunchDarkly/Server/Client.hs view
@@ -0,0 +1,212 @@+-- | This module contains the core functionality of the SDK.++module LaunchDarkly.Server.Client+ ( Client+ , makeClient+ , clientVersion+ , boolVariation+ , boolVariationDetail+ , stringVariation+ , stringVariationDetail+ , intVariation+ , intVariationDetail+ , doubleVariation+ , doubleVariationDetail+ , jsonVariation+ , jsonVariationDetail+ , EvaluationDetail(..)+ , EvaluationReason(..)+ , EvalErrorKind(..)+ , allFlags+ , close+ , flushEvents+ , identify+ , track+ , Status(..)+ , getStatus+ ) where++import Control.Concurrent (forkFinally, killThread)+import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)+import Control.Monad (void, forM_)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger (LoggingT, logDebug)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.Text (Text)+import Data.Aeson (Value(..))+import Data.Generics.Product (getField, setField)+import Data.Scientific (toRealFloat, fromFloatDigits)+import Data.Maybe (isNothing)+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(..), EventType(..), makeBaseEvent, queueEvent, makeEventState, addUserToEvent)+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)++-- | 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++ status <- newIORef Uninitialized+ store <- makeStoreIO (getField @"storeBackend" config) (TimeSpec (fromIntegral $ getField @"storeTTLSeconds" config) 0)+ manager <- newManager tlsManagerSettings+ events <- makeEventState config++ let client = ClientI {..}+ downloadThreadF = if getField @"streaming" config then streamingThread else pollingThread++ eventThreadPair' <- if not (shouldSendEvents config) then pure Nothing else do+ sync <- newEmptyMVar+ thread <- forkFinally (runLogger $ 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)++ pure $ Client+ $ setField @"downloadThreadPair" downloadThreadPair'+ $ setField @"eventThreadPair" eventThreadPair' client++clientRunLogger :: ClientI -> (LoggingT IO () -> IO ())+clientRunLogger client = getField @"logger" $ getField @"config" client++-- | Return the initialization status of the Client+getStatus :: Client -> IO Status+getStatus (Client client) = readIORef $ getField @"status" client++-- | Returns a map from feature flag keys to values for a given user. If the+-- result of the flag's evaluation would result in the default value, `Null`+-- will be returned. This method does not send analytics events back to+-- LaunchDarkly.+allFlags :: Client -> User -> IO (HashMap Text Value)+allFlags (Client client) (User user) = if isNothing $ getField @"key" user then pure mempty else do+ status <- getAllFlagsC $ getField @"store" client+ case status of+ Left _ -> pure HM.empty+ Right flags -> do+ 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 :: 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)++-- | Track reports that a user has performed an event. Custom data can be+-- attached to the event, and / or a numeric value.+--+-- The numeric value is used by the LaunchDarkly experimentation feature in+-- numeric custom metrics, and will also be returned as part of the custom event+-- for Data Export.+track :: Client -> User -> Text -> Maybe Value -> Maybe Double -> IO ()+track (Client client) (User user) key value metric = do+ x <- makeBaseEvent $ addUserToEvent (getField @"config" client) user CustomEvent+ { key = key, user = Nothing, userKey = Nothing, metricValue = metric, value = value }+ queueEvent (getField @"config" client) (getField @"events" client) (EventTypeCustom x)++-- | Flush tells the client that all pending analytics events (if any) should be+-- delivered as soon as possible. Flushing is asynchronous, so this method will+-- return before it is complete.+flushEvents :: Client -> IO ()+flushEvents (Client client) = putMVar (getField @"flush" $ getField @"events" client) ()++-- | Close shuts down the LaunchDarkly client. After calling this, the+-- LaunchDarkly client should no longer be used. The method will block until all+-- pending analytics events have been sent.+close :: Client -> IO ()+close outer@(Client client) = clientRunLogger client $ do+ $(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+ forM_ (getField @"eventThreadPair" client) $ \(_, sync) -> do+ $(logDebug) "Triggering event flush"+ liftIO $ flushEvents outer+ $(logDebug) "Waiting on event thread to die"+ liftIO $ void $ takeMVar sync+ $(logDebug) "Client background resources destroyed"++type ValueConverter a = (a -> Value, Value -> Maybe a)++reorderStuff :: ValueConverter a -> Bool -> Client -> Text -> User -> a -> IO (EvaluationDetail a)+reorderStuff converter includeReason (Client client) key (User user) fallback = evaluateTyped client key user fallback (fst converter) includeReason (snd converter)++dropReason :: (Text -> User -> a -> IO (EvaluationDetail a)) -> Text -> User -> a -> IO a+dropReason = (((fmap (getField @"value") .) .) .)++boolConverter :: ValueConverter Bool+boolConverter = (,) Bool $ \case Bool x -> pure x; _ -> Nothing++stringConverter :: ValueConverter Text+stringConverter = (,) String $ \case String x -> pure x; _ -> Nothing++intConverter :: ValueConverter Int+intConverter = (,) (Number . fromIntegral) $ \case Number x -> pure $ truncate x; _ -> Nothing++doubleConverter :: ValueConverter Double+doubleConverter = (,) (Number . fromFloatDigits) $ \case Number x -> pure $ toRealFloat x; _ -> Nothing++jsonConverter :: ValueConverter Value+jsonConverter = (,) id pure++-- | Evaluate a Boolean typed flag.+boolVariation :: Client -> Text -> User -> Bool -> IO Bool+boolVariation = dropReason . reorderStuff boolConverter False++-- | Evaluate a Boolean typed flag, and return an explation.+boolVariationDetail :: Client -> Text -> User -> Bool -> IO (EvaluationDetail Bool)+boolVariationDetail = reorderStuff boolConverter True++-- | Evaluate a String typed flag.+stringVariation :: Client -> Text -> User -> Text -> IO Text+stringVariation = dropReason . reorderStuff stringConverter False++-- | Evaluate a String typed flag, and return an explanation.+stringVariationDetail :: Client -> Text -> User -> Text -> IO (EvaluationDetail Text)+stringVariationDetail = reorderStuff stringConverter True++-- | Evaluate a Number typed flag, and truncate the result.+intVariation :: Client -> Text -> User -> Int -> IO Int+intVariation = dropReason . reorderStuff intConverter False++-- | Evaluate a Number typed flag, truncate the result, and return an+-- explanation.+intVariationDetail :: Client -> Text -> User -> Int -> IO (EvaluationDetail Int)+intVariationDetail = reorderStuff intConverter True++-- | Evaluate a Number typed flag.+doubleVariation :: Client -> Text -> User -> Double -> IO Double+doubleVariation = dropReason . reorderStuff doubleConverter False++-- | Evaluate a Number typed flag, and return an explanation.+doubleVariationDetail :: Client -> Text -> User -> Double -> IO (EvaluationDetail Double)+doubleVariationDetail = reorderStuff doubleConverter True++-- | Evaluate a JSON typed flag.+jsonVariation :: Client -> Text -> User -> Value -> IO Value+jsonVariation = dropReason . reorderStuff jsonConverter False++-- | Evaluate a JSON typed flag, and return an explanation.+jsonVariationDetail :: Client -> Text -> User -> Value -> IO (EvaluationDetail Value)+jsonVariationDetail = reorderStuff jsonConverter True
+ src/LaunchDarkly/Server/Client/Internal.hs view
@@ -0,0 +1,56 @@+module LaunchDarkly.Server.Client.Internal+ ( Client(..)+ , ClientI(..)+ , Status(..)+ , clientVersion+ , setStatus+ ) where++import Data.Text (Text)+import Data.IORef (IORef, atomicModifyIORef')+import GHC.Generics (Generic)+import Control.Concurrent (ThreadId)+import Control.Concurrent.MVar (MVar)+import Data.Generics.Product (getField)++import LaunchDarkly.Server.Config.Internal (ConfigI)+import LaunchDarkly.Server.Store.Internal (StoreHandle)+import LaunchDarkly.Server.Events (EventState)++-- | Client is the LaunchDarkly client. Client instances are thread-safe.+-- Applications should instantiate a single instance for the lifetime of their+-- application.+newtype Client = Client ClientI++-- | The version string for this library.+clientVersion :: Text+clientVersion = "1.0.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)++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', ())++data ClientI = ClientI+ { config :: !(ConfigI)+ , store :: !(StoreHandle IO)+ , status :: !(IORef Status)+ , events :: !EventState+ , downloadThreadPair :: !(Maybe (ThreadId, MVar ()))+ , eventThreadPair :: !(Maybe (ThreadId, MVar ()))+ } deriving (Generic)
+ src/LaunchDarkly/Server/Config.hs view
@@ -0,0 +1,155 @@+-- | This module is for configuration of the SDK.++module LaunchDarkly.Server.Config+ ( Config+ , makeConfig+ , configSetKey+ , configSetBaseURI+ , configSetStreamURI+ , configSetEventsURI+ , configSetStreaming+ , configSetAllAttributesPrivate+ , configSetPrivateAttributeNames+ , configSetFlushIntervalSeconds+ , configSetPollIntervalSeconds+ , configSetUserKeyLRUCapacity+ , configSetInlineUsersInEvents+ , configSetEventsCapacity+ , configSetLogger+ , configSetSendEvents+ , configSetOffline+ , configSetRequestTimeoutSeconds+ , configSetStoreBackend+ , configSetStoreTTL+ , configSetUseLdd+ ) where++import Control.Monad.Logger (LoggingT, runStdoutLoggingT)+import Data.Generics.Product (setField)+import Data.Set (Set)+import Data.Text (Text)+import Data.Monoid (mempty)+import GHC.Natural (Natural)++import LaunchDarkly.Server.Config.Internal (Config(..), mapConfig, ConfigI(..))+import LaunchDarkly.Server.Store (StoreInterface)++-- | Create a default configuration from a given SDK key.+makeConfig :: Text -> Config+makeConfig key = Config $ ConfigI+ { key = key+ , baseURI = "https://app.launchdarkly.com"+ , streamURI = "https://stream.launchdarkly.com"+ , eventsURI = "https://events.launchdarkly.com"+ , storeBackend = Nothing+ , storeTTLSeconds = 10+ , streaming = True+ , allAttributesPrivate = False+ , privateAttributeNames = mempty+ , flushIntervalSeconds = 5+ , pollIntervalSeconds = 30+ , userKeyLRUCapacity = 1000+ , inlineUsersInEvents = False+ , eventsCapacity = 10000+ , logger = runStdoutLoggingT+ , sendEvents = True+ , offline = False+ , requestTimeoutSeconds = 30+ , useLdd = False+ }++-- | Set the SDK key used to authenticate with LaunchDarkly.+configSetKey :: Text -> Config -> Config+configSetKey = mapConfig . setField @"key"++-- | 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"++-- | 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"++-- | 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"++-- | Configures a handle to an external store such as Redis.+configSetStoreBackend :: Maybe StoreInterface -> Config -> Config+configSetStoreBackend = mapConfig . setField @"storeBackend"++-- | When a store backend is configured, control how long values should be+-- cached in memory before going back to the backend.+configSetStoreTTL :: Natural -> Config -> Config+configSetStoreTTL = mapConfig . setField @"storeTTLSeconds"++-- | Sets whether streaming mode should be enabled. By default, streaming is+-- enabled. It should only be disabled on the advice of LaunchDarkly support.+configSetStreaming :: Bool -> Config -> Config+configSetStreaming = mapConfig . setField @"streaming"++-- | Sets whether or not all user attributes (other than the key) should be+-- hidden from LaunchDarkly. If this is true, all user attribute values will be+-- private, not just the attributes specified in PrivateAttributeNames.+configSetAllAttributesPrivate :: Bool -> Config -> Config+configSetAllAttributesPrivate = mapConfig . setField @"allAttributesPrivate"++-- | Marks a set of user attribute names private. Any users sent to LaunchDarkly+-- with this configuration active will have attributes with these names removed.+configSetPrivateAttributeNames :: Set Text -> Config -> Config+configSetPrivateAttributeNames = mapConfig . setField @"privateAttributeNames"++-- | The time between flushes of the event buffer. Decreasing the flush interval+-- means that the event buffer is less likely to reach capacity.+configSetFlushIntervalSeconds :: Natural -> Config -> Config+configSetFlushIntervalSeconds = mapConfig . setField @"flushIntervalSeconds"++-- | The polling interval (when streaming is disabled).+configSetPollIntervalSeconds :: Natural -> Config -> Config+configSetPollIntervalSeconds = mapConfig . setField @"pollIntervalSeconds"++-- | The number of user keys that the event processor can remember at any one+-- time, so that duplicate user details will not be sent in analytics events.+configSetUserKeyLRUCapacity :: Natural -> Config -> Config+configSetUserKeyLRUCapacity = mapConfig . setField @"userKeyLRUCapacity"++-- | Set to true if you need to see the full user details in every analytics+-- event.+configSetInlineUsersInEvents :: Bool -> Config -> Config+configSetInlineUsersInEvents = mapConfig . setField @"inlineUsersInEvents"++-- | The capacity of the events buffer. The client buffers up to this many+-- events in memory before flushing. If the capacity is exceeded before the+-- buffer is flushed, events will be discarded.+configSetEventsCapacity :: Natural -> Config -> Config+configSetEventsCapacity = mapConfig . setField @"eventsCapacity"++-- | Set the logger to be used by the client.+configSetLogger :: (LoggingT IO () -> IO ()) -> Config -> Config+configSetLogger = mapConfig . setField @"logger"++-- | Sets whether to send analytics events back to LaunchDarkly. By default, the+-- client will send events. This differs from Offline in that it only affects+-- sending events, not streaming or polling for events from the server.+configSetSendEvents :: Bool -> Config -> Config+configSetSendEvents = mapConfig . setField @"sendEvents"++-- | Sets whether this client is offline. An offline client will not make any+-- network connections to LaunchDarkly, and will return default values for all+-- feature flags.+configSetOffline :: Bool -> Config -> Config+configSetOffline = mapConfig . setField @"offline"++-- | Sets how long an the HTTP client should wait before a response is returned.+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+configSetUseLdd :: Bool -> Config -> Config+configSetUseLdd = mapConfig . setField @"useLdd"
+ src/LaunchDarkly/Server/Config/Internal.hs view
@@ -0,0 +1,46 @@+module LaunchDarkly.Server.Config.Internal+ ( Config(..)+ , mapConfig+ , ConfigI(..)+ , shouldSendEvents+ ) where++import Control.Monad.Logger (LoggingT)+import Data.Generics.Product (getField)+import Data.Text (Text)+import Data.Set (Set)+import GHC.Natural (Natural)+import GHC.Generics (Generic)++import LaunchDarkly.Server.Store (StoreInterface)++mapConfig :: (ConfigI -> ConfigI) -> Config -> Config+mapConfig f (Config c) = Config $ f c++shouldSendEvents :: ConfigI -> Bool+shouldSendEvents config = (not $ getField @"offline" config) && (getField @"sendEvents" config)++-- | Config allows advanced configuration of the LaunchDarkly client.+newtype Config = Config ConfigI++data ConfigI = ConfigI+ { key :: !Text+ , baseURI :: !Text+ , streamURI :: !Text+ , eventsURI :: !Text+ , storeBackend :: !(Maybe StoreInterface)+ , storeTTLSeconds :: !Natural+ , streaming :: !Bool+ , allAttributesPrivate :: !Bool+ , privateAttributeNames :: !(Set Text)+ , flushIntervalSeconds :: !Natural+ , pollIntervalSeconds :: !Natural+ , userKeyLRUCapacity :: !Natural+ , inlineUsersInEvents :: !Bool+ , eventsCapacity :: !Natural+ , logger :: !(LoggingT IO () -> IO ())+ , sendEvents :: !Bool+ , offline :: !Bool+ , requestTimeoutSeconds :: !Natural+ , useLdd :: !Bool+ } deriving (Generic)
+ src/LaunchDarkly/Server/Details.hs view
@@ -0,0 +1,102 @@+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.Natural (Natural)+import GHC.Generics (Generic)++-- | Combines the result of a flag evaluation with an explanation of how it was+-- calculated.+data EvaluationDetail value = EvaluationDetail+ { value :: !value+ -- ^ The result of the flag evaluation. This will be either one of the+ -- flag's variations or the default value passed by the application.+ , variationIndex :: !(Maybe Natural)+ -- ^ The index of the returned value within the flag's list of variations,+ -- e.g. 0 for the first variation - or Nothing if the default value was+ -- returned.+ , reason :: !EvaluationReason+ -- ^ Describes the main factor that influenced the flag evaluation value.+ } deriving (Generic, Eq, Show)++instance ToJSON a => ToJSON (EvaluationDetail a) where+ toJSON = toJSON++-- | Defines the possible values of the Kind property of EvaluationReason.+data EvaluationReason+ = EvaluationReasonOff+ -- ^ Indicates that the flag was off and therefore returned its configured+ -- off value.+ | EvaluationReasonTargetMatch+ -- ^ indicates that the user key was specifically targeted for this flag.+ | EvaluationReasonRuleMatch+ { ruleIndex :: !Natural+ -- ^ The index of the rule that was matched (0 being the first).+ , ruleId :: !Text+ -- ^ The unique identifier of the rule that was matched.+ }+ -- ^ Indicates that the user matched one of the flag's rules.+ | EvaluationReasonPrerequisiteFailed+ { prerequisiteKey :: !Text+ -- ^ The flag key of the prerequisite that failed.+ }+ -- ^ Indicates that the flag was considered off because it had at least+ -- one prerequisite flag that either was off or did not return the desired+ -- variation.+ | EvaluationReasonFallthrough+ -- ^ Indicates that the flag was on but the user did not match any targets+ -- or rules.+ | EvaluationReasonError+ { errorKind :: !EvalErrorKind+ -- ^ Describes the type of error.+ }+ -- ^ Indicates that the flag could not be evaluated, e.g. because it does+ -- not exist or due to an unexpected error. In this case the result value+ -- will be the default value that the caller passed to the client.+ deriving (Generic, Eq, Show)++instance ToJSON EvaluationReason where+ toJSON x = case x of+ EvaluationReasonOff ->+ Object $ HM.fromList [("kind", "OFF")]+ EvaluationReasonTargetMatch ->+ Object $ HM.fromList [("kind", "TARGET_MATCH")]+ (EvaluationReasonRuleMatch ruleIndex ruleId) ->+ Object $ HM.fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId)]+ (EvaluationReasonPrerequisiteFailed prerequisiteKey) ->+ Object $ HM.fromList [("kind", "PREREQUISITE_FAILED"), ("prerequisiteKey", toJSON prerequisiteKey)]+ EvaluationReasonFallthrough ->+ Object $ HM.fromList [("kind", "FALLTHROUGH")]+ (EvaluationReasonError errorKind) ->+ Object $ HM.fromList [("kind", "ERROR"), ("errorKind", toJSON errorKind)]++-- | Defines the possible values of the errorKind property of EvaluationReason.+data EvalErrorKind+ = EvalErrorKindMalformedFlag+ -- ^ Indicates that there was an internal inconsistency in the flag data,+ -- e.g. a rule specified a nonexistent variation.+ | EvalErrorFlagNotFound+ -- ^ Indicates that the caller provided a flag key that did not match any+ -- known flag.+ | EvalErrorWrongType+ -- ^ Indicates that the result value was not of the requested type, e.g.+ -- you called boolVariationDetail but the value was an integer.+ | EvalErrorUserNotSpecified+ -- ^ Indicates that the caller passed a user without a key for the user+ -- parameter.+ | EvalErrorClientNotReady+ -- ^ Indicates that the caller tried to evaluate a flag before the client+ -- had successfully initialized.+ | EvalErrorExternalStore !Text+ -- ^ Indicates that some error was returned by the external feature store.+ deriving (Generic, Eq, Show)++instance ToJSON EvalErrorKind where+ toJSON x = String $ case x of+ EvalErrorKindMalformedFlag -> "MALFORMED_FLAG"+ EvalErrorFlagNotFound -> "FLAG_NOT_FOUND"+ EvalErrorWrongType -> "WRONG_TYPE"+ EvalErrorUserNotSpecified -> "USER_NOT_SPECIFIED"+ EvalErrorClientNotReady -> "CLIENT_NOT_READY"+ EvalErrorExternalStore _ -> "EXTERNAL_STORE_ERROR"
+ src/LaunchDarkly/Server/Evaluate.hs view
@@ -0,0 +1,224 @@+module LaunchDarkly.Server.Evaluate where++import Control.Monad (mzero, msum)+import Control.Monad.Extra (ifM, anyM, allM, firstJustM)+import Crypto.Hash.SHA1 (hash)+import Data.Scientific (Scientific, floatingOrInteger)+import Data.Either (either, fromLeft)+import Data.Aeson.Types (Value(..))+import Data.Maybe (maybe, fromJust, isJust, fromMaybe)+import Data.Text (Text)+import Data.Generics.Product (getField)+import Data.List (genericIndex, null, find)+import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import Data.Text.Encoding (encodeUtf8)+import GHC.Natural (Natural, naturalToInt)+import Data.Word (Word8)+import Data.ByteString (ByteString)+import Data.IORef (readIORef)++import LaunchDarkly.Server.Client.Internal (ClientI, Status(Initialized))+import LaunchDarkly.Server.User.Internal (UserI, valueOf)+import LaunchDarkly.Server.Features (Flag, Segment, Prerequisite, SegmentRule, Clause, VariationOrRollout, Rule)+import LaunchDarkly.Server.Store.Internal (LaunchDarklyStoreRead, getFlagC, getSegmentC)+import LaunchDarkly.Server.Operators (Op(OpSegmentMatch), getOperation)+import LaunchDarkly.Server.Events (EvalEvent, newUnknownFlagEvent, newSuccessfulEvalEvent, processEvalEvents)+import LaunchDarkly.Server.Details (EvaluationDetail(..), EvaluationReason(..), EvalErrorKind(..))++setFallback :: EvaluationDetail Value -> Value -> EvaluationDetail Value+setFallback detail fallback = case getField @"variationIndex" detail of+ Nothing -> detail { value = fallback }; _ -> detail++setValue :: EvaluationDetail Value -> a -> EvaluationDetail a+setValue x v = x { value = v }++isError :: EvaluationReason -> Bool+isError reason = case reason of (EvaluationReasonError _) -> True; _ -> False++evaluateTyped :: ClientI -> Text -> UserI -> a -> (a -> Value) -> Bool -> (Value -> Maybe a) -> IO (EvaluationDetail a)+evaluateTyped client key user fallback wrap includeReason convert = readIORef (getField @"status" client) >>= \status -> if status /= Initialized+ then pure $ EvaluationDetail fallback Nothing $ EvaluationReasonError EvalErrorClientNotReady+ else evaluateInternalClient client key user (wrap fallback) includeReason >>= \r -> pure $ maybe+ (EvaluationDetail fallback Nothing $ if isError (getField @"reason" r)+ then (getField @"reason" r) else EvaluationReasonError EvalErrorWrongType)+ (setValue r) (convert $ getField @"value" r)++evaluateInternalClient :: ClientI -> Text -> UserI -> Value -> Bool -> IO (EvaluationDetail Value)+evaluateInternalClient client key user fallback includeReason = do+ (reason, unknown, events) <- getFlagC (getField @"store" client) key >>= \case+ Left err -> do+ let event = newUnknownFlagEvent key fallback (EvaluationReasonError $ EvalErrorExternalStore err)+ pure (errorDetail $ EvalErrorExternalStore err, True, pure event)+ Right Nothing -> do+ let event = newUnknownFlagEvent key fallback (EvaluationReasonError EvalErrorFlagNotFound)+ pure (errorDetail EvalErrorFlagNotFound, True, pure event)+ Right (Just flag) -> do+ (reason, events) <- case getField @"key" user of+ Nothing -> pure (errorDetail EvalErrorUserNotSpecified, [])+ Just _ -> evaluateDetail flag user $ getField @"store" client+ let reason' = setFallback reason fallback+ pure (reason', False, flip (:) events $ newSuccessfulEvalEvent flag (getField @"variationIndex" reason')+ (getField @"value" reason') (Just fallback) (getField @"reason" reason') Nothing)+ processEvalEvents (getField @"config" client) (getField @"events" client) user includeReason events unknown+ pure reason++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 }++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 }++evaluateDetail :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> UserI -> store+ -> m (EvaluationDetail Value, [EvalEvent])+evaluateDetail flag user store = if getField @"on" flag+ then checkPrerequisites flag user store >>= \case+ (Nothing, events) -> evaluateInternal flag user store >>= (\x -> pure (x, events))+ (Just reason, events) -> pure (getOffValue flag reason, events)+ else pure (getOffValue flag EvaluationReasonOff, [])++status :: Prerequisite -> EvaluationDetail a -> Flag -> Bool+status prereq result prereqFlag = getField @"on" prereqFlag && (getField @"variationIndex" result) ==+ pure (getField @"variation" prereq)++checkPrerequisite :: (Monad m, LaunchDarklyStoreRead store m) => store -> UserI -> Flag -> Prerequisite+ -> m (Maybe EvaluationReason, [EvalEvent])+checkPrerequisite store user flag prereq = getFlagC store (getField @"key" prereq) >>= \case+ Left err -> pure (pure $ EvaluationReasonError $ EvalErrorExternalStore err, [])+ Right Nothing -> pure (pure $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), [])+ Right (Just prereqFlag) -> evaluateDetail prereqFlag user store >>= \(r, events) -> let+ event = newSuccessfulEvalEvent prereqFlag (getField @"variationIndex" r) (getField @"value" r) Nothing+ (getField @"reason" r) (Just $ getField @"key" flag)+ in if status prereq r prereqFlag then pure (Nothing, event : events) else+ pure (pure $ EvaluationReasonPrerequisiteFailed (getField @"key" prereq), event : events)++sequenceUntil :: Monad m => (a -> Bool) -> [m a] -> m [a]+sequenceUntil _ [] = return []+sequenceUntil p (m:ms) = m >>= \a -> if p a then return [a] else+ sequenceUntil p ms >>= \as -> return (a:as)++checkPrerequisites :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> UserI -> store+ -> m (Maybe EvaluationReason, [EvalEvent])+checkPrerequisites flag user store = let p = getField @"prerequisites" flag in if null p then pure (Nothing, []) else do+ evals <- sequenceUntil (isJust . fst) $ map (checkPrerequisite store user flag) p+ pure (msum $ map fst evals, concatMap snd evals)++evaluateInternal :: (Monad m, LaunchDarklyStoreRead store m) => Flag -> UserI -> store -> m (EvaluationDetail Value)+evaluateInternal flag user store = result where+ checkTarget target = if elem (getField @"key" user) (Just <$> getField @"values" target)+ then Just $ getVariation flag (getField @"variation" target) EvaluationReasonTargetMatch else Nothing+ checkRule (ruleIndex, rule) = ifM (ruleMatchesUser rule user store)+ (pure $ Just $ getValueForVariationOrRollout flag (getField @"variationOrRollout" rule) user+ EvaluationReasonRuleMatch { ruleIndex = ruleIndex, ruleId = getField @"id" rule })+ (pure Nothing)+ fallthrough = getValueForVariationOrRollout flag (getField @"fallthrough" flag) user EvaluationReasonFallthrough+ result = let+ ruleMatch = checkRule <$> zip [0..] (getField @"rules" flag)+ targetMatch = return . checkTarget <$> getField @"targets" flag+ in fromMaybe fallthrough <$> firstJustM Prelude.id (ruleMatch ++ targetMatch)++errorDetail :: EvalErrorKind -> EvaluationDetail Value+errorDetail kind = EvaluationDetail { value = Null, variationIndex = mzero, reason = EvaluationReasonError kind }++getValueForVariationOrRollout :: Flag -> VariationOrRollout -> UserI -> EvaluationReason -> EvaluationDetail Value+getValueForVariationOrRollout flag vr user reason =+ case variationIndexForUser vr user (getField @"key" flag) (getField @"salt" flag) of+ Nothing -> errorDetail EvalErrorKindMalformedFlag+ Just x -> getVariation flag x reason++ruleMatchesUser :: Monad m => LaunchDarklyStoreRead store m => Rule -> UserI -> store -> m Bool+ruleMatchesUser rule user store =+ allM (\clause -> clauseMatchesUser store clause user) (getField @"clauses" rule)++variationIndexForUser :: VariationOrRollout -> UserI -> Text -> Text -> Maybe Natural+variationIndexForUser vor user key salt+ | (Just variation) <- getField @"variation" vor = pure variation+ | (Just rollout) <- getField @"rollout" vor = let+ variations = getField @"variations" rollout+ bucket = bucketUser user key (fromMaybe "key" $ getField @"bucketBy" rollout) salt+ c acc i = acc >>= \acc -> let t = acc + ((getField @"weight" i) / 100000.0) in+ if bucket < t then Left (getField @"variation" i) else Right t+ in if null variations then Nothing else pure $ fromLeft (getField @"variation" $ last variations) $+ foldl c (Right (0.0 :: Float)) variations+ | otherwise = Nothing++-- Bucketing -------------------------------------------------------------------++hexCharToNumber :: Word8 -> Maybe Natural+hexCharToNumber w = fmap fromIntegral $ if+ | 48 <= w && w <= 57 -> pure $ w - 48+ | 65 <= w && w <= 70 -> pure $ w - 55+ | 97 <= w && w <= 102 -> pure $ w - 87+ | otherwise -> Nothing++hexStringToNumber :: ByteString -> Maybe Natural+hexStringToNumber bytes = B.foldl' step (Just 0) bytes where+ step acc x = acc >>= \acc' -> hexCharToNumber x >>= pure . (+) (acc' * 16)++bucketUser :: UserI -> Text -> Text -> Text -> Float+bucketUser user key attribute salt = fromMaybe 0 $ do+ i <- valueOf user attribute >>= bucketableStringValue >>= \x -> pure $ B.take 15 $ B16.encode $ hash $ encodeUtf8 $+ T.concat [key, ".", salt, ".", x, maybe "" (T.append ".") $ getField @"secondary" user]+ pure $ ((fromIntegral $ fromJust $ hexStringToNumber i) :: Float) / (0xFFFFFFFFFFFFFFF)++floatingOrInteger' :: Scientific -> Either Double Integer+floatingOrInteger' = floatingOrInteger++bucketableStringValue :: Value -> Maybe Text+bucketableStringValue (String x) = pure x+bucketableStringValue (Number s) = either (const Nothing) (pure . T.pack . show) (floatingOrInteger' s)+bucketableStringValue _ = Nothing++-- Clause ----------------------------------------------------------------------++maybeNegate :: Clause -> Bool -> Bool+maybeNegate clause value = if getField @"negate" clause then not value else value++matchAny :: (Value -> Value -> Bool) -> Value -> [Value] -> Bool+matchAny op value = any (op value)++clauseMatchesUserNoSegments :: Clause -> UserI -> Bool+clauseMatchesUserNoSegments clause user = case valueOf user $ getField @"attribute" clause of+ Nothing -> False+ Just (Array a) -> maybeNegate clause $ V.any (\x -> matchAny f x v) a+ Just x -> maybeNegate clause $ matchAny f x v+ where+ f = getOperation $ getField @"op" clause+ v = getField @"values" clause++clauseMatchesUser :: (Monad m, LaunchDarklyStoreRead store m) => store -> Clause -> UserI -> m Bool+clauseMatchesUser store clause user+ | getField @"op" clause == OpSegmentMatch = do+ let values = [ x | String x <- getField @"values" clause]+ x <- anyM (\k -> getSegmentC store k >>= pure . checkSegment) values+ pure $ maybeNegate clause x+ | otherwise = pure $ clauseMatchesUserNoSegments clause user+ where+ checkSegment :: Either Text (Maybe Segment) -> Bool+ checkSegment (Right (Just segment)) = segmentContainsUser segment user+ checkSegment _ = False++-- Segment ---------------------------------------------------------------------++segmentRuleMatchesUser :: SegmentRule -> UserI -> Text -> Text -> Bool+segmentRuleMatchesUser rule user key salt = (&&)+ (all (flip clauseMatchesUserNoSegments user) (getField @"clauses" rule))+ (flip (maybe True) (getField @"weight" rule) $ \weight ->+ bucketUser user key (fromMaybe "key" $ getField @"bucketBy" rule) salt < weight / 100000.0)++segmentContainsUser :: Segment -> UserI -> Bool+segmentContainsUser segment user+ | Nothing <- getField @"key" user = False+ | elem (fromJust $ getField @"key" user) (getField @"included" segment) = True+ | elem (fromJust $ getField @"key" user) (getField @"excluded" segment) = False+ | Just _ <- find+ (\r -> segmentRuleMatchesUser r user (getField @"key" segment) (getField @"salt" segment))+ (getField @"rules" segment) = True+ | otherwise = False
+ src/LaunchDarkly/Server/Events.hs view
@@ -0,0 +1,313 @@+module LaunchDarkly.Server.Events where++import Data.Aeson (ToJSON, Value(..), toJSON, object)+import Data.Text (Text)+import GHC.Natural (Natural)+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 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 qualified Data.Cache.LRU as LRU++import LaunchDarkly.Server.Config.Internal (ConfigI, shouldSendEvents)+import LaunchDarkly.Server.User.Internal (UserI, userSerializeRedacted)+import LaunchDarkly.Server.Details (EvaluationReason(..))+import LaunchDarkly.Server.Features (Flag)++data EvalEvent = EvalEvent+ { key :: !Text+ , variation :: !(Maybe Natural)+ , value :: !Value+ , defaultValue :: !(Maybe Value)+ , version :: !(Maybe Natural)+ , prereqOf :: !(Maybe Text)+ , reason :: !EvaluationReason+ , trackEvents :: !Bool+ , forceIncludeReason :: !Bool+ , debug :: !Bool+ , debugEventsUntilDate :: !(Maybe Natural)+ } deriving (Generic, Eq, Show)++data EventState = EventState+ { events :: !(MVar [EventType])+ , 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+ pure EventState{..}++convertFeatures :: HashMap Text (FlagSummaryContext (HashMap Text CounterContext))+ -> HashMap Text (FlagSummaryContext [CounterContext])+convertFeatures summary = (flip HM.map) summary $ \context -> context & field @"counters" %~ HM.elems++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++unixMilliseconds :: IO Natural+unixMilliseconds = (round . (* 1000)) <$> getPOSIXTime++makeBaseEvent :: a -> IO (BaseEvent a)+makeBaseEvent child = unixMilliseconds >>= \now -> pure $ BaseEvent { creationDate = now, event = child }++processSummary :: ConfigI -> EventState -> IO ()+processSummary config state = tryTakeMVar (getField @"startDate" state) >>= \case+ Nothing -> pure ()+ (Just startDate) -> do+ endDate <- unixMilliseconds+ features <- convertFeatures <$> swapMVar (getField @"summary" state) mempty+ makeBaseEvent SummaryEvent {..} >>= queueEvent config state . EventTypeSummary++class EventKind a where+ eventKind :: a -> Text++data SummaryEvent = SummaryEvent+ { startDate :: !Natural+ , endDate :: !Natural+ , features :: !(HashMap Text (FlagSummaryContext [CounterContext]))+ } deriving (Generic, Show, ToJSON)++instance EventKind SummaryEvent where+ eventKind _ = "summary"++data FlagSummaryContext a = FlagSummaryContext+ { defaultValue :: Maybe Value+ , counters :: a+ } deriving (Generic, Show)++instance ToJSON a => ToJSON (FlagSummaryContext a) where+ toJSON ctx = object $ filter ((/=) Null . snd)+ [ ("default", toJSON $ getField @"defaultValue" ctx)+ , ("counters", toJSON $ getField @"counters" ctx)+ ]++data CounterContext = CounterContext+ { count :: !Natural+ , version :: !(Maybe Natural)+ , variation :: !(Maybe Natural)+ , value :: !Value+ , unknown :: !Bool+ } deriving (Generic, Show, ToJSON)++data IdentifyEvent = IdentifyEvent+ { key :: !(Maybe Text)+ , user :: !Value+ } deriving (Generic, ToJSON, Show)++instance EventKind IdentifyEvent where+ eventKind _ = "identify"++data IndexEvent = IndexEvent { user :: Value } deriving (Generic, ToJSON, Show)++instance EventKind IndexEvent where+ eventKind _ = "index"++data FeatureEvent = FeatureEvent+ { key :: !Text+ , user :: !(Maybe Value)+ , userKey :: !(Maybe Text)+ , value :: !Value+ , defaultValue :: !(Maybe Value)+ , version :: !(Maybe Natural)+ , variation :: !(Maybe Natural)+ , reason :: !(Maybe EvaluationReason)+ } deriving (Generic, Show)++instance ToJSON FeatureEvent where+ toJSON event = object $ filter ((/=) Null . snd)+ [ ("key", toJSON $ getField @"key" event)+ , ("user", toJSON $ getField @"user" event)+ , ("userKey", toJSON $ getField @"userKey" event)+ , ("value", toJSON $ getField @"value" event)+ , ("default", toJSON $ getField @"defaultValue" event)+ , ("version", toJSON $ getField @"version" event)+ , ("variation", toJSON $ getField @"variation" event)+ , ("reason", toJSON $ getField @"reason" event)+ ]++instance EventKind FeatureEvent where+ eventKind _ = "feature"++newtype DebugEvent = DebugEvent FeatureEvent++instance EventKind DebugEvent where+ eventKind _ = "debug"++instance ToJSON DebugEvent where+ toJSON (DebugEvent x) = toJSON x++addUserToEvent :: (HasField' "user" r (Maybe Value), HasField' "userKey" r (Maybe Text)) => ConfigI -> UserI -> r -> r+addUserToEvent config user event = if getField @"inlineUsersInEvents" config+ then setField @"user" (pure $ userSerializeRedacted config user) event+ else setField @"userKey" (getField @"key" user) event++makeFeatureEvent :: ConfigI -> UserI -> Bool -> EvalEvent -> FeatureEvent+makeFeatureEvent config user includeReason event = addUserToEvent config user $ FeatureEvent+ { key = getField @"key" event+ , user = Nothing+ , userKey = Nothing+ , value = getField @"value" event+ , defaultValue = getField @"defaultValue" event+ , version = getField @"version" event+ , variation = getField @"variation" event+ , reason = if includeReason || getField @"forceIncludeReason" event+ then pure $ getField @"reason" event else Nothing+ }++data CustomEvent = CustomEvent+ { key :: !Text+ , user :: !(Maybe Value)+ , userKey :: !(Maybe Text)+ , metricValue :: !(Maybe Double)+ , value :: !(Maybe Value)+ } deriving (Generic, Show)++instance ToJSON CustomEvent where+ toJSON ctx = object $ filter ((/=) Null . snd)+ [ ("key", toJSON $ getField @"key" ctx)+ , ("user", toJSON $ getField @"user" ctx)+ , ("userKey", toJSON $ getField @"userKey" ctx)+ , ("metricValue", toJSON $ getField @"metricValue" ctx)+ , ("data", toJSON $ getField @"value" ctx)+ ]++instance EventKind CustomEvent where+ eventKind _ = "custom"++data BaseEvent event = BaseEvent+ { creationDate :: Natural+ , event :: event+ } deriving (Generic, Show)++fromObject :: Value -> HashMap Text 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+ [ ("creationDate", toJSON $ getField @"creationDate" event)+ , ("kind", String $ eventKind $ getField @"event" event)+ ]++data EventType =+ EventTypeIdentify !(BaseEvent IdentifyEvent)+ | EventTypeFeature !(BaseEvent FeatureEvent)+ | EventTypeSummary !(BaseEvent SummaryEvent)+ | EventTypeCustom !(BaseEvent CustomEvent)+ | EventTypeIndex !(BaseEvent IndexEvent)+ | EventTypeDebug !(BaseEvent DebugEvent)++instance ToJSON EventType where+ toJSON event = case event of+ EventTypeIdentify x -> toJSON x+ EventTypeFeature x -> toJSON x+ EventTypeSummary x -> toJSON x+ EventTypeCustom x -> toJSON x+ EventTypeIndex x -> toJSON x+ EventTypeDebug x -> toJSON x++newUnknownFlagEvent :: Text -> Value -> EvaluationReason -> EvalEvent+newUnknownFlagEvent key defaultValue reason = EvalEvent+ { key = key+ , variation = Nothing+ , value = defaultValue+ , defaultValue = pure defaultValue+ , version = Nothing+ , prereqOf = Nothing+ , reason = reason+ , trackEvents = False+ , forceIncludeReason = False+ , debug = False+ , debugEventsUntilDate = Nothing+ }++newSuccessfulEvalEvent :: Flag -> Maybe Natural -> Value -> Maybe Value -> EvaluationReason -> Maybe Text -> EvalEvent+newSuccessfulEvalEvent flag variation value defaultValue reason prereqOf = EvalEvent+ { key = getField @"key" flag+ , variation = variation+ , value = value+ , defaultValue = defaultValue+ , version = Just $ getField @"version" flag+ , prereqOf = prereqOf+ , reason = reason+ , trackEvents = getField @"trackEvents" flag || shouldForceReason+ , forceIncludeReason = shouldForceReason+ , debug = False+ , debugEventsUntilDate = getField @"debugEventsUntilDate" flag+ }++ where++ shouldForceReason = case reason of+ EvaluationReasonFallthrough -> getField @"trackEventsFallthrough" flag+ (EvaluationReasonRuleMatch idx _) -> getField @"trackEvents" (getField @"rules" flag !! fromIntegral idx)+ _ -> False++makeSummaryKey :: EvalEvent -> Text+makeSummaryKey event = T.intercalate "-"+ [ fromMaybe "" $ fmap (T.pack . show) $ getField @"version" event+ , fromMaybe "" $ fmap (T.pack . show) $ getField @"variation" event+ ]++summarizeEvent :: (HashMap Text (FlagSummaryContext (HashMap Text CounterContext)))+ -> EvalEvent -> Bool -> (HashMap Text (FlagSummaryContext (HashMap Text CounterContext)))+summarizeEvent context event unknown = result where+ key = makeSummaryKey event+ root = case HM.lookup (getField @"key" event) context of+ (Just x) -> x; Nothing -> FlagSummaryContext (getField @"defaultValue" event) mempty+ leaf = case HM.lookup key (getField @"counters" root) of+ (Just x) -> x & field @"count" %~ (1 +)+ Nothing -> CounterContext+ { count = 1+ , version = getField @"version" event+ , variation = getField @"variation" event+ , value = getField @"value" event+ , unknown = unknown+ }+ result = flip (HM.insert $ getField @"key" event) context $+ root & field @"counters" %~ HM.insert key leaf++putIfEmptyMVar :: MVar a -> a -> IO ()+putIfEmptyMVar mvar value = tryTakeMVar mvar >>= \case Just x -> putMVar mvar x; Nothing -> putMVar mvar value;++runSummary :: Natural -> EventState -> EvalEvent -> Bool -> IO ()+runSummary now state event unknown = putIfEmptyMVar (getField @"startDate" state) now >>+ modifyMVar_ (getField @"summary" state) (\summary -> pure $ summarizeEvent summary event unknown)++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) $+ queueEvent config state $ EventTypeFeature $ BaseEvent now $ featureEvent+ when (now < fromMaybe 0 (getField @"debugEventsUntilDate" event)) $+ queueEvent config state $ EventTypeDebug $ BaseEvent now $ DebugEvent featureEvent+ runSummary now state event unknown+ 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 = fromMaybe "" $ 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'
+ src/LaunchDarkly/Server/Features.hs view
@@ -0,0 +1,110 @@+module LaunchDarkly.Server.Features where++import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), withObject, (.:), (.:?), object, (.=))+import Data.Text (Text)+import Data.HashSet (HashSet)+import Data.Generics.Product (getField)+import GHC.Natural (Natural)+import GHC.Generics (Generic)++import LaunchDarkly.Server.Operators (Op)++data Target = Target+ { values :: ![Text]+ , variation :: !Natural+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)++data Rule = Rule+ { id :: !Text+ , clauses :: ![Clause]+ , variationOrRollout :: !VariationOrRollout+ , trackEvents :: !Bool+ } deriving (Generic, Show, Eq)++instance FromJSON Rule where+ parseJSON = withObject "Rule" $ \o -> do+ id <- o .: "id"+ clauses <- o .: "clauses"+ variation <- o .:? "variation"+ rollout <- o .:? "rollout"+ trackEvents <- o .: "trackEvents"+ pure Rule+ { id = id+ , clauses = clauses+ , variationOrRollout = VariationOrRollout+ { variation = variation+ , rollout = rollout+ }+ , trackEvents = trackEvents+ }++instance ToJSON Rule where+ toJSON rule = object+ [ "id" .= getField @"id" rule+ , "clauses" .= getField @"clauses" rule+ , "trackEvents" .= getField @"trackEvents" rule+ , "variation" .= getField @"variation" (getField @"variationOrRollout" rule)+ , "rollout" .= getField @"rollout" (getField @"variationOrRollout" rule)+ ]++data WeightedVariation = WeightedVariation+ { variation :: !Natural+ , weight :: !Float+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)++data Rollout = Rollout+ { variations :: ![WeightedVariation]+ , bucketBy :: !(Maybe Text)+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)++data VariationOrRollout = VariationOrRollout+ { variation :: !(Maybe Natural)+ , rollout :: !(Maybe Rollout)+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)++data Flag = Flag+ { key :: !Text+ , version :: !Natural+ , on :: !Bool+ , trackEvents :: !Bool+ , trackEventsFallthrough :: !Bool+ , deleted :: !Bool+ , prerequisites :: ![Prerequisite]+ , salt :: !Text+ , sel :: !Text+ , targets :: ![Target]+ , rules :: ![Rule]+ , fallthrough :: !VariationOrRollout+ , offVariation :: !(Maybe Natural)+ , variations :: ![Value]+ , debugEventsUntilDate :: !(Maybe Natural)+ } deriving (Generic, ToJSON, FromJSON, Show, Eq)++data Prerequisite = Prerequisite+ { key :: !Text+ , variation :: !Natural+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)++data SegmentRule = SegmentRule+ { id :: !Text+ , clauses :: ![Clause]+ , weight :: !(Maybe Float)+ , bucketBy :: !(Maybe Text)+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)++data Segment = Segment+ { key :: !Text+ , included :: !(HashSet Text)+ , excluded :: !(HashSet Text)+ , salt :: !Text+ , rules :: ![SegmentRule]+ , version :: !Natural+ , deleted :: !Bool+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)++data Clause = Clause+ { attribute :: !Text+ , negate :: !Bool+ , op :: !Op+ , values :: ![Value]+ } deriving (Generic, FromJSON, ToJSON, Show, Eq)
+ src/LaunchDarkly/Server/Network/Common.hs view
@@ -0,0 +1,51 @@+module LaunchDarkly.Server.Network.Common+ ( prepareRequest+ , withResponseGeneric+ , tryAuthorized+ , checkAuthorization+ , tryHTTP+ , addToAL+ ) where++import Data.ByteString (append)+import Network.HTTP.Client (HttpException, Manager, Request(..), Response(..), BodyReader, setRequestIgnoreStatus, responseOpen, responseTimeout, responseTimeoutMicro, responseClose)+import Network.HTTP.Types.Status (unauthorized401, forbidden403)+import Data.Generics.Product (getField)+import Data.Text.Encoding (encodeUtf8)+import Data.Function ((&))+import Control.Monad (when)+import Control.Monad.Catch (Exception, MonadCatch, MonadMask, MonadThrow, try, bracket, throwM)+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)++tryHTTP :: MonadCatch m => m a -> m (Either HttpException a)+tryHTTP = try++addToAL :: Eq k => [(k, v)] -> k -> v -> [(k, v)]+addToAL l k v = (k, v) : filter ((/=) k . fst) l++prepareRequest :: ConfigI -> Request -> Request+prepareRequest config request = request+ { requestHeaders = (requestHeaders request)+ & \l -> addToAL l "Authorization" (encodeUtf8 $ getField @"key" config)+ & \l -> addToAL l "User-Agent" (append "HaskellServerClient/" $ encodeUtf8 clientVersion)+ , responseTimeout = responseTimeoutMicro $ (fromIntegral $ getField @"requestTimeoutSeconds" config) * 1000000+ } & setRequestIgnoreStatus++withResponseGeneric :: (MonadIO m, MonadMask m) => Request -> Manager -> (Response BodyReader -> m a) -> m a+withResponseGeneric req man f = bracket (liftIO $ responseOpen req man) (liftIO . responseClose) f++data UnauthorizedE = UnauthorizedE deriving (Show, Exception)++tryAuthorized :: (MonadIO m, MonadLogger m, MonadCatch m) => ClientI -> m a -> m ()+tryAuthorized client operation = try operation >>= \case+ (Left UnauthorizedE) -> do+ $(logError) "SDK key is unauthorized"+ liftIO $ setStatus client Unauthorized+ _ -> pure ()++checkAuthorization :: (MonadThrow m) => Response body -> m ()+checkAuthorization response = when (elem (responseStatus response) [unauthorized401, forbidden403]) $ throwM UnauthorizedE
+ src/LaunchDarkly/Server/Network/Eventing.hs view
@@ -0,0 +1,70 @@+module LaunchDarkly.Server.Network.Eventing (eventThread) where++import Data.Aeson (encode)+import Data.Function ((&))+import Data.Tuple (swap)+import Data.IORef (newIORef, readIORef, atomicModifyIORef')+import qualified Data.UUID as UUID+import Control.Monad.Logger (MonadLogger, logDebug, logWarn, logError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Network.HTTP.Client (Manager, Request(..), RequestBody(..), httpLbs, parseRequest, responseStatus)+import Data.Generics.Product (getField)+import qualified Data.Text as T+import Control.Concurrent (killThread, myThreadId)+import Control.Monad (forever, when, void, unless)+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Concurrent.MVar (takeMVar, readMVar, swapMVar)+import System.Timeout (timeout)+import System.Random (newStdGen, random)+import Data.Text.Encoding (decodeUtf8)+import qualified Data.ByteString.Lazy as L+import Network.HTTP.Types.Status (status400, status408, status429, status500)++import LaunchDarkly.Server.Client.Internal (ClientI, Status(ShuttingDown))+import LaunchDarkly.Server.Network.Common (tryAuthorized, checkAuthorization, prepareRequest, tryHTTP, addToAL)+import LaunchDarkly.Server.Events (processSummary)++-- 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 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++setEventHeaders :: Request -> Request+setEventHeaders request = request+ { requestHeaders = (requestHeaders request)+ & \l -> addToAL l "Content-Type" "application/json"+ & \l -> addToAL l "X-LaunchDarkly-Event-Schema" "3"+ , method = "POST"+ }++eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> m ()+eventThread manager client = do+ let state = getField @"events" client; config = getField @"config" client;+ rngRef <- liftIO $ newStdGen >>= newIORef+ req <- (liftIO $ parseRequest $ (T.unpack $ getField @"eventsURI" config) ++ "/bulk") >>= pure . setEventHeaders . prepareRequest config+ void $ tryAuthorized client $ forever $ do+ liftIO $ processSummary config state+ events' <- liftIO $ swapMVar (getField @"events" state) []+ when (not $ null events') $ do+ payloadId <- liftIO $ atomicModifyIORef' rngRef (swap . random)+ let+ encoded = encode events'+ thisReq = req+ { requestBody = RequestBodyLBS encoded+ , requestHeaders = (requestHeaders req)+ & \l -> addToAL l "X-LaunchDarkly-Payload-ID" (UUID.toASCIIBytes payloadId)+ }+ $(logDebug) $ T.append "sending events: " $ decodeUtf8 $ L.toStrict encoded+ success <- processSend manager thisReq+ unless success $ 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"+ $(logDebug) "finished send of event batch"+ status <- liftIO $ readIORef $ getField @"status" client+ liftIO $ when (status == ShuttingDown) (myThreadId >>= killThread)+ liftIO $ void $ timeout ((*) 1000000 $ fromIntegral $ getField @"flushIntervalSeconds" config) $ takeMVar $ getField @"flush" state
+ src/LaunchDarkly/Server/Network/Polling.hs view
@@ -0,0 +1,50 @@+module LaunchDarkly.Server.Network.Polling (pollingThread) where++import GHC.Generics (Generic)+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 Data.Generics.Product (getField)+import Control.Monad (forever)+import Control.Concurrent (threadDelay)+import Data.Aeson (eitherDecode, FromJSON(..))+import Control.Monad.Logger (MonadLogger, logInfo, logError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Catch (MonadMask, MonadThrow)+import Network.HTTP.Types.Status (ok200)++import LaunchDarkly.Server.Client.Internal (ClientI, Status(Initialized), setStatus)+import LaunchDarkly.Server.Network.Common (tryAuthorized, checkAuthorization, prepareRequest, tryHTTP)+import LaunchDarkly.Server.Features (Flag, Segment)+import LaunchDarkly.Server.Store.Internal (StoreHandle, initializeStore)++data PollingResponse = PollingResponse+ { flags :: !(HashMap Text Flag)+ , segments :: !(HashMap Text Segment)+ } deriving (Generic, FromJSON, Show)++processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => ClientI -> Manager -> StoreHandle IO -> Request -> m ()+processPoll client manager store 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))+ case status of+ Right () -> liftIO $ setStatus client Initialized+ Left err -> do+ $(logError) $ T.append "store failed put: " err+ pure ()++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+ $(logInfo) "starting poll"+ processPoll client manager store req+ $(logInfo) "finished poll"+ liftIO $ threadDelay $ (*) 1000000 $ fromIntegral $ getField @"pollIntervalSeconds" config
+ src/LaunchDarkly/Server/Network/Streaming.hs view
@@ -0,0 +1,163 @@+module LaunchDarkly.Server.Network.Streaming (streamingThread) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Attoparsec.Text as P hiding (Result)+import Control.Monad (void, mzero, forever)+import Data.ByteString (ByteString)+import Control.Applicative (many)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.HashMap.Strict (HashMap)+import Network.HTTP.Client (Manager, Response(..), Request, parseRequest, brRead, throwErrorStatusCodes)+import Control.Monad.Logger (MonadLogger, logInfo, logWarn, logError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Generics.Product (getField)+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)++import LaunchDarkly.Server.Client.Internal (ClientI, Status(Initialized), setStatus)+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)++data PutBody = PutBody+ { flags :: !(HashMap Text Flag)+ , segments :: !(HashMap Text Segment)+ } deriving (Generic, Show, FromJSON)++data PathData d = PathData+ { path :: !Text+ , pathData :: !d+ } deriving (Generic, Show)++data PathVersion = PathVersion+ { path :: !Text+ , version :: !Natural+ } deriving (Generic, Show, FromJSON)++instance FromJSON a => FromJSON (PathData a) where+ parseJSON = withObject "Put" $ \o -> do+ pathData <- o .: "data"+ path <- o .: "path"+ pure $ PathData { path = path, pathData = pathData }++data SSE = SSE+ { name :: !Text+ , buffer :: !Text+ , lastEventId :: !(Maybe Text)+ , retry :: !(Maybe Text)+ } deriving (Generic, Show, Eq)++nameCharPredicate :: Char -> Bool+nameCharPredicate x = x /= '\r' && x /= ':' && x /= '\n'++anyCharPredicate :: Char -> Bool+anyCharPredicate x = x /= '\r' && x /= '\n'++endOfLineSSE :: Parser ()+endOfLineSSE = choice [void $ string "\r\n", void $ string "\r", void $ string "\n", endOfInput]++comment :: Parser ()+comment = char ':' >> P.takeWhile anyCharPredicate >> endOfLineSSE >> pure ()++parseField :: Parser (Text, Text)+parseField = do+ fieldName <- P.takeWhile1 nameCharPredicate+ void $ option ' ' $ char ':'+ void $ option ' ' $ char ' '+ fieldValue <- P.takeWhile anyCharPredicate+ endOfLineSSE+ pure (fieldName, fieldValue)++processField :: (Text, Text) -> SSE -> SSE+processField (fieldName, fieldValue) event = case fieldName of+ "event" -> event { name = fieldValue }+ "id" -> event { lastEventId = Just fieldValue }+ "retry" -> event { retry = Just fieldValue }+ "data" -> event { buffer = T.concat [ buffer event, if T.null (buffer event) then "" else "\n", fieldValue] }+ _ -> event++parseEvent :: Parser SSE+parseEvent = do+ fields <- many (many comment >> parseField >>= pure)+ endOfLineSSE+ 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) => ClientI -> StoreHandle IO -> L.ByteString -> m ()+processPut client store value = case eitherDecode value of+ Right (PathData _ (PutBody flags segments)) -> do+ $(logInfo) "initializing store with put"+ status <- liftIO $ initializeStore store flags segments+ either (\err -> $(logError) $ T.append "store failed put: " err)+ (\_ -> liftIO $ setStatus client Initialized) status+ 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+ Right (PathData path body)+ | T.isPrefixOf "/flags/" path -> insPatch "flag" path insertFlag (fromJSON body)+ | T.isPrefixOf "/segments/" path -> insPatch "segment" path insertSegment (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 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++processDelete :: forall m. (MonadIO m, MonadLogger m) => StoreHandle IO -> L.ByteString -> m ()+processDelete store 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)+ | 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++processEvent :: (MonadIO m, MonadLogger m) => ClientI -> StoreHandle IO -> Text -> L.ByteString -> m ()+processEvent client store name value = case name of+ "put" -> processPut client store value+ "patch" -> processPatch store value+ "delete" -> processDelete store value+ _ -> $(logWarn) "unknown event type"++readStream :: (MonadIO m, MonadLogger m) => ClientI -> IO ByteString -> StoreHandle IO -> m ()+readStream client body store = loop "" where+ loop initial = liftIO (parseWith (decodeUtf8 <$> brRead body) parseEvent initial) >>= \case+ Done remaining event -> do+ processEvent client store (name event) (L.fromStrict $ encodeUtf8 $ buffer event)+ loop remaining+ Fail _ context err ->+ $(logError) $ T.intercalate " " ["failed parsing SSE frame", T.pack $ show context, T.pack err]+ Partial _ -> $(logError) "failed parsing SSE frame unexpected partial"++-- https://aws.amazon.com/blogs/architecture/exponential-backoff-and-jitter/+retryPolicy :: MonadIO m => RetryPolicyM m+retryPolicy = capDelay (3600 * 1000000) $ fullJitterBackoff (1 * 1000000)++handleStream :: (MonadIO m, MonadLogger m, MonadMask m) => ClientI -> Manager -> Request -> StoreHandle IO -> RetryStatus -> m Bool+handleStream client manager request store _ = do+ status <- tryHTTP $ withResponseGeneric request manager $ \response -> checkAuthorization response >>+ if responseStatus response /= ok200 then throwErrorStatusCodes request response else+ readStream client (responseBody response) store+ case status of+ (Left err) -> $(logError) (T.intercalate " " ["HTTP Exception", T.pack $ show err]) >> pure True+ (Right _) -> pure False++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 $ forever $ retrying retryPolicy (\_ status -> pure status) $ handleStream client manager req store
+ src/LaunchDarkly/Server/Operators.hs view
@@ -0,0 +1,134 @@+module LaunchDarkly.Server.Operators+ ( Op(..)+ , getOperation+ ) where++import Data.Maybe (fromMaybe, isJust)+import Data.Either (fromRight)+import Data.Text as T+import Data.Text (Text, isPrefixOf, isInfixOf, isSuffixOf, unpack)+import Data.Char (isDigit)+import Data.Text.Encoding (encodeUtf8)+import Data.Scientific (Scientific, toRealFloat)+import Data.Aeson.Types (Value(..), FromJSON, ToJSON(..), withText, parseJSON)+import Data.Time.ISO8601 (parseISO8601)+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)+import Data.SemVer (Version, fromText, toText, metadata)+import Control.Monad (liftM2)+import Control.Lens ((.~))+import GHC.Generics (Generic)+import Text.Regex.PCRE.Light (compileM, match)++data Op =+ OpIn+ | OpEndsWith+ | OpStartsWith+ | OpMatches+ | OpContains+ | OpLessThan+ | OpLessThanOrEqual+ | OpGreaterThan+ | OpGreaterThanOrEqual+ | OpBefore+ | OpAfter+ | OpSemVerEqual+ | OpSemVerLessThan+ | OpSemVerGreaterThan+ | OpSegmentMatch+ | OpUnknown+ deriving (Generic, Show, Eq)++instance FromJSON Op where+ parseJSON = withText "Op" $ \v -> case v of+ "in" -> pure OpIn+ "endsWith" -> pure OpEndsWith+ "startsWith" -> pure OpStartsWith+ "matches" -> pure OpMatches+ "contains" -> pure OpContains+ "lessThan" -> pure OpLessThan+ "lessThanOrEqual" -> pure OpLessThanOrEqual+ "greaterThan" -> pure OpGreaterThan+ "greaterThanOrEqual" -> pure OpGreaterThanOrEqual+ "before" -> pure OpBefore+ "after" -> pure OpAfter+ "semVerEqual" -> pure OpSemVerEqual+ "semVerLessThan" -> pure OpSemVerLessThan+ "semVerGreaterThan" -> pure OpSemVerGreaterThan+ "segmentMatch" -> pure OpSegmentMatch+ _ -> pure OpUnknown++instance ToJSON Op where+ toJSON op = String $ case op of+ OpIn -> "in"+ OpEndsWith -> "endsWith"+ OpStartsWith -> "startsWith"+ OpMatches -> "matches"+ OpContains -> "contains"+ OpLessThan -> "lessThan"+ OpLessThanOrEqual -> "lessThanOrEqual"+ OpGreaterThan -> "greaterThan"+ OpGreaterThanOrEqual -> "greaterThanOrEqual"+ OpBefore -> "before"+ OpAfter -> "after"+ OpSemVerEqual -> "semVerEqual"+ OpSemVerLessThan -> "semVerLessThan"+ OpSemVerGreaterThan -> "semVerGreaterThan"+ OpSegmentMatch -> "segmentMatch"+ OpUnknown -> "unknown"++checkString :: (Text -> Text -> Bool) -> Value -> Value -> Bool+checkString op (String x) (String y) = op x y+checkString _ _ _ = False++checkNumber :: (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool+checkNumber op (Number x) (Number y) = op x y+checkNumber _ _ _ = False++doubleToPOSIXTime :: Double -> POSIXTime+doubleToPOSIXTime = realToFrac++parseTime :: Value -> Maybe UTCTime+parseTime (Number x) = Just $ posixSecondsToUTCTime $ doubleToPOSIXTime $ (toRealFloat x) / 1000+parseTime (String x) = parseISO8601 $ unpack x+parseTime _ = Nothing++compareTime :: (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool+compareTime op x y = fromMaybe False $ liftM2 op (parseTime x) (parseTime y)++padSemVer :: Text -> Text+padSemVer text = T.concat [l, padding, r] where+ (l, r) = T.span (\c -> isDigit c || c == '.') text+ dots = T.count "." l+ padding = if dots < 2 then T.replicate (2 - dots) ".0" else ""++parseSemVer :: Text -> Either String Version+parseSemVer raw = fmap (metadata .~ []) (fromText $ padSemVer raw) >>= \x ->+ if T.isPrefixOf (toText x) (padSemVer raw) then Right x else Left "mismatch" where++compareSemVer :: (Version -> Version -> Bool) -> Text -> Text -> Bool+compareSemVer op x y = fromRight False $ liftM2 op (parseSemVer x) (parseSemVer y)++matches :: Text -> Text -> Bool+matches text pattern = case compileM (encodeUtf8 pattern) [] of+ Left _ -> False+ Right compiled -> isJust $ match compiled (encodeUtf8 text) []++getOperation :: Op -> (Value -> Value -> Bool)+getOperation op = case op of+ OpIn -> (==)+ OpEndsWith -> checkString (flip isSuffixOf)+ OpStartsWith -> checkString (flip isPrefixOf)+ OpContains -> checkString (flip isInfixOf)+ OpMatches -> checkString matches+ OpLessThan -> checkNumber (<)+ OpLessThanOrEqual -> checkNumber (<=)+ OpGreaterThan -> checkNumber (>)+ OpGreaterThanOrEqual -> checkNumber (>=)+ OpBefore -> compareTime (<)+ OpAfter -> compareTime (>)+ OpSemVerEqual -> checkString $ compareSemVer (==)+ OpSemVerLessThan -> checkString $ compareSemVer (<)+ OpSemVerGreaterThan -> checkString $ compareSemVer (>)+ OpSegmentMatch -> error "cannot get operation for OpSegmentMatch"+ OpUnknown -> const $ const False
+ src/LaunchDarkly/Server/Store.hs view
@@ -0,0 +1,11 @@+-- | This module contains details for external store implementations.++module LaunchDarkly.Server.Store+ ( StoreResult+ , FeatureKey+ , FeatureNamespace+ , StoreInterface(..)+ , RawFeature(..)+ ) where++import LaunchDarkly.Server.Store.Internal
+ src/LaunchDarkly/Server/Store/Internal.hs view
@@ -0,0 +1,350 @@+module LaunchDarkly.Server.Store.Internal+ ( isInitialized+ , getAllFlags+ , getFlag+ , getSegment+ , upsertFlag+ , upsertSegment+ , initialize+ , StoreResult+ , StoreResultM+ , StoreInterface(..)+ , RawFeature(..)+ , StoreHandle(..)+ , LaunchDarklyStoreRead(..)+ , LaunchDarklyStoreWrite(..)+ , Versioned(..)+ , makeStoreIO+ , insertFlag+ , deleteFlag+ , insertSegment+ , deleteSegment+ , initializeStore+ , versionedToRaw+ , FeatureKey+ , FeatureNamespace+ ) where++import Control.Monad (void)+import Control.Lens (Lens', (%~), (^.))+import Data.Aeson (ToJSON, FromJSON, encode, decode)+import Data.IORef (IORef, readIORef, atomicModifyIORef', newIORef)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict, fromStrict)+import Data.Text (Text)+import Data.Function ((&))+import Data.Maybe (isJust)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.Generics.Product (setField, getField, field)+import System.Clock (TimeSpec, Clock(Monotonic), getTime)+import GHC.Generics (Generic)+import GHC.Natural (Natural)++import LaunchDarkly.Server.Features (Segment, Flag)++-- Store result not defined in terms of StoreResultM so we dont have to export.+type StoreResultM m a = m (Either Text a)++-- | The result type for every `StoreInterface` function. Instead of throwing+-- an exception, any store related error should return `Left`. Exceptions+-- unrelated to the store should not be caught.+type StoreResult a = IO (Either Text a)++class LaunchDarklyStoreRead store m where+ getFlagC :: store -> Text -> StoreResultM m (Maybe Flag)+ getSegmentC :: store -> Text -> StoreResultM m (Maybe Segment)+ getAllFlagsC :: store -> StoreResultM m (HashMap Text Flag)+ getInitializedC :: store -> StoreResultM m Bool++class LaunchDarklyStoreWrite store m where+ storeInitializeC :: store -> HashMap Text (Versioned Flag) -> HashMap Text (Versioned Segment) -> StoreResultM m ()+ upsertSegmentC :: store -> Text -> Versioned (Maybe Segment) -> StoreResultM m ()+ upsertFlagC :: store -> Text -> Versioned (Maybe Flag) -> StoreResultM m ()++data StoreHandle m = StoreHandle+ { storeHandleGetFlag :: !(Text -> StoreResultM m (Maybe Flag))+ , storeHandleGetSegment :: !(Text -> StoreResultM m (Maybe Segment))+ , storeHandleAllFlags :: !(StoreResultM m (HashMap Text Flag))+ , storeHandleInitialized :: !(StoreResultM m Bool)+ , storeHandleInitialize :: !(HashMap Text (Versioned Flag) -> HashMap Text (Versioned Segment) -> StoreResultM m ())+ , storeHandleUpsertSegment :: !(Text -> Versioned (Maybe Segment) -> StoreResultM m ())+ , storeHandleUpsertFlag :: !(Text -> Versioned (Maybe Flag) -> StoreResultM m ())+ , storeHandleExpireAll :: !(StoreResultM m ())+ } deriving (Generic)++instance Monad m => LaunchDarklyStoreRead (StoreHandle m) m where+ getFlagC = storeHandleGetFlag+ getSegmentC = storeHandleGetSegment+ getAllFlagsC = storeHandleAllFlags+ getInitializedC = storeHandleInitialized++instance Monad m => LaunchDarklyStoreWrite (StoreHandle m) m where+ storeInitializeC = storeHandleInitialize+ upsertSegmentC = storeHandleUpsertSegment+ upsertFlagC = storeHandleUpsertFlag++initializeStore :: (LaunchDarklyStoreWrite store m, Monad m) => store+ -> HashMap Text Flag -> HashMap Text Segment -> StoreResultM m ()+initializeStore store flags segments = storeInitializeC store (makeVersioned flags) (makeVersioned segments)+ where makeVersioned = HM.map (\f -> Versioned f (getField @"version" f))++insertFlag :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Flag -> StoreResultM m ()+insertFlag store flag = upsertFlagC store (getField @"key" flag) $ Versioned (pure flag) (getField @"version" flag)++deleteFlag :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Text -> Natural -> StoreResultM m ()+deleteFlag store key version = upsertFlagC store key $ Versioned Nothing version++insertSegment :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Segment -> StoreResultM m ()+insertSegment store segment = upsertSegmentC store (getField @"key" segment) $ Versioned (pure segment) (getField @"version" segment)++deleteSegment :: (LaunchDarklyStoreWrite store m, Monad m) => store -> Text -> Natural -> StoreResultM m ()+deleteSegment store key version = upsertSegmentC store key $ Versioned Nothing version++makeStoreIO :: Maybe StoreInterface -> TimeSpec -> IO (StoreHandle IO)+makeStoreIO backend ttl = do+ state <- newIORef State+ { allFlags = Expirable HM.empty True 0+ , flags = HM.empty+ , segments = HM.empty+ , initialized = Expirable False True 0+ }+ let store = Store state backend ttl+ pure StoreHandle+ { storeHandleGetFlag = getFlag store+ , storeHandleGetSegment = getSegment store+ , storeHandleAllFlags = getAllFlags store+ , storeHandleInitialized = isInitialized store+ , storeHandleInitialize = initialize store+ , storeHandleUpsertSegment = upsertSegment store+ , storeHandleUpsertFlag = upsertFlag store+ , storeHandleExpireAll = expireAllItems store >> (pure $ Right ())+ }++data Expirable a = Expirable+ { value :: !a+ , forceExpire :: !Bool+ , updatedOn :: !TimeSpec+ } deriving (Generic)++data Versioned a = Versioned+ { value :: !a+ , version :: !Natural+ } deriving (Generic)++data State = State+ { allFlags :: !(Expirable (HashMap Text Flag))+ , flags :: !(HashMap Text (Expirable (Versioned (Maybe Flag))))+ , segments :: !(HashMap Text (Expirable (Versioned (Maybe Segment))))+ , initialized :: !(Expirable Bool)+ } deriving (Generic)++-- | Represents the key for a given feature.+type FeatureKey = Text+-- | Represents a namespace such as flags or segments+type FeatureNamespace = Text++-- | The interface implemented by external stores for use by the SDK.+data StoreInterface = StoreInterface+ { storeInterfaceAllFeatures :: !(FeatureNamespace -> StoreResult (HashMap Text RawFeature))+ -- ^ A map of all features in a given namespace including deleted.+ , storeInterfaceGetFeature :: !(FeatureNamespace -> FeatureKey -> StoreResult RawFeature)+ -- ^ Return the value of a key in a namespace.+ , storeInterfaceUpsertFeature :: !(FeatureNamespace -> FeatureKey -> RawFeature -> StoreResult Bool)+ -- ^ Upsert a given feature. Versions should be compared before upsert.+ -- The result should indicate if the feature was replaced or not.+ , storeInterfaceIsInitialized :: !(StoreResult Bool)+ -- ^ Checks if the external store has been initialized, which may+ -- have been done by another instance of the SDK.+ , storeInterfaceInitialize :: !(HashMap FeatureNamespace (HashMap FeatureKey RawFeature) -> StoreResult ())+ -- ^ A map of namespaces, and items in namespaces. The entire store state+ -- should be replaced with these values.+ }++-- | An abstract representation of a store object.+data RawFeature = RawFeature+ { rawFeatureBuffer :: !(Maybe ByteString)+ -- ^ A serialized item. If the item is deleted or does not exist this+ -- should be `Nothing`.+ , rawFeatureVersion :: !Natural+ -- ^ The version of a given item. If the item does not exist this should+ -- be zero.+ }++data Store = Store+ { state :: !(IORef State)+ , backend :: !(Maybe StoreInterface)+ , timeToLive :: !TimeSpec+ } deriving (Generic)++expireAllItems :: Store -> IO ()+expireAllItems store = atomicModifyIORef' (getField @"state" store) $ \state -> (, ()) $ state+ & field @"allFlags" %~ expire+ & field @"initialized" %~ expire+ & field @"flags" %~ HM.map expire+ & field @"segments" %~ HM.map expire+ where expire = setField @"forceExpire" True++isExpired :: Store -> TimeSpec -> Expirable a -> Bool+isExpired store now item = (isJust $ getField @"backend" store) && ((getField @"forceExpire" item)+ || (getField @"timeToLive" store) + (getField @"updatedOn" item) < now)++getMonotonicTime :: IO TimeSpec+getMonotonicTime = getTime Monotonic++initialize :: Store -> HashMap Text (Versioned Flag) -> HashMap Text (Versioned Segment) -> StoreResult ()+initialize store flags segments = case getField @"backend" store of+ Nothing -> do+ atomicModifyIORef' (getField @"state" store) $ \state -> (, ()) $ state+ & setField @"flags" (HM.map (\f -> Expirable f True 0) $ c flags)+ & setField @"segments" (HM.map (\f -> Expirable f True 0) $ c segments)+ & setField @"allFlags" (Expirable (HM.map (getField @"value") flags) True 0)+ & setField @"initialized" (Expirable True False 0)+ pure $ Right ()+ Just backend -> (storeInterfaceInitialize backend) raw >>= \case+ Left err -> pure $ Left err+ Right () -> expireAllItems store >> pure (Right ())+ where+ raw = HM.empty+ & HM.insert "flags" (HM.map versionedToRaw $ c flags)+ & HM.insert "segments" (HM.map versionedToRaw $ c segments)+ c x = HM.map (\f -> f & field @"value" %~ Just) x++rawToVersioned :: (FromJSON a) => RawFeature -> Maybe (Versioned (Maybe a))+rawToVersioned raw = case rawFeatureBuffer raw of+ Nothing -> pure $ Versioned Nothing (rawFeatureVersion raw)+ Just buffer -> case decode $ fromStrict buffer of+ Nothing -> Nothing+ Just decoded -> pure $ Versioned decoded (rawFeatureVersion raw)++versionedToRaw :: (ToJSON a) => Versioned (Maybe a) -> RawFeature+versionedToRaw versioned = case getField @"value" versioned of+ Nothing -> RawFeature Nothing $ getField @"version" versioned+ Just x -> RawFeature (pure $ toStrict $ encode x) $ getField @"version" versioned++tryGetBackend :: (FromJSON a) => StoreInterface -> Text -> Text -> StoreResult (Versioned (Maybe a))+tryGetBackend backend namespace key =+ ((storeInterfaceGetFeature backend) namespace key) >>= \case+ Left err -> pure $ Left err+ Right raw -> case rawToVersioned raw of+ Nothing -> pure $ Left "failed to decode from external store"+ Just versioned -> pure $ Right versioned++getGeneric :: FromJSON a => Store -> Text -> Text+ -> Lens' State (HashMap Text (Expirable (Versioned (Maybe a))))+ -> StoreResult (Maybe a)+getGeneric store namespace key lens = do+ state <- readIORef $ getField @"state" store+ case getField @"backend" store of+ Nothing -> case HM.lookup key (state ^. lens) of+ Nothing -> pure $ Right Nothing+ Just x -> pure $ Right $ getField @"value" $ getField @"value" x+ Just backend -> do+ now <- getMonotonicTime+ case HM.lookup key (state ^. lens) of+ Nothing -> updateFromBackend backend now+ Just x -> if isExpired store now x+ then updateFromBackend backend now+ else pure $ Right $ getField @"value" $ getField @"value" x+ where+ updateFromBackend backend now = tryGetBackend backend namespace key >>= \case+ Left err -> pure $ Left err+ Right v -> do+ atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $ stateRef & lens %~+ (HM.insert key (Expirable v False now))+ pure $ Right $ getField @"value" v++getFlag :: Store -> Text -> StoreResult (Maybe Flag)+getFlag store key = getGeneric store "flags" key (field @"flags")++getSegment :: Store -> Text -> StoreResult (Maybe Segment)+getSegment store key = getGeneric store "segments" key (field @"segments")++upsertGeneric :: (ToJSON a) => Store -> Text -> Text -> Versioned (Maybe a)+ -> Lens' State (HashMap Text (Expirable (Versioned (Maybe a))))+ -> (Bool -> State -> State)+ -> StoreResult ()+upsertGeneric store namespace key versioned lens action = do+ case getField @"backend" store of+ Nothing -> do+ void $ atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $ upsertMemory stateRef+ pure $ Right ()+ Just backend -> do+ result <- (storeInterfaceUpsertFeature backend) namespace key (versionedToRaw versioned)+ case result of+ Left err -> pure $ Left err+ Right updated -> if not updated then pure (Right ()) else do+ now <- getMonotonicTime+ void $ atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $ stateRef+ & lens %~ (HM.insert key (Expirable versioned False now))+ & action True+ pure $ Right ()+ where+ upsertMemory state = case HM.lookup key (state ^. lens) of+ Nothing -> updateMemory state+ Just existing -> if (getField @"version" $ getField @"value" existing) < getField @"version" versioned+ then updateMemory state else state+ updateMemory state = state+ & lens %~ (HM.insert key (Expirable versioned False 0))+ & action False++upsertFlag :: Store -> Text -> Versioned (Maybe Flag) -> StoreResult ()+upsertFlag store key versioned = upsertGeneric store "flags" key versioned (field @"flags") postAction where+ postAction external state = if external+ then state & field @"allFlags" %~ (setField @"forceExpire" True)+ else state & (field @"allFlags" . field @"value") %~ updateAllFlags+ updateAllFlags allFlags = case getField @"value" versioned of+ Nothing -> HM.delete key allFlags+ Just flag -> HM.insert key flag allFlags++upsertSegment :: Store -> Text -> Versioned (Maybe Segment) -> StoreResult ()+upsertSegment store key versioned = upsertGeneric store "segments" key versioned (field @"segments") postAction where+ postAction _ state = state++filterAndCacheFlags :: Store -> TimeSpec -> HashMap Text RawFeature -> IO (HashMap Text Flag)+filterAndCacheFlags store now raw = do+ let decoded = HM.mapMaybe rawToVersioned raw+ allFlags = HM.mapMaybe (getField @"value") decoded+ atomicModifyIORef' (getField @"state" store) $ \state -> (, ()) $+ setField @"allFlags" (Expirable allFlags False now) $+ setField @"flags" (HM.map (\x -> Expirable x False now) decoded) state+ pure allFlags++getAllFlags :: Store -> StoreResult (HashMap Text Flag)+getAllFlags store = do+ state <- readIORef $ getField @"state" store+ let memoryFlags = pure $ Right $ getField @"value" $ getField @"allFlags" state+ case getField @"backend" store of+ Nothing -> memoryFlags+ Just backend -> do+ now <- getMonotonicTime+ if not (isExpired store now $ getField @"allFlags" state)+ then memoryFlags+ else do+ result <- (storeInterfaceAllFeatures backend) "flags"+ case result of+ Left err -> pure (Left err)+ Right raw -> do+ filtered <- filterAndCacheFlags store now raw+ pure (Right filtered)++isInitialized :: Store -> StoreResult Bool+isInitialized store = do+ state <- readIORef $ getField @"state" store+ let initialized = getField @"initialized" state+ if getField @"value" initialized+ then pure $ Right True+ else case getField @"backend" store of+ Nothing -> pure $ Right False+ Just backend -> do+ now <- getMonotonicTime+ if isExpired store now initialized+ then do+ result <- storeInterfaceIsInitialized backend+ case result of+ Left err -> pure $ Left err+ Right i -> do+ atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $+ setField @"initialized" (Expirable i False now) stateRef+ pure $ Right i+ else pure $ Right False
+ src/LaunchDarkly/Server/User.hs view
@@ -0,0 +1,94 @@+-- | This module is for configuration of the user object.++module LaunchDarkly.Server.User+ ( User+ , makeUser+ , userSetKey+ , userSetSecondary+ , userSetIP+ , userSetCountry+ , userSetEmail+ , userSetFirstName+ , userSetLastName+ , userSetAvatar+ , userSetName+ , userSetAnonymous+ , userSetCustom+ , userSetPrivateAttributeNames+ ) where++import Data.Aeson (Value)+import Data.Generics.Product (setField)+import Data.HashMap.Strict (HashMap)+import Data.Set (Set)+import Data.Text (Text)++import LaunchDarkly.Server.User.Internal (User(..), mapUser, UserI(..))++-- | Creates a new user identified by the given key.+makeUser :: Text -> User+makeUser key = User $ UserI+ { key = pure key+ , secondary = mempty+ , ip = mempty+ , country = mempty+ , email = mempty+ , firstName = mempty+ , lastName = mempty+ , avatar = mempty+ , name = mempty+ , anonymous = False+ , custom = mempty+ , privateAttributeNames = mempty+ }++-- | Set the primary key for a user.+userSetKey :: (Maybe Text) -> User -> User+userSetKey = mapUser . setField @"key"++-- | Set the secondary key for a user.+userSetSecondary :: Maybe Text -> User -> User+userSetSecondary = mapUser . setField @"secondary"++-- | Set the IP for a user.+userSetIP :: Maybe Text -> User -> User+userSetIP = mapUser . setField @"ip"++-- | Set the country for a user.+userSetCountry :: Maybe Text -> User -> User+userSetCountry = mapUser . setField @"country"++-- | Set the email for a user.+userSetEmail :: Maybe Text -> User -> User+userSetEmail = mapUser . setField @"email"++-- | Set the first name for a user.+userSetFirstName :: Maybe Text -> User -> User+userSetFirstName = mapUser . setField @"firstName"++-- | Set the last name for a user.+userSetLastName :: Maybe Text -> User -> User+userSetLastName = mapUser . setField @"lastName"++-- | Set the avatar for a user.+userSetAvatar :: Maybe Text -> User -> User+userSetAvatar = mapUser . setField @"avatar"++-- | Set the name for a user.+userSetName :: Maybe Text -> User -> User+userSetName = mapUser . setField @"name"++-- | Set if the user is anonymous or not.+userSetAnonymous :: Bool -> User -> User+userSetAnonymous = mapUser . setField @"anonymous"++-- | Set custom fields for a user.+userSetCustom :: HashMap Text Value -> User -> User+userSetCustom = mapUser . setField @"custom"++-- | This contains list of attributes to keep private, whether they appear at+-- the top-level or Custom The attribute "key" is always sent regardless of+-- whether it is in this list, and "custom" cannot be used to eliminate all+-- custom attributes+userSetPrivateAttributeNames :: Set Text -> User -> User+userSetPrivateAttributeNames = mapUser . setField @"privateAttributeNames"
+ src/LaunchDarkly/Server/User/Internal.hs view
@@ -0,0 +1,125 @@+module LaunchDarkly.Server.User.Internal+ ( User(..)+ , mapUser+ , UserI(..)+ , valueOf+ , userSerializeRedacted+ ) where++import Data.Aeson (FromJSON, ToJSON, Value(..), (.:?), withObject, object, parseJSON, toJSON)+import Data.Foldable (fold, or)+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 GHC.Generics (Generic)++import LaunchDarkly.Server.Config.Internal (ConfigI)++mapUser :: (UserI -> UserI) -> User -> User+mapUser f (User c) = User $ f c++-- | User contains specific attributes of a user of your application+--+-- The only mandatory property is the Key, which must uniquely identify+-- each user. For authenticated users, this may be a username or e-mail address.+-- For anonymous users, this could be an IP address or session ID.+newtype User = User { unwrapUser :: UserI }++data UserI = UserI+ { key :: !(Maybe Text)+ , secondary :: !(Maybe Text)+ , ip :: !(Maybe Text)+ , country :: !(Maybe Text)+ , email :: !(Maybe Text)+ , firstName :: !(Maybe Text)+ , lastName :: !(Maybe Text)+ , avatar :: !(Maybe Text)+ , name :: !(Maybe Text)+ , anonymous :: !Bool+ , custom :: !(HashMap Text Value)+ , privateAttributeNames :: !(Set Text)+ } deriving (Generic)++falseToNothing :: Bool -> Maybe Bool+falseToNothing x = if x then pure x else Nothing++emptyToNothing :: (Eq m, Monoid m) => m -> Maybe m+emptyToNothing x = if x == mempty then mempty else pure x++instance FromJSON UserI where+ parseJSON = withObject "User" $ \o -> UserI+ <$> o .:? "key"+ <*> o .:? "secondary"+ <*> o .:? "ip"+ <*> o .:? "country"+ <*> o .:? "email"+ <*> o .:? "firstName"+ <*> o .:? "lastName"+ <*> o .:? "avatar"+ <*> o .:? "name"+ <*> fmap or (o .:? "anonymous")+ <*> fmap fold (o .:? "custom")+ <*> fmap fold (o .:? "privateAttributeNames")++instance ToJSON UserI where+ toJSON user = object $ filter ((/=) Null . snd)+ [ ("key", toJSON $ getField @"key" user)+ , ("secondary", toJSON $ getField @"secondary" user)+ , ("ip", toJSON $ getField @"ip" user)+ , ("country", toJSON $ getField @"country" user)+ , ("email", toJSON $ getField @"email" user)+ , ("firstName", toJSON $ getField @"firstName" user)+ , ("lastName", toJSON $ getField @"lastName" user)+ , ("avatar", toJSON $ getField @"avatar" user)+ , ("name", toJSON $ getField @"name" user)+ , ("anonymous", toJSON $ falseToNothing $ getField @"anonymous" user)+ , ("custom", toJSON $ emptyToNothing $ getField @"custom" user)+ , ("privateAttributeNames", toJSON $ emptyToNothing $ getField @"privateAttributeNames" user)+ ]++valueOf :: UserI -> Text -> Maybe Value+valueOf user attribute = case attribute of+ "key" -> String <$> getField @"key" user+ "secondary" -> String <$> getField @"secondary" user+ "ip" -> String <$> getField @"ip" user+ "country" -> String <$> getField @"country" user+ "email" -> String <$> getField @"email" user+ "firstName" -> String <$> getField @"firstName" user+ "lastName" -> String <$> getField @"lastName" user+ "avatar" -> String <$> getField @"avatar" user+ "name" -> String <$> getField @"name" user+ "anonymous" -> pure $ Bool $ getField @"anonymous" user+ x -> HM.lookup x $ getField @"custom" user++userSerializeRedacted :: ConfigI -> UserI -> Value+userSerializeRedacted config user = if getField @"allAttributesPrivate" config+ then userSerializeAllPrivate user+ else userSerializeRedactedNotAllPrivate (getField @"privateAttributeNames" config) user++fromObject :: Value -> HashMap Text 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++setPrivateAttrs :: Set Text -> HashMap Text Value -> Value+setPrivateAttrs private redacted = Object $ HM.insert "privateAttrs" (Array $ V.fromList $ map String $ S.toList private) redacted++redact :: Set Text -> HashMap Text Value -> HashMap Text Value+redact private = HM.filterWithKey (\k _ -> S.notMember 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)++userSerializeRedactedNotAllPrivate :: Set Text -> UserI -> Value+userSerializeRedactedNotAllPrivate globalPrivate user = setPrivateAttrs private redacted where+ raw = HM.delete "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
+ stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis.hs view
@@ -0,0 +1,8 @@+module LaunchDarkly.Server.Store.Redis+ ( RedisStoreConfig+ , makeRedisStoreConfig+ , redisConfigSetNamespace+ , makeRedisStore+ ) where++import LaunchDarkly.Server.Store.Redis.Internal
+ stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs view
@@ -0,0 +1,135 @@+-- | The public interface for the LaunchDarkly Haskell Redis integration++module LaunchDarkly.Server.Store.Redis.Internal+ ( RedisStoreConfig+ , makeRedisStoreConfig+ , redisConfigSetNamespace+ , makeRedisStore+ , redisUpsertInternal+ ) where++import Data.Maybe (isJust)+import Control.Monad (forM_, void)+import Control.Monad.Catch (MonadCatch, Exception, catches, Handler(..))+import Control.Exception (throwIO)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (FromJSON, ToJSON, decode, encode)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict, fromStrict)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Typeable (Typeable)+import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict (HashMap)+import Data.Generics.Product (getField, setField)+import Database.Redis (ConnectionLostException, Reply, multiExec, runRedis, del, get+ , set, hget, hgetall, hset, watch, Redis, Connection, TxResult(..))+import GHC.Natural (Natural)+import GHC.Generics (Generic)++import LaunchDarkly.Server.Store (StoreInterface(..), RawFeature(..), StoreResult(..))++data MinimalFeature = MinimalFeature+ { key :: Text+ , version :: Natural+ , deleted :: Bool+ } deriving (Generic, ToJSON, FromJSON)++-- | Opaque type used to configure the Redis store integration.+data RedisStoreConfig = RedisStoreConfig+ { namespace :: Text+ , connection :: Connection+ }++-- | Create a default config from a given connection pool.+makeRedisStoreConfig :: Connection -> RedisStoreConfig+makeRedisStoreConfig connection = RedisStoreConfig+ { namespace = "LaunchDarkly"+ , connection = connection+ }++-- | Configure the Redis key prefix. All keys are prefixed by default before+-- being inserted into Redis. The default prefix is "LaunchDarkly".+redisConfigSetNamespace :: Text -> RedisStoreConfig -> RedisStoreConfig+redisConfigSetNamespace namespace' config = config { namespace = namespace' }++-- | Construct a `StoreInterface` that can then be used during SDK+-- configuration.+makeRedisStore :: RedisStoreConfig -> IO StoreInterface+makeRedisStore config = pure StoreInterface+ { storeInterfaceUpsertFeature = redisUpsert config+ , storeInterfaceGetFeature = redisGetFeature config+ , storeInterfaceInitialize = redisInitialize config+ , storeInterfaceIsInitialized = redisIsInitialized config+ , storeInterfaceAllFeatures = redisGetAll config+ }++data RedisError = RedisError Text deriving (Typeable, Show, Exception)++makeKey :: RedisStoreConfig -> Text -> ByteString+makeKey config key = encodeUtf8 $ T.concat [namespace config, ":", key]++exceptOnReply :: (MonadIO m) => Either Reply a -> m a+exceptOnReply = \case+ Left err -> liftIO $ throwIO $ RedisError $ T.pack $ show err+ Right x -> pure x++run :: RedisStoreConfig -> Redis a -> StoreResult a+run config action = catches (runRedis (connection config) action >>= pure . pure)+ [ Handler $ \(e :: ConnectionLostException) -> pure $ Left $ T.pack $ show e+ , Handler $ \(RedisError err) -> pure $ Left err+ ]++decodeMinimal :: ByteString -> Maybe MinimalFeature+decodeMinimal = decode . fromStrict++rawToOpaque :: ByteString -> RawFeature+rawToOpaque raw = case decodeMinimal raw of+ Nothing -> RawFeature Nothing 0+ Just decoded -> RawFeature (if getField @"deleted" decoded then Nothing else pure raw)+ (getField @"version" decoded)++opaqueToRep :: Text -> RawFeature -> ByteString+opaqueToRep key opaque = case rawFeatureBuffer opaque of+ Just buffer -> buffer+ Nothing -> toStrict $ encode $ MinimalFeature key (rawFeatureVersion opaque) True++redisInitialize :: RedisStoreConfig -> HashMap Text (HashMap Text RawFeature) -> StoreResult ()+redisInitialize config values = run config $ do+ del (map (makeKey config) $ HM.keys values) >>= void . exceptOnReply+ forM_ (HM.toList values) $ \(kind, features) -> forM_ (HM.toList features) $ \(key, feature) ->+ (hset (makeKey config kind) (encodeUtf8 key) $ opaqueToRep key feature) >>= void . exceptOnReply+ set (makeKey config "$inited") "" >>= void . exceptOnReply++redisUpsert :: RedisStoreConfig -> Text -> Text -> RawFeature -> StoreResult Bool+redisUpsert = redisUpsertInternal (pure ())++redisUpsertInternal :: IO () -> RedisStoreConfig -> Text -> Text -> RawFeature -> StoreResult Bool+redisUpsertInternal hook config kind key opaque = run config tryUpsert where+ tryUpsert = watch [space] >>= void . exceptOnReply >>+ hget space (encodeUtf8 key) >>= exceptOnReply >>= \x -> (liftIO hook) >> case x of+ Nothing -> doInsert+ (Just raw) -> case decodeMinimal raw of+ Nothing -> pure True+ Just decoded -> if getField @"version" decoded >= rawFeatureVersion opaque+ then pure False else doInsert+ space = makeKey config kind+ doInsert = multiExec (hset space (encodeUtf8 key) (opaqueToRep key opaque)) >>= \case+ TxSuccess _ -> pure True+ TxError err -> liftIO $ throwIO $ RedisError $ T.pack $ show err+ TxAborted -> tryUpsert++redisGetFeature :: RedisStoreConfig -> Text -> Text -> StoreResult RawFeature+redisGetFeature config kind key = run config $ hget (makeKey config kind) (encodeUtf8 key)+ >>= exceptOnReply >>= \case+ Nothing -> pure $ RawFeature Nothing 0+ (Just raw) -> pure $ rawToOpaque raw++redisIsInitialized :: RedisStoreConfig -> StoreResult Bool+redisIsInitialized config = run config $ get (makeKey config "$inited")+ >>= exceptOnReply >>= pure . isJust++redisGetAll :: RedisStoreConfig -> Text -> StoreResult (HashMap Text RawFeature)+redisGetAll config kind = run config $ hgetall (makeKey config kind)+ >>= exceptOnReply >>= pure . HM.map rawToOpaque . HM.fromList . map (\(k, v) -> (decodeUtf8 k, v))
+ test/Spec.hs view
@@ -0,0 +1,27 @@+module Main where++import Control.Monad (void)+import Test.HUnit (runTestTT, Test(TestList))++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.Store+import qualified Spec.StoreInterface+import qualified Spec.Redis++main :: IO ()+main = void $ runTestTT $ TestList+ [ Spec.Operators.allTests+ , Spec.Bucket.allTests+ , Spec.Segment.allTests+ , Spec.Streaming.allTests+ , Spec.User.allTests+ , Spec.Evaluate.allTests+ , Spec.Store.allTests+ , Spec.StoreInterface.allTests+ , Spec.Redis.allTests+ ]
+ test/Spec/Bucket.hs view
@@ -0,0 +1,70 @@+module Spec.Bucket (allTests) where++import Test.HUnit+import Data.Aeson.Types (Value(..))+import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict (HashMap)+import Data.Function ((&))++import LaunchDarkly.Server.User+import LaunchDarkly.Server.User.Internal+import LaunchDarkly.Server.Client+import LaunchDarkly.Server.Features+import LaunchDarkly.Server.Evaluate++testBucketUserByKey :: Test+testBucketUserByKey = TestList+ [ TestCase $ assertEqual "bucket one" 0.42157587 (bucketUser (unwrapUser $ makeUser "userKeyA") "hashKey" "key" "saltyA")+ , TestCase $ assertEqual "bucket two" 0.6708485 (bucketUser (unwrapUser $ makeUser "userKeyB") "hashKey" "key" "saltyA")+ , TestCase $ assertEqual "bucket three" 0.10343106 (bucketUser (unwrapUser $ makeUser "userKeyC") "hashKey" "key" "saltyA")+ ]++testBucketUserByIntAttr :: Test+testBucketUserByIntAttr = TestList+ [ TestCase $ assertEqual "intAttr" 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyD")+ & userSetCustom (HM.singleton "intAttr" (Number 33333))) "hashKey" "intAttr" "saltyA"+ , TestCase $ assertEqual "stringAttr" 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyD")+ & userSetCustom (HM.singleton "stringAttr" (String "33333"))) "hashKey" "stringAttr" "saltyA"+ ]++testBucketUserByFloatAttrNotAllowed :: Test+testBucketUserByFloatAttrNotAllowed = (~=?) 0 $ bucketUser (unwrapUser $ (makeUser "userKeyE")+ & userSetCustom (HM.singleton "floatAttr" (Number 999.999))) "hashKey" "floatAttr" "saltyA"++testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed :: Test+testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed = (~=?) 0.54771423 $ bucketUser (unwrapUser $ (makeUser "userKeyE")+ & userSetCustom (HM.singleton "floatAttr" (Number 33333))) "hashKey" "floatAttr" "saltyA"++testVariationIndexForUser :: Test+testVariationIndexForUser = TestCase $ do+ assertEqual "test" (Just 0) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyA") "hashKey" "saltyA"+ assertEqual "test" (Just 1) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyB") "hashKey" "saltyA"+ assertEqual "test" (Just 0) $ variationIndexForUser rollout (unwrapUser $ makeUser "userKeyC") "hashKey" "saltyA"++ where++ rollout = VariationOrRollout+ { variation = Nothing+ , rollout = Just Rollout+ { bucketBy = Nothing+ , variations =+ [ WeightedVariation+ { variation = 0+ , weight = 60000+ }+ , WeightedVariation+ { variation = 1+ , weight = 40000+ }+ ]+ }+ }++allTests :: Test+allTests = TestList+ [ testBucketUserByKey+ , testBucketUserByIntAttr+ , testBucketUserByFloatAttrNotAllowed+ , testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed+ , testVariationIndexForUser+ ]
+ test/Spec/Evaluate.hs view
@@ -0,0 +1,432 @@+module Spec.Evaluate (allTests) where++import Test.HUnit+import Data.Aeson+import Data.Aeson.Types (Value(..))+import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict (HashMap)+import Data.Function ((&))+import Data.Generics.Product (getField)++import LaunchDarkly.Server.Store+import LaunchDarkly.Server.Store.Internal+import LaunchDarkly.Server.Client+import LaunchDarkly.Server.Client.Internal+import LaunchDarkly.Server.User+import LaunchDarkly.Server.User.Internal+import LaunchDarkly.Server.Features+import LaunchDarkly.Server.Operators+import LaunchDarkly.Server.Details+import LaunchDarkly.Server.Store.Internal+import LaunchDarkly.Server.Evaluate+import LaunchDarkly.Server.Config++import Util.Features++testFlagReturnsOffVariationIfFlagIsOff :: Test+testFlagReturnsOffVariationIfFlagIsOff = TestCase $ do+ store <- makeStoreIO Nothing 0+ x <- evaluateDetail flag user store+ assertEqual "test" expected x++ where++ expected = (EvaluationDetail+ { value = String "off"+ , variationIndex = pure 1+ , reason = EvaluationReasonOff+ }, [])++ user = unwrapUser $ makeUser "x"++ flag = Flag+ { key = "feature"+ , version = 1+ , on = False+ , trackEvents = False+ , trackEventsFallthrough = False+ , deleted = False+ , prerequisites = []+ , salt = ""+ , sel = ""+ , targets = []+ , rules = []+ , fallthrough = VariationOrRollout+ { variation = Just 0+ , rollout = Nothing+ }+ , offVariation = Just 1+ , variations = [String "fall", String "off", String "on"]+ , debugEventsUntilDate = Nothing+ }++testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules :: Test+testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules = TestCase $ do+ store <- makeStoreIO Nothing 0+ x <- evaluateDetail flag user store+ assertEqual "test" expected x++ where++ expected = (EvaluationDetail+ { value = String "fall"+ , variationIndex = pure 0+ , reason = EvaluationReasonFallthrough+ }, [])++ user = unwrapUser $ makeUser "x"++ flag = Flag+ { key = "feature"+ , version = 1+ , on = True+ , trackEvents = False+ , trackEventsFallthrough = False+ , deleted = False+ , prerequisites = []+ , salt = ""+ , sel = ""+ , targets = []+ , rules = []+ , fallthrough = VariationOrRollout+ { variation = Just 0+ , rollout = Nothing+ }+ , offVariation = Just 1+ , variations = [String "fall", String "off", String "on"]+ , debugEventsUntilDate = Nothing+ }++testFlagReturnsErrorIfFallthroughHasTooHighVariation :: Test+testFlagReturnsErrorIfFallthroughHasTooHighVariation = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag >>= (pure () @=?)+ stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)+ where+ flag = (makeTestFlag "a" 52)+ { on = True+ , offVariation = Nothing+ , fallthrough = VariationOrRollout+ { variation = Just 999+ , rollout = Nothing+ }+ , variations =+ [ String "abc"+ , String "123"+ , String "456"+ ]+ }+ expected = EvaluationDetail+ { value = "default"+ , variationIndex = Nothing+ , reason = EvaluationReasonError EvalErrorKindMalformedFlag+ }++testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout :: Test+testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag >>= (pure () @=?)+ stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)+ where+ flag = (makeTestFlag "a" 52)+ { on = True+ , offVariation = Nothing+ , fallthrough = VariationOrRollout+ { variation = Nothing+ , rollout = Nothing+ }+ , variations = [String "abc"]+ }+ expected = EvaluationDetail+ { value = "default"+ , variationIndex = Nothing+ , reason = EvaluationReasonError EvalErrorKindMalformedFlag+ }++testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList :: Test+testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag >>= (pure () @=?)+ stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)+ where+ flag = (makeTestFlag "a" 52)+ { on = True+ , offVariation = Nothing+ , fallthrough = VariationOrRollout+ { variation = Nothing+ , rollout = pure Rollout+ { variations = []+ , bucketBy = pure "key"+ }+ }+ , variations = [String "abc"]+ }+ expected = EvaluationDetail+ { value = "default"+ , variationIndex = Nothing+ , reason = EvaluationReasonError EvalErrorKindMalformedFlag+ }++testFlagReturnsOffVariationIfPrerequisiteIsNotFound :: Test+testFlagReturnsOffVariationIfPrerequisiteIsNotFound = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag >>= (pure () @=?)+ stringVariationDetail client "a" (makeUser "b") "default" >>= (expected @=?)+ where+ flag = (makeTestFlag "a" 52)+ { on = True+ , offVariation = pure 1+ , fallthrough = VariationOrRollout+ { variation = pure 0+ , rollout = Nothing+ }+ , variations = [String "fall", String "off", String "on"]+ , prerequisites =+ [ Prerequisite+ { key = "feature1"+ , variation = 1+ }+ ]+ }+ expected = EvaluationDetail+ { value = "off"+ , variationIndex = pure 1+ , reason = EvaluationReasonPrerequisiteFailed "feature1"+ }++testFlagReturnsOffVariationIfPrerequisiteIsOff :: Test+testFlagReturnsOffVariationIfPrerequisiteIsOff = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag0 >>= (pure () @=?)+ insertFlag (getField @"store" clientI) flag1 >>= (pure () @=?)+ stringVariationDetail client "feature0" (makeUser "b") "default" >>= (expected @=?)+ where+ flag0 = (makeTestFlag "feature0" 52)+ { on = True+ , offVariation = pure 1+ , fallthrough = VariationOrRollout+ { variation = pure 0+ , rollout = Nothing+ }+ , variations = [String "fall", String "off", String "on"]+ , prerequisites =+ [ Prerequisite+ { key = "feature1"+ , variation = 1+ }+ ]+ }+ flag1 = (makeTestFlag "feature1" 52)+ { on = False+ , offVariation = pure 1+ , fallthrough = VariationOrRollout+ { variation = pure 0+ , rollout = Nothing+ }+ , variations = [String "nogo", String "go"]+ }+ expected = EvaluationDetail+ { value = "off"+ , variationIndex = pure 1+ , reason = EvaluationReasonPrerequisiteFailed "feature1"+ }++testFlagReturnsOffVariationIfPrerequisiteIsNotMet :: Test+testFlagReturnsOffVariationIfPrerequisiteIsNotMet = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag0 >>= (pure () @=?)+ insertFlag (getField @"store" clientI) flag1 >>= (pure () @=?)+ stringVariationDetail client "feature0" (makeUser "b") "default" >>= (expected @=?)+ where+ flag0 = (makeTestFlag "feature0" 52)+ { on = True+ , offVariation = pure 1+ , fallthrough = VariationOrRollout+ { variation = pure 0+ , rollout = Nothing+ }+ , variations = [String "fall", String "off", String "on"]+ , prerequisites =+ [ Prerequisite+ { key = "feature1"+ , variation = 1+ }+ ]+ }+ flag1 = (makeTestFlag "feature1" 52)+ { on = True+ , offVariation = pure 1+ , fallthrough = VariationOrRollout+ { variation = pure 0+ , rollout = Nothing+ }+ , variations = [String "nogo", String "go"]+ }+ expected = EvaluationDetail+ { value = "off"+ , variationIndex = pure 1+ , reason = EvaluationReasonPrerequisiteFailed "feature1"+ }++testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules :: Test+testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag0 >>= (pure () @=?)+ insertFlag (getField @"store" clientI) flag1 >>= (pure () @=?)+ stringVariationDetail client "feature0" (makeUser "b") "default" >>= (expected @=?)+ where+ flag0 = (makeTestFlag "feature0" 52)+ { on = True+ , offVariation = pure 1+ , fallthrough = VariationOrRollout+ { variation = pure 0+ , rollout = Nothing+ }+ , variations = [String "fall", String "off", String "on"]+ , prerequisites =+ [ Prerequisite+ { key = "feature1"+ , variation = 1+ }+ ]+ }+ flag1 = (makeTestFlag "feature1" 52)+ { on = True+ , offVariation = pure 1+ , fallthrough = VariationOrRollout+ { variation = pure 1+ , rollout = Nothing+ }+ , variations = [String "nogo", String "go"]+ }+ expected = EvaluationDetail+ { value = "fall"+ , variationIndex = pure 0+ , reason = EvaluationReasonFallthrough+ }++testClauseCanMatchCustomAttribute :: Test+testClauseCanMatchCustomAttribute = TestCase $ do+ store <- makeStoreIO Nothing 0+ x <- evaluateDetail flag user store+ assertEqual "test" expected x++ where++ expected = (EvaluationDetail+ { value = Bool True+ , variationIndex = pure 1+ , reason = EvaluationReasonRuleMatch+ { ruleIndex = 0+ , ruleId = "clause"+ }+ }, [])++ user = unwrapUser $ (makeUser "x")+ & userSetName (pure "bob")+ & userSetCustom (HM.fromList [("legs", Number 4)])++ flag = Flag+ { key = "feature"+ , version = 1+ , on = True+ , trackEvents = False+ , trackEventsFallthrough = False+ , deleted = False+ , prerequisites = []+ , salt = ""+ , sel = ""+ , targets = []+ , rules =+ [ Rule+ { clauses =+ [ Clause+ { attribute = "name"+ , op = OpIn+ , values = [String "bob"]+ , negate = False+ }+ ]+ , variationOrRollout = VariationOrRollout+ { variation = Just 1+ , rollout = Nothing+ }+ , id = "clause"+ , trackEvents = False+ }+ ]+ , fallthrough = VariationOrRollout+ { variation = Just 0+ , rollout = Nothing+ }+ , offVariation = Just 0+ , variations = [Bool False, Bool True]+ , debugEventsUntilDate = Nothing+ }++makeTestClient :: IO Client+makeTestClient = do+ (Client client) <- makeClient $ (makeConfig "") & configSetOffline True+ setStatus client Initialized+ pure (Client client)++testEvaluatingUnknownFlagReturnsDefault :: Test+testEvaluatingUnknownFlagReturnsDefault = TestCase $ do+ client <- makeTestClient+ boolVariation client "a" (makeUser "b") False >>= (False @=?)++testEvaluatingUnknownFlagReturnsDefaultWithDetail :: Test+testEvaluatingUnknownFlagReturnsDefaultWithDetail = TestCase $ do+ client <- makeTestClient+ boolVariationDetail client "a" (makeUser "b") False >>= (expected @=?)+ where+ expected = EvaluationDetail+ { value = False+ , variationIndex = Nothing+ , reason = EvaluationReasonError EvalErrorFlagNotFound+ }++testDefaultIsReturnedIfFlagEvaluatesToNil :: Test+testDefaultIsReturnedIfFlagEvaluatesToNil = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag >>= (pure () @=?)+ boolVariation client "a" (makeUser "b") False >>= (False @=?)+ where+ flag = (makeTestFlag "a" 52)+ { on = False+ , offVariation = Nothing+ }++testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail :: Test+testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail = TestCase $ do+ client@(Client clientI) <- makeTestClient+ insertFlag (getField @"store" clientI) flag >>= (pure () @=?)+ boolVariationDetail client "a" (makeUser "b") False >>= (expected @=?)+ where+ flag = (makeTestFlag "a" 52)+ { on = False+ , offVariation = Nothing+ }+ expected = EvaluationDetail+ { value = False+ , variationIndex = Nothing+ , reason = EvaluationReasonOff+ }++allTests :: Test+allTests = TestList+ [ testFlagReturnsOffVariationIfFlagIsOff+ , testFlagReturnsFallthroughIfFlagIsOnAndThereAreNoRules+ , testFlagReturnsErrorIfFallthroughHasTooHighVariation+ , testFlagReturnsErrorIfFallthroughHasNeitherVariationNorRollout+ , testFlagReturnsErrorIfFallthroughHasEmptyRolloutVariationList+ , testFlagReturnsOffVariationIfPrerequisiteIsNotFound+ , testFlagReturnsOffVariationIfPrerequisiteIsOff+ , testFlagReturnsOffVariationIfPrerequisiteIsNotMet+ , testFlagReturnsFallthroughVariationIfPrerequisiteIsMetAndThereAreNoRules+ , testClauseCanMatchCustomAttribute+ , testEvaluatingUnknownFlagReturnsDefault+ , testEvaluatingUnknownFlagReturnsDefaultWithDetail+ , testDefaultIsReturnedIfFlagEvaluatesToNil+ , testDefaultIsReturnedIfFlagEvaluatesToNilWithDetail+ ]
+ test/Spec/Operators.hs view
@@ -0,0 +1,100 @@+module Spec.Operators (allTests) where++import Test.HUnit+import Data.Aeson.Types (Value(..))++import LaunchDarkly.Server.Operators++dateStr1 :: Value+dateStr1 = String "2017-12-06T00:00:00.000-07:00"++dateStr2 :: Value+dateStr2 = String "2017-12-06T00:01:01.000-07:00"++invalidDate :: Value+invalidDate = String "hey what's this?"++dateMs1 :: Value+dateMs1 = Number $ fromInteger 10000000++dateMs2 :: Value+dateMs2 = Number $ fromInteger 10000001++makeTest :: (Op, Value, Value, Bool) -> Test+makeTest f@(o, x, y, e) = TestCase $ assertEqual (show f) e $ (getOperation o) x y++allTests :: Test+allTests = TestList $ map makeTest+ -- numeric operators+ [ (OpIn, Number $ fromInteger 50, Number $ fromInteger 50, True)+ , (OpIn, Number $ fromRational 99.0001, Number $ fromRational 99.0001, True)+ , (OpLessThan, Number $ fromInteger 1, Number $ fromRational 1.99999, True)+ , (OpLessThan, Number $ fromRational 1.99999, Number $ fromInteger 1, False)+ , (OpLessThan, Number $ fromInteger 1, Number $ fromInteger 2, True)+ , (OpLessThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True)+ , (OpGreaterThan, Number $ fromInteger 2, Number $ fromRational 1.99999, True)+ , (OpGreaterThan, Number $ fromRational 1.99999, Number $ fromInteger 2, False)+ , (OpGreaterThan, Number $ fromInteger 2, Number $ fromInteger 1, True)+ , (OpGreaterThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True)+ -- string operators+ , (OpIn, String "x", String "x", True)+ , (OpIn, String "x", String "xyz", False)+ , (OpStartsWith, String "xyz", String "x", True)+ , (OpStartsWith, String "x", String "xyz", False)+ , (OpEndsWith, String "xyz", String "z", True)+ , (OpEndsWith, String "z", String "xyz", False)+ , (OpContains, String "xyz", String "y", True)+ , (OpContains, String "y", String "yz", False)+ -- mixed strings and numbers+ , (OpIn, String "99", Number $ fromInteger 99, False)+ , (OpIn, Number $ fromInteger 99, String "99", False)+ , (OpContains, String "99", Number $ fromInteger 99, False)+ , (OpStartsWith, String "99", Number $ fromInteger 99, False)+ , (OpEndsWith, String "99", Number $ fromInteger 99, False)+ , (OpLessThanOrEqual, String "99", Number $ fromInteger 99, False)+ , (OpLessThanOrEqual, Number $ fromInteger 99, String "99", False)+ , (OpGreaterThanOrEqual, String "99", Number $ fromInteger 99, False)+ , (OpGreaterThanOrEqual, Number $ fromInteger 99, String "99", False)+ -- date operators+ , (OpBefore, dateStr1, dateStr2, True)+ , (OpBefore, dateMs1, dateMs2, True)+ , (OpBefore, dateStr2, dateStr1, False)+ , (OpBefore, dateMs2, dateMs1, False)+ , (OpBefore, dateStr1, dateStr1, False)+ , (OpBefore, dateMs1, dateMs1, False)+ , (OpBefore, String "", dateStr1, False)+ , (OpBefore, dateStr1, invalidDate, False)+ , (OpAfter, dateStr2, dateStr1, True)+ , (OpAfter, dateMs2, dateMs1, True)+ , (OpAfter, dateStr1, dateStr2, False)+ , (OpAfter, dateMs1, dateMs2, False)+ , (OpAfter, dateStr1, dateStr1, False)+ , (OpAfter, dateMs1, dateMs1, False)+ , (OpAfter, String "", dateStr1, False)+ , (OpAfter, dateStr1, invalidDate, False)+ -- regex+ , (OpMatches, String "hello world", String "hello.*rld", True)+ , (OpMatches, String "hello world", String "hello.*orl", True)+ , (OpMatches, String "hello world", String "l+", True)+ , (OpMatches, String "hello world", String "(world|planet)", True)+ , (OpMatches, String "hello world", String "aloha", False)+ , (OpMatches, String "hello world", String "***bad rg", False)+ -- semver operators+ , (OpSemVerEqual, String "2.0.0", String "2.0.0", True)+ , (OpSemVerEqual, String "2.0", String "2.0.0", True)+ , (OpSemVerEqual, String "2.0-rc1", String "2.0.0-rc1", True)+ , (OpSemVerEqual, String "2+build2", String "2.0.0+build2", True)+ , (OpSemVerEqual, String "2.0.0", String "2.0.1", False)+ , (OpSemVerEqual, String "02.0.0", String "2.0.0", False)+ , (OpSemVerLessThan, String "2.0.0", String "2.0.1", True)+ , (OpSemVerLessThan, String "2.0", String "2.0.1", True)+ , (OpSemVerLessThan, String "2.0.1", String "2.0.0", False)+ , (OpSemVerLessThan, String "2.0.1", String "2.0", False)+ , (OpSemVerLessThan, String "2.0.1", String "xbad%ver", False)+ , (OpSemVerLessThan, String "2.0.0-rc", String "2.0.0-rc.beta", True)+ , (OpSemVerGreaterThan, String "2.0.1", String "2.0", True)+ , (OpSemVerGreaterThan, String "2.0.0", String "2.0.1", False)+ , (OpSemVerGreaterThan, String "2.0", String "2.0.1", False)+ , (OpSemVerGreaterThan, String "2.0.1", String "xbad%ver", False)+ , (OpSemVerGreaterThan, String "2.0.0-rc.1", String "2.0.0-rc.0", True)+ ]
+ test/Spec/Redis.hs view
@@ -0,0 +1,49 @@+module Spec.Redis (allTests) where++import Test.HUnit+import Data.Text (Text)+import qualified Database.Redis as R+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Control.Monad (void)+import GHC.Natural (Natural)+import GHC.Int (Int64)+import System.Clock (TimeSpec(..))++import Util.Features (makeTestFlag)++import Spec.Store (testWithStore)++import LaunchDarkly.Server.Features (Flag(..), VariationOrRollout(..))+import LaunchDarkly.Server.Store.Internal+import LaunchDarkly.Server.Store.Redis.Internal++freshConnection :: IO R.Connection+freshConnection = do+ con <- R.checkedConnect R.defaultConnectInfo+ void $ R.runRedis con $ R.flushall+ pure con++testUpsertRace :: Test+testUpsertRace = TestCase $ do+ con <- freshConnection+ let config = makeRedisStoreConfig con+ backend <- makeRedisStore config+ store <- makeStoreIO (pure backend) $ TimeSpec 0 0+ let hook = (insertFlag store $ makeTestFlag "a" 2) >>= (Right () @=?)+ redisUpsertInternal hook config "flags" "a" (versionedToRaw $ Versioned (pure $ makeTestFlag "a" 1) 1)+ >>= (Right False @=?)+ getFlagC store "a" >>= (Right (pure $ makeTestFlag "a" 2) @=?)++prepareRedisStore :: Int64 -> IO (StoreHandle IO)+prepareRedisStore ttl = do+ con <- freshConnection+ backend <- makeRedisStore $ makeRedisStoreConfig con+ makeStoreIO (pure backend) $ TimeSpec ttl 0++allTests :: Test+allTests = TestList+ [ testWithStore $ prepareRedisStore 10+ , testWithStore $ prepareRedisStore 0+ , testUpsertRace+ ]
+ test/Spec/Segment.hs view
@@ -0,0 +1,209 @@+module Spec.Segment (allTests) where++import Test.HUnit+import Data.Aeson.Types (Value(..))+import Data.Function ((&))+import qualified Data.HashSet as HS++import LaunchDarkly.Server.Client+import LaunchDarkly.Server.Features+import LaunchDarkly.Server.User+import LaunchDarkly.Server.User.Internal+import LaunchDarkly.Server.Operators+import LaunchDarkly.Server.Evaluate++testExplicitIncludeUser :: Test+testExplicitIncludeUser = True ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.fromList ["foo"]+ , excluded = HS.empty+ , salt = "abcdef"+ , rules = []+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ makeUser "foo"++testExplicitExcludeUser :: Test+testExplicitExcludeUser = False ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.empty+ , excluded = HS.fromList ["foo"]+ , salt = "abcdef"+ , rules = []+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ makeUser "foo"++testExplicitIncludeHasPrecedence :: Test+testExplicitIncludeHasPrecedence = True ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.fromList ["foo"]+ , excluded = HS.fromList ["foo"]+ , salt = "abcdef"+ , rules = []+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ makeUser "foo"++testNeitherIncludedNorExcluded :: Test+testNeitherIncludedNorExcluded = False ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.fromList [""]+ , excluded = HS.fromList [""]+ , salt = "abcdef"+ , rules = []+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ makeUser "foo"++testMatchingRuleWithFullRollout :: Test+testMatchingRuleWithFullRollout = True ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.empty+ , excluded = HS.empty+ , salt = "abcdef"+ , rules =+ [ SegmentRule+ { id = "rule"+ , clauses =+ [ Clause+ { attribute = "email"+ , negate = False+ , op = OpIn+ , values = [String "test@example.com"]+ }+ ]+ , weight = Just 100000+ , bucketBy = Nothing+ }+ ]+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ (makeUser "foo") & userSetEmail (pure "test@example.com")++testMatchingRuleWithZeroRollout :: Test+testMatchingRuleWithZeroRollout = False ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.empty+ , excluded = HS.empty+ , salt = "abcdef"+ , rules =+ [ SegmentRule+ { id = "rule"+ , clauses =+ [ Clause+ { attribute = "email"+ , negate = False+ , op = OpIn+ , values = [String "test@example.com"]+ }+ ]+ , weight = Just 0+ , bucketBy = Nothing+ }+ ]+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ (makeUser "foo") & userSetEmail (pure "test@example.com")++testMatchingRuleWithMultipleClauses :: Test+testMatchingRuleWithMultipleClauses = True ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.empty+ , excluded = HS.empty+ , salt = "abcdef"+ , rules =+ [ SegmentRule+ { id = "rule"+ , clauses =+ [ Clause+ { attribute = "email"+ , negate = False+ , op = OpIn+ , values = [String "test@example.com"]+ }+ , Clause+ { attribute = "name"+ , negate = False+ , op = OpIn+ , values = ["bob"]+ }+ ]+ , weight = Nothing+ , bucketBy = Nothing+ }+ ]+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ (makeUser "foo")+ & userSetEmail (pure "test@example.com")+ & userSetName (pure "bob")++testNonMatchingRuleWithMultipleClauses :: Test+testNonMatchingRuleWithMultipleClauses = False ~=? (segmentContainsUser segment user) where+ segment = Segment+ { key = "test"+ , included = HS.empty+ , excluded = HS.empty+ , salt = "abcdef"+ , rules =+ [ SegmentRule+ { id = "rule"+ , clauses =+ [ Clause+ { attribute = "email"+ , negate = False+ , op = OpIn+ , values = [String "test@example.com"]+ }+ , Clause+ { attribute = "name"+ , negate = False+ , op = OpIn+ , values = ["bill"]+ }+ ]+ , weight = Nothing+ , bucketBy = Nothing+ }+ ]+ , version = 1+ , deleted = False+ }++ user = unwrapUser $ (makeUser "foo")+ & userSetEmail (pure "test@example.com")+ & userSetName (pure "bob")++allTests :: Test+allTests = TestList+ [ testExplicitIncludeUser+ , testExplicitExcludeUser+ , testExplicitIncludeHasPrecedence+ , testNeitherIncludedNorExcluded+ , testMatchingRuleWithFullRollout+ , testMatchingRuleWithZeroRollout+ , testMatchingRuleWithMultipleClauses+ , testNonMatchingRuleWithMultipleClauses+ ]
+ test/Spec/Store.hs view
@@ -0,0 +1,86 @@+module Spec.Store (allTests, testWithStore) where++import Test.HUnit+import Data.Text (Text)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Control.Monad (void)+import GHC.Natural (Natural)+import GHC.Int (Int64)+import System.Clock (TimeSpec(..))++import Util.Features (makeTestFlag, makeTestSegment)++import LaunchDarkly.Server.Features (Flag(..), VariationOrRollout(..))+import LaunchDarkly.Server.Store.Internal+import LaunchDarkly.Server.Store.Redis++testInitializationEmpty :: IO (StoreHandle IO) -> Test+testInitializationEmpty makeStore = TestCase $ do+ store <- makeStore+ getInitializedC store >>= (pure False @=?)+ storeHandleInitialize store HM.empty HM.empty >>= (pure () @=?)+ getInitializedC store >>= (pure True @=?)++testInitializationWithFeatures :: IO (StoreHandle IO) -> Test+testInitializationWithFeatures makeStore = TestCase $ do+ store <- makeStore+ getInitializedC store >>= (pure False @=?)+ storeHandleInitialize store flagsV segmentsV >>= (pure () @=?)+ getInitializedC store >>= (pure True @=?)+ storeHandleGetFlag store "a" >>= (pure (pure flagA) @=?)+ storeHandleAllFlags store >>= (pure flagsR @=?)+ storeHandleGetSegment store "a" >>= (pure (pure segmentA) @=?)+ where+ segmentA = makeTestSegment "a" 50+ flagA = makeTestFlag "a" 52+ flagsR = HM.singleton "a" flagA+ flagsV = HM.singleton "a" (Versioned flagA 52)+ segmentsV = HM.singleton "a" (Versioned segmentA 50)++testGetAndUpsertAndGetAndGetAllFlags :: IO (StoreHandle IO) -> Test+testGetAndUpsertAndGetAndGetAllFlags makeStore = TestCase $ do+ store <- makeStore+ getFlagC store "a" >>= (pure Nothing @=?)+ upsertFlagC store "a" (Versioned (pure flag) 52) >>= (pure () @=?)+ getFlagC store "a" >>= (pure (pure flag) @=?)+ getAllFlagsC store >>= (pure (HM.singleton "a" flag) @=?)+ where+ flag = makeTestFlag "a" 52++testGetAndUpsertAndGetSegment :: IO (StoreHandle IO) -> Test+testGetAndUpsertAndGetSegment makeStore = TestCase $ do+ store <- makeStore+ getSegmentC store "a" >>= (pure Nothing @=?)+ upsertSegmentC store "a" (Versioned (pure segment) 52) >>= (pure () @=?)+ getSegmentC store "a" >>= (pure (pure segment) @=?)+ where+ segment = makeTestSegment "a" 52++testUpsertRespectsVersion :: IO (StoreHandle IO) -> Test+testUpsertRespectsVersion makeStore = TestCase $ do+ store <- makeStore+ upsertFlagC store "a" (Versioned (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?)+ upsertFlagC store "a" (Versioned (pure $ makeTestFlag "a" 2) 2) >>= (pure () @=?)+ getFlagC store "a" >>= (pure (pure $ makeTestFlag "a" 2) @=?)+ getAllFlagsC store >>= (pure (HM.singleton "a" $ makeTestFlag "a" 2) @=?)+ upsertFlagC store "a" (Versioned (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?)+ getFlagC store "a" >>= (pure (pure $ makeTestFlag "a" 2) @=?)+ getAllFlagsC store >>= (pure (HM.singleton "a" $ makeTestFlag "a" 2) @=?)+ upsertFlagC store "a" (Versioned Nothing 3) >>= (pure () @=?)+ getFlagC store "a" >>= (pure Nothing @=?)+ getAllFlagsC store >>= (pure mempty @=?)++testWithStore :: IO (StoreHandle IO) -> Test+testWithStore makeStore = TestList $ map (\f -> f makeStore)+ [ testInitializationEmpty+ , testInitializationWithFeatures+ , testGetAndUpsertAndGetAndGetAllFlags+ , testUpsertRespectsVersion+ , testGetAndUpsertAndGetSegment+ ]++allTests :: Test+allTests = TestList+ [ testWithStore $ makeStoreIO Nothing 0+ ]
+ test/Spec/StoreInterface.hs view
@@ -0,0 +1,191 @@+module Spec.StoreInterface (allTests) where++import Control.Monad (void)+import Data.Function ((&))+import Data.IORef (newIORef, readIORef, atomicModifyIORef', writeIORef)+import Data.Either (isLeft)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.ByteString ()+import Test.HUnit+import System.Clock (TimeSpec(..))++import Util.Features (makeTestFlag)++import LaunchDarkly.Server.Store.Internal++makeTestStore :: Maybe StoreInterface -> IO (StoreHandle IO)+makeTestStore backend = makeStoreIO backend $ TimeSpec 10 0++makeStoreInterface :: StoreInterface+makeStoreInterface = StoreInterface+ { storeInterfaceAllFeatures = const $ assertFailure "allFeatures should not be called"+ , storeInterfaceGetFeature = const $ const $ assertFailure "getFeatures should not be called"+ , storeInterfaceUpsertFeature = const $ const $ const $ assertFailure "upsertFeature should not be called"+ , storeInterfaceIsInitialized = assertFailure "isInitialized should not be called"+ , storeInterfaceInitialize = const $ assertFailure "initialize should not be called"+ }++testFailInit :: Test+testFailInit = TestCase $ do+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceInitialize = \_ -> pure $ Left "err"+ }+ initializeStore store HM.empty HM.empty >>= (Left "err" @?=)++testFailGet :: Test+testFailGet = TestCase $ do+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceGetFeature = \_ _ -> pure $ Left "err"+ }+ getFlagC store "abc" >>= (Left "err" @?=)++testFailAll :: Test+testFailAll = TestCase $ do+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceAllFeatures = \_ -> pure $ Left "err"+ }+ getAllFlagsC store >>= (Left "err" @?=)++testFailIsInitialized :: Test+testFailIsInitialized = TestCase $ do+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceIsInitialized = pure $ Left "err"+ }+ getInitializedC store >>= (Left "err" @?=)++testFailUpsert :: Test+testFailUpsert = TestCase $ do+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceUpsertFeature = \_ _ _ -> pure $ Left "err"+ }+ insertFlag store (makeTestFlag "test" 123) >>= (Left "err" @?=)++testFailGetInvalidJSON :: Test+testFailGetInvalidJSON = TestCase $ do+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceGetFeature = \_ _ -> pure $ Right $ RawFeature (pure "invalid json") 0+ }+ getFlagC store "abc" >>= (\v -> True @?= isLeft v)++testGetAllInvalidJSON :: Test+testGetAllInvalidJSON = TestCase $ do+ let flag = makeTestFlag "abc" 52+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceAllFeatures = \_ -> pure $ Right $ HM.empty+ & HM.insert "abc" (versionedToRaw $ Versioned (pure flag) 52)+ & HM.insert "xyz" (RawFeature (pure "invalid json") 64)+ }+ getAllFlagsC store >>= (Right (HM.singleton "abc" flag) @?=)++testInitializedCache :: Test+testInitializedCache = TestCase $ do+ counter <- newIORef 0+ value <- newIORef False+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceIsInitialized = do+ atomicModifyIORef' counter (\c -> (c + 1, ()))+ Right <$> readIORef value+ }+ getInitializedC store >>= (Right False @=?)+ readIORef counter >>= (1 @=?)+ getInitializedC store >>= (Right False @=?)+ readIORef counter >>= (1 @=?)+ storeHandleExpireAll store >>= (Right () @=?)+ getInitializedC store >>= (Right False @=?)+ readIORef counter >>= (2 @=?)+ writeIORef value True+ storeHandleExpireAll store >>= (Right () @=?)+ getInitializedC store >>= (Right True @=?)+ readIORef counter >>= (3 @=?)+ getInitializedC store >>= (Right True @=?)+ readIORef counter >>= (3 @=?)++testGetCache :: Test+testGetCache = TestCase $ do+ counter <- newIORef 0+ value <- newIORef $ RawFeature Nothing 0+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceGetFeature = \_ _ -> do+ atomicModifyIORef' counter (\c -> (c + 1, ()))+ Right <$> readIORef value+ }+ getFlagC store "abc" >>= (Right Nothing @?=)+ readIORef counter >>= (1 @=?)+ getFlagC store "abc" >>= (Right Nothing @?=)+ readIORef counter >>= (1 @=?)+ storeHandleExpireAll store >>= (Right () @=?)+ let flag = pure $ makeTestFlag "abc" 12+ writeIORef value $ versionedToRaw $ Versioned flag 12+ getFlagC store "abc" >>= (Right flag @=?)+ readIORef counter >>= (2 @=?)+ getFlagC store "abc" >>= (Right flag @=?)+ readIORef counter >>= (2 @=?)++testUpsertInvalidatesAllFlags :: Test+testUpsertInvalidatesAllFlags = TestCase $ do+ allCounter <- newIORef 0+ upsertCounter <- newIORef 0+ upsertResult <- newIORef $ Right True+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceUpsertFeature = \_ _ _ -> do+ atomicModifyIORef' upsertCounter (\c -> (c + 1, ()))+ readIORef upsertResult+ , storeInterfaceAllFeatures = \_ -> do+ atomicModifyIORef' allCounter (\c -> (c + 1, ()))+ pure $ Right HM.empty+ }+ getAllFlagsC store >>= (Right HM.empty @=?)+ readIORef allCounter >>= (1 @=?)+ deleteFlag store "abc" 52 >>= (Right () @=?)+ readIORef upsertCounter >>= (1 @=?)+ getAllFlagsC store >>= (Right HM.empty @=?)+ readIORef allCounter >>= (2 @=?)+ writeIORef upsertResult $ Right False+ deleteFlag store "abc" 53 >>= (Right () @=?)+ readIORef upsertCounter >>= (2 @=?)+ getAllFlagsC store >>= (Right HM.empty @=?)+ readIORef allCounter >>= (2 @=?)++testAllFlagsCache :: Test+testAllFlagsCache = TestCase $ do+ counter <- newIORef 0+ value <- newIORef HM.empty+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceAllFeatures = \_ -> do+ atomicModifyIORef' counter (\c -> (c + 1, ()))+ pure $ Right HM.empty+ }+ getAllFlagsC store >>= (Right HM.empty @=?)+ readIORef counter >>= (1 @=?)+ getAllFlagsC store >>= (Right HM.empty @=?)+ readIORef counter >>= (1 @=?)+ storeHandleExpireAll store >>= (Right () @=?)+ getAllFlagsC store >>= (Right HM.empty @=?)+ readIORef counter >>= (2 @=?)++testAllFlagsUpdatesRegularCache :: Test+testAllFlagsUpdatesRegularCache = TestCase $ do+ let flag = makeTestFlag "abc" 12+ store <- makeTestStore $ pure $ makeStoreInterface+ { storeInterfaceAllFeatures = \_ -> pure $ Right $+ HM.singleton "abc" (versionedToRaw $ Versioned (pure flag) 12)+ }+ getAllFlagsC store >>= (Right (HM.singleton "abc" flag) @=?)+ getFlagC store "abc" >>= (Right (pure flag) @=?)++allTests :: Test+allTests = TestList+ [ testFailInit+ , testFailGet+ , testFailAll+ , testFailIsInitialized+ , testFailUpsert+ , testFailGetInvalidJSON+ , testGetAllInvalidJSON+ , testInitializedCache+ , testGetCache+ , testUpsertInvalidatesAllFlags+ , testAllFlagsCache+ , testAllFlagsUpdatesRegularCache+ ]
+ test/Spec/Streaming.hs view
@@ -0,0 +1,10 @@+module Spec.Streaming (allTests) where++import Test.HUnit+import Data.Attoparsec.ByteString+import Control.Monad (mzero)++import LaunchDarkly.Server.Network.Streaming++allTests :: Test+allTests = TestList []
+ test/Spec/User.hs view
@@ -0,0 +1,21 @@+module Spec.User (allTests) where++import Test.HUnit+import Data.Aeson+import Data.Aeson.Types (Value(..))+import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict (HashMap)+import Data.Function ((&))++import LaunchDarkly.Server.User+import LaunchDarkly.Server.User.Internal++serializeEmpty :: Test+serializeEmpty = expected ~=? actual where+ actual = decode $ encode $ unwrapUser $ makeUser "abc"+ expected = pure $ Object $ HM.fromList [("key", String "abc")]++allTests :: Test+allTests = TestList+ [ serializeEmpty+ ]
+ test/Util/Features.hs view
@@ -0,0 +1,39 @@+module Util.Features (makeTestFlag, makeTestSegment) where++import Data.Text (Text)+import GHC.Natural (Natural)++import LaunchDarkly.Server.Features++makeTestFlag :: Text -> Natural -> Flag+makeTestFlag key version = Flag+ { key = key+ , version = version+ , on = True+ , trackEvents = False+ , trackEventsFallthrough = False+ , deleted = False+ , prerequisites = []+ , salt = ""+ , sel = ""+ , targets = []+ , rules = []+ , fallthrough = VariationOrRollout+ { variation = Nothing+ , rollout = Nothing+ }+ , offVariation = Nothing+ , variations = []+ , debugEventsUntilDate = Nothing+ }++makeTestSegment :: Text -> Natural -> Segment+makeTestSegment key version = Segment+ { key = key+ , included = mempty+ , excluded = mempty+ , salt = ""+ , rules = mempty+ , version = version+ , deleted = False+ }