launchdarkly-server-sdk 3.0.0 → 3.0.1
raw patch · 18 files changed
+223/−163 lines, 18 filesdep ~attoparsecdep ~basedep ~generic-lens
Dependency ranges changed: attoparsec, base, generic-lens, hedis, lens, retry
Files
- CHANGELOG.md +4/−0
- launchdarkly-server-sdk.cabal +14/−14
- src/LaunchDarkly/AesonCompat.hs +63/−2
- src/LaunchDarkly/Server/Client.hs +14/−14
- src/LaunchDarkly/Server/Client/Internal.hs +2/−2
- src/LaunchDarkly/Server/DataSource/Internal.hs +2/−2
- src/LaunchDarkly/Server/Events.hs +28/−30
- src/LaunchDarkly/Server/Integrations/FileData.hs +6/−7
- src/LaunchDarkly/Server/Integrations/TestData.hs +5/−5
- src/LaunchDarkly/Server/Network/Common.hs +1/−1
- src/LaunchDarkly/Server/Network/Eventing.hs +2/−2
- src/LaunchDarkly/Server/Network/Polling.hs +4/−3
- src/LaunchDarkly/Server/Network/Streaming.hs +4/−3
- src/LaunchDarkly/Server/Store/Internal.hs +40/−41
- src/LaunchDarkly/Server/User/Internal.hs +1/−1
- stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs +6/−7
- test/Spec/Store.hs +10/−11
- test/Spec/StoreInterface.hs +17/−18
CHANGELOG.md view
@@ -2,6 +2,10 @@ 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). +## [3.0.1] - 2022-07-01+### Fixed:+- Fixed Aeson 2.0 compatibility layer.+ ## [3.0.0] - 2022-06-27 ### Added: - Add flag support for the client side availability property, as well
launchdarkly-server-sdk.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: launchdarkly-server-sdk-version: 3.0.0+version: 3.0.1 synopsis: Server-side SDK for integrating with LaunchDarkly description: Please see the README on GitHub at <https://github.com/launchdarkly/haskell-server-sdk#readme> category: Web@@ -37,6 +37,7 @@ library exposed-modules:+ LaunchDarkly.AesonCompat LaunchDarkly.Server LaunchDarkly.Server.Client LaunchDarkly.Server.Config@@ -45,7 +46,6 @@ LaunchDarkly.Server.Integrations.FileData LaunchDarkly.Server.Integrations.TestData other-modules:- LaunchDarkly.AesonCompat LaunchDarkly.Server.Client.Internal LaunchDarkly.Server.Client.Status LaunchDarkly.Server.Config.ClientContext@@ -93,8 +93,8 @@ ghc-options: -fwarn-unused-imports -Wall -Wno-name-shadowing build-depends: aeson >=1.4.4.0 && <1.6 || >=2.0.1.0 && <2.1- , attoparsec >=0.13.2.2 && <0.14- , base >=4.7 && <5+ , attoparsec >=0.13.2.2 && <0.15+ , base >=4.12 && <5 , base16-bytestring >=0.1.1.6 && <1.1 , bytestring >=0.10.8.2 && <0.12 , clock ==0.8.*@@ -102,20 +102,20 @@ , cryptohash >=0.11.9 && <0.12 , exceptions >=0.10.2 && <0.11 , extra >=1.6.17 && <1.8- , generic-lens >=1.1.0.0 && <2.2+ , generic-lens >=1.1.0.0 && <2.3 , hashtables >=1.2.3.4 && <1.3- , hedis >=0.12.7 && <0.15+ , hedis >=0.12.7 && <0.16 , http-client >=0.6.4 && <0.8 , http-client-tls >=0.3.5.3 && <0.4 , http-types >=0.12.3 && <0.13 , iso8601-time >=0.1.5 && <0.2- , lens >=4.17.1 && <4.20+ , lens >=4.17.1 && <5.1 , 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 && <1.3- , retry >=0.8.0.1 && <0.9+ , retry >=0.8.0.1 && <0.10 , scientific >=0.3.6.2 && <0.4 , semver >=0.3.4 && <0.5 , text >=1.2.3.1 && <1.3@@ -204,8 +204,8 @@ build-depends: HUnit , aeson >=1.4.4.0 && <1.6 || >=2.0.1.0 && <2.1- , attoparsec >=0.13.2.2 && <0.14- , base >=4.7 && <5+ , attoparsec >=0.13.2.2 && <0.15+ , base >=4.12 && <5 , base16-bytestring >=0.1.1.6 && <1.1 , bytestring >=0.10.8.2 && <0.12 , clock ==0.8.*@@ -213,20 +213,20 @@ , cryptohash >=0.11.9 && <0.12 , exceptions >=0.10.2 && <0.11 , extra >=1.6.17 && <1.8- , generic-lens >=1.1.0.0 && <2.2+ , generic-lens >=1.1.0.0 && <2.3 , hashtables >=1.2.3.4 && <1.3- , hedis >=0.12.7 && <0.15+ , hedis >=0.12.7 && <0.16 , http-client >=0.6.4 && <0.8 , http-client-tls >=0.3.5.3 && <0.4 , http-types >=0.12.3 && <0.13 , iso8601-time >=0.1.5 && <0.2- , lens >=4.17.1 && <4.20+ , lens >=4.17.1 && <5.1 , 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 && <1.3- , retry >=0.8.0.1 && <0.9+ , retry >=0.8.0.1 && <0.10 , scientific >=0.3.6.2 && <0.4 , semver >=0.3.4 && <0.5 , text >=1.2.3.1 && <1.3
src/LaunchDarkly/AesonCompat.hs view
@@ -6,6 +6,7 @@ import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import Data.Functor.Identity (Identity(..), runIdentity)+import qualified Data.Map.Strict as M #else import qualified Data.HashMap.Strict as HM #endif@@ -14,12 +15,30 @@ #if MIN_VERSION_aeson(2,0,0) type KeyMap = KeyMap.KeyMap -deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v-deleteKey = KeyMap.delete+emptyObject :: KeyMap v+emptyObject = KeyMap.empty +singleton :: T.Text -> v -> KeyMap v+singleton key = KeyMap.singleton (Key.fromText key)++fromList :: [(T.Text, v)] -> KeyMap v+fromList list = KeyMap.fromList (map (\(k, v) -> ((Key.fromText k), v)) list)++toList :: KeyMap v -> [(T.Text, v)]+toList m = map (\(k, v) -> ((Key.toText k), v)) (KeyMap.toList m)++deleteKey :: T.Text -> KeyMap.KeyMap v -> KeyMap.KeyMap v+deleteKey key = KeyMap.delete (Key.fromText key)++lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v+lookupKey key = KeyMap.lookup (Key.fromText key)+ objectKeys :: KeyMap.KeyMap v -> [T.Text] objectKeys = map Key.toText . KeyMap.keys +objectValues :: KeyMap.KeyMap v -> [v]+objectValues m = map snd $ KeyMap.toList m+ keyToText :: Key -> T.Text keyToText = Key.toText @@ -29,20 +48,50 @@ filterKeys :: (Key -> Bool) -> KeyMap.KeyMap a -> KeyMap.KeyMap a filterKeys p = KeyMap.filterWithKey (\key _ -> p key) +filterObject :: (v -> Bool) -> KeyMap.KeyMap v -> KeyMap.KeyMap v+filterObject = KeyMap.filter+ adjustKey :: (v -> v) -> Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v adjustKey f k = runIdentity . KeyMap.alterF (Identity . fmap f) k +mapValues :: (v1 -> v2) -> KeyMap.KeyMap v1 -> KeyMap.KeyMap v2+mapValues = KeyMap.map++mapWithKey :: (T.Text -> v1 -> v2) -> KeyMap.KeyMap v1 -> KeyMap.KeyMap v2+mapWithKey f m = KeyMap.fromMap (M.mapWithKey (\k v -> f (keyToText k) v) (KeyMap.toMap m))++mapMaybeValues :: (v1 -> Maybe v2) -> KeyMap.KeyMap v1 -> KeyMap.KeyMap v2+mapMaybeValues = KeyMap.mapMaybe+ keyMapUnion :: KeyMap.KeyMap v -> KeyMap.KeyMap v -> KeyMap.KeyMap v keyMapUnion = KeyMap.union #else type KeyMap = HM.HashMap T.Text +emptyObject :: KeyMap v+emptyObject = HM.empty++singleton :: T.Text -> v -> HM.HashMap T.Text v+singleton = HM.singleton++fromList :: [(T.Text, v)] -> KeyMap v+fromList = HM.fromList++toList :: HM.HashMap T.Text v -> [(T.Text, v)]+toList = HM.toList+ deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v deleteKey = HM.delete +lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v+lookupKey = HM.lookup+ objectKeys :: HM.HashMap T.Text v -> [T.Text] objectKeys = HM.keys +objectValues :: HM.HashMap T.Text v -> [v]+objectValues = HM.elems+ keyToText :: T.Text -> T.Text keyToText = id @@ -52,8 +101,20 @@ filterKeys :: (T.Text -> Bool) -> HM.HashMap T.Text a -> HM.HashMap T.Text a filterKeys p = HM.filterWithKey (\key _ -> p key) +filterObject :: (v -> Bool) -> HM.HashMap T.Text v -> HM.HashMap T.Text v+filterObject = HM.filter+ adjustKey :: (v -> v) -> T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v adjustKey = HM.adjust++mapValues :: (v1 -> v2) -> HM.HashMap T.Text v1 -> HM.HashMap T.Text v2+mapValues = HM.map++mapWithKey :: (T.Text -> v1 -> v2) -> HM.HashMap T.Text v1 -> HM.HashMap T.Text v2+mapWithKey = HM.mapWithKey++mapMaybeValues :: (v1 -> Maybe v2) -> HM.HashMap T.Text v1 -> HM.HashMap T.Text v2+mapMaybeValues = HM.mapMaybe keyMapUnion :: HM.HashMap T.Text v -> HM.HashMap T.Text v -> HM.HashMap T.Text v keyMapUnion = HM.union
src/LaunchDarkly/Server/Client.hs view
@@ -36,8 +36,6 @@ import Control.Monad.Logger (LoggingT, logDebug, logWarn) import Control.Monad.Fix (mfix) import Data.IORef (newIORef, writeIORef, readIORef)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T@@ -67,6 +65,8 @@ import LaunchDarkly.Server.Network.Streaming (streamingThread) import LaunchDarkly.Server.Store.Internal (makeStoreIO, getAllFlagsC) import LaunchDarkly.Server.User.Internal (User(..), userSerializeRedacted)+import LaunchDarkly.AesonCompat (KeyMap, insertKey, emptyObject, mapValues, filterObject)+ networkDataSourceFactory :: (ClientContext -> DataSourceUpdates -> LoggingT IO ()) -> DataSourceFactory networkDataSourceFactory threadF clientContext dataSourceUpdates = do@@ -151,21 +151,21 @@ getStatus (Client client) = getStatusI client -- TODO(mmk) This method exists in multiple places. Should we move this into a util file?-fromObject :: Value -> HashMap Text Value+fromObject :: Value -> KeyMap Value fromObject x = case x of (Object o) -> o; _ -> error "expected object" -- | AllFlagsState captures the state of all feature flag keys as evaluated for -- a specific user. This includes their values, as well as other metadata. data AllFlagsState = AllFlagsState- { evaluations :: !(HashMap Text Value)- , state :: !(HashMap Text FlagState)+ { evaluations :: !(KeyMap Value)+ , state :: !(KeyMap FlagState) , valid :: !Bool } deriving (Show, Generic) instance ToJSON AllFlagsState where toJSON state = Object $- HM.insert "$flagsState" (toJSON $ getField @"state" state) $- HM.insert "$valid" (toJSON $ getField @"valid" state)+ insertKey "$flagsState" (toJSON $ getField @"state" state) $+ insertKey "$valid" (toJSON $ getField @"valid" state) (fromObject $ toJSON $ getField @"evaluations" state) data FlagState = FlagState@@ -210,13 +210,13 @@ allFlagsState (Client client) (User user) client_side_only with_reasons details_only_for_tracked_flags = do status <- getAllFlagsC $ getField @"store" client case status of- Left _ -> pure AllFlagsState { evaluations = HM.empty, state = HM.empty, valid = False }+ Left _ -> pure AllFlagsState { evaluations = emptyObject, state = emptyObject, valid = False } Right flags -> do- filtered <- pure $ (HM.filter (\flag -> (not client_side_only) || isClientSideOnlyFlag flag) flags)+ filtered <- pure $ (filterObject (\flag -> (not client_side_only) || isClientSideOnlyFlag flag) flags) details <- mapM (\flag -> (\detail -> (flag, fst detail)) <$> (evaluateDetail flag user $ getField @"store" client)) filtered- evaluations <- pure $ HM.map (getField @"value" . snd) details+ evaluations <- pure $ mapValues (getField @"value" . snd) details now <- unixMilliseconds- state <- pure $ HM.map (\(flag, detail) -> do+ state <- pure $ mapValues (\(flag, detail) -> do let reason' = getField @"reason" detail inExperiment = isInExperiment flag reason' isDebugging = now < fromMaybe 0 (getField @"debugEventsUntilDate" flag)@@ -237,14 +237,14 @@ -- 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 -> User -> IO (KeyMap Value) allFlags (Client client) (User user) = do status <- getAllFlagsC $ getField @"store" client case status of- Left _ -> pure HM.empty+ Left _ -> pure emptyObject Right flags -> do evals <- mapM (\flag -> evaluateDetail flag user $ getField @"store" client) flags- pure $ HM.map (getField @"value" . fst) evals+ pure $ mapValues (getField @"value" . fst) evals -- | Identify reports details about a user. identify :: Client -> User -> IO ()
src/LaunchDarkly/Server/Client/Internal.hs view
@@ -27,10 +27,10 @@ -- | The version string for this library. clientVersion :: Text-clientVersion = "3.0.0"+clientVersion = "3.0.1" setStatus :: ClientI -> Status -> IO ()-setStatus client status' = +setStatus client status' = atomicModifyIORef' (getField @"status" client) (fmap (,()) (transitionStatus status')) getStatusI :: ClientI -> IO Status
src/LaunchDarkly/Server/DataSource/Internal.hs view
@@ -8,7 +8,6 @@ where import Data.IORef (IORef, atomicModifyIORef')-import Data.HashMap.Strict (HashMap) import Data.Text (Text) import GHC.Natural (Natural) @@ -16,6 +15,7 @@ import LaunchDarkly.Server.Client.Status (Status, transitionStatus) import LaunchDarkly.Server.Features (Segment, Flag) import LaunchDarkly.Server.Store.Internal (initializeStore, insertFlag, insertSegment, deleteFlag, deleteSegment, StoreHandle)+import LaunchDarkly.AesonCompat (KeyMap) type DataSourceFactory = ClientContext -> DataSourceUpdates -> IO DataSource @@ -30,7 +30,7 @@ } data DataSourceUpdates = DataSourceUpdates- { dataSourceUpdatesInit :: !(HashMap Text Flag -> HashMap Text Segment -> IO (Either Text ()))+ { dataSourceUpdatesInit :: !(KeyMap Flag -> KeyMap Segment -> IO (Either Text ())) , dataSourceUpdatesInsertFlag :: !(Flag -> IO (Either Text ())) , dataSourceUpdatesInsertSegment :: !(Segment -> IO (Either Text ())) , dataSourceUpdatesDeleteFlag :: !(Text -> Natural -> IO (Either Text ()))
src/LaunchDarkly/Server/Events.hs view
@@ -3,13 +3,11 @@ import Data.Aeson (ToJSON, Value(..), toJSON, object, (.=)) import Data.Text (Text) import GHC.Exts (fromList)-import GHC.Natural (Natural, intToNatural)+import GHC.Natural (Natural, naturalFromInteger) import GHC.Generics (Generic) import Data.Generics.Product (HasField', getField, field, setField) import qualified Data.Text as T import Control.Concurrent.MVar (MVar, putMVar, swapMVar, newEmptyMVar, newMVar, tryTakeMVar, modifyMVar_, modifyMVar, readMVar)-import qualified Data.HashMap.Strict as HM-import Data.HashMap.Strict (HashMap) import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Lens ((&), (%~)) import Data.Maybe (fromMaybe)@@ -17,7 +15,7 @@ import Control.Monad (when, unless) import qualified Data.Cache.LRU as LRU -import LaunchDarkly.AesonCompat (KeyMap, keyMapUnion)+import LaunchDarkly.AesonCompat (KeyMap, keyMapUnion, insertKey, mapValues, objectValues, lookupKey) import LaunchDarkly.Server.Config.Internal (ConfigI, shouldSendEvents) import LaunchDarkly.Server.User.Internal (UserI, userSerializeRedacted) import LaunchDarkly.Server.Details (EvaluationReason(..))@@ -32,7 +30,7 @@ ContextKindAnonymousUser -> "anonymousUser" userGetContextKind :: UserI -> ContextKind-userGetContextKind user = if (getField @"anonymous" user)+userGetContextKind user = if getField @"anonymous" user then ContextKindAnonymousUser else ContextKindUser data EvalEvent = EvalEvent@@ -51,9 +49,9 @@ data EventState = EventState { events :: !(MVar [EventType])- , lastKnownServerTime :: !(MVar Int)+ , lastKnownServerTime :: !(MVar Integer) , flush :: !(MVar ())- , summary :: !(MVar (HashMap Text (FlagSummaryContext (HashMap Text CounterContext))))+ , summary :: !(MVar (KeyMap (FlagSummaryContext (KeyMap CounterContext)))) , startDate :: !(MVar Natural) , userKeyLRU :: !(MVar (LRU Text ())) } deriving (Generic)@@ -68,20 +66,20 @@ 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+convertFeatures :: KeyMap (FlagSummaryContext (KeyMap CounterContext))+ -> KeyMap (FlagSummaryContext [CounterContext])+convertFeatures summary = flip mapValues summary $ \context -> context & field @"counters" %~ objectValues queueEvent :: ConfigI -> EventState -> EventType -> IO () queueEvent config state event = if not (shouldSendEvents config) then pure () else modifyMVar_ (getField @"events" state) $ \events -> pure $ case event of- EventTypeSummary _ -> (event : events)- _ | length events < fromIntegral (getField @"eventsCapacity" config) -> (event : events)+ EventTypeSummary _ -> event : events+ _ | length events < fromIntegral (getField @"eventsCapacity" config) -> event : events _ -> events unixMilliseconds :: IO Natural-unixMilliseconds = (round . (* 1000)) <$> getPOSIXTime+unixMilliseconds = round . (* 1000) <$> getPOSIXTime makeBaseEvent :: a -> IO (BaseEvent a) makeBaseEvent child = unixMilliseconds >>= \now -> pure $ BaseEvent { creationDate = now, event = child }@@ -100,7 +98,7 @@ data SummaryEvent = SummaryEvent { startDate :: !Natural , endDate :: !Natural- , features :: !(HashMap Text (FlagSummaryContext [CounterContext]))+ , features :: !(KeyMap (FlagSummaryContext [CounterContext])) } deriving (Generic, Show, ToJSON) instance EventKind SummaryEvent where@@ -132,7 +130,7 @@ ] <> filter ((/=) Null . snd) [ "version" .= getField @"version" context , "variation" .= getField @"variation" context- , "unknown" .= if (getField @"unknown" context) then Just True else Nothing+ , "unknown" .= if getField @"unknown" context then Just True else Nothing ] data IdentifyEvent = IdentifyEvent@@ -170,7 +168,7 @@ , ("version", toJSON $ getField @"version" event) , ("variation", toJSON $ getField @"variation" event) , ("reason", toJSON $ getField @"reason" event)- , ("contextKind", let c = (getField @"contextKind" event) in+ , ("contextKind", let c = getField @"contextKind" event in if c == ContextKindUser then Null else toJSON c) ] @@ -223,7 +221,7 @@ , ("userKey", toJSON $ getField @"userKey" ctx) , ("metricValue", toJSON $ getField @"metricValue" ctx) , ("data", toJSON $ getField @"value" ctx)- , ("contextKind", let c = (getField @"contextKind" ctx) in+ , ("contextKind", let c = getField @"contextKind" ctx in if c == ContextKindUser then Null else toJSON c) ] @@ -266,7 +264,7 @@ data EventType = EventTypeIdentify !(BaseEvent IdentifyEvent) | EventTypeFeature !(BaseEvent FeatureEvent)- | EventTypeSummary !(SummaryEvent)+ | EventTypeSummary !SummaryEvent | EventTypeCustom !(BaseEvent CustomEvent) | EventTypeIndex !(BaseEvent IndexEvent) | EventTypeDebug !(BaseEvent DebugEvent)@@ -276,8 +274,8 @@ toJSON event = case event of EventTypeIdentify x -> toJSON x EventTypeFeature x -> toJSON x- EventTypeSummary x -> Object $ HM.insert "kind" (String "summary") (fromObject $ toJSON x)- EventTypeCustom x -> toJSON $ x+ EventTypeSummary x -> Object $ insertKey "kind" (String "summary") (fromObject $ toJSON x)+ EventTypeCustom x -> toJSON x EventTypeIndex x -> toJSON x EventTypeDebug x -> toJSON x EventTypeAlias x -> toJSON x@@ -327,13 +325,13 @@ , fromMaybe "" $ fmap (T.pack . show) $ getField @"variation" event ] -summarizeEvent :: (HashMap Text (FlagSummaryContext (HashMap Text CounterContext)))- -> EvalEvent -> Bool -> (HashMap Text (FlagSummaryContext (HashMap Text CounterContext)))+summarizeEvent :: KeyMap (FlagSummaryContext (KeyMap CounterContext))+ -> EvalEvent -> Bool -> KeyMap (FlagSummaryContext (KeyMap CounterContext)) summarizeEvent context event unknown = result where key = makeSummaryKey event- root = case HM.lookup (getField @"key" event) context of+ root = case lookupKey (getField @"key" event) context of (Just x) -> x; Nothing -> FlagSummaryContext (getField @"defaultValue" event) mempty- leaf = case HM.lookup key (getField @"counters" root) of+ leaf = case lookupKey key (getField @"counters" root) of (Just x) -> x & field @"count" %~ (1 +) Nothing -> CounterContext { count = 1@@ -342,8 +340,8 @@ , value = getField @"value" event , unknown = unknown }- result = flip (HM.insert $ getField @"key" event) context $- root & field @"counters" %~ HM.insert key leaf+ result = flip (insertKey $ getField @"key" event) context $+ root & field @"counters" %~ insertKey key leaf putIfEmptyMVar :: MVar a -> a -> IO () putIfEmptyMVar mvar value = tryTakeMVar mvar >>= \case Just x -> putMVar mvar x; Nothing -> putMVar mvar value;@@ -355,12 +353,12 @@ 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- trackEvents = (getField @"trackEvents" event)- inlineUsers = (getField @"inlineUsersInEvents" config)+ trackEvents = getField @"trackEvents" event+ inlineUsers = getField @"inlineUsersInEvents" config debugEventsUntilDate = fromMaybe 0 (getField @"debugEventsUntilDate" event)- lastKnownServerTime <- intToNatural <$> (* 1000) <$> readMVar (getField @"lastKnownServerTime" state)+ lastKnownServerTime <- naturalFromInteger <$> (* 1000) <$> readMVar (getField @"lastKnownServerTime" state) when trackEvents $- queueEvent config state $ EventTypeFeature $ BaseEvent now $ featureEvent+ queueEvent config state $ EventTypeFeature $ BaseEvent now featureEvent when (now < debugEventsUntilDate && lastKnownServerTime < debugEventsUntilDate) $ queueEvent config state $ EventTypeDebug $ BaseEvent now $ DebugEvent $ forceUserInlineInEvent config user featureEvent runSummary now state event unknown
src/LaunchDarkly/Server/Integrations/FileData.hs view
@@ -15,10 +15,9 @@ import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory, DataSource(..), DataSourceUpdates(..)) import qualified LaunchDarkly.Server.Features as F import LaunchDarkly.Server.Client.Status+import LaunchDarkly.AesonCompat (KeyMap, mapWithKey) import Data.Maybe (fromMaybe) import qualified Data.ByteString.Lazy as BSL-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM import Data.HashSet (HashSet) import Data.Text (Text) import GHC.Generics (Generic)@@ -95,9 +94,9 @@ } data FileBody = FileBody- { flags :: Maybe (HashMap Text FileFlag)- , flagValues :: Maybe (HashMap Text Value)- , segments :: Maybe (HashMap Text FileSegment)+ { flags :: Maybe (KeyMap FileFlag)+ , flagValues :: Maybe (KeyMap Value)+ , segments :: Maybe (KeyMap FileSegment) } deriving (Generic, Show, FromJSON) instance Semigroup FileBody where@@ -215,8 +214,8 @@ dataSourceStart = do FileBody mFlags mFlagValues mSegments <- mconcat <$> traverse loadFile sources let mSimpleFlags = fmap (fmap expandSimpleFlag) mFlagValues- flags' = maybe mempty (HM.mapWithKey fromFileFlag) (mFlags <> mSimpleFlags)- segments' = maybe mempty (HM.mapWithKey fromFileSegment) mSegments+ flags' = maybe mempty (mapWithKey fromFileFlag) (mFlags <> mSimpleFlags)+ segments' = maybe mempty (mapWithKey fromFileSegment) mSegments _ <- dataSourceUpdatesInit dataSourceUpdates flags' segments' dataSourceUpdatesSetStatus dataSourceUpdates Initialized writeIORef inited True
src/LaunchDarkly/Server/Integrations/TestData.hs view
@@ -68,8 +68,6 @@ import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, newEmptyMVar, readMVar, putMVar) import Control.Monad (void) import Data.Foldable (traverse_)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.Map.Strict (Map)@@ -81,7 +79,9 @@ import LaunchDarkly.Server.DataSource.Internal import qualified LaunchDarkly.Server.Features as Features import LaunchDarkly.Server.Integrations.TestData.FlagBuilder+import LaunchDarkly.AesonCompat (KeyMap, insertKey, insertKey, lookupKey) + dataSourceFactory :: TestData -> DataSourceFactory dataSourceFactory (TestData ref) _clientContext dataSourceUpdates = do listenerIdRef <- newEmptyMVar@@ -105,7 +105,7 @@ data TestData' = TestData' { flagBuilders :: Map Text FlagBuilder- , currentFlags :: HashMap Text Features.Flag+ , currentFlags :: KeyMap Features.Flag , nextDataSourceListenerId :: Int , dataSourceListeners :: IntMap TestDataListener }@@ -170,11 +170,11 @@ update (TestData ref) fb = modifyMVar_ ref $ \td -> do let key = fbKey fb- mOldFlag = HM.lookup key (currentFlags td)+ mOldFlag = lookupKey key (currentFlags td) oldFlagVersion = maybe 0 (getField @"version") mOldFlag newFlag = buildFlag (oldFlagVersion + 1) fb td' = td{ flagBuilders = Map.insert key fb (flagBuilders td)- , currentFlags = HM.insert key newFlag (currentFlags td)+ , currentFlags = insertKey key newFlag (currentFlags td) } notifyListeners td newFlag pure td'
src/LaunchDarkly/Server/Network/Common.hs view
@@ -63,7 +63,7 @@ checkAuthorization :: (MonadThrow m) => Response body -> m () checkAuthorization response = when (elem (responseStatus response) [unauthorized401, forbidden403]) $ throwM UnauthorizedE -getServerTime :: Response body -> Int+getServerTime :: Response body -> Integer getServerTime response | date == "" = 0 | otherwise = fromMaybe 0 (truncate <$> utcTimeToPOSIXSeconds <$> parsedTime)
src/LaunchDarkly/Server/Network/Eventing.hs view
@@ -25,7 +25,7 @@ import LaunchDarkly.Server.Events (processSummary, EventState) -- A true result indicates a retry does not need to be attempted-processSend :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> Request -> m (Bool, Int)+processSend :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> Request -> m (Bool, Integer) processSend manager req = (liftIO $ tryHTTP $ httpLbs req manager) >>= \case (Left err) -> $(logError) (T.pack $ show err) >> pure (False, 0) (Right response) -> do@@ -47,7 +47,7 @@ , method = "POST" } -updateLastKnownServerTime :: EventState -> Int -> IO ()+updateLastKnownServerTime :: EventState -> Integer -> IO () updateLastKnownServerTime state serverTime = modifyMVar_ (getField @"lastKnownServerTime" state) (\lastKnown -> pure $ max serverTime lastKnown) eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> m ()
src/LaunchDarkly/Server/Network/Polling.hs view
@@ -1,7 +1,6 @@ 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)@@ -16,7 +15,9 @@ import LaunchDarkly.Server.Network.Common (checkAuthorization, tryHTTP, handleUnauthorized) import LaunchDarkly.Server.Features (Flag, Segment)+import LaunchDarkly.AesonCompat (KeyMap) + import GHC.Natural (Natural) import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..)) import LaunchDarkly.Server.Config.ClientContext@@ -24,8 +25,8 @@ import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..), prepareRequest) data PollingResponse = PollingResponse- { flags :: !(HashMap Text Flag)- , segments :: !(HashMap Text Segment)+ { flags :: !(KeyMap Flag)+ , segments :: !(KeyMap Segment) } deriving (Generic, FromJSON, Show) processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m ()
src/LaunchDarkly/Server/Network/Streaming.hs view
@@ -11,7 +11,6 @@ import qualified Data.ByteString as B import Control.Applicative (many) import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.HashMap.Strict (HashMap) import Network.HTTP.Client (Manager, Response(..), Request, HttpException(..), HttpExceptionContent(..), brRead, throwErrorStatusCodes) import Control.Monad.Logger (MonadLogger, logInfo, logWarn, logError, logDebug) import Control.Monad.IO.Class (MonadIO, liftIO)@@ -30,10 +29,12 @@ import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..)) import LaunchDarkly.Server.Features (Flag, Segment) import LaunchDarkly.Server.Network.Common (handleUnauthorized, checkAuthorization, withResponseGeneric, tryHTTP)+import LaunchDarkly.AesonCompat (KeyMap) + data PutBody = PutBody- { flags :: !(HashMap Text Flag)- , segments :: !(HashMap Text Segment)+ { flags :: !(KeyMap Flag)+ , segments :: !(KeyMap Segment) } deriving (Generic, Show, FromJSON) data PathData d = PathData
src/LaunchDarkly/Server/Store/Internal.hs view
@@ -34,14 +34,13 @@ 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)+import LaunchDarkly.AesonCompat (KeyMap, mapValues, emptyObject, insertKey, lookupKey, insertKey, deleteKey, mapMaybeValues) -- Store result not defined in terms of StoreResultM so we dont have to export. type StoreResultM m a = m (Either Text a)@@ -54,20 +53,20 @@ 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)+ getAllFlagsC :: store -> StoreResultM m (KeyMap Flag) getInitializedC :: store -> StoreResultM m Bool class LaunchDarklyStoreWrite store m where- storeInitializeC :: store -> HashMap Text (Versioned Flag) -> HashMap Text (Versioned Segment) -> StoreResultM m ()+ storeInitializeC :: store -> KeyMap (Versioned Flag) -> KeyMap (Versioned Segment) -> StoreResultM m () upsertSegmentC :: store -> Text -> Versioned (Maybe Segment) -> StoreResultM m () upsertFlagC :: store -> Text -> Versioned (Maybe Flag) -> StoreResultM m () data StoreHandle m = StoreHandle { storeHandleGetFlag :: !(Text -> StoreResultM m (Maybe Flag)) , storeHandleGetSegment :: !(Text -> StoreResultM m (Maybe Segment))- , storeHandleAllFlags :: !(StoreResultM m (HashMap Text Flag))+ , storeHandleAllFlags :: !(StoreResultM m (KeyMap Flag)) , storeHandleInitialized :: !(StoreResultM m Bool)- , storeHandleInitialize :: !(HashMap Text (Versioned Flag) -> HashMap Text (Versioned Segment) -> StoreResultM m ())+ , storeHandleInitialize :: !(KeyMap (Versioned Flag) -> KeyMap (Versioned Segment) -> StoreResultM m ()) , storeHandleUpsertSegment :: !(Text -> Versioned (Maybe Segment) -> StoreResultM m ()) , storeHandleUpsertFlag :: !(Text -> Versioned (Maybe Flag) -> StoreResultM m ()) , storeHandleExpireAll :: !(StoreResultM m ())@@ -85,9 +84,9 @@ upsertFlagC = storeHandleUpsertFlag initializeStore :: (LaunchDarklyStoreWrite store m, Monad m) => store- -> HashMap Text Flag -> HashMap Text Segment -> StoreResultM m ()+ -> KeyMap Flag -> KeyMap Segment -> StoreResultM m () initializeStore store flags segments = storeInitializeC store (makeVersioned flags) (makeVersioned segments)- where makeVersioned = HM.map (\f -> Versioned f (getField @"version" f))+ where makeVersioned = mapValues (\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)@@ -104,9 +103,9 @@ 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+ { allFlags = Expirable emptyObject True 0+ , flags = emptyObject+ , segments = emptyObject , initialized = Expirable False True 0 } let store = Store state backend ttl@@ -133,9 +132,9 @@ } deriving (Generic) data State = State- { allFlags :: !(Expirable (HashMap Text Flag))- , flags :: !(HashMap Text (Expirable (Versioned (Maybe Flag))))- , segments :: !(HashMap Text (Expirable (Versioned (Maybe Segment))))+ { allFlags :: !(Expirable (KeyMap Flag))+ , flags :: !(KeyMap (Expirable (Versioned (Maybe Flag))))+ , segments :: !(KeyMap (Expirable (Versioned (Maybe Segment)))) , initialized :: !(Expirable Bool) } deriving (Generic) @@ -146,7 +145,7 @@ -- | The interface implemented by external stores for use by the SDK. data StoreInterface = StoreInterface- { storeInterfaceAllFeatures :: !(FeatureNamespace -> StoreResult (HashMap Text RawFeature))+ { storeInterfaceAllFeatures :: !(FeatureNamespace -> StoreResult (KeyMap RawFeature)) -- ^ A map of all features in a given namespace including deleted. , storeInterfaceGetFeature :: !(FeatureNamespace -> FeatureKey -> StoreResult RawFeature) -- ^ Return the value of a key in a namespace.@@ -156,7 +155,7 @@ , 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 ())+ , storeInterfaceInitialize :: !(KeyMap (KeyMap RawFeature) -> StoreResult ()) -- ^ A map of namespaces, and items in namespaces. The entire store state -- should be replaced with these values. }@@ -181,8 +180,8 @@ expireAllItems store = atomicModifyIORef' (getField @"state" store) $ \state -> (, ()) $ state & field @"allFlags" %~ expire & field @"initialized" %~ expire- & field @"flags" %~ HM.map expire- & field @"segments" %~ HM.map expire+ & field @"flags" %~ mapValues expire+ & field @"segments" %~ mapValues expire where expire = setField @"forceExpire" True isExpired :: Store -> TimeSpec -> Expirable a -> Bool@@ -192,23 +191,23 @@ getMonotonicTime :: IO TimeSpec getMonotonicTime = getTime Monotonic -initialize :: Store -> HashMap Text (Versioned Flag) -> HashMap Text (Versioned Segment) -> StoreResult ()+initialize :: Store -> KeyMap (Versioned Flag) -> KeyMap (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 @"flags" (mapValues (\f -> Expirable f True 0) $ c flags)+ & setField @"segments" (mapValues (\f -> Expirable f True 0) $ c segments)+ & setField @"allFlags" (Expirable (mapValues (getField @"value") flags) True 0) & setField @"initialized" (Expirable True False 0) 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+ raw = emptyObject+ & insertKey "flags" (mapValues versionedToRaw $ c flags)+ & insertKey "segments" (mapValues versionedToRaw $ c segments)+ c x = mapValues (\f -> f & field @"value" %~ Just) x rawToVersioned :: (FromJSON a) => RawFeature -> Maybe (Versioned (Maybe a)) rawToVersioned raw = case rawFeatureBuffer raw of@@ -231,17 +230,17 @@ Just versioned -> pure $ Right versioned getGeneric :: FromJSON a => Store -> Text -> Text- -> Lens' State (HashMap Text (Expirable (Versioned (Maybe a))))+ -> Lens' State (KeyMap (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 -> case lookupKey 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+ case lookupKey key (state ^. lens) of Nothing -> updateFromBackend backend now Just x -> if isExpired store now x then updateFromBackend backend now@@ -251,7 +250,7 @@ Left err -> pure $ Left err Right v -> do atomicModifyIORef' (getField @"state" store) $ \stateRef -> (, ()) $ stateRef & lens %~- (HM.insert key (Expirable v False now))+ (insertKey key (Expirable v False now)) pure $ Right $ getField @"value" v getFlag :: Store -> Text -> StoreResult (Maybe Flag)@@ -261,7 +260,7 @@ 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))))+ -> Lens' State (KeyMap (Expirable (Versioned (Maybe a)))) -> (Bool -> State -> State) -> StoreResult () upsertGeneric store namespace key versioned lens action = do@@ -276,16 +275,16 @@ 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))+ & lens %~ (insertKey key (Expirable versioned False now)) & action True pure $ Right () where- upsertMemory state = case HM.lookup key (state ^. lens) of+ upsertMemory state = case lookupKey key (state ^. lens) of Nothing -> updateMemory state Just existing -> if (getField @"version" $ getField @"value" existing) < getField @"version" versioned then updateMemory state else state updateMemory state = state- & lens %~ (HM.insert key (Expirable versioned False 0))+ & lens %~ (insertKey key (Expirable versioned False 0)) & action False upsertFlag :: Store -> Text -> Versioned (Maybe Flag) -> StoreResult ()@@ -294,23 +293,23 @@ 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+ Nothing -> deleteKey key allFlags+ Just flag -> insertKey key flag allFlags upsertSegment :: Store -> Text -> Versioned (Maybe Segment) -> StoreResult () upsertSegment store key versioned = upsertGeneric store "segments" key versioned (field @"segments") postAction where postAction _ state = state -filterAndCacheFlags :: Store -> TimeSpec -> HashMap Text RawFeature -> IO (HashMap Text Flag)+filterAndCacheFlags :: Store -> TimeSpec -> KeyMap RawFeature -> IO (KeyMap Flag) filterAndCacheFlags store now raw = do- let decoded = HM.mapMaybe rawToVersioned raw- allFlags = HM.mapMaybe (getField @"value") decoded+ let decoded = mapMaybeValues rawToVersioned raw+ allFlags = mapMaybeValues (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+ setField @"flags" (mapValues (\x -> Expirable x False now) decoded) state pure allFlags -getAllFlags :: Store -> StoreResult (HashMap Text Flag)+getAllFlags :: Store -> StoreResult (KeyMap Flag) getAllFlags store = do state <- readIORef $ getField @"state" store let memoryFlags = pure $ Right $ getField @"value" $ getField @"allFlags" state
src/LaunchDarkly/Server/User/Internal.hs view
@@ -109,7 +109,7 @@ setPrivateAttrs :: Set Text -> KeyMap Value -> Value setPrivateAttrs private redacted- | S.null private = Object $ redacted+ | S.null private = Object redacted | otherwise = Object $ insertKey "privateAttrs" (toJSON private) redacted redact :: Set Text -> KeyMap Value -> KeyMap Value
stores/launchdarkly-server-sdk-redis/src/LaunchDarkly/Server/Store/Redis/Internal.hs view
@@ -20,8 +20,6 @@ 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(..))@@ -29,6 +27,7 @@ import GHC.Generics (Generic) import LaunchDarkly.Server.Store (StoreInterface(..), RawFeature(..), StoreResult(..))+import LaunchDarkly.AesonCompat (KeyMap, mapValues, toList, fromList, objectKeys) data MinimalFeature = MinimalFeature { key :: Text@@ -95,10 +94,10 @@ Just buffer -> buffer Nothing -> toStrict $ encode $ MinimalFeature key (rawFeatureVersion opaque) True -redisInitialize :: RedisStoreConfig -> HashMap Text (HashMap Text RawFeature) -> StoreResult ()+redisInitialize :: RedisStoreConfig -> KeyMap (KeyMap 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) ->+ del (map (makeKey config) $ objectKeys values) >>= void . exceptOnReply+ forM_ (toList values) $ \(kind, features) -> forM_ (toList features) $ \(key, feature) -> (hset (makeKey config kind) (encodeUtf8 key) $ opaqueToRep key feature) >>= void . exceptOnReply set (makeKey config "$inited") "" >>= void . exceptOnReply @@ -130,6 +129,6 @@ redisIsInitialized config = run config $ get (makeKey config "$inited") >>= exceptOnReply >>= pure . isJust -redisGetAll :: RedisStoreConfig -> Text -> StoreResult (HashMap Text RawFeature)+redisGetAll :: RedisStoreConfig -> Text -> StoreResult (KeyMap RawFeature) redisGetAll config kind = run config $ hgetall (makeKey config kind)- >>= exceptOnReply >>= pure . HM.map rawToOpaque . HM.fromList . map (\(k, v) -> (decodeUtf8 k, v))+ >>= exceptOnReply >>= pure . mapValues rawToOpaque . fromList . map (\(k, v) -> (decodeUtf8 k, v))
test/Spec/Store.hs view
@@ -2,8 +2,6 @@ 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)@@ -11,6 +9,7 @@ import Util.Features (makeTestFlag, makeTestSegment) +import LaunchDarkly.AesonCompat (emptyObject, singleton) import LaunchDarkly.Server.Features (Flag(..), VariationOrRollout(..)) import LaunchDarkly.Server.Store.Internal import LaunchDarkly.Server.Store.Redis@@ -18,9 +17,9 @@ 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 @=?)+ getInitializedC store >>= (pure False @=?)+ storeHandleInitialize store emptyObject emptyObject >>= (pure () @=?)+ getInitializedC store >>= (pure True @=?) testInitializationWithFeatures :: IO (StoreHandle IO) -> Test testInitializationWithFeatures makeStore = TestCase $ do@@ -34,9 +33,9 @@ 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)+ flagsR = singleton "a" flagA+ flagsV = singleton "a" (Versioned flagA 52)+ segmentsV = singleton "a" (Versioned segmentA 50) testGetAndUpsertAndGetAndGetAllFlags :: IO (StoreHandle IO) -> Test testGetAndUpsertAndGetAndGetAllFlags makeStore = TestCase $ do@@ -44,7 +43,7 @@ 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) @=?)+ getAllFlagsC store >>= (pure (singleton "a" flag) @=?) where flag = makeTestFlag "a" 52 @@ -63,10 +62,10 @@ 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) @=?)+ getAllFlagsC store >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?) upsertFlagC store "a" (Versioned (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?) getFlagC store "a" >>= (pure (pure $ makeTestFlag "a" 2) @=?)- getAllFlagsC store >>= (pure (HM.singleton "a" $ makeTestFlag "a" 2) @=?)+ getAllFlagsC store >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?) upsertFlagC store "a" (Versioned Nothing 3) >>= (pure () @=?) getFlagC store "a" >>= (pure Nothing @=?) getAllFlagsC store >>= (pure mempty @=?)
test/Spec/StoreInterface.hs view
@@ -4,8 +4,6 @@ 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(..))@@ -13,6 +11,7 @@ import Util.Features (makeTestFlag) import LaunchDarkly.Server.Store.Internal+import LaunchDarkly.AesonCompat (emptyObject, insertKey, singleton) makeTestStore :: Maybe StoreInterface -> IO (StoreHandle IO) makeTestStore backend = makeStoreIO backend $ TimeSpec 10 0@@ -31,7 +30,7 @@ store <- makeTestStore $ pure $ makeStoreInterface { storeInterfaceInitialize = \_ -> pure $ Left "err" }- initializeStore store HM.empty HM.empty >>= (Left "err" @?=)+ initializeStore store emptyObject emptyObject >>= (Left "err" @?=) testFailGet :: Test testFailGet = TestCase $ do@@ -72,11 +71,11 @@ 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)+ { storeInterfaceAllFeatures = \_ -> pure $ Right $ emptyObject+ & insertKey "abc" (versionedToRaw $ Versioned (pure flag) 52)+ & insertKey "xyz" (RawFeature (pure "invalid json") 64) }- getAllFlagsC store >>= (Right (HM.singleton "abc" flag) @?=)+ getAllFlagsC store >>= (Right (singleton "abc" flag) @?=) testInitializedCache :: Test testInitializedCache = TestCase $ do@@ -133,35 +132,35 @@ readIORef upsertResult , storeInterfaceAllFeatures = \_ -> do atomicModifyIORef' allCounter (\c -> (c + 1, ()))- pure $ Right HM.empty+ pure $ Right emptyObject }- getAllFlagsC store >>= (Right HM.empty @=?)+ getAllFlagsC store >>= (Right emptyObject @=?) readIORef allCounter >>= (1 @=?) deleteFlag store "abc" 52 >>= (Right () @=?) readIORef upsertCounter >>= (1 @=?)- getAllFlagsC store >>= (Right HM.empty @=?)+ getAllFlagsC store >>= (Right emptyObject @=?) readIORef allCounter >>= (2 @=?) writeIORef upsertResult $ Right False deleteFlag store "abc" 53 >>= (Right () @=?) readIORef upsertCounter >>= (2 @=?)- getAllFlagsC store >>= (Right HM.empty @=?)+ getAllFlagsC store >>= (Right emptyObject @=?) readIORef allCounter >>= (2 @=?) testAllFlagsCache :: Test testAllFlagsCache = TestCase $ do counter <- newIORef 0- value <- newIORef HM.empty+ value <- newIORef emptyObject store <- makeTestStore $ pure $ makeStoreInterface { storeInterfaceAllFeatures = \_ -> do atomicModifyIORef' counter (\c -> (c + 1, ()))- pure $ Right HM.empty+ pure $ Right emptyObject }- getAllFlagsC store >>= (Right HM.empty @=?)+ getAllFlagsC store >>= (Right emptyObject @=?) readIORef counter >>= (1 @=?)- getAllFlagsC store >>= (Right HM.empty @=?)+ getAllFlagsC store >>= (Right emptyObject @=?) readIORef counter >>= (1 @=?) storeHandleExpireAll store >>= (Right () @=?)- getAllFlagsC store >>= (Right HM.empty @=?)+ getAllFlagsC store >>= (Right emptyObject @=?) readIORef counter >>= (2 @=?) testAllFlagsUpdatesRegularCache :: Test@@ -169,9 +168,9 @@ let flag = makeTestFlag "abc" 12 store <- makeTestStore $ pure $ makeStoreInterface { storeInterfaceAllFeatures = \_ -> pure $ Right $- HM.singleton "abc" (versionedToRaw $ Versioned (pure flag) 12)+ singleton "abc" (versionedToRaw $ Versioned (pure flag) 12) }- getAllFlagsC store >>= (Right (HM.singleton "abc" flag) @=?)+ getAllFlagsC store >>= (Right (singleton "abc" flag) @=?) getFlagC store "abc" >>= (Right (pure flag) @=?) allTests :: Test