diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +# LaunchDarkly Server-side SDK for Haskell + +[![CircleCI](https://circleci.com/gh/launchdarkly/haskell-server-sdk.svg?style=svg)](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! + +[![Twitter Follow](https://img.shields.io/twitter/follow/launchdarkly.svg?style=social&label=Follow&maxAge=2592000)](https://twitter.com/intent/follow?screen_name=launchdarkly) + +## Getting started + +Download a release archive from the [GitHub Releases](https://github.com/launchdarkly/haskell-server-sdk/releases) for use in your project. Refer to the [SDK documentation](https://docs.launchdarkly.com/docs/haskell-server-sdk-reference#section-getting-started) for complete instructions on getting started with using the SDK. + +## 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/launchdarkly-server-sdk.cabal b/launchdarkly-server-sdk.cabal new file mode 100644 --- /dev/null +++ b/launchdarkly-server-sdk.cabal @@ -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 +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 diff --git a/src/LaunchDarkly/Server.hs b/src/LaunchDarkly/Server.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Client.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Client/Internal.hs b/src/LaunchDarkly/Server/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Client/Internal.hs @@ -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) diff --git a/src/LaunchDarkly/Server/Config.hs b/src/LaunchDarkly/Server/Config.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Config.hs @@ -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" diff --git a/src/LaunchDarkly/Server/Config/Internal.hs b/src/LaunchDarkly/Server/Config/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Config/Internal.hs @@ -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) diff --git a/src/LaunchDarkly/Server/Details.hs b/src/LaunchDarkly/Server/Details.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Details.hs @@ -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" diff --git a/src/LaunchDarkly/Server/Evaluate.hs b/src/LaunchDarkly/Server/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Evaluate.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Events.hs b/src/LaunchDarkly/Server/Events.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Events.hs @@ -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' diff --git a/src/LaunchDarkly/Server/Features.hs b/src/LaunchDarkly/Server/Features.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Features.hs @@ -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) diff --git a/src/LaunchDarkly/Server/Network/Common.hs b/src/LaunchDarkly/Server/Network/Common.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Network/Common.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Network/Eventing.hs b/src/LaunchDarkly/Server/Network/Eventing.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Network/Eventing.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Network/Polling.hs b/src/LaunchDarkly/Server/Network/Polling.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Network/Polling.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Network/Streaming.hs b/src/LaunchDarkly/Server/Network/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Network/Streaming.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Operators.hs b/src/LaunchDarkly/Server/Operators.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Operators.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Store.hs b/src/LaunchDarkly/Server/Store.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Store.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Store/Internal.hs b/src/LaunchDarkly/Server/Store/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/Store/Internal.hs @@ -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 diff --git a/src/LaunchDarkly/Server/User.hs b/src/LaunchDarkly/Server/User.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/User.hs @@ -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" diff --git a/src/LaunchDarkly/Server/User/Internal.hs b/src/LaunchDarkly/Server/User/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LaunchDarkly/Server/User/Internal.hs @@ -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 diff --git a/stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis.hs b/stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis.hs new file mode 100644 --- /dev/null +++ b/stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis.hs @@ -0,0 +1,8 @@ +module LaunchDarkly.Server.Store.Redis + ( RedisStoreConfig + , makeRedisStoreConfig + , redisConfigSetNamespace + , makeRedisStore + ) where + +import LaunchDarkly.Server.Store.Redis.Internal diff --git a/stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs b/stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs new file mode 100644 --- /dev/null +++ b/stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs @@ -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)) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/Spec/Bucket.hs b/test/Spec/Bucket.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Bucket.hs @@ -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 + ] diff --git a/test/Spec/Evaluate.hs b/test/Spec/Evaluate.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Evaluate.hs @@ -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 + ] diff --git a/test/Spec/Operators.hs b/test/Spec/Operators.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Operators.hs @@ -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) + ] diff --git a/test/Spec/Redis.hs b/test/Spec/Redis.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Redis.hs @@ -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 + ] diff --git a/test/Spec/Segment.hs b/test/Spec/Segment.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Segment.hs @@ -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 + ] diff --git a/test/Spec/Store.hs b/test/Spec/Store.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Store.hs @@ -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 + ] diff --git a/test/Spec/StoreInterface.hs b/test/Spec/StoreInterface.hs new file mode 100644 --- /dev/null +++ b/test/Spec/StoreInterface.hs @@ -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 + ] diff --git a/test/Spec/Streaming.hs b/test/Spec/Streaming.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Streaming.hs @@ -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 [] diff --git a/test/Spec/User.hs b/test/Spec/User.hs new file mode 100644 --- /dev/null +++ b/test/Spec/User.hs @@ -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 + ] diff --git a/test/Util/Features.hs b/test/Util/Features.hs new file mode 100644 --- /dev/null +++ b/test/Util/Features.hs @@ -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 + }