diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,17 @@ 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). +## [4.6.1](https://github.com/launchdarkly/haskell-server-sdk/compare/4.6.0...4.6.1) (2026-11-05) + + +### Bug Fixes + +* Make putIfEmptyMVar atomic to avoid blocking evaluations ([#117](https://github.com/launchdarkly/haskell-server-sdk/issues/117)) ([74e0af5](https://github.com/launchdarkly/haskell-server-sdk/commit/74e0af596ef19a53cdaebc2bd784010010a33c0c)) +* Match other SDKs in the secure mode hash and canonical key for multi-kind contexts with a user ([#125](https://github.com/launchdarkly/haskell-server-sdk/issues/125)) ([3b19794](https://github.com/launchdarkly/haskell-server-sdk/commit/3b197949c86f36faab190b2b23570fd233a3a52e)) +* Prevent event summary start dates from retaining memory between flushes ([#124](https://github.com/launchdarkly/haskell-server-sdk/issues/124)) ([1754765](https://github.com/launchdarkly/haskell-server-sdk/commit/1754765edd4dca7fed95b9560e9ebcbe8488e8f7)) +* Prevent unbounded memory growth and lost counts in event summaries ([#121](https://github.com/launchdarkly/haskell-server-sdk/issues/121)) ([7ca8b8b](https://github.com/launchdarkly/haskell-server-sdk/commit/7ca8b8b3e710cc8c8ae1b264b2e591df2e64d588)) +* Remove the need for a system PCRE library to build the SDK ([#122](https://github.com/launchdarkly/haskell-server-sdk/issues/122)) ([d5f6ee4](https://github.com/launchdarkly/haskell-server-sdk/commit/d5f6ee422f8914ab46132f10bb64afe3153d0379)) + ## [4.6.0](https://github.com/launchdarkly/haskell-server-sdk/compare/4.5.1...4.6.0) (2026-05-28) 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: 4.6.0 +version: 4.6.1 synopsis: Server-side SDK for integrating with LaunchDarkly description: Please see the README on GitHub at category: Web @@ -117,8 +117,8 @@ , monad-logger >=0.3.36 && <0.4 , monad-loops ==0.4.* , mtl >=2.2.2 && <2.4 - , pcre-light >=0.4.1.0 && <0.5 , random >=1.1 && <1.3 + , regex-pcre-builtin >=0.95.1.3.8.43 && <0.96 , scientific >=0.3.6.2 && <0.4 , semver >=0.3.4 && <0.5 , text >=1.2.4.0 && <2.1 @@ -139,6 +139,7 @@ Spec.Context Spec.DataSource Spec.Evaluate + Spec.Events Spec.Features Spec.HttpConfiguration Spec.Integrations.FileData @@ -230,8 +231,8 @@ , monad-logger >=0.3.36 && <0.4 , monad-loops ==0.4.* , mtl >=2.2.2 && <2.4 - , pcre-light >=0.4.1.0 && <0.5 , random >=1.1 && <1.3 + , regex-pcre-builtin >=0.95.1.3.8.43 && <0.96 , scientific >=0.3.6.2 && <0.4 , semver >=0.3.4 && <0.5 , text >=1.2.4.0 && <2.1 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 @@ -28,7 +28,7 @@ ) where import Control.Concurrent (forkFinally, killThread) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryPutMVar) import Control.Monad (forM_, void) import Control.Monad.Fix (mfix) import Control.Monad.IO.Class (liftIO) @@ -297,7 +297,7 @@ -- be delivered as soon as possible. Flushing is asynchronous, so this method -- will return before it is complete. flushEvents :: Client -> IO () -flushEvents client = putMVar (getField @"flush" $ getField @"events" client) () +flushEvents client = void $ tryPutMVar (getField @"flush" $ getField @"events" client) () -- | -- Close shuts down the LaunchDarkly client. After calling this, the 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 @@ -31,7 +31,7 @@ -- | The version string for this library. clientVersion :: Text -clientVersion = "4.6.0" -- x-release-please-version +clientVersion = "4.6.1" -- x-release-please-version -- | -- Client is the LaunchDarkly client. Client instances are thread-safe. diff --git a/src/LaunchDarkly/Server/Context/Internal.hs b/src/LaunchDarkly/Server/Context/Internal.hs --- a/src/LaunchDarkly/Server/Context/Internal.hs +++ b/src/LaunchDarkly/Server/Context/Internal.hs @@ -159,7 +159,7 @@ _ -> Multi MultiContext - { fullKey = intercalate ":" $ map (\c -> canonicalizeKey (getField @"key" c) (kind c)) sorted + { fullKey = intercalate ":" $ map (\c -> canonicalizeKeyForMulti (getField @"key" c) (kind c)) sorted , contexts = fromList $ map (\c -> ((kind c), c)) singleContexts } @@ -251,16 +251,19 @@ | otherwise = Single $ c {privateAttributes = Just attrs} withPrivateAttributes _ c = c --- Given a key and kind, generate a canonical key. --- --- In a multi-kind context, each individual context should theoretically --- contain the same key. To address this restriction, we generate a canonical --- key that includes the context's kind. However, if the kind is "user", we --- omit the kind inclusion to maintain backwards compatibility. +-- Given a key and kind, generate a canonical key for a standalone single-kind +-- context. The "user" kind is omitted from the canonical form to maintain +-- backwards compatibility with the pre-context user model. canonicalizeKey :: Text -> Text -> Text canonicalizeKey key "user" = key -canonicalizeKey key kind = kind <> ":" <> (replace "%" "%25" key & replace ":" "%3A") +canonicalizeKey key kind = canonicalizeKeyForMulti key kind +-- Canonical key form used for a sub-context inside a multi-kind context. The +-- kind prefix is always included -- the user-prefix-omission rule applies only +-- to standalone single-kind contexts. +canonicalizeKeyForMulti :: Text -> Text -> Text +canonicalizeKeyForMulti key kind = kind <> ":" <> (replace "%" "%25" key & replace ":" "%3A") + unwrapSingleContext :: Context -> Maybe SingleContext unwrapSingleContext (Single c) = Just c unwrapSingleContext _ = Nothing @@ -337,7 +340,6 @@ [ ("key", toJSON $ key) , ("kind", toJSON $ if includeKind then String kind else Null) , ("anonymous", toJSON $ if anonymous then Bool True else Null) - , ("_meta", maybe Null toJSON privateAttributes) , ( "_meta" , case privateAttributes of 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 @@ -1,6 +1,6 @@ module LaunchDarkly.Server.Events where -import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, tryTakeMVar) +import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, readMVar, swapMVar) import Control.Lens ((%~), (&)) import Control.Monad (when) import Data.Aeson (ToJSON, Value (..), object, toJSON, (.=)) @@ -43,8 +43,7 @@ { events :: !(MVar [EventType]) , lastKnownServerTime :: !(MVar Integer) , flush :: !(MVar ()) - , summary :: !(MVar (KeyMap FlagSummaryContext)) - , startDate :: !(MVar Natural) + , summary :: !(MVar SummaryState) , contextKeyLRU :: !(MVar (LRU Text ())) } deriving (Generic) @@ -54,8 +53,7 @@ events <- newMVar [] lastKnownServerTime <- newMVar 0 flush <- newEmptyMVar - summary <- newMVar mempty - startDate <- newEmptyMVar + summary <- newMVar emptySummaryState contextKeyLRU <- newMVar $ newLRU $ pure $ fromIntegral $ getField @"contextKeyLRUCapacity" config pure EventState {..} @@ -75,13 +73,22 @@ makeBaseEvent :: a -> IO (BaseEvent a) makeBaseEvent child = unixMilliseconds >>= \now -> pure $ BaseEvent {creationDate = now, event = child} +-- The summary data for the current flush window. +-- +-- The start date and the counters are in one value. Thus a single MVar +-- operation changes both together. The start date is Nothing only when +-- there are no counters. +data SummaryState = SummaryState !(Maybe Natural) !(KeyMap FlagSummaryContext) + +emptySummaryState :: SummaryState +emptySummaryState = SummaryState Nothing mempty + processSummary :: Config -> EventState -> IO () processSummary config state = - tryTakeMVar (getField @"startDate" state) >>= \case - Nothing -> pure () - (Just startDate) -> do + swapMVar (getField @"summary" state) emptySummaryState >>= \case + SummaryState Nothing _ -> pure () + SummaryState (Just startDate) features -> do endDate <- unixMilliseconds - features <- swapMVar (getField @"summary" state) mempty queueEvent config state $ EventTypeSummary $ SummaryEvent {..} class EventKind a where @@ -98,9 +105,9 @@ eventKind _ = "summary" data FlagSummaryContext = FlagSummaryContext - { defaultValue :: Maybe Value - , counters :: KeyMap CounterContext - , contextKinds :: HS.HashSet Text + { defaultValue :: !(Maybe Value) + , counters :: !(KeyMap CounterContext) + , contextKinds :: !(HS.HashSet Text) } deriving (Generic, Show) @@ -341,15 +348,19 @@ , value = getField @"value" event , unknown = unknown } - result = flip (insertKey $ getField @"key" event) summaryContext $ (root & field @"counters" %~ (insertKey key leaf) & field @"contextKinds" %~ (HS.union contextKinds)) - -putIfEmptyMVar :: MVar a -> a -> IO () -putIfEmptyMVar mvar value = tryTakeMVar mvar >>= \case Just x -> putMVar mvar x; Nothing -> putMVar mvar value + root' = root & field @"counters" %~ (insertKey key leaf) & field @"contextKinds" %~ (HS.union contextKinds) + -- The map does not evaluate its values. Evaluate them here, so that + -- repeated updates do not keep a chain of unevaluated values in memory. + result = leaf `seq` root' `seq` insertKey (getField @"key" event) root' summaryContext runSummary :: Natural -> EventState -> EvalEvent -> Bool -> IO () runSummary now state event unknown = - putIfEmptyMVar (getField @"startDate" state) now - >> modifyMVar_ (getField @"summary" state) (\summary -> pure $ summarizeEvent summary event unknown) + modifyMVar_ (getField @"summary" state) $ \(SummaryState startDate features) -> + -- Callers read the time before they get the MVar. Thus a later caller + -- can write first. Keep the earliest time as the start date. Evaluate + -- it now, so that repeated updates do not keep a chain of + -- unevaluated values in memory. + pure $! SummaryState (Just $! maybe now (min now) startDate) (summarizeEvent features event unknown) processEvalEvent :: Natural -> Config -> EventState -> Context -> Bool -> Bool -> EvalEvent -> IO () processEvalEvent now config state context includeReason unknown event = do @@ -371,7 +382,10 @@ processEvalEvents :: Config -> EventState -> Context -> Bool -> [EvalEvent] -> Bool -> IO () processEvalEvents config state context includeReason events unknown = - unixMilliseconds >>= \now -> mapM_ (processEvalEvent now config state context includeReason unknown) events + -- Do not record any event data when the SDK does not send events. + -- Otherwise the summary data grows without limit. + when (shouldSendEvents config) $ + unixMilliseconds >>= \now -> mapM_ (processEvalEvent now config state context includeReason unknown) events maybeIndexContext :: Natural -> Config -> Context -> EventState -> IO () maybeIndexContext now config context state = do 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 @@ -188,7 +188,7 @@ -- "segments": { -- "segment-key-1": { -- "key": "segment-key-1", --- "includes": [ "user-key-1" ] +-- "included": [ "user-key-1" ] -- } -- } -- } diff --git a/src/LaunchDarkly/Server/Operators.hs b/src/LaunchDarkly/Server/Operators.hs --- a/src/LaunchDarkly/Server/Operators.hs +++ b/src/LaunchDarkly/Server/Operators.hs @@ -20,7 +20,8 @@ import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) import Data.Time.ISO8601 (parseISO8601) import GHC.Generics (Generic) -import Text.Regex.PCRE.Light (compileM, match) +import System.IO.Unsafe (unsafePerformIO) +import Text.Regex.PCRE.ByteString (compBlank, compile, execBlank, execute) data Op = OpIn @@ -114,10 +115,20 @@ compareSemVer :: (Version -> Version -> Bool) -> Text -> Text -> Bool compareSemVer op x y = fromRight False $ liftM2 op (parseSemVer x) (parseSemVer y) +-- | Return True if the pattern matches part of the text. +-- +-- A pattern that is not valid does not match. A match error, for example a +-- match limit, also does not match. The pattern compiles without UTF mode. +-- Thus, "." and case-insensitive matches operate on bytes of the UTF-8 text. +-- +-- The function uses the IO functions of regex-pcre-builtin. The pure match +-- functions throw an exception when a match error occurs. matches :: Text -> Text -> Bool -matches text pattern = case compileM (encodeUtf8 pattern) [] of - Left _ -> False - Right compiled -> isJust $ match compiled (encodeUtf8 text) [] +matches text pattern = unsafePerformIO $ do + compiled <- compile compBlank execBlank (encodeUtf8 pattern) + case compiled of + Left _ -> pure False + Right regex -> either (const False) isJust <$> execute regex (encodeUtf8 text) getOperation :: Op -> (Value -> Value -> Bool) getOperation op = case op of diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,13 +2,14 @@ import Test.HUnit (Counts (..), Test (TestLabel, TestList), runTestTT) -import Control.Monad.Cont (when) +import Control.Monad (when) import qualified Spec.Bucket import qualified Spec.Client import qualified Spec.Config import qualified Spec.Context import qualified Spec.DataSource import qualified Spec.Evaluate +import qualified Spec.Events import qualified Spec.Features import qualified Spec.HttpConfiguration import qualified Spec.Integrations.FileData @@ -32,6 +33,7 @@ , Spec.Context.allTests , Spec.DataSource.allTests , Spec.Evaluate.allTests + , Spec.Events.allTests , Spec.Features.allTests , Spec.HttpConfiguration.allTests , Spec.Operators.allTests diff --git a/test/Spec/Client.hs b/test/Spec/Client.hs --- a/test/Spec/Client.hs +++ b/test/Spec/Client.hs @@ -2,6 +2,7 @@ import Data.Function ((&)) import Data.Generics.Product (getField) +import System.Timeout (timeout) import Test.HUnit import LaunchDarkly.Server.Client @@ -26,6 +27,13 @@ userContext = makeContext "Message" "user" orgContext = makeContext "Message" "org" +-- Test that flushEvents returns when no event thread takes the flush signal. +testFlushEventsDoesNotBlock :: Test +testFlushEventsDoesNotBlock = TestCase $ do + client <- makeTestClient "secret" + result <- timeout (5 * 1000000) $ flushEvents client >> flushEvents client + assertEqual "flushEvents returned" (Just ()) result + makeTestClient :: Text -> IO Client makeTestClient sdkKey = do client <- makeClient $ (makeConfig sdkKey) & configSetOffline True @@ -36,4 +44,5 @@ allTests = TestList [ testSecureModeHashIsGeneratedCorrectly + , testFlushEventsDoesNotBlock ] diff --git a/test/Spec/Context.hs b/test/Spec/Context.hs --- a/test/Spec/Context.hs +++ b/test/Spec/Context.hs @@ -2,8 +2,8 @@ import Test.HUnit -import Control.Monad.Cont (liftIO) -import Data.Aeson (Value (..), decode, encode) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..), decode, encode, toJSON) import Data.Function ((&)) import Data.Maybe (fromJust) import qualified Data.Set as S @@ -12,7 +12,7 @@ import LaunchDarkly.AesonCompat (lookupKey) import LaunchDarkly.Server.Config (configSetAllAttributesPrivate, makeConfig) import LaunchDarkly.Server.Context -import LaunchDarkly.Server.Context.Internal (redactContext, redactContextRedactAnonymous, withoutAnonymousContexts) +import LaunchDarkly.Server.Context.Internal (getCanonicalKey, redactContext, redactContextRedactAnonymous, withoutAnonymousContexts) import qualified LaunchDarkly.Server.Reference as R confirmInvalidContext :: Context -> Text -> Assertion @@ -67,6 +67,32 @@ where user = makeContext "user-key" "user" +canonicalKeyForSingleUserOmitsKindPrefix :: Test +canonicalKeyForSingleUserOmitsKindPrefix = + TestCase $ + assertEqual "" "user-key" $ + getCanonicalKey (makeContext "user-key" "user") + +canonicalKeyForSingleNonUserIncludesKindPrefix :: Test +canonicalKeyForSingleNonUserIncludesKindPrefix = + TestCase $ + assertEqual "" "org:org-key" $ + getCanonicalKey (makeContext "org-key" "org") + +canonicalKeyEscapesPercentAndColonInKey :: Test +canonicalKeyEscapesPercentAndColonInKey = + TestCase $ + assertEqual "" "org:a%25b%3Ac" $ + getCanonicalKey (makeContext "a%b:c" "org") + +canonicalKeyForMultiIncludesUserKindPrefix :: Test +canonicalKeyForMultiIncludesUserKindPrefix = + TestCase $ + let user = makeContext "user-key" "user" + org = makeContext "org-key" "org" + multi = makeMultiContext [user, org] + in assertEqual "" "org:org-key:user:user-key" $ getCanonicalKey multi + multiKindCanOnlyRetrieveKindAttribute :: Test multiKindCanOnlyRetrieveKindAttribute = TestCase $ @@ -416,6 +442,71 @@ assertEqual "" False $ isValid $ withoutAnonymousContexts anonMc ) +canonicalKeyForMultiSortsKindsAndEscapesKeys :: Test +canonicalKeyForMultiSortsKindsAndEscapesKeys = + TestCase $ + let user = makeContext "a:b" "user" + org = makeContext "c%d" "org" + in assertEqual "" "org:c%25d:user:a%3Ab" $ getCanonicalKey (makeMultiContext [user, org]) + +canonicalKeyForMultiWithoutUser :: Test +canonicalKeyForMultiWithoutUser = + TestCase $ + let org = makeContext "org-key" "org" + device = makeContext "device-key" "device" + in assertEqual "" "device:device-key:org:org-key" $ getCanonicalKey (makeMultiContext [org, device]) + +canonicalKeyForParsedMultiIncludesUserKindPrefix :: Test +canonicalKeyForParsedMultiIncludesUserKindPrefix = + TestCase $ + assertEqual "" (Just "org:org-key:user:user-key") $ + getCanonicalKey <$> decode "{\"kind\": \"multi\", \"user\": {\"key\": \"user-key\"}, \"org\": {\"key\": \"org-key\"}}" + +privateAttributesContext :: Text -> Text -> Context +privateAttributesContext key kind = + makeContext key kind + & withAttribute "name" "Sandy" + & withPrivateAttributes (S.fromList [R.makeReference "name", R.makeReference "/address/city"]) + +metaOf :: Value -> Maybe Value +metaOf (Object o) = lookupKey "_meta" o +metaOf _ = Nothing + +expectedMeta :: Maybe Value +expectedMeta = Just $ Object $ fromList [("privateAttributes", Array $ fromList ["/address/city", "name"])] + +singleContextSerializesPrivateAttributesInMeta :: Test +singleContextSerializesPrivateAttributesInMeta = + TestCase $ + assertEqual "" expectedMeta $ + metaOf (toJSON $ privateAttributesContext "user-key" "user") + +singleContextWithoutPrivateAttributesOmitsMeta :: Test +singleContextWithoutPrivateAttributesOmitsMeta = + TestCase $ + assertEqual "" Nothing $ + metaOf (toJSON $ makeContext "user-key" "user") + +multiContextSerializesPrivateAttributesPerContext :: Test +multiContextSerializesPrivateAttributesPerContext = + TestCase $ do + assertEqual "" expectedMeta $ metaOf user + assertEqual "" Nothing $ metaOf org + where + multi = makeMultiContext [privateAttributesContext "user-key" "user", makeContext "org-key" "org"] + (user, org) = case toJSON multi of + Object o -> (fromJust $ lookupKey "user" o, fromJust $ lookupKey "org" o) + _ -> error "expected object" + +privateAttributesSurviveRoundTrip :: Test +privateAttributesSurviveRoundTrip = + TestCase $ do + assertEqual "" (Just single) $ decode (encode single) + assertEqual "" (Just multi) $ decode (encode multi) + where + single = privateAttributesContext "user-key" "user" + multi = makeMultiContext [single, privateAttributesContext "org-key" "org"] + allTests :: Test allTests = TestList @@ -425,6 +516,17 @@ , multiKindRequiresUnique , multiKindRequiresSingleContextsOnly , multiKindWithSingleKindWillReturnSingleKind + , canonicalKeyForSingleUserOmitsKindPrefix + , canonicalKeyForSingleNonUserIncludesKindPrefix + , canonicalKeyEscapesPercentAndColonInKey + , canonicalKeyForMultiIncludesUserKindPrefix + , canonicalKeyForMultiSortsKindsAndEscapesKeys + , canonicalKeyForMultiWithoutUser + , canonicalKeyForParsedMultiIncludesUserKindPrefix + , singleContextSerializesPrivateAttributesInMeta + , singleContextWithoutPrivateAttributesOmitsMeta + , multiContextSerializesPrivateAttributesPerContext + , privateAttributesSurviveRoundTrip , multiKindCanOnlyRetrieveKindAttribute , canRetrievalIndividualContextsFromMultiKindContext , canRetrievalIndividualContextsFromSingleKindContext diff --git a/test/Spec/Events.hs b/test/Spec/Events.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Events.hs @@ -0,0 +1,126 @@ +module Spec.Events (allTests) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar, takeMVar) +import Control.Monad (forM, forM_, replicateM_) +import Data.Aeson (Value (..)) +import Data.Function ((&)) +import Data.Generics.Product (getField) +import GHC.Natural (Natural) +import System.Timeout (timeout) +import Test.HUnit + +import LaunchDarkly.AesonCompat (objectValues) +import LaunchDarkly.Server.Config (configSetSendEvents, makeConfig) +import LaunchDarkly.Server.Config.Internal (Config) +import LaunchDarkly.Server.Context (makeContext) +import LaunchDarkly.Server.Details (EvaluationReason (EvaluationReasonOff)) +import LaunchDarkly.Server.Events + +enabledConfig :: Config +enabledConfig = makeConfig "sdk-key" + +disabledConfig :: Config +disabledConfig = makeConfig "sdk-key" & configSetSendEvents False + +evalEvent :: EvalEvent +evalEvent = newUnknownFlagEvent "flag" (Bool True) EvaluationReasonOff (makeContext "user-key" "user") + +summaryEvents :: EventState -> IO [SummaryEvent] +summaryEvents state = do + events <- readMVar $ getField @"events" state + pure [summary | EventTypeSummary summary <- events] + +totalCount :: SummaryEvent -> Natural +totalCount summary = + sum + [ getField @"count" counter + | flag <- objectValues $ getField @"features" summary + , counter <- objectValues $ getField @"counters" flag + ] + +-- Test that a flush with no evaluations does not queue a summary event. +testNoSummaryWithoutEvaluations :: Test +testNoSummaryWithoutEvaluations = TestCase $ do + state <- makeEventState enabledConfig + processSummary enabledConfig state + summaries <- summaryEvents state + assertEqual "summary event count" 0 (length summaries) + +-- Test that evaluations with events disabled do not keep summary data. +-- The flush uses an enabled config to show any data that is kept. +testDisabledEventsKeepNoSummary :: Test +testDisabledEventsKeepNoSummary = TestCase $ do + state <- makeEventState disabledConfig + replicateM_ 100 $ processEvalEvents disabledConfig state (makeContext "user-key" "user") False [evalEvent] False + processSummary enabledConfig state + summaries <- summaryEvents state + assertEqual "summary event count" 0 (length summaries) + +-- Test that the start date is the earliest evaluation time, not the first one recorded. +testStartDateIsEarliestEvaluation :: Test +testStartDateIsEarliestEvaluation = TestCase $ do + state <- makeEventState enabledConfig + runSummary 200 state evalEvent False + runSummary 100 state evalEvent False + runSummary 300 state evalEvent False + processSummary enabledConfig state + summaries <- summaryEvents state + case summaries of + [summary] -> do + assertEqual "startDate" 100 (getField @"startDate" summary) + assertEqual "total count" 3 (totalCount summary) + _ -> assertFailure $ "expected one summary event, got " ++ show (length summaries) + +-- Test that a flush resets the summary, so the next window counts only new evaluations. +testFlushStartsNewWindow :: Test +testFlushStartsNewWindow = TestCase $ do + state <- makeEventState enabledConfig + runSummary 100 state evalEvent False + runSummary 100 state evalEvent False + processSummary enabledConfig state + runSummary 500 state evalEvent False + processSummary enabledConfig state + -- The events queue holds the newest event first. + summaries <- summaryEvents state + case summaries of + [second, first] -> do + assertEqual "first startDate" 100 (getField @"startDate" first) + assertEqual "first total count" 2 (totalCount first) + assertEqual "second startDate" 500 (getField @"startDate" second) + assertEqual "second total count" 1 (totalCount second) + _ -> assertFailure $ "expected two summary events, got " ++ show (length summaries) + +-- Test that concurrent evaluations finish and that the summary counts every evaluation. +testConcurrentEvaluationsAreCounted :: Test +testConcurrentEvaluationsAreCounted = TestCase $ do + state <- makeEventState enabledConfig + let threadCount = 32 :: Int + callsPerThread = 1000 :: Int + result <- timeout (30 * 1000000) $ do + done <- forM [1 .. threadCount] $ \thread -> do + finished <- newEmptyMVar + _ <- forkIO $ do + forM_ [1 .. callsPerThread] $ \call -> + runSummary (fromIntegral $ 1000 + thread + call) state evalEvent False + putMVar finished () + pure finished + mapM_ takeMVar done + assertEqual "all threads finished" (Just ()) result + processSummary enabledConfig state + summaries <- summaryEvents state + case summaries of + [summary] -> do + assertEqual "startDate" 1002 (getField @"startDate" summary) + assertEqual "total count" (fromIntegral $ threadCount * callsPerThread) (totalCount summary) + _ -> assertFailure $ "expected one summary event, got " ++ show (length summaries) + +allTests :: Test +allTests = + TestList + [ testNoSummaryWithoutEvaluations + , testDisabledEventsKeepNoSummary + , testStartDateIsEarliestEvaluation + , testFlushStartsNewWindow + , testConcurrentEvaluationsAreCounted + ] diff --git a/test/Spec/Operators.hs b/test/Spec/Operators.hs --- a/test/Spec/Operators.hs +++ b/test/Spec/Operators.hs @@ -82,6 +82,30 @@ , (OpMatches, String "hello world", String "(world|planet)", True) , (OpMatches, String "hello world", String "aloha", False) , (OpMatches, String "hello world", String "***bad rg", False) + , (OpMatches, String "hello world", String "(hello", False) + , (OpMatches, String "hello world", String "[a-", False) + , -- This pattern backtracks until it reaches the match limit. The match error gives False. + (OpMatches, String "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaab", String "^(a+)+$", False) + , (OpMatches, String "hello world", String "", True) + , (OpMatches, String "", String "", True) + , (OpMatches, String "", String "^$", True) + , (OpMatches, String "", String "a", False) + , (OpMatches, String "hello world", String "^hello", True) + , (OpMatches, String "hello world", String "^world", False) + , (OpMatches, String "hello world", String "world$", True) + , (OpMatches, String "hello world", String "hello$", False) + , (OpMatches, String "hello world", String "^hello world$", True) + , (OpMatches, String "HELLO", String "hello", False) + , (OpMatches, String "HELLO", String "(?i)hello", True) + , (OpMatches, String "caf\233", String "caf\233", True) + , (OpMatches, String "\26085\26412\35486", String "\26412", True) + , (OpMatches, String "\233", String "[\233]", True) + , (OpMatches, String "e", String "[\233]", False) + , (OpMatches, String "\1635", String "\\d", False) + , (OpMatches, String "a.b", String "a\\.b", True) + , (OpMatches, String "axb", String "a\\.b", False) + , (OpMatches, Number $ fromInteger 5, String "5", False) + , (OpMatches, String "5", Number $ fromInteger 5, False) , -- semver operators (OpSemVerEqual, String "2.0.0", String "2.0.0", True) , (OpSemVerEqual, String "2.0", String "2.0.0", True)