packages feed

launchdarkly-server-sdk 4.6.0 → 4.6.1

raw patch · 13 files changed

+345/−43 lines, 13 filesdep +regex-pcre-builtindep −pcre-lightPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-pcre-builtin

Dependencies removed: pcre-light

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -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)
launchdarkly-server-sdk.cabal view
@@ -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 <https://github.com/launchdarkly/haskell-server-sdk#readme> 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
src/LaunchDarkly/Server/Client.hs view
@@ -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
src/LaunchDarkly/Server/Client/Internal.hs view
@@ -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.
src/LaunchDarkly/Server/Context/Internal.hs view
@@ -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
src/LaunchDarkly/Server/Events.hs view
@@ -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
src/LaunchDarkly/Server/Integrations/FileData.hs view
@@ -188,7 +188,7 @@ --     "segments": { --         "segment-key-1": { --             "key": "segment-key-1",---             "includes": [ "user-key-1" ]+--             "included": [ "user-key-1" ] --         } --     } -- }
src/LaunchDarkly/Server/Operators.hs view
@@ -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
test/Spec.hs view
@@ -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
test/Spec/Client.hs view
@@ -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         ]
test/Spec/Context.hs view
@@ -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
+ test/Spec/Events.hs view
@@ -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+        ]
test/Spec/Operators.hs view
@@ -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)