diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/launchdarkly-server-sdk.cabal b/launchdarkly-server-sdk.cabal --- a/launchdarkly-server-sdk.cabal +++ b/launchdarkly-server-sdk.cabal @@ -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 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 diff --git a/src/LaunchDarkly/AesonCompat.hs b/src/LaunchDarkly/AesonCompat.hs --- a/src/LaunchDarkly/AesonCompat.hs +++ b/src/LaunchDarkly/AesonCompat.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -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 () diff --git a/src/LaunchDarkly/Server/Client/Internal.hs b/src/LaunchDarkly/Server/Client/Internal.hs --- a/src/LaunchDarkly/Server/Client/Internal.hs +++ b/src/LaunchDarkly/Server/Client/Internal.hs @@ -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 diff --git a/src/LaunchDarkly/Server/DataSource/Internal.hs b/src/LaunchDarkly/Server/DataSource/Internal.hs --- a/src/LaunchDarkly/Server/DataSource/Internal.hs +++ b/src/LaunchDarkly/Server/DataSource/Internal.hs @@ -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 ())) diff --git a/src/LaunchDarkly/Server/Events.hs b/src/LaunchDarkly/Server/Events.hs --- a/src/LaunchDarkly/Server/Events.hs +++ b/src/LaunchDarkly/Server/Events.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Integrations/FileData.hs b/src/LaunchDarkly/Server/Integrations/FileData.hs --- a/src/LaunchDarkly/Server/Integrations/FileData.hs +++ b/src/LaunchDarkly/Server/Integrations/FileData.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Integrations/TestData.hs b/src/LaunchDarkly/Server/Integrations/TestData.hs --- a/src/LaunchDarkly/Server/Integrations/TestData.hs +++ b/src/LaunchDarkly/Server/Integrations/TestData.hs @@ -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' diff --git a/src/LaunchDarkly/Server/Network/Common.hs b/src/LaunchDarkly/Server/Network/Common.hs --- a/src/LaunchDarkly/Server/Network/Common.hs +++ b/src/LaunchDarkly/Server/Network/Common.hs @@ -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) diff --git a/src/LaunchDarkly/Server/Network/Eventing.hs b/src/LaunchDarkly/Server/Network/Eventing.hs --- a/src/LaunchDarkly/Server/Network/Eventing.hs +++ b/src/LaunchDarkly/Server/Network/Eventing.hs @@ -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 () diff --git a/src/LaunchDarkly/Server/Network/Polling.hs b/src/LaunchDarkly/Server/Network/Polling.hs --- a/src/LaunchDarkly/Server/Network/Polling.hs +++ b/src/LaunchDarkly/Server/Network/Polling.hs @@ -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 () diff --git a/src/LaunchDarkly/Server/Network/Streaming.hs b/src/LaunchDarkly/Server/Network/Streaming.hs --- a/src/LaunchDarkly/Server/Network/Streaming.hs +++ b/src/LaunchDarkly/Server/Network/Streaming.hs @@ -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 diff --git a/src/LaunchDarkly/Server/Store/Internal.hs b/src/LaunchDarkly/Server/Store/Internal.hs --- a/src/LaunchDarkly/Server/Store/Internal.hs +++ b/src/LaunchDarkly/Server/Store/Internal.hs @@ -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 diff --git a/src/LaunchDarkly/Server/User/Internal.hs b/src/LaunchDarkly/Server/User/Internal.hs --- a/src/LaunchDarkly/Server/User/Internal.hs +++ b/src/LaunchDarkly/Server/User/Internal.hs @@ -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 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 --- 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 @@ -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)) diff --git a/test/Spec/Store.hs b/test/Spec/Store.hs --- a/test/Spec/Store.hs +++ b/test/Spec/Store.hs @@ -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 @=?) diff --git a/test/Spec/StoreInterface.hs b/test/Spec/StoreInterface.hs --- a/test/Spec/StoreInterface.hs +++ b/test/Spec/StoreInterface.hs @@ -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