diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,31 @@ # Revision history for kiroku-metrics +## 0.4.0.0 — 2026-10-26 + +### Breaking Changes + +- With `corsDisabled`, WebSocket upgrades carrying any `Origin` header now receive + HTTP 403 `origin_not_allowed`. Configure `--cors-origin ` or + `corsAllowOrigins` to restore browser access, including behind a same-origin + proxy that preserves the browser's Origin header. HTTP and origin-less WebSocket + clients retain their behavior. +- Require `kiroku-store ^>=0.12.0.0` for its expanded operational event surface. + +### Bug Fixes + +- Handle target-mismatch detail events without duplicating the subsequent + crashed-stop counter, including startup refusals without `Started`. +- `kiroku-inspect` reports redacted `bind`, `database`, `schema`, or `other` + startup failures. A first SIGINT/SIGTERM shuts down gracefully; a second, + including mixed signals, forces exit 130. + +### Other Changes + +- Document loopback-only `--port 0` and all-interface fixed ports. +- Require `kiroku-cli ^>=0.2.0.11` in library and test dependencies. +- Correct the 0.3.0.0 notes to describe its public collector and standalone API + changes. + ## 0.3.0.1 — 2026-10-20 ### Bug Fixes @@ -45,10 +71,23 @@ * `Kiroku.Metrics.Cors` provides validated `AllowedOrigin`, `CorsPolicy` and `corsMiddleware`: explicit default-off browser access with cache-correct - HTTP/preflight handling and WebSocket origin refusal before upgrade. + HTTP/preflight handling and WebSocket origin refusal before upgrade only when + CORS is enabled. * Shared `errorEnvelope`, `errorResponse` and sanitized `storeErrorResponse` helpers for new inspection routes. CORS refusals use `origin_not_allowed`, `cors_method_not_allowed` and `invalid_cors_request` codes. + +### Erratum — 2026-10-25 + +The original 0.3.0.0 notes omitted that WebSocket origin refusal required enabled +CORS; disabled-policy upgrades were open. This repository correction cannot update +the published Hackage copy. See the Unreleased breaking migration note above. + +The same release also added the `effectful-core` library dependency. Store-backed +starters automatically enable browse, dead-letter and checkpoint routes on +upgrade; this is a change to their default route surface, not merely an opt-in +API addition. Hosts that need selected providers must use explicit +`ServerProviders` composition through the `...WithProviders` functions. ### Other Changes diff --git a/app-inspect/InspectSignals.hs b/app-inspect/InspectSignals.hs new file mode 100644 --- /dev/null +++ b/app-inspect/InspectSignals.hs @@ -0,0 +1,20 @@ +-- | Shared only by the executable and its subprocess test fixture. +module InspectSignals (withInspectSignals) where + +import Control.Exception (bracket) +import Control.Monad (void) +import Data.IORef (atomicModifyIORef', newIORef) +import System.Exit (ExitCode (..)) +import System.Posix.Process (exitImmediately) +import System.Posix.Signals (Handler (..), installHandler, sigINT, sigTERM) + +-- | The shutdown state persists even after the caller consumes its notification. +-- Nested brackets also restore SIGINT if installing SIGTERM fails. +withInspectSignals :: IO () -> IO a -> IO a +withInspectSignals requestShutdown action = do + requested <- newIORef False + let handler = Catch $ do + alreadyRequested <- atomicModifyIORef' requested (\previous -> (True, previous)) + if alreadyRequested then exitImmediately (ExitFailure 130) else requestShutdown + withHandler signal = bracket (installHandler signal handler Nothing) (\previous -> void (installHandler signal previous Nothing)) + withHandler sigINT $ \_ -> withHandler sigTERM $ \_ -> action diff --git a/app-inspect/Main.hs b/app-inspect/Main.hs --- a/app-inspect/Main.hs +++ b/app-inspect/Main.hs @@ -2,37 +2,35 @@ import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar) import Control.Exception (SomeAsyncException, SomeException, fromException, tryJust) -import Control.Monad (forM_, void) +import Control.Monad (void) import Data.Text.IO qualified as TIO +import InspectSignals (withInspectSignals) import Options.Applicative (execParser) import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitWith) import System.IO (hFlush, stderr, stdout) -import System.Posix.Signals (Handler (..), installHandler, sigINT, sigTERM) import Kiroku.Metrics.Standalone main :: IO () main = do - opts <- execParser inspectParserInfo - env <- getEnvironment - case resolveInspectOptions env opts of - Left err -> TIO.hPutStrLn stderr err >> exitWith (ExitFailure 2) - Right rt -> do - done <- newEmptyMVar - forM_ [sigINT, sigTERM] $ \signal -> - void (installHandler signal (Catch (void (tryPutMVar done ()))) Nothing) - let hooks = - InspectHooks - { onListening = \port caps -> mapM_ TIO.putStrLn (renderStartupBanner rt port caps) >> hFlush stdout - , waitForShutdown = takeMVar done >> TIO.putStrLn "kiroku-inspect: shutting down" - } - result <- tryJust synchronousException (runInspect hooks rt) - case result of - Left _ -> TIO.hPutStrLn stderr "kiroku-inspect: startup or server failure (details redacted)" >> exitFailure - Right () -> pure () + opts <- execParser inspectParserInfo + env <- getEnvironment + case resolveInspectOptions env opts of + Left err -> TIO.hPutStrLn stderr err >> exitWith (ExitFailure 2) + Right rt -> do + done <- newEmptyMVar + let hooks = + InspectHooks + { onListening = \port caps -> mapM_ TIO.putStrLn (renderStartupBanner rt port caps) >> hFlush stdout, + waitForShutdown = takeMVar done >> TIO.putStrLn "kiroku-inspect: shutting down" + } + result <- tryJust synchronousException (withInspectSignals (void (tryPutMVar done ())) (runInspect hooks rt)) + case result of + Left err -> TIO.hPutStrLn stderr (renderInspectFailure (classifyInspectFailure err)) >> exitFailure + Right () -> pure () synchronousException :: SomeException -> Maybe SomeException synchronousException err = case fromException err :: Maybe SomeAsyncException of - Just _ -> Nothing - Nothing -> Just err + Just _ -> Nothing + Nothing -> Just err diff --git a/bench/WebSocketTail.hs b/bench/WebSocketTail.hs --- a/bench/WebSocketTail.hs +++ b/bench/WebSocketTail.hs @@ -24,83 +24,84 @@ main :: IO () main = withMigratedTestDatabase $ \conn -> withStore (defaultConnectionSettings conn) $ \store -> do - -- Setup and publication complete before the fixed comparison. - mapM_ (\n -> append store (StreamName ("names-" <> T.pack (show n))) 1) [1 .. 500 :: Int] - append store (StreamName "appender") 1 - bounded (atomically (Pub.publisherPosition store.publisher >>= check . (>= GlobalPosition 501))) - Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 500) - putStrLn "Focused local tail delivery: 500 distinct names, 50 batches/trial, 5 paired rounds." - putStrLn "Each case concurrently appends 50 batches of 10 events to the same existing stream." - putStrLn "Control uses frozen encoder, warm caches pre-resolve, cold starts one cache per trial. No remote acceptance inference." - samples <- forM [0 .. 4 :: Int] $ \roundNumber -> do - let modes = if even roundNumber then ["control", "warm", "cold"] else ["cold", "warm", "control"] - measured <- traverse (runCase store events) modes - pure [(mode, result) | (mode, result) <- zip modes measured] - mapM_ - ( \name -> do - let xs = map (fromJust . lookup name) samples - putStrLn (name <> " raw (tail ms, append ms, lookups, retained map/FIFO): " <> show xs) - putStrLn (name <> " medians tail/append ms: " <> show (median [t | (t, _, _, _) <- xs], median [a | (_, a, _, _) <- xs])) - ) - ["control", "warm", "cold"] - finalHead <- runStoreIO store visibleGlobalHeadPosition - case finalHead of - Right (GlobalPosition 8001) -> putStrLn "Verified 501 seeded + 7500 concurrently appended events; final visible head 8001." - other -> fail ("unexpected final head: " <> show other) + -- Setup and publication complete before the fixed comparison. + mapM_ (\n -> append store (StreamName ("names-" <> T.pack (show n))) 1) [1 .. 500 :: Int] + append store (StreamName "appender") 1 + bounded (atomically (Pub.publisherPosition store.publisher >>= check . (>= GlobalPosition 501))) + Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 500) + putStrLn "Focused local tail delivery: 500 distinct names, 50 batches/trial, 5 paired rounds." + putStrLn "Each case concurrently appends 50 batches of 10 events to the same existing stream." + putStrLn "Control uses frozen encoder, warm caches pre-resolve, cold starts one cache per trial. No remote acceptance inference." + samples <- forM [0 .. 4 :: Int] $ \roundNumber -> do + let modes = if even roundNumber then ["control", "warm", "cold"] else ["cold", "warm", "control"] + measured <- traverse (runCase store events) modes + pure [(mode, result) | (mode, result) <- zip modes measured] + mapM_ + ( \name -> do + let xs = map (fromJust . lookup name) samples + putStrLn (name <> " raw (tail ms, append ms, lookups, retained map/FIFO): " <> show xs) + putStrLn (name <> " medians tail/append ms: " <> show (median [t | (t, _, _, _) <- xs], median [a | (_, a, _, _) <- xs])) + ) + ["control", "warm", "cold"] + finalHead <- runStoreIO store visibleGlobalHeadPosition + case finalHead of + Right (GlobalPosition 8001) -> putStrLn "Verified 501 seeded + 7500 concurrently appended events; final visible head 8001." + other -> fail ("unexpected final head: " <> show other) runCase :: KirokuStore -> V.Vector RecordedEvent -> String -> IO (Double, Double, Int, (Int, Int)) runCase store events mode = do - cache <- newStreamNameCache - calls <- newIORef (0 :: Int) - count <- newTVarIO (0 :: Int) - sub <- Pub.PublisherSubscription <$> newTBQueueIO 1 <*> newTVarIO Pub.Active <*> newTVarIO 0 <*> pure (pure ()) - let lookupBatch ids = do - modifyIORef' calls (+ 1) - either (error . show) id <$> runStoreIO store (lookupStreamNames ids) - send msg = do - _ <- evaluate (LBS.length (encode msg)) - case msg of - Event _ -> atomically (modifyTVar' count (+ 1)) - _ -> fail "unexpected loss/error" - worker = - if mode == "control" - then replicateM_ 50 $ do - UnchangedBatch batch <- atomically (readTBQueue sub.subscriptionQueue) - V.mapM_ (send . Event . recordedEventToJSON) (V.filter (const True) batch) - -- Reproduce the original loop's post-delivery status sample. - _ <- atomically (readTVar sub.subscriptionStatus) - pure () - else broadcastEventsWith send cache lookupBatch sub (const True) - if mode == "warm" then resolveEventNames cache lookupBatch events >> writeIORef calls 0 else pure () - withAsync worker $ \_ -> do - (tailMs, appendMs) <- - concurrently - ( timed $ do - replicateM_ 50 (atomically (writeTBQueue sub.subscriptionQueue (UnchangedBatch events))) - bounded (atomically (readTVar count >>= check . (== 25000))) - ) - (timed $ replicateM_ 50 (append store (StreamName "appender") 10)) - lookups <- readIORef calls - retained <- streamNameCacheSize cache + cache <- newStreamNameCache + calls <- newIORef (0 :: Int) + count <- newTVarIO (0 :: Int) + sub <- Pub.PublisherSubscription <$> newTBQueueIO 1 <*> newTVarIO Pub.Active <*> newTVarIO 0 <*> pure (pure ()) + let lookupBatch ids = do + modifyIORef' calls (+ 1) + either (error . show) id <$> runStoreIO store (lookupStreamNames ids) + send msg = do + _ <- evaluate (LBS.length (encode msg)) + case msg of + Event _ -> atomically (modifyTVar' count (+ 1)) + _ -> fail "unexpected loss/error" + worker = if mode == "control" - then pure () - else do - if lookups == (if mode == "warm" then 0 else 1) && retained == (500, 500) then pure () else fail "cache invariant failed" - pure (tailMs, appendMs, lookups, retained) + then replicateM_ 50 $ do + UnchangedBatch batch <- atomically (readTBQueue sub.subscriptionQueue) + V.mapM_ (send . Event . recordedEventToJSON) (V.filter (const True) batch) + -- Reproduce the original loop's post-delivery status sample. + _ <- atomically (readTVar sub.subscriptionStatus) + pure () + else broadcastEventsWith send cache lookupBatch sub (const True) + if mode == "warm" then resolveEventNames cache lookupBatch events >> writeIORef calls 0 else pure () + withAsync worker $ \_ -> do + (tailMs, appendMs) <- + concurrently + ( timed $ do + replicateM_ 50 (atomically (writeTBQueue sub.subscriptionQueue (UnchangedBatch events))) + bounded (atomically (readTVar count >>= check . (== 25000))) + ) + (timed $ replicateM_ 50 (append store (StreamName "appender") 10)) + lookups <- readIORef calls + retained <- streamNameCacheSize cache + if mode == "control" + then pure () + else do + if lookups == (if mode == "warm" then 0 else 1) && retained == (500, 500) then pure () else fail "cache invariant failed" + pure (tailMs, appendMs, lookups, retained) append :: KirokuStore -> StreamName -> Int -> IO () append store name n = do - result <- runStoreIO store (appendToStream name AnyVersion (replicate n (EventData Nothing (EventType "Bench") (object []) Nothing Nothing Nothing))) - either (fail . show) (const (pure ())) result + result <- runStoreIO store (appendToStream name AnyVersion (replicate n (EventData Nothing (EventType "Bench") (object []) Nothing Nothing Nothing))) + either (fail . show) (const (pure ())) result timed :: IO a -> IO Double timed action = do - t0 <- getCurrentTime - _ <- action - t1 <- getCurrentTime - pure (realToFrac (diffUTCTime t1 t0) * 1000 :: Double) + t0 <- getCurrentTime + _ <- action + t1 <- getCurrentTime + pure (realToFrac (diffUTCTime t1 t0) * 1000 :: Double) bounded :: IO a -> IO a bounded action = timeout 30_000_000 action >>= maybe (fail "focused tail timeout") pure + median :: [Double] -> Double median xs = sort xs !! (length xs `div` 2) diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,18 +1,17 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-} -{- | A self-verifying runnable demo of @kiroku-metrics@ (EP-4). - -Boots an ephemeral, migrated PostgreSQL, opens a store with the metrics collector -wired into its callbacks /before/ @withStore@, starts the combined HTTP+WebSocket -server, appends a few events, then checks its own endpoints over real HTTP and a -real WebSocket. Prints a step transcript and exits non-zero if any check fails, so -running it is a test that the documented behavior holds: - -@ -cabal run kiroku-metrics-example -@ --} +-- | A self-verifying runnable demo of @kiroku-metrics@ (EP-4). +-- +-- Boots an ephemeral, migrated PostgreSQL, opens a store with the metrics collector +-- wired into its callbacks /before/ @withStore@, starts the combined HTTP+WebSocket +-- server, appends a few events, then checks its own endpoints over real HTTP and a +-- real WebSocket. Prints a step transcript and exits non-zero if any check fails, so +-- running it is a test that the documented behavior holds: +-- +-- @ +-- cabal run kiroku-metrics-example +-- @ module Main (main) where import Control.Concurrent (threadDelay) @@ -30,8 +29,8 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE -import Network.HTTP.Client ( - Manager, +import Network.HTTP.Client + ( Manager, defaultManagerSettings, httpLbs, method, @@ -41,15 +40,15 @@ responseBody, responseHeaders, responseStatus, - ) + ) import Network.HTTP.Types (statusCode) import Network.WebSockets qualified as WS import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) import System.Timeout (timeout) -import Kiroku.Metrics ( - Capabilities (..), +import Kiroku.Metrics + ( Capabilities (..), CheckpointInventoryResponse (..), MetricsServer (..), MetricsSnapshot (..), @@ -64,10 +63,10 @@ postgresPing, snapshotMetrics, withMetricsServerWithStore, - ) + ) import Kiroku.Metrics.Config (MetricsServerConfig (..)) -import Kiroku.Store ( - EventData (..), +import Kiroku.Store + ( EventData (..), EventType (..), ExpectedVersion (..), KirokuStore (..), @@ -76,128 +75,128 @@ defaultConnectionSettings, runStoreIO, withStore, - ) + ) import Kiroku.Store.Subscription.EventPublisher (EventPublisher (..), publisherPosition) import Kiroku.Store.Types (GlobalPosition (..)) import Kiroku.Test.Postgres (withMigratedTestDatabase) main :: IO () main = withMigratedTestDatabase $ \connStr -> do - step "[1/11] ephemeral postgres ready" + step "[1/11] ephemeral postgres ready" - -- The collector must observe events from the first append, so its callbacks - -- go on ConnectionSettings BEFORE withStore. But snapshots read store-level - -- gauges from the live handle — so the collector is built from STM readers - -- over a TVar that holds the store once it is open (the deferral pattern). - storeVar <- newTVarIO Nothing - metrics <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - let settings = - defaultConnectionSettings connStr - & #eventHandler .~ Just (metricsEventHandler metrics Nothing) - & #observationHandler .~ Just (metricsObservationHandler metrics Nothing) + -- The collector must observe events from the first append, so its callbacks + -- go on ConnectionSettings BEFORE withStore. But snapshots read store-level + -- gauges from the live handle — so the collector is built from STM readers + -- over a TVar that holds the store once it is open (the deferral pattern). + storeVar <- newTVarIO Nothing + metrics <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + let settings = + defaultConnectionSettings connStr + & #eventHandler .~ Just (metricsEventHandler metrics Nothing) + & #observationHandler .~ Just (metricsObservationHandler metrics Nothing) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - origin <- either (fail . show) pure (allowedOrigin "https://ops.example.com") - withMetricsServerWithStore (defaultConfig{port = 0, cors = corsAllowOrigins [origin]}) metrics store [postgresPing store] $ \srv -> do - threadDelay 300_000 - let port = srv.serverPort - base = "http://127.0.0.1:" <> show port - step ("[2/11] store + collector + metrics server on port " <> show port) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + origin <- either (fail . show) pure (allowedOrigin "https://ops.example.com") + withMetricsServerWithStore (defaultConfig {port = 0, cors = corsAllowOrigins [origin]}) metrics store [postgresPing store] $ \srv -> do + threadDelay 300_000 + let port = srv.serverPort + base = "http://127.0.0.1:" <> show port + step ("[2/11] store + collector + metrics server on port " <> show port) - appendEvents store (StreamName "orders-1") ["OrderCreated", "OrderPaid", "OrderShipped"] - step "[3/11] appended 3 events to orders-1" + appendEvents store (StreamName "orders-1") ["OrderCreated", "OrderPaid", "OrderShipped"] + step "[3/11] appended 3 events to orders-1" - mgr <- newManager defaultManagerSettings + mgr <- newManager defaultManagerSettings - (sMetrics, bMetrics) <- httpGet mgr (base <> "/metrics") - check "GET /metrics is 200" (sMetrics == 200) - let gpos = globalPositionOf bMetrics - check ("GET /metrics store.global_position >= 3 (got " <> show gpos <> ")") (gpos >= 3) + (sMetrics, bMetrics) <- httpGet mgr (base <> "/metrics") + check "GET /metrics is 200" (sMetrics == 200) + let gpos = globalPositionOf bMetrics + check ("GET /metrics store.global_position >= 3 (got " <> show gpos <> ")") (gpos >= 3) - (sProm, bProm) <- httpGet mgr (base <> "/metrics/prometheus") - check "GET /metrics/prometheus is 200" (sProm == 200) - check - "Prometheus body contains kiroku_events_appended_total" - (T.isInfixOf "kiroku_events_appended_total" (bodyText bProm)) + (sProm, bProm) <- httpGet mgr (base <> "/metrics/prometheus") + check "GET /metrics/prometheus is 200" (sProm == 200) + check + "Prometheus body contains kiroku_events_appended_total" + (T.isInfixOf "kiroku_events_appended_total" (bodyText bProm)) - (sLive, _) <- httpGet mgr (base <> "/health/live") - check "GET /health/live is 200" (sLive == 200) - (sReady, _) <- httpGet mgr (base <> "/health/ready") - check "GET /health/ready is 200" (sReady == 200) - step "[4/11] HTTP /metrics, /prometheus, /health/live, /health/ready all OK" + (sLive, _) <- httpGet mgr (base <> "/health/live") + check "GET /health/live is 200" (sLive == 200) + (sReady, _) <- httpGet mgr (base <> "/health/ready") + check "GET /health/ready is 200" (sReady == 200) + step "[4/11] HTTP /metrics, /prometheus, /health/live, /health/ready all OK" - -- Browser preflight and ordinary reads share the host's allowlist. - request <- parseRequest (base <> "/metrics") - let ops = "https://ops.example.com" - evil = "https://evil.example.com" - preflight <- httpLbs (request{method = "OPTIONS", requestHeaders = [("Origin", ops), ("Access-Control-Request-Method", "GET")]}) mgr - check "CORS preflight is 204" (statusCode (responseStatus preflight) == 204) - check "CORS preflight echoes origin" (lookup "Access-Control-Allow-Origin" (responseHeaders preflight) == Just ops) - allowed <- httpLbs (request{requestHeaders = [("Origin", ops)]}) mgr - check "CORS GET echoes origin" (lookup "Access-Control-Allow-Origin" (responseHeaders allowed) == Just ops) - denied <- httpLbs (request{requestHeaders = [("Origin", evil)]}) mgr - check "CORS denied GET is unchanged" (statusCode (responseStatus denied) == 200) - check "CORS denied GET grants nothing" (all (\(name, _) -> name `notElem` ["Access-Control-Allow-Origin", "Access-Control-Allow-Credentials", "Access-Control-Allow-Methods", "Access-Control-Allow-Headers", "Access-Control-Max-Age"]) (responseHeaders denied)) - step "[5/11] CORS: preflight and GET from https://ops.example.com allowed; https://evil.example.com undecorated" + -- Browser preflight and ordinary reads share the host's allowlist. + request <- parseRequest (base <> "/metrics") + let ops = "https://ops.example.com" + evil = "https://evil.example.com" + preflight <- httpLbs (request {method = "OPTIONS", requestHeaders = [("Origin", ops), ("Access-Control-Request-Method", "GET")]}) mgr + check "CORS preflight is 204" (statusCode (responseStatus preflight) == 204) + check "CORS preflight echoes origin" (lookup "Access-Control-Allow-Origin" (responseHeaders preflight) == Just ops) + allowed <- httpLbs (request {requestHeaders = [("Origin", ops)]}) mgr + check "CORS GET echoes origin" (lookup "Access-Control-Allow-Origin" (responseHeaders allowed) == Just ops) + denied <- httpLbs (request {requestHeaders = [("Origin", evil)]}) mgr + check "CORS denied GET is unchanged" (statusCode (responseStatus denied) == 200) + check "CORS denied GET grants nothing" (all (\(name, _) -> name `notElem` ["Access-Control-Allow-Origin", "Access-Control-Allow-Credentials", "Access-Control-Allow-Methods", "Access-Control-Allow-Headers", "Access-Control-Max-Age"]) (responseHeaders denied)) + step "[5/11] CORS: preflight and GET from https://ops.example.com allowed; https://evil.example.com undecorated" - (sCheckpoints, bCheckpoints) <- httpGet mgr (base <> "/subscription-checkpoints") - check "GET /subscription-checkpoints is 200" (sCheckpoints == 200) - case decode bCheckpoints of - Just (CheckpointInventoryResponse position rows) -> do - check "durable store_position >= 3" (position >= 3) - check "no durable checkpoints without subscriptions" (null rows) - step ("[6/11] GET /subscription-checkpoints store_position=" <> show position <> " with no durable checkpoints (this example runs no subscription)") - Nothing -> check "durable inventory decodes" False + (sCheckpoints, bCheckpoints) <- httpGet mgr (base <> "/subscription-checkpoints") + check "GET /subscription-checkpoints is 200" (sCheckpoints == 200) + case decode bCheckpoints of + Just (CheckpointInventoryResponse position rows) -> do + check "durable store_position >= 3" (position >= 3) + check "no durable checkpoints without subscriptions" (null rows) + step ("[6/11] GET /subscription-checkpoints store_position=" <> show position <> " with no durable checkpoints (this example runs no subscription)") + Nothing -> check "durable inventory decodes" False - (sStreams, bStreams) <- httpGet mgr (base <> "/streams?category=orders") - check "GET /streams is 200" (sStreams == 200) - check "stream page has items" (maybe False (\v -> case lookKey ["items"] v of Just (Array rows) -> not (null rows); _ -> False) (decode bStreams)) - (sEvents, bEvents) <- httpGet mgr (base <> "/events?from=0&limit=10") - check "GET /events is 200" (sEvents == 200) - case decode bEvents of - Just value | Just (Array rows) <- lookKey ["items"] value -> do - check "event page includes original names" (all (\row -> lookKey ["original_stream_name"] row == Just (String "orders-1")) rows) - case foldr (:) [] rows of - first : _ | Just (String uuid) <- lookKey ["eventId"] first -> do - (status, _) <- httpGet mgr (base <> "/events/" <> T.unpack uuid) - check "GET event by id is 200" (status == 200) - _ -> check "event page is nonempty" False - _ -> check "event page decodes" False - step "[7/11] Stream browsing and historical events resolve original stream names" + (sStreams, bStreams) <- httpGet mgr (base <> "/streams?category=orders") + check "GET /streams is 200" (sStreams == 200) + check "stream page has items" (maybe False (\v -> case lookKey ["items"] v of Just (Array rows) -> not (null rows); _ -> False) (decode bStreams)) + (sEvents, bEvents) <- httpGet mgr (base <> "/events?from=0&limit=10") + check "GET /events is 200" (sEvents == 200) + case decode bEvents of + Just value | Just (Array rows) <- lookKey ["items"] value -> do + check "event page includes original names" (all (\row -> lookKey ["original_stream_name"] row == Just (String "orders-1")) rows) + case foldr (:) [] rows of + first : _ | Just (String uuid) <- lookKey ["eventId"] first -> do + (status, _) <- httpGet mgr (base <> "/events/" <> T.unpack uuid) + check "GET event by id is 200" (status == 200) + _ -> check "event page is nonempty" False + _ -> check "event page decodes" False + step "[7/11] Stream browsing and historical events resolve original stream names" - (sDeadLetters, bDeadLetters) <- httpGet mgr (base <> "/subscriptions/example/dead-letters?limit=10") - check "dead-letter page status" (sDeadLetters == 200) - check "dead-letter page is empty without a cursor" (decode bDeadLetters == Just (object ["items" .= ([] :: [Value])])) - step "[8/11] GET /subscriptions/example/dead-letters returned an empty page (this example runs no subscription)" + (sDeadLetters, bDeadLetters) <- httpGet mgr (base <> "/subscriptions/example/dead-letters?limit=10") + check "dead-letter page status" (sDeadLetters == 200) + check "dead-letter page is empty without a cursor" (decode bDeadLetters == Just (object ["items" .= ([] :: [Value])])) + step "[8/11] GET /subscriptions/example/dead-letters returned an empty page (this example runs no subscription)" - (sCaps, bCaps) <- httpGet mgr (base <> "/capabilities") - check "discovery status" (sCaps == 200) - case decode bCaps of - Just (caps :: Capabilities) -> - check - "discovery reflects legacy store wiring" - (caps.routes.browse && caps.routes.subscriptionsCheckpoints && caps.routes.deadLetters && caps.routes.websocketEvents && not caps.routes.subscriptionsLive) - Nothing -> check "discovery decodes" False - step "[9/11] GET /capabilities reports browse, checkpoints, dead letters, and the event tail" + (sCaps, bCaps) <- httpGet mgr (base <> "/capabilities") + check "discovery status" (sCaps == 200) + case decode bCaps of + Just (caps :: Capabilities) -> + check + "discovery reflects legacy store wiring" + (caps.routes.browse && caps.routes.subscriptionsCheckpoints && caps.routes.deadLetters && caps.routes.websocketEvents && not caps.routes.subscriptionsLive) + Nothing -> check "discovery decodes" False + step "[9/11] GET /capabilities reports browse, checkpoints, dead letters, and the event tail" - -- WebSocket: subscribe to the live event tail, then append one more - -- event and assert it arrives over the socket as a JSON event message. - evType <- - requireJust "WebSocket /ws/events round-trip timed out" $ - timeout 15_000_000 $ - WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do - WS.sendTextData conn (encode (object ["type" .= ("subscribe_events" :: Text)])) - _ <- waitForType conn "event_stream_started" - appendThread <- async (appendEvents store (StreamName "orders-2") ["OrderRefunded"]) - ev <- waitForType conn "event" - wait appendThread - pure (eventTypeOf ev) - check ("WebSocket event eventType == OrderRefunded (got " <> T.unpack evType <> ")") (evType == "OrderRefunded") - step ("[10/11] WebSocket /ws/events received event eventType=" <> T.unpack evType) + -- WebSocket: subscribe to the live event tail, then append one more + -- event and assert it arrives over the socket as a JSON event message. + evType <- + requireJust "WebSocket /ws/events round-trip timed out" $ + timeout 15_000_000 $ + WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do + WS.sendTextData conn (encode (object ["type" .= ("subscribe_events" :: Text)])) + _ <- waitForType conn "event_stream_started" + appendThread <- async (appendEvents store (StreamName "orders-2") ["OrderRefunded"]) + ev <- waitForType conn "event" + wait appendThread + pure (eventTypeOf ev) + check ("WebSocket event eventType == OrderRefunded (got " <> T.unpack evType <> ")") (evType == "OrderRefunded") + step ("[10/11] WebSocket /ws/events received event eventType=" <> T.unpack evType) - snap <- snapshotMetrics metrics - step ("[11/11] kiroku-metrics-example: all checks passed (snapshot global position = " <> show snap.store.globalPosition <> ")") + snap <- snapshotMetrics metrics + step ("[11/11] kiroku-metrics-example: all checks passed (snapshot global position = " <> show snap.store.globalPosition <> ")") -------------------------------------------------------------------------------- -- Helpers @@ -210,47 +209,47 @@ -- | Assert a condition; on failure print to stderr and exit non-zero. check :: String -> Bool -> IO () check label ok = - unless ok $ do - hPutStrLn stderr ("kiroku-metrics-example: FAILED: " <> label) - exitFailure + unless ok $ do + hPutStrLn stderr ("kiroku-metrics-example: FAILED: " <> label) + exitFailure -- | Require a timed action to have produced a result; else fail the example. requireJust :: String -> IO (Maybe a) -> IO a requireJust label act = - act >>= \case - Just a -> pure a - Nothing -> do - hPutStrLn stderr ("kiroku-metrics-example: FAILED: " <> label) - exitFailure + act >>= \case + Just a -> pure a + Nothing -> do + hPutStrLn stderr ("kiroku-metrics-example: FAILED: " <> label) + exitFailure -- | GET a URL, returning the status code and the body (no throwing on non-2xx). httpGet :: Manager -> String -> IO (Int, ByteString) httpGet mgr url = do - req <- parseRequest url - resp <- httpLbs req mgr - pure (statusCode (responseStatus resp), responseBody resp) + req <- parseRequest url + resp <- httpLbs req mgr + pure (statusCode (responseStatus resp), responseBody resp) -- | Read server messages until one with the given @"type"@ arrives; return it. waitForType :: WS.Connection -> Text -> IO Value waitForType conn want = go where go = do - raw <- WS.receiveData conn :: IO ByteString - case decode raw of - Just v | lookKey ["type"] v == Just (String want) -> pure v - _ -> go + raw <- WS.receiveData conn :: IO ByteString + case decode raw of + Just v | lookKey ["type"] v == Just (String want) -> pure v + _ -> go -- | Extract @event.eventType@ from an @event@ message ("" if absent). eventTypeOf :: Value -> Text eventTypeOf v = case lookKey ["event", "eventType"] v of - Just (String t) -> t - _ -> "" + Just (String t) -> t + _ -> "" -- | Extract @store.global_position@ from a @/metrics@ JSON body. globalPositionOf :: ByteString -> Int globalPositionOf body = case decode body of - Just v | Just (Number n) <- lookKey ["store", "global_position"] v -> truncate (toRealFloat n :: Double) - _ -> -1 + Just v | Just (Number n) <- lookKey ["store", "global_position"] v -> truncate (toRealFloat n :: Double) + _ -> -1 -- | Navigate nested object keys. lookKey :: [Text] -> Value -> Maybe Value @@ -263,28 +262,28 @@ appendEvents :: KirokuStore -> StreamName -> [Text] -> IO () appendEvents store stream types = do - let events = - [ EventData - { eventId = Nothing - , eventType = EventType t - , payload = Null - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } - | t <- types - ] - result <- runStoreIO store (appendToStream stream NoStream events) - case result of - Right _ -> pure () - Left err -> do - hPutStrLn stderr ("kiroku-metrics-example: append failed: " <> show err) - exitFailure + let events = + [ EventData + { eventId = Nothing, + eventType = EventType t, + payload = Null, + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } + | t <- types + ] + result <- runStoreIO store (appendToStream stream NoStream events) + case result of + Right _ -> pure () + Left err -> do + hPutStrLn stderr ("kiroku-metrics-example: append failed: " <> show err) + exitFailure readPosition :: TVar (Maybe KirokuStore) -> STM GlobalPosition readPosition storeVar = - readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) + readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) readSubscribers :: TVar (Maybe KirokuStore) -> STM Int readSubscribers storeVar = - readTVar storeVar >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) + readTVar storeVar >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) diff --git a/kiroku-metrics.cabal b/kiroku-metrics.cabal --- a/kiroku-metrics.cabal +++ b/kiroku-metrics.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: kiroku-metrics -version: 0.3.0.1 +version: 0.4.0.0 synopsis: Metrics, health, and event-streaming HTTP endpoints for Kiroku @@ -69,8 +69,8 @@ , hasql >=1.10 && <1.11 , hasql-pool >=1.2 && <1.5 , http-types >=0.12 && <0.13 - , kiroku-cli ^>=0.2.0.10 - , kiroku-store ^>=0.11.0.0 + , kiroku-cli ^>=0.2.0.11 + , kiroku-store ^>=0.12.0.0 , network >=3.1 && <3.3 , optparse-applicative >=0.19 && <0.20 , stm >=2.5 && <2.6 @@ -89,6 +89,7 @@ import: common main-is: Main.hs hs-source-dirs: app-inspect + other-modules: InspectSignals ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , base >=4.18 && <5 @@ -126,7 +127,7 @@ , http-client >=0.7 && <0.8 , http-types >=0.12 && <0.13 , kiroku-metrics - , kiroku-store ^>=0.11.0.0 + , kiroku-store ^>=0.12.0.0 , kiroku-test-support ^>=0.1 , lens >=5.2 && <5.4 , scientific >=0.3 && <0.4 @@ -140,6 +141,7 @@ build-tool-depends: kiroku-metrics:kiroku-inspect main-is: Main.hs other-modules: + InspectSignals Test.BrowseSpec Test.CapabilitiesSpec Test.CheckpointsSpec @@ -153,7 +155,7 @@ Test.WebSocketConvergenceSpec Test.WebSocketSpec - hs-source-dirs: test + hs-source-dirs: test app-inspect ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , aeson >=2.1 && <2.3 @@ -170,9 +172,9 @@ , hspec >=2.10 && <2.12 , http-client >=0.7 && <0.8 , http-types >=0.12 && <0.13 - , kiroku-cli ^>=0.2.0.10 + , kiroku-cli ^>=0.2.0.11 , kiroku-metrics - , kiroku-store ^>=0.11.0.0 + , kiroku-store ^>=0.12.0.0 , kiroku-test-support , lens >=5.2 && <5.4 , network >=3.1 && <3.3 @@ -196,14 +198,14 @@ hs-source-dirs: bench ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A32m" build-depends: - , aeson >=2.1 && <2.3 - , async >=2.2 && <2.3 - , base >=4.18 && <5 - , bytestring >=0.11 && <0.13 + , aeson >=2.1 && <2.3 + , async >=2.2 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 , kiroku-metrics - , kiroku-store + , kiroku-store ^>=0.12.0.0 , kiroku-test-support - , stm >=2.5 && <2.6 - , text >=2.0 && <2.2 - , time >=1.12 && <1.15 - , vector >=0.13 && <0.14 + , stm >=2.5 && <2.6 + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , vector >=0.13 && <0.14 diff --git a/src/Kiroku/Metrics.hs b/src/Kiroku/Metrics.hs --- a/src/Kiroku/Metrics.hs +++ b/src/Kiroku/Metrics.hs @@ -1,10 +1,9 @@ -{- | Umbrella re-export for the @kiroku-metrics@ package. Importing -@Kiroku.Metrics@ brings the in-process metrics collector, the JSON-encodable -snapshot type, the server configuration and lifecycle, and the health-check -types into scope. --} -module Kiroku.Metrics ( - module Kiroku.Metrics.Browse, +-- | Umbrella re-export for the @kiroku-metrics@ package. Importing +-- @Kiroku.Metrics@ brings the in-process metrics collector, the JSON-encodable +-- snapshot type, the server configuration and lifecycle, and the health-check +-- types into scope. +module Kiroku.Metrics + ( module Kiroku.Metrics.Browse, module Kiroku.Metrics.Capabilities, module Kiroku.Metrics.Types, module Kiroku.Metrics.Collector, @@ -17,7 +16,8 @@ module Kiroku.Metrics.Standalone, module Kiroku.Metrics.Subscriptions, module Kiroku.Metrics.WebSocket, -) where + ) +where import Kiroku.Metrics.Browse import Kiroku.Metrics.Capabilities diff --git a/src/Kiroku/Metrics/Browse.hs b/src/Kiroku/Metrics/Browse.hs --- a/src/Kiroku/Metrics/Browse.hs +++ b/src/Kiroku/Metrics/Browse.hs @@ -1,9 +1,8 @@ -{- | Bounded inspection reads. Stream names use stable UTF-8 byte order; -category enumeration retains the database's category collation. Cursors are -exclusive and describe live pages rather than a cross-request snapshot. --} -module Kiroku.Metrics.Browse ( - StoreBrowser (..), +-- | Bounded inspection reads. Stream names use stable UTF-8 byte order; +-- category enumeration retains the database's category collation. Cursors are +-- exclusive and describe live pages rather than a cross-request snapshot. +module Kiroku.Metrics.Browse + ( StoreBrowser (..), storeBrowser, storeBrowserWith, BrowseLimits, @@ -16,7 +15,8 @@ browseApp, browseNotConfiguredApp, streamInfoToJSON, -) where + ) +where import Data.Aeson (Value, encode, object, toJSON, (.=)) import Data.ByteString qualified as BS @@ -40,207 +40,223 @@ import Text.Read (readMaybe) data StoreBrowser = StoreBrowser - { runStoreRead :: forall a. Eff '[Store, Error StoreError, IOE] a -> IO (Either StoreError a) - , limits :: !BrowseLimits - } + { runStoreRead :: forall a. Eff '[Store, Error StoreError, IOE] a -> IO (Either StoreError a), + limits :: !BrowseLimits + } data BrowseLimits = BrowseLimits {defaultLimit :: !Int, maxLimit :: !Int} - deriving stock (Eq, Show) + deriving stock (Eq, Show) + data BrowseLimitsError = InvalidBrowseLimits !Int !Int deriving stock (Eq, Show) + mkBrowseLimits :: Int -> Int -> Either BrowseLimitsError BrowseLimits mkBrowseLimits def cap - | 1 <= def && def <= cap && cap <= 1000 = Right (BrowseLimits def cap) - | otherwise = Left (InvalidBrowseLimits def cap) + | 1 <= def && def <= cap && cap <= 1000 = Right (BrowseLimits def cap) + | otherwise = Left (InvalidBrowseLimits def cap) + defaultBrowseLimits :: BrowseLimits defaultBrowseLimits = BrowseLimits 100 1000 + storeBrowser :: KirokuStore -> StoreBrowser storeBrowser = storeBrowserWith defaultBrowseLimits + storeBrowserWith :: BrowseLimits -> KirokuStore -> StoreBrowser storeBrowserWith lims store = StoreBrowser (runStoreIO store) lims data ReadDirection = ReadForward | ReadBackward deriving stock (Eq, Show) + type ReadProgram a = Eff '[Store, Error StoreError, IOE] a + type Failure = (Status, Text, Text, Maybe Value) -- | Preserve GET status/headers for HEAD. Other methods never run a read. readMethods :: (Request -> IO Response) -> Application readMethods action req respond - | requestMethod req == "GET" = action req >>= respond - | requestMethod req == "HEAD" = do - response <- action req - respond (responseLBS (responseStatus response) (responseHeaders response) "") - | otherwise = - respond $ - mapResponseHeaders (("Allow", "GET, HEAD") :) $ - errorResponse status405 "method_not_allowed" "Only GET and HEAD are supported." Nothing + | requestMethod req == "GET" = action req >>= respond + | requestMethod req == "HEAD" = do + response <- action req + respond (responseLBS (responseStatus response) (responseHeaders response) "") + | otherwise = + respond $ + mapResponseHeaders (("Allow", "GET, HEAD") :) $ + errorResponse status405 "method_not_allowed" "Only GET and HEAD are supported." Nothing browseNotConfiguredApp :: Application browseNotConfiguredApp = readMethods $ \_ -> pure (errorResponse status404 "store_browsing_not_configured" "Store browsing is not configured." Nothing) browseApp :: StoreBrowser -> Application browseApp browser = readMethods $ \req -> case route browser req of - Left (status, code, message, details) -> pure (errorResponse status code message details) - Right program -> - runStoreRead browser program >>= \case - Left err -> pure (storeErrorResponse "store_unavailable" err) - Right (Left (status, code, message, details)) -> pure (errorResponse status code message details) - Right (Right value) -> pure (jsonResponse status200 (encode value)) + Left (status, code, message, details) -> pure (errorResponse status code message details) + Right program -> + runStoreRead browser program >>= \case + Left err -> pure (storeErrorResponse "store_unavailable" err) + Right (Left (status, code, message, details)) -> pure (errorResponse status code message details) + Right (Right value) -> pure (jsonResponse status200 (encode value)) route :: StoreBrowser -> Request -> Either Failure (ReadProgram (Either Failure Value)) route browser req = case pathInfo req of - ["streams"] -> do - limit <- pageLimit - category <- fmap CategoryName <$> textParam "category" - prefix <- textParam "prefix" - cursor <- fmap StreamName <$> textParam "from" - size <- browseSize limit - pure $ do - rows <- listStreams category prefix cursor size - pure $ Right $ pageJSON limit streamInfoToJSON (\row -> let StreamName name = row.name in AesonText name) rows - ["streams", name] -> do - stream <- validStream name - pure $ getStream stream >>= pure . maybe (Left (missing "stream_not_found" "Stream not found.")) (Right . streamInfoToJSON) - ["streams", name, "events"] -> do - stream <- validStream name - limit <- pageLimit - cursor <- position - direction <- readDirection - pure $ - getStream stream >>= \case - Nothing -> pure (Left (missing "stream_not_found" "Stream not found.")) - Just _ -> - Right - <$> eventPage - limit - (\event -> let StreamVersion v = event.streamVersion in AesonNumber v) - (case direction of ReadForward -> readStreamForward stream (StreamVersion cursor) (overfetch limit); ReadBackward -> readStreamBackward stream (StreamVersion cursor) (overfetch limit)) - ["categories"] -> do - limit <- pageLimit - cursor <- fmap CategoryName <$> textParam "from" - size <- browseSize limit - pure $ do - rows <- listCategories cursor size - pure $ Right $ pageJSON limit (\(CategoryName name) -> object ["name" .= name]) (\(CategoryName name) -> AesonText name) rows - ["categories", name, "events"] -> do - validText "category" name - limit <- pageLimit - cursor <- position - -- Category reads have one supported direction; do not silently ignore it. - direction <- readDirection - if direction == ReadBackward - then Left (invalid "direction" "backward" "Category events support forward reads.") - else - pure $ Right <$> eventPage limit globalCursor (readCategory (CategoryName name) (GlobalPosition cursor) (overfetch limit)) - ["events"] -> do - limit <- pageLimit - cursor <- position - direction <- readDirection - pure $ - Right - <$> eventPage - limit - globalCursor - (case direction of ReadForward -> readAllForward (GlobalPosition cursor) (overfetch limit); ReadBackward -> readAllBackward (GlobalPosition cursor) (overfetch limit)) - ["events", rawId] -> case UUID.fromText rawId of - Nothing -> Left (status400, "invalid_event_id", "The event id must be a UUID.", Nothing) - Just uuid -> - pure $ - getEvent (EventId uuid) >>= \case - Nothing -> pure (Left (missing "event_not_found" "Event not found.")) - Just event -> do - mapping <- lookupStreamNames [event.originalStreamId] - pure (Right (recordedEventToJSONResolved mapping event)) - _ -> Left (missing "not_found" "Not found.") + ["streams"] -> do + limit <- pageLimit + category <- fmap CategoryName <$> textParam "category" + prefix <- textParam "prefix" + cursor <- fmap StreamName <$> textParam "from" + size <- browseSize limit + pure $ do + rows <- listStreams category prefix cursor size + pure $ Right $ pageJSON limit streamInfoToJSON (\row -> let StreamName name = row.name in AesonText name) rows + ["streams", name] -> do + stream <- validStream name + pure $ getStream stream >>= pure . maybe (Left (missing "stream_not_found" "Stream not found.")) (Right . streamInfoToJSON) + ["streams", name, "events"] -> do + stream <- validStream name + limit <- pageLimit + cursor <- position + direction <- readDirection + pure $ + getStream stream >>= \case + Nothing -> pure (Left (missing "stream_not_found" "Stream not found.")) + Just _ -> + Right + <$> eventPage + limit + (\event -> let StreamVersion v = event.streamVersion in AesonNumber v) + (case direction of ReadForward -> readStreamForward stream (StreamVersion cursor) (overfetch limit); ReadBackward -> readStreamBackward stream (StreamVersion cursor) (overfetch limit)) + ["categories"] -> do + limit <- pageLimit + cursor <- fmap CategoryName <$> textParam "from" + size <- browseSize limit + pure $ do + rows <- listCategories cursor size + pure $ Right $ pageJSON limit (\(CategoryName name) -> object ["name" .= name]) (\(CategoryName name) -> AesonText name) rows + ["categories", name, "events"] -> do + validText "category" name + limit <- pageLimit + cursor <- position + -- Category reads have one supported direction; do not silently ignore it. + direction <- readDirection + if direction == ReadBackward + then Left (invalid "direction" "backward" "Category events support forward reads.") + else + pure $ Right <$> eventPage limit globalCursor (readCategory (CategoryName name) (GlobalPosition cursor) (overfetch limit)) + ["events"] -> do + limit <- pageLimit + cursor <- position + direction <- readDirection + pure $ + Right + <$> eventPage + limit + globalCursor + (case direction of ReadForward -> readAllForward (GlobalPosition cursor) (overfetch limit); ReadBackward -> readAllBackward (GlobalPosition cursor) (overfetch limit)) + ["events", rawId] -> case UUID.fromText rawId of + Nothing -> Left (status400, "invalid_event_id", "The event id must be a UUID.", Nothing) + Just uuid -> + pure $ + getEvent (EventId uuid) >>= \case + Nothing -> pure (Left (missing "event_not_found" "Event not found.")) + Just event -> do + mapping <- lookupStreamNames [event.originalStreamId] + pure (Right (recordedEventToJSONResolved mapping event)) + _ -> Left (missing "not_found" "Not found.") where pageLimit = do - value <- rawParam req "limit" - case value of - Nothing -> Right browser.limits.defaultLimit - Just raw -> case decimal raw of - Just n | 1 <= n && n <= toInteger browser.limits.maxLimit -> Right (fromInteger n) - _ -> Left (invalid "limit" raw "Expected a decimal integer within the configured page limit.") + value <- rawParam req "limit" + case value of + Nothing -> Right browser.limits.defaultLimit + Just raw -> case decimal raw of + Just n | 1 <= n && n <= toInteger browser.limits.maxLimit -> Right (fromInteger n) + _ -> Left (invalid "limit" raw "Expected a decimal integer within the configured page limit.") textParam key = do - value <- rawParam req key - mapM_ (validText key) value - pure value + value <- rawParam req key + mapM_ (validText key) value + pure value position = do - value <- rawParam req "from" - case value of - Nothing -> Right 0 - Just raw -> case decimal raw of - Just n | n <= toInteger (maxBound :: Int64) -> Right (fromInteger n) - _ -> Left (invalid "from" raw "Expected a non-negative Int64 decimal integer.") + value <- rawParam req "from" + case value of + Nothing -> Right 0 + Just raw -> case decimal raw of + Just n | n <= toInteger (maxBound :: Int64) -> Right (fromInteger n) + _ -> Left (invalid "from" raw "Expected a non-negative Int64 decimal integer.") readDirection = - rawParam req "direction" >>= \case - Nothing -> Right ReadForward - Just "forward" -> Right ReadForward - Just "backward" -> Right ReadBackward - Just raw -> Left (invalid "direction" raw "Expected forward or backward.") + rawParam req "direction" >>= \case + Nothing -> Right ReadForward + Just "forward" -> Right ReadForward + Just "backward" -> Right ReadBackward + Just raw -> Left (invalid "direction" raw "Expected forward or backward.") -- Closed bounds make over-fetch safe before conversion to the store's Int32. overfetch :: Int -> Int32 overfetch limit = fromIntegral (limit + 1) + browseSize :: Int -> Either Failure BrowsePageSize browseSize limit = case mkBrowsePageSize (limit + 1) of - Right size -> Right size - Left _ -> Left (invalid "limit" (T.pack (show limit)) "Invalid page limit.") + Right size -> Right size + Left _ -> Left (invalid "limit" (T.pack (show limit)) "Invalid page limit.") data Cursor = AesonText Text | AesonNumber Int64 + cursorJSON :: Cursor -> Value cursorJSON (AesonText text) = toJSON text cursorJSON (AesonNumber n) = toJSON n pageJSON :: Int -> (a -> Value) -> (a -> Cursor) -> Vector a -> Value pageJSON limit encodeItem cursor rows = - object $ ["items" .= V.map encodeItem items] <> ["next_cursor" .= cursorJSON (cursor (V.last items)) | V.length rows > limit && not (V.null items)] + object $ ["items" .= V.map encodeItem items] <> ["next_cursor" .= cursorJSON (cursor (V.last items)) | V.length rows > limit && not (V.null items)] where items = V.take limit rows eventPage :: Int -> (RecordedEvent -> Cursor) -> ReadProgram (Vector RecordedEvent) -> ReadProgram Value eventPage limit cursor readPage = do - rows <- readPage - mapping <- resolveNames (V.take limit rows) - pure (pageJSON limit (recordedEventToJSONResolved mapping) cursor rows) + rows <- readPage + mapping <- resolveNames (V.take limit rows) + pure (pageJSON limit (recordedEventToJSONResolved mapping) cursor rows) + resolveNames :: Vector RecordedEvent -> ReadProgram (Map StreamId StreamName) resolveNames rows - | V.null rows = pure Map.empty - | otherwise = lookupStreamNames (Set.toList (Set.fromList (map (\event -> event.originalStreamId) (V.toList rows)))) + | V.null rows = pure Map.empty + | otherwise = lookupStreamNames (Set.toList (Set.fromList (map (\event -> event.originalStreamId) (V.toList rows)))) + globalCursor :: RecordedEvent -> Cursor globalCursor event = let GlobalPosition n = event.globalPosition in AesonNumber n streamInfoToJSON :: StreamInfo -> Value streamInfoToJSON stream = - object - [ "stream_id" .= (let StreamId n = stream.id in n) - , "name" .= (let StreamName name = stream.name in name) - , "category" .= (let CategoryName category = categoryName stream.name in category) - , "version" .= (let StreamVersion n = stream.version in n) - , "created_at" .= stream.createdAt - , "deleted_at" .= stream.deletedAt - , "truncate_before" .= (let StreamVersion n = stream.truncateBefore in n) - ] + object + [ "stream_id" .= (let StreamId n = stream.id in n), + "name" .= (let StreamName name = stream.name in name), + "category" .= (let CategoryName category = categoryName stream.name in category), + "version" .= (let StreamVersion n = stream.version in n), + "created_at" .= stream.createdAt, + "deleted_at" .= stream.deletedAt, + "truncate_before" .= (let StreamVersion n = stream.truncateBefore in n) + ] missing :: Text -> Text -> Failure missing code message = (status404, code, message, Nothing) + invalid :: Text -> Text -> Text -> Failure invalid key raw reason = (status400, "invalid_query_parameter", "Invalid query parameter.", Just (object ["parameter" .= key, "value" .= raw, "reason" .= reason])) + rawParam :: Request -> BS.ByteString -> Either Failure (Maybe Text) rawParam req key = case lookup key (queryString req) of - Nothing -> Right Nothing - Just Nothing -> Right (Just "") - Just (Just bytes) -> case TE.decodeUtf8' bytes of - Right value -> Right (Just value) - Left _ -> Left (invalid (TE.decodeUtf8 key) "" "Expected valid UTF-8.") + Nothing -> Right Nothing + Just Nothing -> Right (Just "") + Just (Just bytes) -> case TE.decodeUtf8' bytes of + Right value -> Right (Just value) + Left _ -> Left (invalid (TE.decodeUtf8 key) "" "Expected valid UTF-8.") + validText :: BS.ByteString -> Text -> Either Failure () validText key value - | T.any (== '\0') value || BS.length (TE.encodeUtf8 value) > 512 = Left (invalid (TE.decodeUtf8 key) value "Expected at most 512 UTF-8 bytes without NUL.") - | otherwise = Right () + | T.any (== '\0') value || BS.length (TE.encodeUtf8 value) > 512 = Left (invalid (TE.decodeUtf8 key) value "Expected at most 512 UTF-8 bytes without NUL.") + | otherwise = Right () + validStream :: Text -> Either Failure StreamName validStream value = case validateStreamName (StreamName value) of - Right () | not (T.any (== '\0') value) -> Right (StreamName value) - _ -> Left (status400, "invalid_stream_name", "Invalid stream name.", Just (object ["stream_name" .= value])) + Right () | not (T.any (== '\0') value) -> Right (StreamName value) + _ -> Left (status400, "invalid_stream_name", "Invalid stream name.", Just (object ["stream_name" .= value])) + decimal :: Text -> Maybe Integer decimal value - | T.null value || not (T.all (\c -> '0' <= c && c <= '9') value) = Nothing - | T.length value > 20 = Nothing - | otherwise = readMaybe (T.unpack value) + | T.null value || not (T.all (\c -> '0' <= c && c <= '9') value) = Nothing + | T.length value > 20 = Nothing + | otherwise = readMaybe (T.unpack value) diff --git a/src/Kiroku/Metrics/Capabilities.hs b/src/Kiroku/Metrics/Capabilities.hs --- a/src/Kiroku/Metrics/Capabilities.hs +++ b/src/Kiroku/Metrics/Capabilities.hs @@ -1,8 +1,8 @@ {-# LANGUAGE NoFieldSelectors #-} -- | Mount-relative discovery, computed from configuration and actual provider wiring. -module Kiroku.Metrics.Capabilities ( - WebSocketChannels (..), +module Kiroku.Metrics.Capabilities + ( WebSocketChannels (..), noWebSocketChannels, storeWebSocketChannels, ProviderPresence (..), @@ -13,7 +13,8 @@ processLocalRoutes, capabilitiesApp, capabilitiesPath, -) where + ) +where import Data.Aeson (FromJSON (..), ToJSON (..), encode, object, withObject, (.:), (.=)) import Data.Text (Text) @@ -29,43 +30,43 @@ -- | Declaration by the host choosing the opaque WebSocket application. data WebSocketChannels = WebSocketChannels - {metricsChannel :: !Bool, eventsChannel :: !Bool} - deriving stock (Eq, Show) + {metricsChannel :: !Bool, eventsChannel :: !Bool} + deriving stock (Eq, Show) noWebSocketChannels, storeWebSocketChannels :: WebSocketChannels noWebSocketChannels = WebSocketChannels False False storeWebSocketChannels = WebSocketChannels True True data ProviderPresence = ProviderPresence - { hasSubscriptionStatus :: !Bool - , hasCheckpointInventory :: !Bool - , hasBrowser :: !Bool - , hasDeadLetters :: !Bool - , presentWebSocketChannels :: !WebSocketChannels - } - deriving stock (Eq, Show) + { hasSubscriptionStatus :: !Bool, + hasCheckpointInventory :: !Bool, + hasBrowser :: !Bool, + hasDeadLetters :: !Bool, + presentWebSocketChannels :: !WebSocketChannels + } + deriving stock (Eq, Show) data RouteAvailability = RouteAvailability - { metrics :: !Bool - , prometheus :: !Bool - , health :: !Bool - , subscriptionsLive :: !Bool - , subscriptionsCheckpoints :: !Bool - , deadLetters :: !Bool - , browse :: !Bool - , websocketMetrics :: !Bool - , websocketEvents :: !Bool - } - deriving stock (Eq, Show) + { metrics :: !Bool, + prometheus :: !Bool, + health :: !Bool, + subscriptionsLive :: !Bool, + subscriptionsCheckpoints :: !Bool, + deadLetters :: !Bool, + browse :: !Bool, + websocketMetrics :: !Bool, + websocketEvents :: !Bool + } + deriving stock (Eq, Show) data Capabilities = Capabilities - { package :: !Text - , version :: !Text - , routes :: !RouteAvailability - , corsIsEnabled :: !Bool - , processLocal :: ![Text] - } - deriving stock (Eq, Show) + { package :: !Text, + version :: !Text, + routes :: !RouteAvailability, + corsIsEnabled :: !Bool, + processLocal :: ![Text] + } + deriving stock (Eq, Show) kirokuMetricsVersion :: Text kirokuMetricsVersion = T.pack (showVersion Paths.version) @@ -78,59 +79,59 @@ capabilitiesFor cfg presence = Capabilities "kiroku-metrics" kirokuMetricsVersion availability (Cors.corsEnabled cfg.cors) processLocalRoutes where availability = - RouteAvailability - cfg.enableJSON - cfg.enablePrometheus - cfg.enableJSON - presence.hasSubscriptionStatus - presence.hasCheckpointInventory - presence.hasDeadLetters - presence.hasBrowser - (cfg.enableWebSocket && presence.presentWebSocketChannels.metricsChannel) - (cfg.enableWebSocket && presence.presentWebSocketChannels.eventsChannel) + RouteAvailability + cfg.enableJSON + cfg.enablePrometheus + cfg.enableJSON + presence.hasSubscriptionStatus + presence.hasCheckpointInventory + presence.hasDeadLetters + presence.hasBrowser + (cfg.enableWebSocket && presence.presentWebSocketChannels.metricsChannel) + (cfg.enableWebSocket && presence.presentWebSocketChannels.eventsChannel) instance ToJSON RouteAvailability where - toJSON r = - object - [ "metrics" .= r.metrics - , "prometheus" .= r.prometheus - , "health" .= r.health - , "subscriptions_live" .= r.subscriptionsLive - , "subscriptions_checkpoints" .= r.subscriptionsCheckpoints - , "dead_letters" .= r.deadLetters - , "browse" .= r.browse - , "websocket_metrics" .= r.websocketMetrics - , "websocket_events" .= r.websocketEvents - ] + toJSON r = + object + [ "metrics" .= r.metrics, + "prometheus" .= r.prometheus, + "health" .= r.health, + "subscriptions_live" .= r.subscriptionsLive, + "subscriptions_checkpoints" .= r.subscriptionsCheckpoints, + "dead_letters" .= r.deadLetters, + "browse" .= r.browse, + "websocket_metrics" .= r.websocketMetrics, + "websocket_events" .= r.websocketEvents + ] instance FromJSON RouteAvailability where - parseJSON = withObject "RouteAvailability" $ \o -> - RouteAvailability - <$> o .: "metrics" - <*> o .: "prometheus" - <*> o .: "health" - <*> o .: "subscriptions_live" - <*> o .: "subscriptions_checkpoints" - <*> o .: "dead_letters" - <*> o .: "browse" - <*> o .: "websocket_metrics" - <*> o .: "websocket_events" + parseJSON = withObject "RouteAvailability" $ \o -> + RouteAvailability + <$> o .: "metrics" + <*> o .: "prometheus" + <*> o .: "health" + <*> o .: "subscriptions_live" + <*> o .: "subscriptions_checkpoints" + <*> o .: "dead_letters" + <*> o .: "browse" + <*> o .: "websocket_metrics" + <*> o .: "websocket_events" instance ToJSON Capabilities where - toJSON c = - object - [ "package" .= c.package - , "version" .= c.version - , "routes" .= c.routes - , "cors" .= object ["enabled" .= c.corsIsEnabled] - , "process_local" .= c.processLocal - ] + toJSON c = + object + [ "package" .= c.package, + "version" .= c.version, + "routes" .= c.routes, + "cors" .= object ["enabled" .= c.corsIsEnabled], + "process_local" .= c.processLocal + ] instance FromJSON Capabilities where - parseJSON = withObject "Capabilities" $ \o -> do - corsObject <- o .: "cors" - enabled <- withObject "cors" (.: "enabled") corsObject - Capabilities <$> o .: "package" <*> o .: "version" <*> o .: "routes" <*> pure enabled <*> o .: "process_local" + parseJSON = withObject "Capabilities" $ \o -> do + corsObject <- o .: "cors" + enabled <- withObject "cors" (.: "enabled") corsObject + Capabilities <$> o .: "package" <*> o .: "version" <*> o .: "routes" <*> pure enabled <*> o .: "process_local" capabilitiesPath :: [Text] capabilitiesPath = ["capabilities"] @@ -138,15 +139,15 @@ -- | No store access; the encoded body is shared by requests to this application. capabilitiesApp :: Capabilities -> Application capabilitiesApp caps = \req respond -> do - let response - | pathInfo req /= capabilitiesPath = errorResponse status404 "not_found" "Not found" Nothing - | requestMethod req == "GET" || requestMethod req == "HEAD" = jsonResponse status200 body - | otherwise = - mapResponseHeaders (("Allow", "GET, HEAD") :) $ - errorResponse status405 "method_not_allowed" "Use GET or HEAD." Nothing - respond $ - if requestMethod req == "HEAD" - then responseLBS (responseStatus response) (responseHeaders response) "" - else response + let response + | pathInfo req /= capabilitiesPath = errorResponse status404 "not_found" "Not found" Nothing + | requestMethod req == "GET" || requestMethod req == "HEAD" = jsonResponse status200 body + | otherwise = + mapResponseHeaders (("Allow", "GET, HEAD") :) $ + errorResponse status405 "method_not_allowed" "Use GET or HEAD." Nothing + respond $ + if requestMethod req == "HEAD" + then responseLBS (responseStatus response) (responseHeaders response) "" + else response where body = encode caps diff --git a/src/Kiroku/Metrics/Checkpoints.hs b/src/Kiroku/Metrics/Checkpoints.hs --- a/src/Kiroku/Metrics/Checkpoints.hs +++ b/src/Kiroku/Metrics/Checkpoints.hs @@ -1,6 +1,6 @@ -- | Read-only durable checkpoint inventory, independent of the live registry. -module Kiroku.Metrics.Checkpoints ( - CheckpointInventoryProvider, +module Kiroku.Metrics.Checkpoints + ( CheckpointInventoryProvider, storeCheckpointInventory, CheckpointInventoryResponse (..), CheckpointRow (..), @@ -8,7 +8,8 @@ checkpointsPath, checkpointsApp, checkpointsNotConfiguredApp, -) where + ) +where import Data.Aeson (FromJSON (..), ToJSON (..), encode, object, withObject, (.:), (.=)) import Data.Int (Int32, Int64) @@ -21,52 +22,50 @@ import Kiroku.Metrics.JSON (errorResponse, jsonResponse, storeErrorResponse) import Kiroku.Store (GlobalPosition (..), KirokuStore, StoreError, SubscriptionCheckpoint (..), SubscriptionCheckpointInventory (..), SubscriptionName (..), runStoreIO, subscriptionCheckpointInventory) -{- | One call reads the frontier and all checkpoint rows in one SQL snapshot. -Inventory work is proportional to row count; clients should not overlap polls. --} +-- | One call reads the frontier and all checkpoint rows in one SQL snapshot. +-- Inventory work is proportional to row count; clients should not overlap polls. type CheckpointInventoryProvider = IO (Either StoreError SubscriptionCheckpointInventory) storeCheckpointInventory :: KirokuStore -> CheckpointInventoryProvider storeCheckpointInventory store = runStoreIO store subscriptionCheckpointInventory data CheckpointRow = CheckpointRow - { subscription :: !Text - , member :: !Int32 - , checkpointPosition :: !Int64 - , updatedAt :: !UTCTime - } - deriving stock (Eq, Show) + { subscription :: !Text, + member :: !Int32, + checkpointPosition :: !Int64, + updatedAt :: !UTCTime + } + deriving stock (Eq, Show) data CheckpointInventoryResponse = CheckpointInventoryResponse - { storePosition :: !Int64 - , checkpoints :: ![CheckpointRow] - } - deriving stock (Eq, Show) + { storePosition :: !Int64, + checkpoints :: ![CheckpointRow] + } + deriving stock (Eq, Show) instance ToJSON CheckpointRow where - toJSON row = object ["subscription" .= row.subscription, "member" .= row.member, "checkpoint_position" .= row.checkpointPosition, "updated_at" .= row.updatedAt] + toJSON row = object ["subscription" .= row.subscription, "member" .= row.member, "checkpoint_position" .= row.checkpointPosition, "updated_at" .= row.updatedAt] instance FromJSON CheckpointRow where - parseJSON = withObject "CheckpointRow" $ \o -> CheckpointRow <$> o .: "subscription" <*> o .: "member" <*> o .: "checkpoint_position" <*> o .: "updated_at" + parseJSON = withObject "CheckpointRow" $ \o -> CheckpointRow <$> o .: "subscription" <*> o .: "member" <*> o .: "checkpoint_position" <*> o .: "updated_at" instance ToJSON CheckpointInventoryResponse where - toJSON inventory = object ["store_position" .= inventory.storePosition, "checkpoints" .= inventory.checkpoints] + toJSON inventory = object ["store_position" .= inventory.storePosition, "checkpoints" .= inventory.checkpoints] instance FromJSON CheckpointInventoryResponse where - parseJSON = withObject "CheckpointInventoryResponse" $ \o -> CheckpointInventoryResponse <$> o .: "store_position" <*> o .: "checkpoints" + parseJSON = withObject "CheckpointInventoryResponse" $ \o -> CheckpointInventoryResponse <$> o .: "store_position" <*> o .: "checkpoints" checkpointInventoryResponse :: SubscriptionCheckpointInventory -> CheckpointInventoryResponse checkpointInventoryResponse (SubscriptionCheckpointInventory (GlobalPosition position) rows) = - CheckpointInventoryResponse position (map toRow (V.toList rows)) + CheckpointInventoryResponse position (map toRow (V.toList rows)) where toRow (SubscriptionCheckpoint (SubscriptionName name) index (GlobalPosition cp) updated) = CheckpointRow name index cp updated checkpointsPath :: [Text] checkpointsPath = ["subscription-checkpoints"] -{- | GET and HEAD only. Unknown query parameters are ignored. Expected store -failures are sanitized; thrown exceptions (including cancellation) propagate. --} +-- | GET and HEAD only. Unknown query parameters are ignored. Expected store +-- failures are sanitized; thrown exceptions (including cancellation) propagate. checkpointsApp :: CheckpointInventoryProvider -> Application checkpointsApp provider = checkpointsResponseApp $ either (storeErrorResponse "checkpoint_inventory_unavailable") (jsonResponse status200 . encode . checkpointInventoryResponse) <$> provider @@ -76,14 +75,14 @@ checkpointsResponseApp :: IO Response -> Application checkpointsResponseApp readResponse req respond = do - response <- - if pathInfo req /= checkpointsPath - then pure $ errorResponse status404 "not_found" "Not found" Nothing - else - if requestMethod req `notElem` ["GET", "HEAD"] - then pure $ mapResponseHeaders (("Allow", "GET, HEAD") :) $ errorResponse status405 "method_not_allowed" "Use GET or HEAD." Nothing - else readResponse - respond $ - if requestMethod req == "HEAD" - then responseLBS (responseStatus response) (responseHeaders response) "" - else response + response <- + if pathInfo req /= checkpointsPath + then pure $ errorResponse status404 "not_found" "Not found" Nothing + else + if requestMethod req `notElem` ["GET", "HEAD"] + then pure $ mapResponseHeaders (("Allow", "GET, HEAD") :) $ errorResponse status405 "method_not_allowed" "Use GET or HEAD." Nothing + else readResponse + respond $ + if requestMethod req == "HEAD" + then responseLBS (responseStatus response) (responseHeaders response) "" + else response diff --git a/src/Kiroku/Metrics/Collector.hs b/src/Kiroku/Metrics/Collector.hs --- a/src/Kiroku/Metrics/Collector.hs +++ b/src/Kiroku/Metrics/Collector.hs @@ -1,27 +1,27 @@ -{- | In-process metrics collector for a running Kiroku store. - -A 'KirokuMetrics' is an opaque handle holding STM counters, a pool -connection-status map, and a per-subscription accumulation map. It is driven -entirely by the store's existing public callback seams — wrap -'metricsEventHandler' and 'metricsObservationHandler' into the -'Kiroku.Store.Connection.ConnectionSettings' @eventHandler@/@observationHandler@ -fields /before/ opening the store, and the collector will see every event. Call -'snapshotMetrics' at any time for an immutable, JSON-encodable -'MetricsSnapshot'. - -All callback updates are plain non-blocking STM ('modifyTVar''); they perform no -I/O. This matters because the store invokes the callbacks synchronously on the -emit-site thread (notifier loop, publisher loop, subscription worker, store -interpreter), so a slow callback would stall that loop. --} -module Kiroku.Metrics.Collector ( - KirokuMetrics, +-- | In-process metrics collector for a running Kiroku store. +-- +-- A 'KirokuMetrics' is an opaque handle holding STM counters, a pool +-- connection-status map, and a per-subscription accumulation map. It is driven +-- entirely by the store's existing public callback seams — wrap +-- 'metricsEventHandler' and 'metricsObservationHandler' into the +-- 'Kiroku.Store.Connection.ConnectionSettings' @eventHandler@/@observationHandler@ +-- fields /before/ opening the store, and the collector will see every event. Call +-- 'snapshotMetrics' at any time for an immutable, JSON-encodable +-- 'MetricsSnapshot'. +-- +-- All callback updates are plain non-blocking STM ('modifyTVar''); they perform no +-- I/O. This matters because the store invokes the callbacks synchronously on the +-- emit-site thread (notifier loop, publisher loop, subscription worker, store +-- interpreter), so a slow callback would stall that loop. +module Kiroku.Metrics.Collector + ( KirokuMetrics, newKirokuMetrics, newKirokuMetricsWith, metricsEventHandler, metricsObservationHandler, snapshotMetrics, -) where + ) +where import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, readTVar) import Data.Foldable (for_) @@ -31,253 +31,252 @@ import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.UUID (UUID) -import Kiroku.Metrics.Types ( - LifecycleCounters (..), +import Kiroku.Metrics.Types + ( LifecycleCounters (..), MetricsSnapshot (..), StoreGauges (..), SubscriptionMetrics (..), - ) -import Kiroku.Store ( - ConnectionReadyForUseReason (..), + ) +import Kiroku.Store + ( ConnectionReadyForUseReason (..), ConnectionStatus (..), KirokuEvent (..), KirokuStore (..), Observation (..), SubscriptionDbPhase (..), SubscriptionStopReason (..), - ) -import Kiroku.Store.Subscription.EventPublisher ( - EventPublisher (..), + ) +import Kiroku.Store.Subscription.EventPublisher + ( EventPublisher (..), publisherPosition, - ) -import Kiroku.Store.Subscription.Types ( - CheckpointInitialization (..), + ) +import Kiroku.Store.Subscription.Types + ( CheckpointInitialization (..), ConsumerGroupSizeMismatch (..), SubscriptionCheckpointKey (..), SubscriptionCheckpointMissing (..), SubscriptionName (..), - ) + SubscriptionTargetMismatch (..), + ) import Kiroku.Store.Types (GlobalPosition (..)) -- | Opaque collector handle. Construct with 'newKirokuMetrics'. data KirokuMetrics = KirokuMetrics - { kmCounters :: !(TVar LifecycleCounters) - , kmPool :: !(TVar PoolMutable) - , kmSubs :: !(TVar (Map Text SubMutable)) - , kmPosition :: !(STM GlobalPosition) - -- ^ Reads the store's global position at snapshot time. - , kmSubscribers :: !(STM Int) - -- ^ Reads the store's active-subscriber count at snapshot time. - } + { kmCounters :: !(TVar LifecycleCounters), + kmPool :: !(TVar PoolMutable), + kmSubs :: !(TVar (Map Text SubMutable)), + -- | Reads the store's global position at snapshot time. + kmPosition :: !(STM GlobalPosition), + -- | Reads the store's active-subscriber count at snapshot time. + kmSubscribers :: !(STM Int) + } -- | Mutable pool state: per-connection status plus cumulative lifecycle counts. data PoolMutable = PoolMutable - { pmStatuses :: !(Map UUID ConnectionStatus) - , pmEstablishedTotal :: !Int64 - , pmTerminatedTotal :: !Int64 - } + { pmStatuses :: !(Map UUID ConnectionStatus), + pmEstablishedTotal :: !Int64, + pmTerminatedTotal :: !Int64 + } -- | Mutable per-subscription accumulation. data SubMutable = SubMutable - { smLastKnownPosition :: !Int64 - , smDbErrorCount :: !Int64 - , smLastStopReason :: !(Maybe Text) - } + { smLastKnownPosition :: !Int64, + smDbErrorCount :: !Int64, + smLastStopReason :: !(Maybe Text) + } emptyCounters :: LifecycleCounters emptyCounters = - LifecycleCounters - { notifierReconnecting = 0 - , notifierReconnected = 0 - , publisherPoolErrors = 0 - , publisherLoopErrors = 0 - , publisherDecodeFailures = 0 - , subscriptionHandlerStalls = 0 - , subscriptionDbErrorsLoad = 0 - , subscriptionDbErrorsFetch = 0 - , subscriptionDbErrorsSave = 0 - , subscriptionsStarted = 0 - , subscriptionsCaughtUp = 0 - , subscriptionsPaused = 0 - , subscriptionsResumed = 0 - , subscriptionsReconnecting = 0 - , subscriptionsRetrying = 0 - , subscriptionsDeadLettered = 0 - , subscriptionsStoppedHandler = 0 - , subscriptionsStoppedCancelled = 0 - , subscriptionsStoppedOverflow = 0 - , subscriptionsStoppedCrashed = 0 - , subscriptionsStoppedUndecodable = 0 - , liveFetches = 0 - , batchesDelivered = 0 - , eventsDelivered = 0 - , hardDeletesIssued = 0 - } + LifecycleCounters + { notifierReconnecting = 0, + notifierReconnected = 0, + publisherPoolErrors = 0, + publisherLoopErrors = 0, + publisherDecodeFailures = 0, + subscriptionHandlerStalls = 0, + subscriptionDbErrorsLoad = 0, + subscriptionDbErrorsFetch = 0, + subscriptionDbErrorsSave = 0, + subscriptionsStarted = 0, + subscriptionsCaughtUp = 0, + subscriptionsPaused = 0, + subscriptionsResumed = 0, + subscriptionsReconnecting = 0, + subscriptionsRetrying = 0, + subscriptionsDeadLettered = 0, + subscriptionsStoppedHandler = 0, + subscriptionsStoppedCancelled = 0, + subscriptionsStoppedOverflow = 0, + subscriptionsStoppedCrashed = 0, + subscriptionsStoppedUndecodable = 0, + liveFetches = 0, + batchesDelivered = 0, + eventsDelivered = 0, + hardDeletesIssued = 0 + } emptySub :: SubMutable -emptySub = SubMutable{smLastKnownPosition = 0, smDbErrorCount = 0, smLastStopReason = Nothing} +emptySub = SubMutable {smLastKnownPosition = 0, smDbErrorCount = 0, smLastStopReason = Nothing} -{- | Construct a collector for a live store. The two store-level gauges -(global position and active-subscriber count) are read from the store's -'EventPublisher' at snapshot time. --} +-- | Construct a collector for a live store. The two store-level gauges +-- (global position and active-subscriber count) are read from the store's +-- 'EventPublisher' at snapshot time. newKirokuMetrics :: KirokuStore -> IO KirokuMetrics newKirokuMetrics store = - newKirokuMetricsWith - (publisherPosition store.publisher) - (IntMap.size <$> readTVar (subscribers store.publisher)) + newKirokuMetricsWith + (publisherPosition store.publisher) + (IntMap.size <$> readTVar (subscribers store.publisher)) -{- | Construct a collector from explicit STM readers for the two store-level -gauges. This is the test seam: a unit test passes @pure (GlobalPosition n)@ and -@pure k@ to avoid needing a real store, and an integration test can defer the -store with a @TVar (Maybe KirokuStore)@ (STM readers cannot read an 'IORef'). --} +-- | Construct a collector from explicit STM readers for the two store-level +-- gauges. This is the test seam: a unit test passes @pure (GlobalPosition n)@ and +-- @pure k@ to avoid needing a real store, and an integration test can defer the +-- store with a @TVar (Maybe KirokuStore)@ (STM readers cannot read an 'IORef'). newKirokuMetricsWith :: STM GlobalPosition -> STM Int -> IO KirokuMetrics newKirokuMetricsWith readPosition readSubscribers = do - kmCounters <- newTVarIO emptyCounters - kmPool <- newTVarIO (PoolMutable Map.empty 0 0) - kmSubs <- newTVarIO Map.empty - pure - KirokuMetrics - { kmCounters - , kmPool - , kmSubs - , kmPosition = readPosition - , kmSubscribers = readSubscribers - } + kmCounters <- newTVarIO emptyCounters + kmPool <- newTVarIO (PoolMutable Map.empty 0 0) + kmSubs <- newTVarIO Map.empty + pure + KirokuMetrics + { kmCounters, + kmPool, + kmSubs, + kmPosition = readPosition, + kmSubscribers = readSubscribers + } -{- | Wrap the collector into the store's @eventHandler@ seam, composing with an -optional user passthrough. The collector's STM update runs first, then the -passthrough is invoked with the same event. --} +-- | Wrap the collector into the store's @eventHandler@ seam, composing with an +-- optional user passthrough. The collector's STM update runs first, then the +-- passthrough is invoked with the same event. metricsEventHandler :: KirokuMetrics -> Maybe (KirokuEvent -> IO ()) -> (KirokuEvent -> IO ()) metricsEventHandler km mPassthrough event = do - atomically (applyEvent km event) - for_ mPassthrough ($ event) + atomically (applyEvent km event) + for_ mPassthrough ($ event) -{- | Wrap the collector into the store's @observationHandler@ seam, composing -with an optional user passthrough. The collector's STM update runs first. --} +-- | Wrap the collector into the store's @observationHandler@ seam, composing +-- with an optional user passthrough. The collector's STM update runs first. metricsObservationHandler :: KirokuMetrics -> Maybe (Observation -> IO ()) -> (Observation -> IO ()) metricsObservationHandler km mPassthrough obs = do - atomically (applyObservation km obs) - for_ mPassthrough ($ obs) + atomically (applyObservation km obs) + for_ mPassthrough ($ obs) -- | Apply a single 'KirokuEvent' to the collector state. applyEvent :: KirokuMetrics -> KirokuEvent -> STM () applyEvent km = \case - KirokuEventNotifierReconnecting _ _ -> - bumpCounters km (\c -> c{notifierReconnecting = c.notifierReconnecting + 1}) - KirokuEventNotifierReconnected -> - bumpCounters km (\c -> c{notifierReconnected = c.notifierReconnected + 1}) - KirokuEventPublisherPoolError _ -> - bumpCounters km (\c -> c{publisherPoolErrors = c.publisherPoolErrors + 1}) - KirokuEventSubscriptionHandlerStalled{} -> - bumpCounters km (\c -> c{subscriptionHandlerStalls = c.subscriptionHandlerStalls + 1}) - KirokuEventPublisherDecodeFailed{} -> - bumpCounters km (\c -> c{publisherDecodeFailures = c.publisherDecodeFailures + 1}) - KirokuEventPublisherLoopError _ -> - bumpCounters km (\c -> c{publisherLoopErrors = c.publisherLoopErrors + 1}) - KirokuEventSubscriptionDbError name phase _ _ -> do - bumpCounters km (bumpDbPhase phase) - touchSub km name (\s -> s{smDbErrorCount = s.smDbErrorCount + 1}) - KirokuEventSubscriptionCheckpointResolved initialization _ -> - case initialization of - ExistingCheckpoint (SubscriptionCheckpointKey name _) pos -> recordPosition km name pos - InitializedCheckpoint _ (SubscriptionCheckpointKey name _) pos -> recordPosition km name pos - KirokuEventSubscriptionCheckpointMissing (SubscriptionCheckpointMissing (SubscriptionCheckpointKey name _)) _ -> - touchSub km name id - KirokuEventSubscriptionTargetBound name _ _ -> touchSub km name id - KirokuEventSubscriptionGroupSizeMismatch (ConsumerGroupSizeMismatch name _ _) _ -> - touchSub km name id - KirokuEventSubscriptionStarted name pos _ -> do - bumpCounters km (\c -> c{subscriptionsStarted = c.subscriptionsStarted + 1}) - recordPosition km name pos - KirokuEventSubscriptionCaughtUp name pos _ -> do - bumpCounters km (\c -> c{subscriptionsCaughtUp = c.subscriptionsCaughtUp + 1}) - recordPosition km name pos - KirokuEventSubscriptionStopped name pos reason _ -> do - bumpCounters km (bumpStopReason reason) - recordPosition km name pos - touchSub km name (\s -> s{smLastStopReason = Just (stopReasonText reason)}) - KirokuEventSubscriptionPaused name pos _ -> do - bumpCounters km (\c -> c{subscriptionsPaused = c.subscriptionsPaused + 1}) - recordPosition km name pos - KirokuEventSubscriptionResumed name pos _ -> do - bumpCounters km (\c -> c{subscriptionsResumed = c.subscriptionsResumed + 1}) - recordPosition km name pos - KirokuEventSubscriptionReconnecting name _ _ -> do - bumpCounters km (\c -> c{subscriptionsReconnecting = c.subscriptionsReconnecting + 1}) - touchSub km name id - KirokuEventSubscriptionFetched name _ _ -> do - bumpCounters km (\c -> c{liveFetches = c.liveFetches + 1}) - touchSub km name id - KirokuEventSubscriptionDelivered name n _ _ -> do - bumpCounters - km - ( \c -> - c - { batchesDelivered = c.batchesDelivered + 1 - , eventsDelivered = c.eventsDelivered + fromIntegral n - } - ) - touchSub km name id - KirokuEventSubscriptionRetrying name pos _ _ -> do - bumpCounters km (\c -> c{subscriptionsRetrying = c.subscriptionsRetrying + 1}) - recordPosition km name pos - KirokuEventSubscriptionDeadLettered name pos _ _ -> do - bumpCounters km (\c -> c{subscriptionsDeadLettered = c.subscriptionsDeadLettered + 1}) - recordPosition km name pos - KirokuEventHardDeleteIssued _ _ -> - bumpCounters km (\c -> c{hardDeletesIssued = c.hardDeletesIssued + 1}) - -- Retention transitions are deliberately passed through without being - -- converted into the subscription-focused fixed metrics schema. Callers - -- can consume them from the composed eventHandler. - KirokuEventHistoryRetentionLeaseAcquired{} -> pure () - KirokuEventHistoryRetentionLeaseRenewed{} -> pure () - KirokuEventHistoryRetentionLeaseReleased{} -> pure () - KirokuEventHistoryRetentionLeasesPruned{} -> pure () - KirokuEventHardDeleteHistoryRetentionConflict{} -> pure () + KirokuEventNotifierReconnecting _ _ -> + bumpCounters km (\c -> c {notifierReconnecting = c.notifierReconnecting + 1}) + KirokuEventNotifierReconnected -> + bumpCounters km (\c -> c {notifierReconnected = c.notifierReconnected + 1}) + KirokuEventPublisherPoolError _ -> + bumpCounters km (\c -> c {publisherPoolErrors = c.publisherPoolErrors + 1}) + KirokuEventSubscriptionHandlerStalled {} -> + bumpCounters km (\c -> c {subscriptionHandlerStalls = c.subscriptionHandlerStalls + 1}) + KirokuEventPublisherDecodeFailed {} -> + bumpCounters km (\c -> c {publisherDecodeFailures = c.publisherDecodeFailures + 1}) + KirokuEventPublisherLoopError _ -> + bumpCounters km (\c -> c {publisherLoopErrors = c.publisherLoopErrors + 1}) + KirokuEventSubscriptionDbError name phase _ _ -> do + bumpCounters km (bumpDbPhase phase) + touchSub km name (\s -> s {smDbErrorCount = s.smDbErrorCount + 1}) + KirokuEventSubscriptionCheckpointResolved initialization _ -> + case initialization of + ExistingCheckpoint (SubscriptionCheckpointKey name _) pos -> recordPosition km name pos + InitializedCheckpoint _ (SubscriptionCheckpointKey name _) pos -> recordPosition km name pos + KirokuEventSubscriptionCheckpointMissing (SubscriptionCheckpointMissing (SubscriptionCheckpointKey name _)) _ -> + touchSub km name id + KirokuEventSubscriptionTargetBound name _ _ -> touchSub km name id + KirokuEventSubscriptionGroupSizeMismatch (ConsumerGroupSizeMismatch name _ _) _ -> + touchSub km name id + KirokuEventSubscriptionTargetMismatch (SubscriptionTargetMismatch name _ _) _ -> + touchSub km name id + KirokuEventSubscriptionStarted name pos _ -> do + bumpCounters km (\c -> c {subscriptionsStarted = c.subscriptionsStarted + 1}) + recordPosition km name pos + KirokuEventSubscriptionCaughtUp name pos _ -> do + bumpCounters km (\c -> c {subscriptionsCaughtUp = c.subscriptionsCaughtUp + 1}) + recordPosition km name pos + KirokuEventSubscriptionStopped name pos reason _ -> do + bumpCounters km (bumpStopReason reason) + recordPosition km name pos + touchSub km name (\s -> s {smLastStopReason = Just (stopReasonText reason)}) + KirokuEventSubscriptionPaused name pos _ -> do + bumpCounters km (\c -> c {subscriptionsPaused = c.subscriptionsPaused + 1}) + recordPosition km name pos + KirokuEventSubscriptionResumed name pos _ -> do + bumpCounters km (\c -> c {subscriptionsResumed = c.subscriptionsResumed + 1}) + recordPosition km name pos + KirokuEventSubscriptionReconnecting name _ _ -> do + bumpCounters km (\c -> c {subscriptionsReconnecting = c.subscriptionsReconnecting + 1}) + touchSub km name id + KirokuEventSubscriptionFetched name _ _ -> do + bumpCounters km (\c -> c {liveFetches = c.liveFetches + 1}) + touchSub km name id + KirokuEventSubscriptionDelivered name n _ _ -> do + bumpCounters + km + ( \c -> + c + { batchesDelivered = c.batchesDelivered + 1, + eventsDelivered = c.eventsDelivered + fromIntegral n + } + ) + touchSub km name id + KirokuEventSubscriptionRetrying name pos _ _ -> do + bumpCounters km (\c -> c {subscriptionsRetrying = c.subscriptionsRetrying + 1}) + recordPosition km name pos + KirokuEventSubscriptionDeadLettered name pos _ _ -> do + bumpCounters km (\c -> c {subscriptionsDeadLettered = c.subscriptionsDeadLettered + 1}) + recordPosition km name pos + KirokuEventHardDeleteIssued _ _ -> + bumpCounters km (\c -> c {hardDeletesIssued = c.hardDeletesIssued + 1}) + -- Retention transitions are deliberately passed through without being + -- converted into the subscription-focused fixed metrics schema. Callers + -- can consume them from the composed eventHandler. + KirokuEventHistoryRetentionLeaseAcquired {} -> pure () + KirokuEventHistoryRetentionLeaseRenewed {} -> pure () + KirokuEventHistoryRetentionLeaseReleased {} -> pure () + KirokuEventHistoryRetentionLeasesPruned {} -> pure () + KirokuEventHardDeleteHistoryRetentionConflict {} -> pure () bumpDbPhase :: SubscriptionDbPhase -> LifecycleCounters -> LifecycleCounters bumpDbPhase phase c = case phase of - LoadCheckpoint -> c{subscriptionDbErrorsLoad = c.subscriptionDbErrorsLoad + 1} - FetchBatch -> c{subscriptionDbErrorsFetch = c.subscriptionDbErrorsFetch + 1} - SaveCheckpoint -> c{subscriptionDbErrorsSave = c.subscriptionDbErrorsSave + 1} + LoadCheckpoint -> c {subscriptionDbErrorsLoad = c.subscriptionDbErrorsLoad + 1} + FetchBatch -> c {subscriptionDbErrorsFetch = c.subscriptionDbErrorsFetch + 1} + SaveCheckpoint -> c {subscriptionDbErrorsSave = c.subscriptionDbErrorsSave + 1} bumpStopReason :: SubscriptionStopReason -> LifecycleCounters -> LifecycleCounters bumpStopReason reason c = case reason of - StopHandlerRequested -> c{subscriptionsStoppedHandler = c.subscriptionsStoppedHandler + 1} - StopCancelled -> c{subscriptionsStoppedCancelled = c.subscriptionsStoppedCancelled + 1} - StopOverflowed -> c{subscriptionsStoppedOverflow = c.subscriptionsStoppedOverflow + 1} - StopWorkerCrashed _ -> c{subscriptionsStoppedCrashed = c.subscriptionsStoppedCrashed + 1} - StopUndecodable _ -> c{subscriptionsStoppedUndecodable = c.subscriptionsStoppedUndecodable + 1} + StopHandlerRequested -> c {subscriptionsStoppedHandler = c.subscriptionsStoppedHandler + 1} + StopCancelled -> c {subscriptionsStoppedCancelled = c.subscriptionsStoppedCancelled + 1} + StopOverflowed -> c {subscriptionsStoppedOverflow = c.subscriptionsStoppedOverflow + 1} + StopWorkerCrashed _ -> c {subscriptionsStoppedCrashed = c.subscriptionsStoppedCrashed + 1} + StopUndecodable _ -> c {subscriptionsStoppedUndecodable = c.subscriptionsStoppedUndecodable + 1} stopReasonText :: SubscriptionStopReason -> Text stopReasonText = \case - StopHandlerRequested -> "handler" - StopCancelled -> "cancelled" - StopOverflowed -> "overflow" - StopWorkerCrashed _ -> "crashed" - StopUndecodable _ -> "undecodable" + StopHandlerRequested -> "handler" + StopCancelled -> "cancelled" + StopOverflowed -> "overflow" + StopWorkerCrashed _ -> "crashed" + StopUndecodable _ -> "undecodable" -- | Apply a single pool 'Observation' to the collector state. applyObservation :: KirokuMetrics -> Observation -> STM () applyObservation km (ConnectionObservation connId status) = - modifyTVar' (kmPool km) update + modifyTVar' (kmPool km) update where update p = case status of - TerminatedConnectionStatus _ -> - p - { pmStatuses = Map.delete connId p.pmStatuses - , pmTerminatedTotal = p.pmTerminatedTotal + 1 - } - ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason -> - p - { pmStatuses = Map.insert connId status p.pmStatuses - , pmEstablishedTotal = p.pmEstablishedTotal + 1 - } - _ -> p{pmStatuses = Map.insert connId status p.pmStatuses} + TerminatedConnectionStatus _ -> + p + { pmStatuses = Map.delete connId p.pmStatuses, + pmTerminatedTotal = p.pmTerminatedTotal + 1 + } + ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason -> + p + { pmStatuses = Map.insert connId status p.pmStatuses, + pmEstablishedTotal = p.pmEstablishedTotal + 1 + } + _ -> p {pmStatuses = Map.insert connId status p.pmStatuses} bumpCounters :: KirokuMetrics -> (LifecycleCounters -> LifecycleCounters) -> STM () bumpCounters km f = modifyTVar' (kmCounters km) f @@ -285,40 +284,39 @@ -- | Update a subscription's position to the max of its current and the new one. recordPosition :: KirokuMetrics -> SubscriptionName -> GlobalPosition -> STM () recordPosition km name (GlobalPosition pos) = - touchSub km name (\s -> s{smLastKnownPosition = max s.smLastKnownPosition pos}) + touchSub km name (\s -> s {smLastKnownPosition = max s.smLastKnownPosition pos}) -- | Apply @f@ to the named subscription's mutable entry, creating it if absent. touchSub :: KirokuMetrics -> SubscriptionName -> (SubMutable -> SubMutable) -> STM () touchSub km (SubscriptionName name) f = - modifyTVar' (kmSubs km) (Map.insertWith (\_new old -> f old) name (f emptySub)) + modifyTVar' (kmSubs km) (Map.insertWith (\_new old -> f old) name (f emptySub)) -{- | Read an atomic, immutable snapshot. Reads the collector's own @TVar@s /and/ -the two store readers in a single STM transaction so the result is a coherent -point-in-time view. --} +-- | Read an atomic, immutable snapshot. Reads the collector's own @TVar@s /and/ +-- the two store readers in a single STM transaction so the result is a coherent +-- point-in-time view. snapshotMetrics :: KirokuMetrics -> IO MetricsSnapshot snapshotMetrics km = atomically $ do - counters <- readTVar (kmCounters km) - pool <- readTVar (kmPool km) - subsMap <- readTVar (kmSubs km) - GlobalPosition gpos <- kmPosition km - nSubscribers <- kmSubscribers km - let gauges = - StoreGauges - { globalPosition = gpos - , activeSubscribers = nSubscribers - , poolConnecting = countStatuses isConnecting pool - , poolReady = countStatuses isReady pool - , poolInUse = countStatuses isInUse pool - , poolEstablishedTotal = pool.pmEstablishedTotal - , poolTerminatedTotal = pool.pmTerminatedTotal - } - pure - MetricsSnapshot - { store = gauges - , counters - , subscriptions = Map.map (toSubMetrics gpos) subsMap - } + counters <- readTVar (kmCounters km) + pool <- readTVar (kmPool km) + subsMap <- readTVar (kmSubs km) + GlobalPosition gpos <- kmPosition km + nSubscribers <- kmSubscribers km + let gauges = + StoreGauges + { globalPosition = gpos, + activeSubscribers = nSubscribers, + poolConnecting = countStatuses isConnecting pool, + poolReady = countStatuses isReady pool, + poolInUse = countStatuses isInUse pool, + poolEstablishedTotal = pool.pmEstablishedTotal, + poolTerminatedTotal = pool.pmTerminatedTotal + } + pure + MetricsSnapshot + { store = gauges, + counters, + subscriptions = Map.map (toSubMetrics gpos) subsMap + } countStatuses :: (ConnectionStatus -> Bool) -> PoolMutable -> Int countStatuses p pool = Map.size (Map.filter p pool.pmStatuses) @@ -334,9 +332,9 @@ toSubMetrics :: Int64 -> SubMutable -> SubscriptionMetrics toSubMetrics gpos s = - SubscriptionMetrics - { lastKnownPosition = s.smLastKnownPosition - , lag = max 0 (gpos - s.smLastKnownPosition) - , dbErrorCount = s.smDbErrorCount - , lastStopReason = s.smLastStopReason - } + SubscriptionMetrics + { lastKnownPosition = s.smLastKnownPosition, + lag = max 0 (gpos - s.smLastKnownPosition), + dbErrorCount = s.smDbErrorCount, + lastStopReason = s.smLastStopReason + } diff --git a/src/Kiroku/Metrics/Config.hs b/src/Kiroku/Metrics/Config.hs --- a/src/Kiroku/Metrics/Config.hs +++ b/src/Kiroku/Metrics/Config.hs @@ -1,60 +1,59 @@ -- | Configuration for the Kiroku metrics web server. -module Kiroku.Metrics.Config ( - MetricsServerConfig (..), +module Kiroku.Metrics.Config + ( MetricsServerConfig (..), defaultConfig, -) where + ) +where import Data.Int (Int64) import Numeric.Natural (Natural) import Kiroku.Metrics.Cors (CorsPolicy, corsDisabled) -{- | Configuration for the metrics web server. The @ws*@ fields are consumed by -the WebSocket endpoint (EP-3); they exist here so that plan needs no config -change. @readinessMaxLag@ is the Kiroku analogue of Marten's @maxEventLag@; it -defaults higher than Marten's 100 because Kiroku's lag is an /upper bound/ (see -the collector's lag limitation). --} +-- | Configuration for the metrics web server. The @ws*@ fields are consumed by +-- the WebSocket endpoint (EP-3); they exist here so that plan needs no config +-- change. @readinessMaxLag@ is the Kiroku analogue of Marten's @maxEventLag@; it +-- defaults higher than Marten's 100 because Kiroku's lag is an /upper bound/ (see +-- the collector's lag limitation). data MetricsServerConfig = MetricsServerConfig - { port :: !Int - -- ^ Port to listen on (default: 9091). - , enableJSON :: !Bool - -- ^ Enable the JSON metrics and health endpoints (default: True). - , enablePrometheus :: !Bool - -- ^ Enable the Prometheus text-exposition endpoint (default: True). - , enableWebSocket :: !Bool - -- ^ Enable the WebSocket upgrade path (default: True; EP-3 makes it functional). - , wsPushIntervalUs :: !Int - -- ^ WebSocket live-push interval in microseconds (default: 1_000_000 = 1s). - , wsMaxConnections :: !Int - -- ^ Maximum concurrent WebSocket connections (default: 100). - , wsEventQueueCap :: !Natural - {- ^ Per-connection broadcast queue capacity, in batches, for the event - stream tail (default: 256). Additive field introduced by EP-3; under - 'Kiroku.Store.Subscription.Types.DropOldest' a slow client drops the - oldest undelivered batches rather than stalling the publisher. - -} - , readinessMaxLag :: !Int64 - -- ^ A subscription lagging beyond this fails readiness (default: 10_000). - , livenessTimeoutUs :: !Int - -- ^ Timeout for the liveness snapshot in microseconds (default: 1_000_000 = 1s). - , cors :: !CorsPolicy - -- ^ Explicit browser origins; disabled by default for HTTP and WebSocket alike. - } - deriving stock (Eq, Show) + { -- | Port to listen on (default: 9091). + port :: !Int, + -- | Enable the JSON metrics and health endpoints (default: True). + enableJSON :: !Bool, + -- | Enable the Prometheus text-exposition endpoint (default: True). + enablePrometheus :: !Bool, + -- | Enable the WebSocket upgrade path (default: True; EP-3 makes it functional). + enableWebSocket :: !Bool, + -- | WebSocket live-push interval in microseconds (default: 1_000_000 = 1s). + wsPushIntervalUs :: !Int, + -- | Maximum concurrent WebSocket connections (default: 100). + wsMaxConnections :: !Int, + -- | Per-connection broadcast queue capacity, in batches, for the event + -- stream tail (default: 256). Additive field introduced by EP-3; under + -- 'Kiroku.Store.Subscription.Types.DropOldest' a slow client drops the + -- oldest undelivered batches rather than stalling the publisher. + wsEventQueueCap :: !Natural, + -- | A subscription lagging beyond this fails readiness (default: 10_000). + readinessMaxLag :: !Int64, + -- | Timeout for the liveness snapshot in microseconds (default: 1_000_000 = 1s). + livenessTimeoutUs :: !Int, + -- | Explicit browser origins; disabled by default for HTTP and WebSocket alike. + cors :: !CorsPolicy + } + deriving stock (Eq, Show) -- | Default configuration: port 9091, all endpoints enabled. defaultConfig :: MetricsServerConfig defaultConfig = - MetricsServerConfig - { port = 9091 - , enableJSON = True - , enablePrometheus = True - , enableWebSocket = True - , wsPushIntervalUs = 1_000_000 - , wsMaxConnections = 100 - , wsEventQueueCap = 256 - , readinessMaxLag = 10_000 - , livenessTimeoutUs = 1_000_000 - , cors = corsDisabled - } + MetricsServerConfig + { port = 9091, + enableJSON = True, + enablePrometheus = True, + enableWebSocket = True, + wsPushIntervalUs = 1_000_000, + wsMaxConnections = 100, + wsEventQueueCap = 256, + readinessMaxLag = 10_000, + livenessTimeoutUs = 1_000_000, + cors = corsDisabled + } diff --git a/src/Kiroku/Metrics/Cors.hs b/src/Kiroku/Metrics/Cors.hs --- a/src/Kiroku/Metrics/Cors.hs +++ b/src/Kiroku/Metrics/Cors.hs @@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns #-} -- | Default-off browser access for HTTP and WebSocket inspection surfaces. -module Kiroku.Metrics.Cors ( - AllowedOrigin, +module Kiroku.Metrics.Cors + ( AllowedOrigin, OriginError (..), allowedOrigin, renderAllowedOrigin, @@ -14,7 +14,8 @@ originAllowed, isPreflight, corsMiddleware, -) where + ) +where import Control.Monad (guard) import Data.ByteString (ByteString) @@ -35,21 +36,20 @@ -- | An explicit normalized HTTP(S) origin. Construct with 'allowedOrigin'. newtype AllowedOrigin = AllowedOrigin Text - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) -- | Configuration errors; input is retained only for the host's diagnostic use. data OriginError - = WildcardOrigin - | OpaqueOrigin - | MissingScheme Text - | EmptyHost Text - | HasPathQueryOrFragment Text - | NotAnOrigin Text - deriving stock (Eq, Show) + = WildcardOrigin + | OpaqueOrigin + | MissingScheme Text + | EmptyHost Text + | HasPathQueryOrFragment Text + | NotAnOrigin Text + deriving stock (Eq, Show) -{- | Validate configuration, trimming whitespace and tolerating one final slash. -DNS hosts must be ASCII; use the ASCII form of internationalized names. --} +-- | Validate configuration, trimming whitespace and tolerating one final slash. +-- DNS hosts must be ASCII; use the ASCII form of internationalized names. allowedOrigin :: Text -> Either OriginError AllowedOrigin allowedOrigin input = parseOrigin (maybe trimmed id (T.stripSuffix "/" trimmed)) where @@ -60,19 +60,19 @@ parseOrigin :: Text -> Either OriginError AllowedOrigin parseOrigin input - | input == "*" = Left WildcardOrigin - | input == "null" = Left OpaqueOrigin - | T.any (\c -> not (isAscii c) || ord c <= 32 || ord c == 127) input = invalid - | T.null rest = Left (MissingScheme input) - | scheme /= "http" && scheme /= "https" = invalid - | T.null authority = Left (EmptyHost input) - | T.any (`elem` ("/?#" :: String)) authority = Left (HasPathQueryOrFragment input) - | otherwise = case normalizeAuthority authority of - Nothing -> invalid - Just (host, mPort) -> - let defaultPort = if scheme == "http" then 80 else 443 - suffix = maybe "" (\p -> if p == defaultPort then "" else ":" <> T.pack (show p)) mPort - in Right (AllowedOrigin (scheme <> "://" <> host <> suffix)) + | input == "*" = Left WildcardOrigin + | input == "null" = Left OpaqueOrigin + | T.any (\c -> not (isAscii c) || ord c <= 32 || ord c == 127) input = invalid + | T.null rest = Left (MissingScheme input) + | scheme /= "http" && scheme /= "https" = invalid + | T.null authority = Left (EmptyHost input) + | T.any (`elem` ("/?#" :: String)) authority = Left (HasPathQueryOrFragment input) + | otherwise = case normalizeAuthority authority of + Nothing -> invalid + Just (host, mPort) -> + let defaultPort = if scheme == "http" then 80 else 443 + suffix = maybe "" (\p -> if p == defaultPort then "" else ":" <> T.pack (show p)) mPort + in Right (AllowedOrigin (scheme <> "://" <> host <> suffix)) where (rawScheme, rest) = T.breakOn "://" input scheme = T.map toLower rawScheme @@ -81,109 +81,110 @@ normalizeAuthority :: Text -> Maybe (Text, Maybe Int) normalizeAuthority authority = do - guard (not (T.any (`elem` ("@%*\\" :: String)) authority)) - if T.isPrefixOf "[" authority - then do - let (literal, close) = T.breakOn "]" (T.drop 1 authority) - guard (not (T.null close)) - host <- ipv6 literal - p <- portSuffix (T.drop 1 close) - pure ("[" <> host <> "]", p) - else do - let (host, suffix) = T.breakOn ":" authority - guard (validHost host) - p <- portSuffix suffix - pure (T.map toLower host, p) + guard (not (T.any (`elem` ("@%*\\" :: String)) authority)) + if T.isPrefixOf "[" authority + then do + let (literal, close) = T.breakOn "]" (T.drop 1 authority) + guard (not (T.null close)) + host <- ipv6 literal + p <- portSuffix (T.drop 1 close) + pure ("[" <> host <> "]", p) + else do + let (host, suffix) = T.breakOn ":" authority + guard (validHost host) + p <- portSuffix suffix + pure (T.map toLower host, p) portSuffix :: Text -> Maybe (Maybe Int) portSuffix "" = Just Nothing portSuffix suffix = do - digits <- T.stripPrefix ":" suffix - n <- decimal digits - guard (n <= 65535) - pure (Just (fromInteger n)) + digits <- T.stripPrefix ":" suffix + n <- decimal digits + guard (n <= 65535) + pure (Just (fromInteger n)) decimal :: Text -> Maybe Integer decimal digits = do - guard (not (T.null digits) && T.all (\c -> c >= '0' && c <= '9') digits) - -- Both uses are bounded (ports and IPv4 octets). Stop growing the number - -- once it cannot be a port, even for a very long untrusted header. - T.foldl' step (Just 0) digits + guard (not (T.null digits) && T.all (\c -> c >= '0' && c <= '9') digits) + -- Both uses are bounded (ports and IPv4 octets). Stop growing the number + -- once it cannot be a port, even for a very long untrusted header. + T.foldl' step (Just 0) digits where step number c = do - n <- number - let next = n * 10 + fromIntegral (ord c - ord '0') - guard (next <= 65535) - pure next + n <- number + let next = n * 10 + fromIntegral (ord c - ord '0') + guard (next <= 65535) + pure next validHost :: Text -> Bool validHost host - | T.null host || T.length host > 253 = False - | T.all (\c -> c == '.' || (c >= '0' && c <= '9')) host = isJust (ipv4 host) - | otherwise = all validLabel (T.splitOn "." host) + | T.null host || T.length host > 253 = False + | T.all (\c -> c == '.' || (c >= '0' && c <= '9')) host = isJust (ipv4 host) + | otherwise = all validLabel (T.splitOn "." host) where validLabel label = - not (T.null label) - && T.length label <= 63 - && T.head label /= '-' - && T.last label /= '-' - && T.all (\c -> isAsciiLower c || isAsciiUpper c || (c >= '0' && c <= '9') || c == '-') label + not (T.null label) + && T.length label <= 63 + && T.head label /= '-' + && T.last label /= '-' + && T.all (\c -> isAsciiLower c || isAsciiUpper c || (c >= '0' && c <= '9') || c == '-') label ipv4 :: Text -> Maybe [Int] ipv4 host = do - let parts = T.splitOn "." host - guard (length parts == 4) - traverse octet parts + let parts = T.splitOn "." host + guard (length parts == 4) + traverse octet parts where octet part = do - guard (T.length part <= 3 && (T.length part == 1 || not (T.isPrefixOf "0" part))) - n <- decimal part - guard (n <= 255) - pure (fromInteger n) + guard (T.length part <= 3 && (T.length part == 1 || not (T.isPrefixOf "0" part))) + n <- decimal part + guard (n <= 255) + pure (fromInteger n) -- Normalize IPv6 by expanding the groups; compressed and embedded-IPv4 forms -- compare by address, without DNS lookup or platform-dependent parsing. ipv6 :: Text -> Maybe Text ipv6 literal = do - expanded <- case T.splitOn "::" literal of - [whole] -> do - groups <- side whole - guard (length groups == 8) - pure groups - [left, right] -> do - -- An embedded IPv4 address must occupy the final two groups. - guard (not (T.any (== '.') left)) - l <- side left - r <- side right - guard (length l + length r < 8) - pure (l <> replicate (8 - length l - length r) 0 <> r) - _ -> Nothing - pure (T.intercalate ":" (map (\n -> T.pack (showHex n "")) expanded)) + expanded <- case T.splitOn "::" literal of + [whole] -> do + groups <- side whole + guard (length groups == 8) + pure groups + [left, right] -> do + -- An embedded IPv4 address must occupy the final two groups. + guard (not (T.any (== '.') left)) + l <- side left + r <- side right + guard (length l + length r < 8) + pure (l <> replicate (8 - length l - length r) 0 <> r) + _ -> Nothing + pure (T.intercalate ":" (map (\n -> T.pack (showHex n "")) expanded)) where side "" = Just [] side value = do - let parts = T.splitOn ":" value - case reverse parts of - final : remaining | T.any (== '.') final -> do - octets <- ipv4 final - case octets of - [a, b, c, d] -> do - preceding <- traverse hexGroup (reverse remaining) - pure (preceding <> [a * 256 + b, c * 256 + d]) - _ -> Nothing - _ -> traverse hexGroup parts + let parts = T.splitOn ":" value + case reverse parts of + final : remaining | T.any (== '.') final -> do + octets <- ipv4 final + case octets of + [a, b, c, d] -> do + preceding <- traverse hexGroup (reverse remaining) + pure (preceding <> [a * 256 + b, c * 256 + d]) + _ -> Nothing + _ -> traverse hexGroup parts hexGroup value = do - guard (not (T.null value) && T.length value <= 4 && T.all isHexDigit value) - pure (T.foldl' (\n c -> n * 16 + digitToInt c) 0 value) + guard (not (T.null value) && T.length value <= 4 && T.all isHexDigit value) + pure (T.foldl' (\n c -> n * 16 + digitToInt c) 0 value) -- | Empty origins disable the middleware. Negative max age is treated as absent. data CorsPolicy = CorsPolicy - { allowedOrigins :: ![AllowedOrigin] - , allowCredentials :: !Bool - , maxAgeSeconds :: !(Maybe Int) - } - deriving stock (Eq, Show) + { allowedOrigins :: ![AllowedOrigin], + allowCredentials :: !Bool, + maxAgeSeconds :: !(Maybe Int) + } + deriving stock (Eq, Show) +-- | No HTTP grants; refuse WebSocket upgrades carrying any Origin header. corsDisabled :: CorsPolicy corsDisabled = CorsPolicy [] False Nothing @@ -217,51 +218,54 @@ isPreflight :: Request -> Bool isPreflight req = - requestMethod req == methodOptions - && not (null (headerValues originHeader (requestHeaders req))) - && not (null (headerValues "Access-Control-Request-Method" (requestHeaders req))) + requestMethod req == methodOptions + && not (null (headerValues originHeader (requestHeaders req))) + && not (null (headerValues "Access-Control-Request-Method" (requestHeaders req))) -{- | Disabled policy returns the application itself. Enabled policy captures one -normalized set, protects upgrades before dispatch, and varies all HTTP responses. -Raw WebSocket responses are preserved by WAI's 'mapResponseHeaders'. --} +-- | Disabled policy leaves HTTP and origin-less upgrades unchanged, but refuses +-- upgrades carrying any Origin header. Enabled policy captures one +-- normalized set, protects upgrades before dispatch, and varies all HTTP responses. +-- Raw WebSocket responses are preserved by WAI's 'mapResponseHeaders'. corsMiddleware :: CorsPolicy -> Middleware corsMiddleware policy - | not (corsEnabled policy) = id - | otherwise = - let !origins = originSet policy - in \app req respond -> - let values = headerValues originHeader (requestHeaders req) - grant = case values of - [raw] | maybe False (`Set.member` origins) (requestOrigin raw) -> Just raw - _ -> Nothing - varyKeys = if isPreflight req then ["Origin", "Access-Control-Request-Method", "Access-Control-Request-Headers"] else ["Origin"] - decorate = mapResponseHeaders (decorateHeaders policy grant varyKeys) - reply = respond . decorate - in if isWebSocketsReq req - then case (values, grant) of - ([], _) -> app req reply - (_, Just _) -> app req reply - _ -> reply (errorResponse status403 "origin_not_allowed" "The request origin is not allowed." Nothing) - else case (isPreflight req, grant) of - (True, Just _) -> case headerValues "Access-Control-Request-Method" (requestHeaders req) of - [method] | method == "GET" || method == "HEAD" -> - case requestedHeaders (requestHeaders req) of - Nothing -> reply (errorResponse status400 "invalid_cors_request" "Requested header names must be HTTP tokens." Nothing) - Just headers -> - reply (responseLBS status204 (preflightHeaders policy headers) "") - [_] -> reply (errorResponse status403 "cors_method_not_allowed" "The requested method is not allowed." Nothing) - _ -> reply (errorResponse status400 "invalid_cors_request" "A single requested method is required." Nothing) - _ -> app req reply + | not (corsEnabled policy) = \app req respond -> + if isWebSocketsReq req && not (null (headerValues originHeader (requestHeaders req))) + then respond (errorResponse status403 "origin_not_allowed" "The request origin is not allowed." Nothing) + else app req respond + | otherwise = + let !origins = originSet policy + in \app req respond -> + let values = headerValues originHeader (requestHeaders req) + grant = case values of + [raw] | maybe False (`Set.member` origins) (requestOrigin raw) -> Just raw + _ -> Nothing + varyKeys = if isPreflight req then ["Origin", "Access-Control-Request-Method", "Access-Control-Request-Headers"] else ["Origin"] + decorate = mapResponseHeaders (decorateHeaders policy grant varyKeys) + reply = respond . decorate + in if isWebSocketsReq req + then case (values, grant) of + ([], _) -> app req reply + (_, Just _) -> app req reply + _ -> reply (errorResponse status403 "origin_not_allowed" "The request origin is not allowed." Nothing) + else case (isPreflight req, grant) of + (True, Just _) -> case headerValues "Access-Control-Request-Method" (requestHeaders req) of + [method] | method == "GET" || method == "HEAD" -> + case requestedHeaders (requestHeaders req) of + Nothing -> reply (errorResponse status400 "invalid_cors_request" "Requested header names must be HTTP tokens." Nothing) + Just headers -> + reply (responseLBS status204 (preflightHeaders policy headers) "") + [_] -> reply (errorResponse status403 "cors_method_not_allowed" "The requested method is not allowed." Nothing) + _ -> reply (errorResponse status400 "invalid_cors_request" "A single requested method is required." Nothing) + _ -> app req reply requestedHeaders :: RequestHeaders -> Maybe (Maybe ByteString) requestedHeaders headers = case headerValues "Access-Control-Request-Headers" headers of - [] -> Just Nothing - values -> do - guard (all (not . BS.null . trimOWS) values) - let tokens = map trimOWS (concatMap (BS.split ',') values) - guard (not (null tokens) && all (\t -> not (BS.null t) && BS.all tokenChar t) tokens) - pure (Just (BS.intercalate ", " tokens)) + [] -> Just Nothing + values -> do + guard (all (not . BS.null . trimOWS) values) + let tokens = map trimOWS (concatMap (BS.split ',') values) + guard (not (null tokens) && all (\t -> not (BS.null t) && BS.all tokenChar t) tokens) + pure (Just (BS.intercalate ", " tokens)) where tokenChar c = isAsciiLower c || isAsciiUpper c || (c >= '0' && c <= '9') || c `elem` ("!#$%&'*+-.^_`|~" :: String) @@ -272,24 +276,24 @@ preflightHeaders :: CorsPolicy -> Maybe ByteString -> ResponseHeaders preflightHeaders policy headers = - [("Access-Control-Allow-Methods", corsAllowedMethods)] - <> maybe [] (\v -> [("Access-Control-Allow-Headers", v)]) headers - <> case policy.maxAgeSeconds of - Just n | n >= 0 -> [("Access-Control-Max-Age", BS.pack (show n))] - _ -> [] + [("Access-Control-Allow-Methods", corsAllowedMethods)] + <> maybe [] (\v -> [("Access-Control-Allow-Headers", v)]) headers + <> case policy.maxAgeSeconds of + Just n | n >= 0 -> [("Access-Control-Max-Age", BS.pack (show n))] + _ -> [] decorateHeaders :: CorsPolicy -> Maybe ByteString -> [ByteString] -> ResponseHeaders -> ResponseHeaders decorateHeaders policy grant keys headers = - mergeVary keys (filter (not . isGrant . fst) headers) - <> maybe [] (\raw -> [("Access-Control-Allow-Origin", raw)] <> [("Access-Control-Allow-Credentials", "true") | policy.allowCredentials]) grant + mergeVary keys (filter (not . isGrant . fst) headers) + <> maybe [] (\raw -> [("Access-Control-Allow-Origin", raw)] <> [("Access-Control-Allow-Credentials", "true") | policy.allowCredentials]) grant where isGrant name = name == "Access-Control-Allow-Origin" || name == "Access-Control-Allow-Credentials" mergeVary :: [ByteString] -> ResponseHeaders -> ResponseHeaders mergeVary keys headers = - (varyHeader, BS.intercalate ", " tokens) : filter ((/= varyHeader) . fst) headers + (varyHeader, BS.intercalate ", " tokens) : filter ((/= varyHeader) . fst) headers where existing = filter (not . BS.null) (map trimOWS (concatMap (BS.split ',' . snd) (filter ((== varyHeader) . fst) headers))) tokens - | "*" `elem` existing = ["*"] - | otherwise = nubBy (\a b -> BS.map toLower a == BS.map toLower b) (existing <> keys) + | "*" `elem` existing = ["*"] + | otherwise = nubBy (\a b -> BS.map toLower a == BS.map toLower b) (existing <> keys) diff --git a/src/Kiroku/Metrics/DeadLetters.hs b/src/Kiroku/Metrics/DeadLetters.hs --- a/src/Kiroku/Metrics/DeadLetters.hs +++ b/src/Kiroku/Metrics/DeadLetters.hs @@ -1,6 +1,6 @@ -- | Read-only subscription dead-letter inspection with exclusive keyset pages. -module Kiroku.Metrics.DeadLetters ( - DeadLetterProvider, +module Kiroku.Metrics.DeadLetters + ( DeadLetterProvider, storeDeadLetters, DeadLetterItem (..), DeadLetterPageResponse (..), @@ -11,7 +11,8 @@ parseDeadLetterRequest, deadLettersApp, deadLettersNotConfiguredApp, -) where + ) +where import Data.Aeson (FromJSON (..), ToJSON (..), Value, encode, object, withObject, (.:), (.:?), (.=)) import Data.ByteString qualified as BS @@ -29,34 +30,41 @@ import Text.Read (readMaybe) type DeadLetterProvider = Store.SubscriptionDeadLetterQuery -> IO (Either Store.StoreError Store.SubscriptionDeadLetterPage) + storeDeadLetters :: Store.KirokuStore -> DeadLetterProvider storeDeadLetters store = Store.runStoreIO store . Store.subscriptionDeadLetters data DeadLetterItem = DeadLetterItem - { deadLetterId :: !Int64 - , subscription :: !Text - , member :: !Int32 - , globalPosition :: !Int64 - , eventId :: !UUID - , reason :: !Value - , reasonSummary :: !Text - , attemptCount :: !Int32 - , createdAt :: !UTCTime - } - deriving stock (Eq, Show) + { deadLetterId :: !Int64, + subscription :: !Text, + member :: !Int32, + globalPosition :: !Int64, + eventId :: !UUID, + reason :: !Value, + reasonSummary :: !Text, + attemptCount :: !Int32, + createdAt :: !UTCTime + } + deriving stock (Eq, Show) + data DeadLetterPageResponse = DeadLetterPageResponse - { items :: ![DeadLetterItem] - , nextCursor :: !(Maybe Text) - } - deriving stock (Eq, Show) + { items :: ![DeadLetterItem], + nextCursor :: !(Maybe Text) + } + deriving stock (Eq, Show) + instance ToJSON DeadLetterItem where - toJSON row = object ["dead_letter_id" .= row.deadLetterId, "subscription" .= row.subscription, "member" .= row.member, "global_position" .= row.globalPosition, "event_id" .= row.eventId, "reason" .= row.reason, "reason_summary" .= row.reasonSummary, "attempt_count" .= row.attemptCount, "created_at" .= row.createdAt] + toJSON row = object ["dead_letter_id" .= row.deadLetterId, "subscription" .= row.subscription, "member" .= row.member, "global_position" .= row.globalPosition, "event_id" .= row.eventId, "reason" .= row.reason, "reason_summary" .= row.reasonSummary, "attempt_count" .= row.attemptCount, "created_at" .= row.createdAt] + instance FromJSON DeadLetterItem where - parseJSON = withObject "DeadLetterItem" $ \o -> DeadLetterItem <$> o .: "dead_letter_id" <*> o .: "subscription" <*> o .: "member" <*> o .: "global_position" <*> o .: "event_id" <*> o .: "reason" <*> o .: "reason_summary" <*> o .: "attempt_count" <*> o .: "created_at" + parseJSON = withObject "DeadLetterItem" $ \o -> DeadLetterItem <$> o .: "dead_letter_id" <*> o .: "subscription" <*> o .: "member" <*> o .: "global_position" <*> o .: "event_id" <*> o .: "reason" <*> o .: "reason_summary" <*> o .: "attempt_count" <*> o .: "created_at" + instance ToJSON DeadLetterPageResponse where - toJSON page = object (["items" .= page.items] <> maybe [] (\cursor -> ["next_cursor" .= cursor]) page.nextCursor) + toJSON page = object (["items" .= page.items] <> maybe [] (\cursor -> ["next_cursor" .= cursor]) page.nextCursor) + instance FromJSON DeadLetterPageResponse where - parseJSON = withObject "DeadLetterPageResponse" $ \o -> DeadLetterPageResponse <$> o .: "items" <*> o .:? "next_cursor" + parseJSON = withObject "DeadLetterPageResponse" $ \o -> DeadLetterPageResponse <$> o .: "items" <*> o .:? "next_cursor" + deadLetterPageResponse :: Store.SubscriptionDeadLetterPage -> DeadLetterPageResponse deadLetterPageResponse (Store.SubscriptionDeadLetterPage rows cursor) = DeadLetterPageResponse (map item (V.toList rows)) (renderDeadLetterCursor <$> cursor) where @@ -64,49 +72,54 @@ renderDeadLetterCursor :: Store.SubscriptionDeadLetterCursor -> Text renderDeadLetterCursor (Store.SubscriptionDeadLetterCursor (Store.GlobalPosition position) ident) = T.pack (show position) <> ":" <> T.pack (show ident) + parseDeadLetterCursor :: Text -> Maybe Store.SubscriptionDeadLetterCursor parseDeadLetterCursor raw = case T.splitOn ":" raw of - [p, i] -> Store.SubscriptionDeadLetterCursor . Store.GlobalPosition <$> unsigned p <*> unsigned i - _ -> Nothing + [p, i] -> Store.SubscriptionDeadLetterCursor . Store.GlobalPosition <$> unsigned p <*> unsigned i + _ -> Nothing + unsigned :: forall a. (Integral a, Bounded a) => Text -> Maybe a unsigned raw - | T.null raw || T.length raw > 20 || not (T.all (\c -> c >= '0' && c <= '9') raw) = Nothing - | otherwise = do - value <- readMaybe (T.unpack raw) :: Maybe Integer - if value <= toInteger (maxBound @a) then Just (fromInteger value) else Nothing + | T.null raw || T.length raw > 20 || not (T.all (\c -> c >= '0' && c <= '9') raw) = Nothing + | otherwise = do + value <- readMaybe (T.unpack raw) :: Maybe Integer + if value <= toInteger (maxBound @a) then Just (fromInteger value) else Nothing data DeadLetterRequest = DeadLetterRequest - { requestMember :: !(Maybe Int32) - , requestAfter :: !(Maybe Store.SubscriptionDeadLetterCursor) - , requestLimit :: !Store.SubscriptionDeadLetterLimit - } - deriving stock (Eq, Show) + { requestMember :: !(Maybe Int32), + requestAfter :: !(Maybe Store.SubscriptionDeadLetterCursor), + requestLimit :: !Store.SubscriptionDeadLetterLimit + } + deriving stock (Eq, Show) + type Failure = (Status, Text, Text, Maybe Value) + invalid :: Text -> Text -> Text -> Failure invalid parameter value reason = (status400, "invalid_query_parameter", "Invalid query parameter.", Just (object ["parameter" .= parameter, "value" .= value, "reason" .= reason])) + parseDeadLetterRequest :: Query -> Either Failure DeadLetterRequest parseDeadLetterRequest query = do - member <- parameter "member" unsigned "Expected a non-negative Int32 decimal integer." - cursor <- parameter "from" parseDeadLetterCursor "Expected an opaque position:id cursor with non-negative Int64 components." - size <- parameter "limit" validLimit "Expected a decimal page size from 1 through 1000." - pure (DeadLetterRequest member cursor (maybe Store.defaultSubscriptionDeadLetterLimit id size)) + member <- parameter "member" unsigned "Expected a non-negative Int32 decimal integer." + cursor <- parameter "from" parseDeadLetterCursor "Expected an opaque position:id cursor with non-negative Int64 components." + size <- parameter "limit" validLimit "Expected a decimal page size from 1 through 1000." + pure (DeadLetterRequest member cursor (maybe Store.defaultSubscriptionDeadLetterLimit id size)) where validLimit raw = unsigned raw >>= either (const Nothing) Just . Store.mkSubscriptionDeadLetterLimit parameter :: Text -> (Text -> Maybe a) -> Text -> Either Failure (Maybe a) parameter key parser reason = case [v | (k, v) <- query, k == TE.encodeUtf8 key] of - [] -> Right Nothing - [Just bytes] -> case TE.decodeUtf8' bytes of - Left _ -> Left (invalid key "" "Expected valid UTF-8.") - Right raw -> maybe (Left (invalid key raw reason)) (Right . Just) (parser raw) - [Nothing] -> Left (invalid key "" reason) - _ -> Left (invalid key "" "Parameter must occur at most once.") + [] -> Right Nothing + [Just bytes] -> case TE.decodeUtf8' bytes of + Left _ -> Left (invalid key "" "Expected valid UTF-8.") + Right raw -> maybe (Left (invalid key raw reason)) (Right . Just) (parser raw) + [Nothing] -> Left (invalid key "" reason) + _ -> Left (invalid key "" "Parameter must occur at most once.") -- | Applies GET/HEAD/405 at WAI level, including when mounted without Warp. readMethods :: IO Response -> Application readMethods action req respond - | requestMethod req == "GET" = action >>= respond - | requestMethod req == "HEAD" = action >>= \response -> respond (responseLBS (responseStatus response) (responseHeaders response) "") - | otherwise = respond $ mapResponseHeaders (("Allow", "GET, HEAD") :) $ errorResponse status405 "method_not_allowed" "Only GET and HEAD are supported." Nothing + | requestMethod req == "GET" = action >>= respond + | requestMethod req == "HEAD" = action >>= \response -> respond (responseLBS (responseStatus response) (responseHeaders response) "") + | otherwise = respond $ mapResponseHeaders (("Allow", "GET, HEAD") :) $ errorResponse status405 "method_not_allowed" "Only GET and HEAD are supported." Nothing deadLettersNotConfiguredApp :: Application deadLettersNotConfiguredApp req = readMethods (pure (errorResponse status404 "dead_letters_not_configured" "Dead letters are not configured." Nothing)) req @@ -115,13 +128,13 @@ deadLettersApp provider req = readMethods action req where action = case pathInfo req of - ["subscriptions", name, "dead-letters"] - | T.any (== '\0') name || BS.length (TE.encodeUtf8 name) > 512 -> pure $ failure (invalid "subscription" name "Expected at most 512 UTF-8 bytes without NUL.") - | otherwise -> case parseDeadLetterRequest (queryString req) of - Left err -> pure (failure err) - Right (DeadLetterRequest member cursor size) -> - provider (Store.SubscriptionDeadLetterQuery (Store.SubscriptionName name) member cursor size) >>= \case - Left err -> pure (storeErrorResponse "dead_letters_unavailable" err) - Right page -> pure (jsonResponse status200 (encode (deadLetterPageResponse page))) - _ -> pure (errorResponse status404 "not_found" "Not found" Nothing) + ["subscriptions", name, "dead-letters"] + | T.any (== '\0') name || BS.length (TE.encodeUtf8 name) > 512 -> pure $ failure (invalid "subscription" name "Expected at most 512 UTF-8 bytes without NUL.") + | otherwise -> case parseDeadLetterRequest (queryString req) of + Left err -> pure (failure err) + Right (DeadLetterRequest member cursor size) -> + provider (Store.SubscriptionDeadLetterQuery (Store.SubscriptionName name) member cursor size) >>= \case + Left err -> pure (storeErrorResponse "dead_letters_unavailable" err) + Right page -> pure (jsonResponse status200 (encode (deadLetterPageResponse page))) + _ -> pure (errorResponse status404 "not_found" "Not found" Nothing) failure (status, code, message, details) = errorResponse status code message details diff --git a/src/Kiroku/Metrics/Health.hs b/src/Kiroku/Metrics/Health.hs --- a/src/Kiroku/Metrics/Health.hs +++ b/src/Kiroku/Metrics/Health.hs @@ -1,23 +1,22 @@ -{- | Kubernetes-style health checks derived from the metrics snapshot. - -* Liveness — can we read a snapshot within a time budget? (Is the process and - collector responsive?) -* Readiness — is the store ready to serve: no subscription overflow-stopped, no - subscription lagging beyond 'Kiroku.Metrics.Config.readinessMaxLag', and all - configured 'DependencyCheck's passing? -* Detailed health — the readiness verdict plus the full snapshot, for humans. - -The built-in 'postgresPing' dependency check issues @SELECT 1@ through the -store's pool. Other dependency checks are arbitrary @IO 'DependencyStatus'@ -actions the caller supplies. - -The lag signal is an /upper bound/: the collector observes a subscription's -position only at lifecycle callback points (see the collector's limitation), so -readiness may briefly report a caught-up subscription as lagging until its next -lifecycle event. --} -module Kiroku.Metrics.Health ( - DependencyCheck, +-- | Kubernetes-style health checks derived from the metrics snapshot. +-- +-- * Liveness — can we read a snapshot within a time budget? (Is the process and +-- collector responsive?) +-- * Readiness — is the store ready to serve: no subscription overflow-stopped, no +-- subscription lagging beyond 'Kiroku.Metrics.Config.readinessMaxLag', and all +-- configured 'DependencyCheck's passing? +-- * Detailed health — the readiness verdict plus the full snapshot, for humans. +-- +-- The built-in 'postgresPing' dependency check issues @SELECT 1@ through the +-- store's pool. Other dependency checks are arbitrary @IO 'DependencyStatus'@ +-- actions the caller supplies. +-- +-- The lag signal is an /upper bound/: the collector observes a subscription's +-- position only at lifecycle callback points (see the collector's limitation), so +-- readiness may briefly report a caught-up subscription as lagging until its next +-- lifecycle event. +module Kiroku.Metrics.Health + ( DependencyCheck, DependencyStatus (..), LivenessStatus (..), ReadinessStatus (..), @@ -25,7 +24,8 @@ checkReadiness, checkDetailedHealth, postgresPing, -) where + ) +where import Data.Aeson (ToJSON (..), object, (.=)) import Data.Map.Strict qualified as Map @@ -39,10 +39,10 @@ import Kiroku.Metrics.Collector (KirokuMetrics, snapshotMetrics) import Kiroku.Metrics.Config (MetricsServerConfig (..)) -import Kiroku.Metrics.Types ( - MetricsSnapshot (..), +import Kiroku.Metrics.Types + ( MetricsSnapshot (..), SubscriptionMetrics (..), - ) + ) import Kiroku.Store (KirokuStore (..)) -- | A dependency check is an IO action returning that dependency's status. @@ -50,95 +50,92 @@ -- | Status of one external dependency. data DependencyStatus = DependencyStatus - { name :: !Text - , healthy :: !Bool - , latencyMs :: !(Maybe Int) - , errorMsg :: !(Maybe Text) - } - deriving stock (Eq, Show) + { name :: !Text, + healthy :: !Bool, + latencyMs :: !(Maybe Int), + errorMsg :: !(Maybe Text) + } + deriving stock (Eq, Show) instance ToJSON DependencyStatus where - toJSON ds = - object - [ "name" .= ds.name - , "healthy" .= ds.healthy - , "latency_ms" .= ds.latencyMs - , "error" .= ds.errorMsg - ] + toJSON ds = + object + [ "name" .= ds.name, + "healthy" .= ds.healthy, + "latency_ms" .= ds.latencyMs, + "error" .= ds.errorMsg + ] -- | Liveness verdict. newtype LivenessStatus = LivenessStatus {alive :: Bool} - deriving stock (Eq, Show) + deriving stock (Eq, Show) instance ToJSON LivenessStatus where - toJSON s = object ["alive" .= s.alive] + toJSON s = object ["alive" .= s.alive] -- | Readiness verdict and its components. data ReadinessStatus = ReadinessStatus - { ready :: !Bool - , lagOk :: !Bool - , noOverflow :: !Bool - , dependencies :: ![DependencyStatus] - } - deriving stock (Eq, Show) + { ready :: !Bool, + lagOk :: !Bool, + noOverflow :: !Bool, + dependencies :: ![DependencyStatus] + } + deriving stock (Eq, Show) instance ToJSON ReadinessStatus where - toJSON s = - object - [ "ready" .= s.ready - , "lag_ok" .= s.lagOk - , "no_overflow" .= s.noOverflow - , "dependencies" .= s.dependencies - ] + toJSON s = + object + [ "ready" .= s.ready, + "lag_ok" .= s.lagOk, + "no_overflow" .= s.noOverflow, + "dependencies" .= s.dependencies + ] -{- | Liveness: can we take a snapshot within 'livenessTimeoutUs'? Proves the -collector and store @TVar@s are reachable within the budget. --} +-- | Liveness: can we take a snapshot within 'livenessTimeoutUs'? Proves the +-- collector and store @TVar@s are reachable within the budget. checkLiveness :: MetricsServerConfig -> KirokuMetrics -> IO LivenessStatus checkLiveness cfg m = do - result <- timeout cfg.livenessTimeoutUs (snapshotMetrics m) - pure (LivenessStatus{alive = isJust result}) + result <- timeout cfg.livenessTimeoutUs (snapshotMetrics m) + pure (LivenessStatus {alive = isJust result}) -{- | Readiness: no subscription overflow-stopped, none lagging beyond -'readinessMaxLag', and all dependency checks healthy. --} +-- | Readiness: no subscription overflow-stopped, none lagging beyond +-- 'readinessMaxLag', and all dependency checks healthy. checkReadiness :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> IO ReadinessStatus checkReadiness cfg m depChecks = do - snap <- snapshotMetrics m - deps <- sequence depChecks - let subs = Map.elems snap.subscriptions - noOverflow = not (any ((== Just "overflow") . (.lastStopReason)) subs) - lagOk = all ((<= cfg.readinessMaxLag) . (.lag)) subs - depsOk = all (.healthy) deps - pure - ReadinessStatus - { ready = noOverflow && lagOk && depsOk - , lagOk - , noOverflow - , dependencies = deps - } + snap <- snapshotMetrics m + deps <- sequence depChecks + let subs = Map.elems snap.subscriptions + noOverflow = not (any ((== Just "overflow") . (.lastStopReason)) subs) + lagOk = all ((<= cfg.readinessMaxLag) . (.lag)) subs + depsOk = all (.healthy) deps + pure + ReadinessStatus + { ready = noOverflow && lagOk && depsOk, + lagOk, + noOverflow, + dependencies = deps + } -- | Detailed health: the readiness verdict plus the full snapshot. checkDetailedHealth :: - MetricsServerConfig -> - KirokuMetrics -> - [DependencyCheck] -> - IO (ReadinessStatus, MetricsSnapshot) + MetricsServerConfig -> + KirokuMetrics -> + [DependencyCheck] -> + IO (ReadinessStatus, MetricsSnapshot) checkDetailedHealth cfg m depChecks = do - readiness <- checkReadiness cfg m depChecks - snap <- snapshotMetrics m - pure (readiness, snap) + readiness <- checkReadiness cfg m depChecks + snap <- snapshotMetrics m + pure (readiness, snap) -{- | Built-in dependency check: time a @SELECT 1@ through the store's pool. A -@Right@ result is healthy; a @Left@ 'Pool.UsageError' is unhealthy with the -error rendered into 'errorMsg'. --} +-- | Built-in dependency check: time a @SELECT 1@ through the store's pool. A +-- @Right@ result is healthy; a @Left@ 'Pool.UsageError' is unhealthy with the +-- error rendered into 'errorMsg'. postgresPing :: KirokuStore -> DependencyCheck postgresPing store = do - t0 <- getMonotonicTimeNSec - result <- Pool.use store.pool (Session.script "SELECT 1") - t1 <- getMonotonicTimeNSec - let ms = fromIntegral ((t1 - t0) `div` 1_000_000) - pure $ case result of - Right () -> DependencyStatus "postgres" True (Just ms) Nothing - Left e -> DependencyStatus "postgres" False (Just ms) (Just (T.pack (show e))) + t0 <- getMonotonicTimeNSec + result <- Pool.use store.pool (Session.script "SELECT 1") + t1 <- getMonotonicTimeNSec + let ms = fromIntegral ((t1 - t0) `div` 1_000_000) + pure $ case result of + Right () -> DependencyStatus "postgres" True (Just ms) Nothing + Left e -> DependencyStatus "postgres" False (Just ms) (Just (T.pack (show e))) diff --git a/src/Kiroku/Metrics/JSON.hs b/src/Kiroku/Metrics/JSON.hs --- a/src/Kiroku/Metrics/JSON.hs +++ b/src/Kiroku/Metrics/JSON.hs @@ -1,13 +1,13 @@ -{- | JSON HTTP endpoints: @GET /metrics@ (the full snapshot) and -@GET /metrics/\@ (one subscription's metrics, or 404). --} -module Kiroku.Metrics.JSON ( - jsonApp, +-- | JSON HTTP endpoints: @GET /metrics@ (the full snapshot) and +-- @GET /metrics/\@ (one subscription's metrics, or 404). +module Kiroku.Metrics.JSON + ( jsonApp, jsonResponse, errorEnvelope, errorResponse, storeErrorResponse, -) where + ) +where import Data.Aeson (Value, encode, object, (.=)) import Data.ByteString.Lazy qualified as LBS @@ -20,28 +20,27 @@ import Kiroku.Metrics.Types (MetricsSnapshot (..)) import Kiroku.Store.Error (StoreError (..)) -{- | WAI application for the JSON metrics endpoints. Routes @/metrics@ and -@/metrics/\@; any other path returns a 404 JSON body. --} +-- | WAI application for the JSON metrics endpoints. Routes @/metrics@ and +-- @/metrics/\@; any other path returns a 404 JSON body. jsonApp :: KirokuMetrics -> Application jsonApp m req respond = do - resp <- case pathInfo req of - ["metrics"] -> do - snap <- snapshotMetrics m - pure (jsonResponse status200 (encode snap)) - ["metrics", name] -> do - snap <- snapshotMetrics m - pure $ case Map.lookup name snap.subscriptions of - Just sm -> jsonResponse status200 (encode sm) - Nothing -> - jsonResponse status404 $ - encode $ - object - [ "error" .= ("subscription not found" :: Text) - , "subscription" .= name - ] - _ -> pure (jsonResponse status404 (encode (object ["error" .= ("Not found" :: Text)]))) - respond resp + resp <- case pathInfo req of + ["metrics"] -> do + snap <- snapshotMetrics m + pure (jsonResponse status200 (encode snap)) + ["metrics", name] -> do + snap <- snapshotMetrics m + pure $ case Map.lookup name snap.subscriptions of + Just sm -> jsonResponse status200 (encode sm) + Nothing -> + jsonResponse status404 $ + encode $ + object + [ "error" .= ("subscription not found" :: Text), + "subscription" .= name + ] + _ -> pure (jsonResponse status404 (encode (object ["error" .= ("Not found" :: Text)]))) + respond resp -- | Build an @application/json@ response with the given status and body. jsonResponse :: Status -> LBS.ByteString -> Response @@ -50,20 +49,19 @@ -- | Shared structured error for new inspection routes; legacy errors stay unchanged. errorEnvelope :: Text -> Text -> Maybe Value -> Value errorEnvelope code message details = - object ["error" .= object (["code" .= code, "message" .= message] <> maybe [] (\v -> ["details" .= v]) details)] + object ["error" .= object (["code" .= code, "message" .= message] <> maybe [] (\v -> ["details" .= v]) details)] -- | Build a JSON error, omitting @details@ when absent. errorResponse :: Status -> Text -> Text -> Maybe Value -> Response errorResponse status code message = jsonResponse status . encode . errorEnvelope code message -{- | Sanitize store failures without exposing connection strings or event payloads. -This function handles values only and never catches asynchronous exceptions. --} +-- | Sanitize store failures without exposing connection strings or event payloads. +-- This function handles values only and never catches asynchronous exceptions. storeErrorResponse :: Text -> StoreError -> Response storeErrorResponse unavailableCode = \case - ConnectionError _ -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing - ConnectionLost _ -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing - PoolAcquisitionTimeout -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing - TransientTransactionFailure _ _ -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing - EventDecodeFailed _ -> errorResponse status500 "event_decode_failed" "An event could not be decoded." Nothing - _ -> errorResponse status500 "store_error" "The event store operation failed." Nothing + ConnectionError _ -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing + ConnectionLost _ -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing + PoolAcquisitionTimeout -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing + TransientTransactionFailure _ _ -> errorResponse status503 unavailableCode "The event store is unavailable." Nothing + EventDecodeFailed _ -> errorResponse status500 "event_decode_failed" "An event could not be decoded." Nothing + _ -> errorResponse status500 "store_error" "The event store operation failed." Nothing diff --git a/src/Kiroku/Metrics/Prometheus.hs b/src/Kiroku/Metrics/Prometheus.hs --- a/src/Kiroku/Metrics/Prometheus.hs +++ b/src/Kiroku/Metrics/Prometheus.hs @@ -1,15 +1,15 @@ -{- | Prometheus text-exposition endpoint (@GET /metrics/prometheus@). - -Hand-rolled (no @prometheus-client@ dependency, no global registry): the -snapshot is the single source of truth and is rendered straight to the -text-exposition format that @promtool check metrics@ accepts. Metric names are a -public contract for dashboards — keep them stable once shipped (EP-4 documents -the full list). --} -module Kiroku.Metrics.Prometheus ( - prometheusApp, +-- | Prometheus text-exposition endpoint (@GET /metrics/prometheus@). +-- +-- Hand-rolled (no @prometheus-client@ dependency, no global registry): the +-- snapshot is the single source of truth and is rendered straight to the +-- text-exposition format that @promtool check metrics@ accepts. Metric names are a +-- public contract for dashboards — keep them stable once shipped (EP-4 documents +-- the full list). +module Kiroku.Metrics.Prometheus + ( prometheusApp, renderPrometheus, -) where + ) +where import Data.ByteString.Builder qualified as B import Data.ByteString.Lazy qualified as LBS @@ -23,22 +23,22 @@ import Network.Wai (Application, responseLBS) import Kiroku.Metrics.Collector (KirokuMetrics, snapshotMetrics) -import Kiroku.Metrics.Types ( - LifecycleCounters (..), +import Kiroku.Metrics.Types + ( LifecycleCounters (..), MetricsSnapshot (..), StoreGauges (..), SubscriptionMetrics (..), - ) + ) -- | WAI application for the Prometheus endpoint. prometheusApp :: KirokuMetrics -> Application prometheusApp m _req respond = do - snap <- snapshotMetrics m - respond $ - responseLBS - status200 - [(hContentType, "text/plain; version=0.0.4; charset=utf-8")] - (renderPrometheus snap) + snap <- snapshotMetrics m + respond $ + responseLBS + status200 + [(hContentType, "text/plain; version=0.0.4; charset=utf-8")] + (renderPrometheus snap) -- | Render a snapshot as Prometheus text-exposition format. renderPrometheus :: MetricsSnapshot -> LBS.ByteString @@ -46,65 +46,65 @@ storeSection :: StoreGauges -> B.Builder storeSection g = - mconcat - [ metric "kiroku_events_appended_total" "counter" "Current store global position (opaque; not guaranteed dense)." (g.globalPosition) - , metricI "kiroku_active_subscribers" "gauge" "Currently registered subscribers." g.activeSubscribers - , help "kiroku_pool_connections" "Pool connections by state." - , typ "kiroku_pool_connections" "gauge" - , labelledI "kiroku_pool_connections" "state" "connecting" g.poolConnecting - , labelledI "kiroku_pool_connections" "state" "ready" g.poolReady - , labelledI "kiroku_pool_connections" "state" "in_use" g.poolInUse - , metric "kiroku_pool_established_total" "counter" "Pool connections established." (g.poolEstablishedTotal) - , metric "kiroku_pool_terminated_total" "counter" "Pool connections terminated." (g.poolTerminatedTotal) - ] + mconcat + [ metric "kiroku_events_appended_total" "counter" "Current store global position (opaque; not guaranteed dense)." (g.globalPosition), + metricI "kiroku_active_subscribers" "gauge" "Currently registered subscribers." g.activeSubscribers, + help "kiroku_pool_connections" "Pool connections by state.", + typ "kiroku_pool_connections" "gauge", + labelledI "kiroku_pool_connections" "state" "connecting" g.poolConnecting, + labelledI "kiroku_pool_connections" "state" "ready" g.poolReady, + labelledI "kiroku_pool_connections" "state" "in_use" g.poolInUse, + metric "kiroku_pool_established_total" "counter" "Pool connections established." (g.poolEstablishedTotal), + metric "kiroku_pool_terminated_total" "counter" "Pool connections terminated." (g.poolTerminatedTotal) + ] counterSection :: LifecycleCounters -> B.Builder counterSection c = - mconcat - [ metric "kiroku_notifier_reconnecting_total" "counter" "Notifier reconnection attempts started." c.notifierReconnecting - , metric "kiroku_notifier_reconnected_total" "counter" "Notifier reconnections completed." c.notifierReconnected - , metric "kiroku_publisher_pool_errors_total" "counter" "EventPublisher read-query pool errors." c.publisherPoolErrors - , metric "kiroku_subscription_handler_stalls_total" "counter" "Advisory handler stall warnings." c.subscriptionHandlerStalls - , metric "kiroku_publisher_decode_failures_total" "counter" "Typed undecodable events broadcast by the publisher." c.publisherDecodeFailures - , metric "kiroku_publisher_loop_errors_total" "counter" "EventPublisher callback or broadcast loop errors." c.publisherLoopErrors - , help "kiroku_subscription_db_errors_by_phase_total" "Subscription database errors by phase." - , typ "kiroku_subscription_db_errors_by_phase_total" "counter" - , labelled "kiroku_subscription_db_errors_by_phase_total" "phase" "load" c.subscriptionDbErrorsLoad - , labelled "kiroku_subscription_db_errors_by_phase_total" "phase" "fetch" c.subscriptionDbErrorsFetch - , labelled "kiroku_subscription_db_errors_by_phase_total" "phase" "save" c.subscriptionDbErrorsSave - , metric "kiroku_subscriptions_started_total" "counter" "Subscription workers started." c.subscriptionsStarted - , metric "kiroku_subscriptions_caught_up_total" "counter" "Subscriptions that reached live mode." c.subscriptionsCaughtUp - , metric "kiroku_subscriptions_paused_total" "counter" "Subscription pauses (backpressure)." c.subscriptionsPaused - , metric "kiroku_subscriptions_resumed_total" "counter" "Subscription resumes after pause." c.subscriptionsResumed - , metric "kiroku_subscriptions_reconnecting_total" "counter" "Subscription live-fetch reconnects." c.subscriptionsReconnecting - , metric "kiroku_subscriptions_retrying_total" "counter" "Subscription event redeliveries." c.subscriptionsRetrying - , metric "kiroku_subscriptions_dead_lettered_total" "counter" "Events written to dead letters." c.subscriptionsDeadLettered - , help "kiroku_subscriptions_stopped_total" "Subscription stops by reason." - , typ "kiroku_subscriptions_stopped_total" "counter" - , labelled "kiroku_subscriptions_stopped_total" "reason" "handler" c.subscriptionsStoppedHandler - , labelled "kiroku_subscriptions_stopped_total" "reason" "cancelled" c.subscriptionsStoppedCancelled - , labelled "kiroku_subscriptions_stopped_total" "reason" "overflow" c.subscriptionsStoppedOverflow - , labelled "kiroku_subscriptions_stopped_total" "reason" "crashed" c.subscriptionsStoppedCrashed - , labelled "kiroku_subscriptions_stopped_total" "reason" "undecodable" c.subscriptionsStoppedUndecodable - , metric "kiroku_live_fetches_total" "counter" "Live-mode database fetches." c.liveFetches - , metric "kiroku_batches_delivered_total" "counter" "Non-empty batches delivered to handlers." c.batchesDelivered - , metric "kiroku_events_delivered_total" "counter" "Events delivered to handlers." c.eventsDelivered - , metric "kiroku_hard_deletes_total" "counter" "Hard-delete transactions issued." c.hardDeletesIssued - ] + mconcat + [ metric "kiroku_notifier_reconnecting_total" "counter" "Notifier reconnection attempts started." c.notifierReconnecting, + metric "kiroku_notifier_reconnected_total" "counter" "Notifier reconnections completed." c.notifierReconnected, + metric "kiroku_publisher_pool_errors_total" "counter" "EventPublisher read-query pool errors." c.publisherPoolErrors, + metric "kiroku_subscription_handler_stalls_total" "counter" "Advisory handler stall warnings." c.subscriptionHandlerStalls, + metric "kiroku_publisher_decode_failures_total" "counter" "Typed undecodable events broadcast by the publisher." c.publisherDecodeFailures, + metric "kiroku_publisher_loop_errors_total" "counter" "EventPublisher callback or broadcast loop errors." c.publisherLoopErrors, + help "kiroku_subscription_db_errors_by_phase_total" "Subscription database errors by phase.", + typ "kiroku_subscription_db_errors_by_phase_total" "counter", + labelled "kiroku_subscription_db_errors_by_phase_total" "phase" "load" c.subscriptionDbErrorsLoad, + labelled "kiroku_subscription_db_errors_by_phase_total" "phase" "fetch" c.subscriptionDbErrorsFetch, + labelled "kiroku_subscription_db_errors_by_phase_total" "phase" "save" c.subscriptionDbErrorsSave, + metric "kiroku_subscriptions_started_total" "counter" "Subscription workers started." c.subscriptionsStarted, + metric "kiroku_subscriptions_caught_up_total" "counter" "Subscriptions that reached live mode." c.subscriptionsCaughtUp, + metric "kiroku_subscriptions_paused_total" "counter" "Subscription pauses (backpressure)." c.subscriptionsPaused, + metric "kiroku_subscriptions_resumed_total" "counter" "Subscription resumes after pause." c.subscriptionsResumed, + metric "kiroku_subscriptions_reconnecting_total" "counter" "Subscription live-fetch reconnects." c.subscriptionsReconnecting, + metric "kiroku_subscriptions_retrying_total" "counter" "Subscription event redeliveries." c.subscriptionsRetrying, + metric "kiroku_subscriptions_dead_lettered_total" "counter" "Events written to dead letters." c.subscriptionsDeadLettered, + help "kiroku_subscriptions_stopped_total" "Subscription stops by reason.", + typ "kiroku_subscriptions_stopped_total" "counter", + labelled "kiroku_subscriptions_stopped_total" "reason" "handler" c.subscriptionsStoppedHandler, + labelled "kiroku_subscriptions_stopped_total" "reason" "cancelled" c.subscriptionsStoppedCancelled, + labelled "kiroku_subscriptions_stopped_total" "reason" "overflow" c.subscriptionsStoppedOverflow, + labelled "kiroku_subscriptions_stopped_total" "reason" "crashed" c.subscriptionsStoppedCrashed, + labelled "kiroku_subscriptions_stopped_total" "reason" "undecodable" c.subscriptionsStoppedUndecodable, + metric "kiroku_live_fetches_total" "counter" "Live-mode database fetches." c.liveFetches, + metric "kiroku_batches_delivered_total" "counter" "Non-empty batches delivered to handlers." c.batchesDelivered, + metric "kiroku_events_delivered_total" "counter" "Events delivered to handlers." c.eventsDelivered, + metric "kiroku_hard_deletes_total" "counter" "Hard-delete transactions issued." c.hardDeletesIssued + ] subSection :: Map Text SubscriptionMetrics -> B.Builder subSection subs = - mconcat - [ help "kiroku_subscription_position" "Last-known global position per subscription." - , typ "kiroku_subscription_position" "gauge" - , Map.foldMapWithKey (\n sm -> labelled "kiroku_subscription_position" "subscription" n sm.lastKnownPosition) subs - , help "kiroku_subscription_lag" "Lag behind the global position per subscription (upper bound)." - , typ "kiroku_subscription_lag" "gauge" - , Map.foldMapWithKey (\n sm -> labelled "kiroku_subscription_lag" "subscription" n sm.lag) subs - , help "kiroku_subscription_db_errors_total" "Database errors per subscription." - , typ "kiroku_subscription_db_errors_total" "counter" - , Map.foldMapWithKey (\n sm -> labelled "kiroku_subscription_db_errors_total" "subscription" n sm.dbErrorCount) subs - ] + mconcat + [ help "kiroku_subscription_position" "Last-known global position per subscription.", + typ "kiroku_subscription_position" "gauge", + Map.foldMapWithKey (\n sm -> labelled "kiroku_subscription_position" "subscription" n sm.lastKnownPosition) subs, + help "kiroku_subscription_lag" "Lag behind the global position per subscription (upper bound).", + typ "kiroku_subscription_lag" "gauge", + Map.foldMapWithKey (\n sm -> labelled "kiroku_subscription_lag" "subscription" n sm.lag) subs, + help "kiroku_subscription_db_errors_total" "Database errors per subscription.", + typ "kiroku_subscription_db_errors_total" "counter", + Map.foldMapWithKey (\n sm -> labelled "kiroku_subscription_db_errors_total" "subscription" n sm.dbErrorCount) subs + ] -- | A single unlabelled metric: HELP, TYPE, and one sample (Int64-valued). metric :: Text -> Text -> Text -> Int64 -> B.Builder @@ -123,14 +123,14 @@ -- | A labelled sample line (Int64-valued). labelled :: Text -> Text -> Text -> Int64 -> B.Builder labelled n labelKey labelVal v = - name n - <> B.char8 '{' - <> text labelKey - <> "=\"" - <> text (escapeLabel labelVal) - <> "\"} " - <> B.int64Dec v - <> B.char8 '\n' + name n + <> B.char8 '{' + <> text labelKey + <> "=\"" + <> text (escapeLabel labelVal) + <> "\"} " + <> B.int64Dec v + <> B.char8 '\n' -- | A labelled sample line (Int-valued). labelledI :: Text -> Text -> Text -> Int -> B.Builder @@ -145,7 +145,7 @@ -- | Escape a Prometheus label value: backslash, double-quote, and newline. escapeLabel :: Text -> Text escapeLabel = T.concatMap $ \case - '\\' -> "\\\\" - '"' -> "\\\"" - '\n' -> "\\n" - ch -> T.singleton ch + '\\' -> "\\\\" + '"' -> "\\\"" + '\n' -> "\\n" + ch -> T.singleton ch diff --git a/src/Kiroku/Metrics/Server.hs b/src/Kiroku/Metrics/Server.hs --- a/src/Kiroku/Metrics/Server.hs +++ b/src/Kiroku/Metrics/Server.hs @@ -1,10 +1,9 @@ -{- | The shared inspection composition. Store-backed behavior enters through -provider closures; HTTP and WebSocket dispatch share a mount-relative path and -one outer CORS policy. /capabilities reports this wiring without store access. -Legacy starters retain their signatures. --} -module Kiroku.Metrics.Server ( - MetricsServer (..), +-- | The shared inspection composition. Store-backed behavior enters through +-- provider closures; HTTP and WebSocket dispatch share a mount-relative path and +-- one outer CORS policy. /capabilities reports this wiring without store access. +-- Legacy starters retain their signatures. +module Kiroku.Metrics.Server + ( MetricsServer (..), ServerProviders (..), defaultServerProviders, providerPresence, @@ -24,7 +23,8 @@ combinedApp, httpApp, stubWebSocketApp, -) where + ) +where import Control.Concurrent.Async (Async, asyncWithUnmask, cancel, race, wait, waitCatchSTM) import Control.Concurrent.STM (atomically, newEmptyTMVarIO, orElse, putTMVar, readTMVar) @@ -49,14 +49,14 @@ import Kiroku.Metrics.Config (MetricsServerConfig (..)) import Kiroku.Metrics.Cors (corsMiddleware) import Kiroku.Metrics.DeadLetters (DeadLetterProvider, deadLettersApp, deadLettersNotConfiguredApp, storeDeadLetters) -import Kiroku.Metrics.Health ( - DependencyCheck, +import Kiroku.Metrics.Health + ( DependencyCheck, LivenessStatus (..), ReadinessStatus (..), checkDetailedHealth, checkLiveness, checkReadiness, - ) + ) import Kiroku.Metrics.JSON (jsonApp, jsonResponse) import Kiroku.Metrics.Prometheus (prometheusApp) import Kiroku.Metrics.Subscriptions (SubscriptionStatusProvider, storeSubscriptionStatus, subscriptionsApp) @@ -65,69 +65,66 @@ -- | A running metrics server: the Warp thread and the port it bound. data MetricsServer = MetricsServer - { serverThread :: !(Async ()) - , serverPort :: !Int - } + { serverThread :: !(Async ()), + serverPort :: !Int + } -- | Optional data sources for the shared inspection application. data ServerProviders = ServerProviders - { webSocketServer :: !WS.ServerApp - , subscriptionStatus :: !(Maybe SubscriptionStatusProvider) - , checkpointInventory :: !(Maybe CheckpointInventoryProvider) - , storeBrowsing :: !(Maybe StoreBrowser) - -- ^ Backs the stream, category and event inspection routes. - , deadLetters :: !(Maybe DeadLetterProvider) - -- ^ Backs GET /subscriptions//dead-letters. - , webSocketChannels :: !WebSocketChannels - -- ^ Channels served by the opaque WebSocket app, declared for /capabilities. - } + { webSocketServer :: !WS.ServerApp, + subscriptionStatus :: !(Maybe SubscriptionStatusProvider), + checkpointInventory :: !(Maybe CheckpointInventoryProvider), + -- | Backs the stream, category and event inspection routes. + storeBrowsing :: !(Maybe StoreBrowser), + -- | Backs GET /subscriptions//dead-letters. + deadLetters :: !(Maybe DeadLetterProvider), + -- | Channels served by the opaque WebSocket app, declared for /capabilities. + webSocketChannels :: !WebSocketChannels + } -- | Reject upgrades and leave all optional providers unconfigured. defaultServerProviders :: ServerProviders defaultServerProviders = ServerProviders stubWebSocketApp Nothing Nothing Nothing Nothing noWebSocketChannels -{- | Build every store-backed provider, including the process-local live registry. -Bind this action first, then use 'withMetricsServerWithProviders'. --} +-- | Build every store-backed provider, including the process-local live registry. +-- Bind this action first, then use 'withMetricsServerWithProviders'. storeServerProviders :: MetricsServerConfig -> KirokuMetrics -> KirokuStore -> IO ServerProviders storeServerProviders cfg m store = do - wsState <- newWebSocketState cfg.wsMaxConnections - pure $ ServerProviders (websocketApp cfg m store wsState) (Just (storeSubscriptionStatus store)) (Just (storeCheckpointInventory store)) (Just (storeBrowser store)) (Just (storeDeadLetters store)) storeWebSocketChannels + wsState <- newWebSocketState cfg.wsMaxConnections + pure $ ServerProviders (websocketApp cfg m store wsState) (Just (storeSubscriptionStatus store)) (Just (storeCheckpointInventory store)) (Just (storeBrowser store)) (Just (storeDeadLetters store)) storeWebSocketChannels -{- | Return only after Warp is ready; bind/setup failures are rethrown. -Ephemeral sockets are explicitly closed on every exit, including cancellation. --} +-- | Return only after Warp is ready; bind/setup failures are rethrown. +-- Ephemeral sockets are explicitly closed on every exit, including cancellation. startMetricsServerWithProviders :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> ServerProviders -> IO MetricsServer startMetricsServerWithProviders cfg m deps providers = mask $ \restore -> do - ready <- newEmptyTMVarIO - let app = combinedAppWithProviders cfg m deps providers - settings port = Warp.setBeforeMainLoop (atomically $ putTMVar ready ()) $ Warp.setHost "*" $ Warp.setPort port Warp.defaultSettings - await thread port = do - result <- restore (atomically $ (Left <$> waitCatchSTM thread) `orElse` (Right <$> readTMVar ready)) `onException` cancel thread - case result of - Left (Left err) -> throwIO err - Left (Right ()) -> fail "Metrics server terminated before readiness." - Right () -> pure (MetricsServer thread port) - if cfg.port == 0 - then do - (port, sock) <- Warp.openFreePort - thread <- asyncWithUnmask (\unmask -> unmask (Warp.runSettingsSocket (settings port) sock app) `finally` Socket.close sock) `onException` Socket.close sock - await thread port - else do - thread <- asyncWithUnmask (\unmask -> unmask $ Warp.runSettings (settings cfg.port) app) - await thread cfg.port + ready <- newEmptyTMVarIO + let app = combinedAppWithProviders cfg m deps providers + settings port = Warp.setBeforeMainLoop (atomically $ putTMVar ready ()) $ Warp.setHost "*" $ Warp.setPort port Warp.defaultSettings + await thread port = do + result <- restore (atomically $ (Left <$> waitCatchSTM thread) `orElse` (Right <$> readTMVar ready)) `onException` cancel thread + case result of + Left (Left err) -> throwIO err + Left (Right ()) -> fail "Metrics server terminated before readiness." + Right () -> pure (MetricsServer thread port) + if cfg.port == 0 + then do + (port, sock) <- Warp.openFreePort + thread <- asyncWithUnmask (\unmask -> unmask (Warp.runSettingsSocket (settings port) sock app) `finally` Socket.close sock) `onException` Socket.close sock + await thread port + else do + thread <- asyncWithUnmask (\unmask -> unmask $ Warp.runSettings (settings cfg.port) app) + await thread cfg.port -{- | Supervise the callback and the server together, then release both. -Unexpected server termination cancels the callback and is rethrown to the owner. --} +-- | Supervise the callback and the server together, then release both. +-- Unexpected server termination cancels the callback and is rethrown to the owner. withMetricsServerWithProviders :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> ServerProviders -> (MetricsServer -> IO a) -> IO a withMetricsServerWithProviders cfg m deps providers action = - withRunningServer (startMetricsServerWithProviders cfg m deps providers) action + withRunningServer (startMetricsServerWithProviders cfg m deps providers) action withRunningServer :: IO MetricsServer -> (MetricsServer -> IO a) -> IO a withRunningServer acquire action = bracket acquire stopMetricsServer $ \server -> do - result <- race (wait server.serverThread) (action server) - either (\() -> fail "Metrics server terminated unexpectedly.") pure result + result <- race (wait server.serverThread) (action server) + either (\() -> fail "Metrics server terminated unexpectedly.") pure result -- | Start with the rejecting WebSocket stub and no optional providers. startMetricsServer :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> IO MetricsServer @@ -140,15 +137,14 @@ -- | Legacy binding of a WebSocket app and optional live status provider. startMetricsServerWith' :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> Maybe SubscriptionStatusProvider -> WS.ServerApp -> IO MetricsServer startMetricsServerWith' cfg m deps mProvider wsApp = - startMetricsServerWithProviders cfg m deps defaultServerProviders{webSocketServer = wsApp, subscriptionStatus = mProvider} + startMetricsServerWithProviders cfg m deps defaultServerProviders {webSocketServer = wsApp, subscriptionStatus = mProvider} -{- | Serve the real WebSocket and durable inventory; the legacy live route stays -unconfigured. New hosts wanting every provider use 'storeServerProviders'. --} +-- | Serve the real WebSocket and durable inventory; the legacy live route stays +-- unconfigured. New hosts wanting every provider use 'storeServerProviders'. startMetricsServerWithStore :: MetricsServerConfig -> KirokuMetrics -> KirokuStore -> [DependencyCheck] -> IO MetricsServer startMetricsServerWithStore cfg m store deps = do - providers <- storeServerProviders cfg m store - startMetricsServerWithProviders cfg m deps providers{subscriptionStatus = Nothing} + providers <- storeServerProviders cfg m store + startMetricsServerWithProviders cfg m deps providers {subscriptionStatus = Nothing} stopMetricsServer :: MetricsServer -> IO () stopMetricsServer server = cancel server.serverThread @@ -161,32 +157,31 @@ withMetricsServerSubscriptions :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> SubscriptionStatusProvider -> (MetricsServer -> IO a) -> IO a withMetricsServerSubscriptions cfg m deps provider = - withMetricsServerWithProviders cfg m deps defaultServerProviders{subscriptionStatus = Just provider} + withMetricsServerWithProviders cfg m deps defaultServerProviders {subscriptionStatus = Just provider} -- | Legacy composition binding. CORS is applied once by the general composition. combinedApp :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> Maybe SubscriptionStatusProvider -> WS.ServerApp -> Application combinedApp cfg m deps mProvider wsApp = - combinedAppWithProviders cfg m deps defaultServerProviders{webSocketServer = wsApp, subscriptionStatus = mProvider} + combinedAppWithProviders cfg m deps defaultServerProviders {webSocketServer = wsApp, subscriptionStatus = mProvider} -{- | Mountable composition. Respect the WebSocket switch before upgrade dispatch. -Normalize only the dispatch copy's raw path; keep its original query string. --} +-- | Mountable composition. Respect the WebSocket switch before upgrade dispatch. +-- Normalize only the dispatch copy's raw path; keep its original query string. combinedAppWithProviders :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> ServerProviders -> Application combinedAppWithProviders cfg m deps providers = corsMiddleware cfg.cors dispatch where http = httpAppWithProviders cfg m deps providers dispatch req respond - | cfg.enableWebSocket = - let relativePath = LBS.toStrict $ toLazyByteString $ encodePathSegments (pathInfo req) - in WaiWS.websocketsOr WS.defaultConnectionOptions providers.webSocketServer http (req{rawPathInfo = relativePath}) respond - | otherwise = http req respond + | cfg.enableWebSocket = + let relativePath = LBS.toStrict $ toLazyByteString $ encodePathSegments (pathInfo req) + in WaiWS.websocketsOr WS.defaultConnectionOptions providers.webSocketServer http (req {rawPathInfo = relativePath}) respond + | otherwise = http req respond stubWebSocketApp :: WS.ServerApp stubWebSocketApp pending = WS.rejectRequest pending "WebSocket endpoint not yet implemented" -- | Legacy unwrapped HTTP binding. httpApp :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> Maybe SubscriptionStatusProvider -> Application -httpApp cfg m deps mProvider = httpAppWithProviders cfg m deps defaultServerProviders{subscriptionStatus = mProvider} +httpApp cfg m deps mProvider = httpAppWithProviders cfg m deps defaultServerProviders {subscriptionStatus = mProvider} -- | Unwrapped HTTP router, matching paths relative to the host's mount. httpAppWithProviders :: MetricsServerConfig -> KirokuMetrics -> [DependencyCheck] -> ServerProviders -> Application @@ -194,57 +189,57 @@ where discovery = capabilitiesApp (capabilitiesFor cfg (providerPresence providers)) dispatch req respond = - case pathInfo req of - ["capabilities"] -> discovery req respond - ["metrics", "prometheus"] | cfg.enablePrometheus -> prometheusApp m req respond - ["metrics"] | cfg.enableJSON -> jsonApp m req respond - ["metrics", _] | cfg.enableJSON -> jsonApp m req respond - prefix : _ | prefix `elem` ["streams", "categories", "events"] -> browseRoute - ["subscription-checkpoints"] -> checkpointsRoute - ["subscriptions", _, "dead-letters"] -> deadLettersRoute - ["subscriptions"] -> subscriptionsRoute - ["subscriptions", _] -> subscriptionsRoute - ["health"] | cfg.enableJSON -> do - (readiness, snap) <- checkDetailedHealth cfg m deps - respond $ - jsonResponse - (statusFor readiness.ready) - (encode (object ["status" .= readiness, "metrics" .= snap])) - ["health", "live"] | cfg.enableJSON -> do - liveness <- checkLiveness cfg m - respond (jsonResponse (statusFor liveness.alive) (encode liveness)) - ["health", "ready"] | cfg.enableJSON -> do - readiness <- checkReadiness cfg m deps - respond (jsonResponse (statusFor readiness.ready) (encode readiness)) - ["ws"] - | cfg.enableWebSocket -> - respond $ - jsonResponse - status404 - (encode (object ["error" .= ("WebSocket endpoint - use ws:// protocol" :: Text)])) - _ -> - respond (jsonResponse status404 (encode (object ["error" .= ("Not found" :: Text)]))) + case pathInfo req of + ["capabilities"] -> discovery req respond + ["metrics", "prometheus"] | cfg.enablePrometheus -> prometheusApp m req respond + ["metrics"] | cfg.enableJSON -> jsonApp m req respond + ["metrics", _] | cfg.enableJSON -> jsonApp m req respond + prefix : _ | prefix `elem` ["streams", "categories", "events"] -> browseRoute + ["subscription-checkpoints"] -> checkpointsRoute + ["subscriptions", _, "dead-letters"] -> deadLettersRoute + ["subscriptions"] -> subscriptionsRoute + ["subscriptions", _] -> subscriptionsRoute + ["health"] | cfg.enableJSON -> do + (readiness, snap) <- checkDetailedHealth cfg m deps + respond $ + jsonResponse + (statusFor readiness.ready) + (encode (object ["status" .= readiness, "metrics" .= snap])) + ["health", "live"] | cfg.enableJSON -> do + liveness <- checkLiveness cfg m + respond (jsonResponse (statusFor liveness.alive) (encode liveness)) + ["health", "ready"] | cfg.enableJSON -> do + readiness <- checkReadiness cfg m deps + respond (jsonResponse (statusFor readiness.ready) (encode readiness)) + ["ws"] + | cfg.enableWebSocket -> + respond $ + jsonResponse + status404 + (encode (object ["error" .= ("WebSocket endpoint - use ws:// protocol" :: Text)])) + _ -> + respond (jsonResponse status404 (encode (object ["error" .= ("Not found" :: Text)]))) where statusFor ok = if ok then status200 else status503 deadLettersRoute = maybe deadLettersNotConfiguredApp deadLettersApp providers.deadLetters req respond browseRoute = maybe browseNotConfiguredApp browseApp providers.storeBrowsing req respond checkpointsRoute = case providers.checkpointInventory of - Just provider -> checkpointsApp provider req respond - Nothing -> checkpointsNotConfiguredApp req respond + Just provider -> checkpointsApp provider req respond + Nothing -> checkpointsNotConfiguredApp req respond subscriptionsRoute = case providers.subscriptionStatus of - Just provider -> subscriptionsApp provider req respond - Nothing -> - respond $ - jsonResponse - status404 - (encode (object ["error" .= ("subscription status not configured" :: Text)])) + Just provider -> subscriptionsApp provider req respond + Nothing -> + respond $ + jsonResponse + status404 + (encode (object ["error" .= ("subscription status not configured" :: Text)])) -- | Pure wiring summary; evaluating it never invokes a provider. providerPresence :: ServerProviders -> ProviderPresence providerPresence providers = - ProviderPresence - (isJust providers.subscriptionStatus) - (isJust providers.checkpointInventory) - (isJust providers.storeBrowsing) - (isJust providers.deadLetters) - providers.webSocketChannels + ProviderPresence + (isJust providers.subscriptionStatus) + (isJust providers.checkpointInventory) + (isJust providers.storeBrowsing) + (isJust providers.deadLetters) + providers.webSocketChannels diff --git a/src/Kiroku/Metrics/Standalone.hs b/src/Kiroku/Metrics/Standalone.hs --- a/src/Kiroku/Metrics/Standalone.hs +++ b/src/Kiroku/Metrics/Standalone.hs @@ -1,22 +1,31 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoFieldSelectors #-} -- | Open a store and serve its inspection surface without a Haskell host program. -module Kiroku.Metrics.Standalone ( - InspectOptions (..), +module Kiroku.Metrics.Standalone + ( InspectOptions (..), inspectOptionsParser, inspectParserInfo, InspectRuntime (..), resolveInspectOptions, InspectHooks (..), runInspect, + InspectFailure (..), + InspectBindError (..), + classifyInspectFailure, + renderInspectFailure, renderStartupBanner, -) where + ) +where import Control.Applicative (many, optional, (<|>)) import Control.Concurrent.STM (STM, TVar, atomically, newTVarIO, readTVar, writeTVar) +import Control.Exception (Exception, IOException, SomeException, catch, fromException, throwIO) +import Data.IORef (newIORef, readIORef, writeIORef) import Data.IntMap.Strict qualified as IntMap import Data.Text (Text) import Data.Text qualified as T +import Hasql.Pool qualified as Pool import Options.Applicative qualified as O import Kiroku.Metrics.Capabilities @@ -27,65 +36,68 @@ import Kiroku.Metrics.Health (postgresPing) import Kiroku.Metrics.Server import Kiroku.Store qualified as Store +import Kiroku.Store.Error (StoreError (..), mapGenericUsageError) +import Kiroku.Store.Notification (NotifierStartError (..)) import Kiroku.Store.Subscription.EventPublisher (EventPublisher (..), publisherPosition) -- No Show instances: a database URL can contain credentials. data InspectOptions = InspectOptions - { databaseUrl :: !(Maybe Text) - , schema :: !(Maybe Text) - , poolSize :: !(Maybe Int) - , port :: !(Maybe Int) - , corsOrigins :: ![Text] - , corsAllowCredentials :: !(Maybe Bool) - , wsMaxConnections :: !(Maybe Int) - } - deriving stock (Eq) + { databaseUrl :: !(Maybe Text), + schema :: !(Maybe Text), + poolSize :: !(Maybe Int), + port :: !(Maybe Int), + corsOrigins :: ![Text], + corsAllowCredentials :: !(Maybe Bool), + wsMaxConnections :: !(Maybe Int) + } + deriving stock (Eq) data InspectRuntime = InspectRuntime - { databaseUrl :: !Text - , schema :: !Text - , poolSize :: !Int - , port :: !Int - , cors :: !CorsPolicy - , wsMaxConnections :: !Int - } - deriving stock (Eq) + { databaseUrl :: !Text, + schema :: !Text, + poolSize :: !Int, + port :: !Int, + cors :: !CorsPolicy, + wsMaxConnections :: !Int + } + deriving stock (Eq) data InspectHooks = InspectHooks - { onListening :: !(Int -> Capabilities -> IO ()) - -- ^ Called once after successful binding, with the actual port and wiring. - , waitForShutdown :: !(IO ()) - } + { -- | Called once after successful binding, with the actual port and wiring. + onListening :: !(Int -> Capabilities -> IO ()), + waitForShutdown :: !(IO ()) + } inspectOptionsParser :: O.Parser InspectOptions inspectOptionsParser = - InspectOptions - <$> optional (textOption "database-url" "URL" "Database connection string (or DATABASE_URL)") - <*> optional (textOption "schema" "NAME" "Migrated schema (default kiroku)") - <*> optional (numberOption "pool-size" 1 intMaximum "Connection pool size (default 10)") - <*> optional (numberOption "port" 0 65535 "Listen port (default 9091; 0 selects a free port)") - <*> many (textOption "cors-origin" "ORIGIN" "Allowed HTTP(S) browser origin; repeatable") - <*> optional - ( O.flag' True (O.long "cors-allow-credentials" <> O.help "Allow credentials for explicit origins") - <|> O.flag' False (O.long "no-cors-allow-credentials" <> O.help "Disable credentials, overriding the environment") - ) - <*> optional (numberOption "ws-max-connections" 1 intMaximum "Maximum WebSocket connections (default 100)") + InspectOptions + <$> optional (textOption "database-url" "URL" "Database connection string (or DATABASE_URL)") + <*> optional (textOption "schema" "NAME" "Migrated schema (default kiroku)") + <*> optional (numberOption "pool-size" 1 intMaximum "Connection pool size (default 10)") + <*> optional (numberOption "port" 0 65535 "Listen port (default 9091, all interfaces; 0 selects a loopback-only free port)") + <*> many (textOption "cors-origin" "ORIGIN" "Allowed HTTP(S) browser origin; repeatable") + <*> optional + ( O.flag' True (O.long "cors-allow-credentials" <> O.help "Allow credentials for explicit origins") + <|> O.flag' False (O.long "no-cors-allow-credentials" <> O.help "Disable credentials, overriding the environment") + ) + <*> optional (numberOption "ws-max-connections" 1 intMaximum "Maximum WebSocket connections (default 100)") where textOption name metavar help = O.strOption (O.long name <> O.metavar metavar <> O.help help) numberOption name lower upper help = - O.option - (O.eitherReader (either (Left . T.unpack) Right . boundedDecimal lower upper . T.pack)) - (O.long name <> O.metavar "N" <> O.help help) + O.option + (O.eitherReader (either (Left . T.unpack) Right . boundedDecimal lower upper . T.pack)) + (O.long name <> O.metavar "N" <> O.help help) inspectParserInfo :: O.ParserInfo InspectOptions inspectParserInfo = - O.info - (inspectOptionsParser O.<**> O.helper) - ( O.failureCode 2 - <> O.fullDesc - <> O.header "kiroku-inspect - standalone inspection server" - <> O.progDesc "Serve the read-only inspection API from a migrated Kiroku database. Runs no subscriptions." - ) + O.info + (inspectOptionsParser O.<**> O.helper) + ( O.failureCode 2 + <> O.fullDesc + <> O.header "kiroku-inspect - standalone inspection server" + <> O.footer "First SIGINT/SIGTERM shuts down gracefully; a second signal forces immediate exit 130." + <> O.progDesc "Serve the read-only inspection API from a migrated Kiroku database. Runs no subscriptions." + ) intMaximum :: Integer intMaximum = toInteger (maxBound :: Int) @@ -93,76 +105,122 @@ -- Parse into Integer and stop growing at the upper bound, before narrowing to Int. boundedDecimal :: Integer -> Integer -> Text -> Either Text Int boundedDecimal lower upper value - | T.null value || not (T.all (\c -> c >= '0' && c <= '9') value) = Left "expected ASCII decimal digits" - | otherwise = do - n <- T.foldl' step (Right 0) value - if n < lower then Left "value is below the allowed range" else Right (fromInteger n) + | T.null value || not (T.all (\c -> c >= '0' && c <= '9') value) = Left "expected ASCII decimal digits" + | otherwise = do + n <- T.foldl' step (Right 0) value + if n < lower then Left "value is below the allowed range" else Right (fromInteger n) where step result c = do - n <- result - let next = n * 10 + toInteger (fromEnum c - fromEnum '0') - if next > upper then Left "value exceeds the allowed range" else Right next + n <- result + let next = n * 10 + toInteger (fromEnum c - fromEnum '0') + if next > upper then Left "value exceeds the allowed range" else Right next resolveInspectOptions :: [(String, String)] -> InspectOptions -> Either Text InspectRuntime resolveInspectOptions env opts = do - url <- maybe (Left "kiroku-inspect: no database; pass --database-url or set DATABASE_URL (a libpq URI such as postgresql://user@host/db)") Right (opts.databaseUrl <|> variable "DATABASE_URL") - nonempty "--database-url" url - let schemaName = maybe "kiroku" id (opts.schema <|> variable "KIROKU_INSPECT_SCHEMA") - nonempty "--schema" schemaName - pool <- number opts.poolSize "KIROKU_INSPECT_POOL_SIZE" 1 intMaximum (Store.defaultConnectionSettings url).poolSize - listenPort <- number opts.port "KIROKU_INSPECT_PORT" 0 65535 defaultConfig.port - maxConnections <- number opts.wsMaxConnections "KIROKU_INSPECT_WS_MAX_CONNECTIONS" 1 intMaximum defaultConfig.wsMaxConnections - credentials <- case opts.corsAllowCredentials of - Just b -> Right b - Nothing -> case variable "KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS" of - Nothing -> Right False - Just "true" -> Right True - Just "1" -> Right True - Just "false" -> Right False - Just "0" -> Right False - Just _ -> Left "kiroku-inspect: KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS must be true, false, 1 or 0" - let originTexts = if null opts.corsOrigins then maybe [] (map T.strip . T.splitOn ",") (variable "KIROKU_INSPECT_CORS_ORIGINS") else opts.corsOrigins - origins <- - traverse - ( \origin -> case allowedOrigin origin of - Right o -> Right o - Left WildcardOrigin -> Left "kiroku-inspect: wildcard '*' is not an allowed CORS origin" - Left _ -> Left "kiroku-inspect: invalid CORS origin; use an explicit HTTP(S) origin" - ) - originTexts - let policy = if null origins then corsDisabled else (corsAllowOrigins origins){allowCredentials = credentials} - pure (InspectRuntime url schemaName pool listenPort policy maxConnections) + url <- maybe (Left "kiroku-inspect: no database; pass --database-url or set DATABASE_URL (a libpq URI such as postgresql://user@host/db)") Right (opts.databaseUrl <|> variable "DATABASE_URL") + nonempty "--database-url" url + let schemaName = maybe "kiroku" id (opts.schema <|> variable "KIROKU_INSPECT_SCHEMA") + nonempty "--schema" schemaName + pool <- number opts.poolSize "KIROKU_INSPECT_POOL_SIZE" 1 intMaximum (Store.defaultConnectionSettings url).poolSize + listenPort <- number opts.port "KIROKU_INSPECT_PORT" 0 65535 defaultConfig.port + maxConnections <- number opts.wsMaxConnections "KIROKU_INSPECT_WS_MAX_CONNECTIONS" 1 intMaximum defaultConfig.wsMaxConnections + credentials <- case opts.corsAllowCredentials of + Just b -> Right b + Nothing -> case variable "KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS" of + Nothing -> Right False + Just "true" -> Right True + Just "1" -> Right True + Just "false" -> Right False + Just "0" -> Right False + Just _ -> Left "kiroku-inspect: KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS must be true, false, 1 or 0" + let originTexts = if null opts.corsOrigins then maybe [] (map T.strip . T.splitOn ",") (variable "KIROKU_INSPECT_CORS_ORIGINS") else opts.corsOrigins + origins <- + traverse + ( \origin -> case allowedOrigin origin of + Right o -> Right o + Left WildcardOrigin -> Left "kiroku-inspect: wildcard '*' is not an allowed CORS origin" + Left _ -> Left "kiroku-inspect: invalid CORS origin; use an explicit HTTP(S) origin" + ) + originTexts + let policy = if null origins then corsDisabled else (corsAllowOrigins origins) {allowCredentials = credentials} + pure (InspectRuntime url schemaName pool listenPort policy maxConnections) where variable name = case T.pack <$> lookup name env of - Just value | not (T.null value) -> Just value - _ -> Nothing + Just value | not (T.null value) -> Just value + _ -> Nothing nonempty name value = if T.null (T.strip value) then Left ("kiroku-inspect: " <> name <> " must not be empty") else Right () number explicit name lower upper fallback = case explicit of - Just value | toInteger value >= lower && toInteger value <= upper -> Right value - Just _ -> Left ("kiroku-inspect: " <> T.pack name <> " flag is outside the allowed range") - Nothing -> case variable name of - Nothing -> Right fallback - Just value -> either (\message -> Left ("kiroku-inspect: " <> T.pack name <> ": " <> message)) Right (boundedDecimal lower upper value) + Just value | toInteger value >= lower && toInteger value <= upper -> Right value + Just _ -> Left ("kiroku-inspect: " <> T.pack name <> " flag is outside the allowed range") + Nothing -> case variable name of + Nothing -> Right fallback + Just value -> either (\message -> Left ("kiroku-inspect: " <> T.pack name <> ": " <> message)) Right (boundedDecimal lower upper value) runInspect :: InspectHooks -> InspectRuntime -> IO () runInspect hooks rt = do - storeVar <- newTVarIO Nothing - metrics <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - let settings = - (Store.defaultConnectionSettings rt.databaseUrl) - { Store.schema = rt.schema - , Store.poolSize = rt.poolSize - , Store.eventHandler = Just (metricsEventHandler metrics Nothing) - , Store.observationHandler = Just (metricsObservationHandler metrics Nothing) - } - cfg = defaultConfig{Config.port = rt.port, Config.cors = rt.cors, Config.wsMaxConnections = rt.wsMaxConnections} - Store.withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - providers <- storeServerProviders cfg metrics store - withMetricsServerWithProviders cfg metrics [postgresPing store] providers $ \server -> do - hooks.onListening server.serverPort (capabilitiesFor cfg (providerPresence providers)) - hooks.waitForShutdown + storeVar <- newTVarIO Nothing + metrics <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + let settings = + (Store.defaultConnectionSettings rt.databaseUrl) + { Store.schema = rt.schema, + Store.poolSize = rt.poolSize, + Store.eventHandler = Just (metricsEventHandler metrics Nothing), + Store.observationHandler = Just (metricsObservationHandler metrics Nothing) + } + cfg = defaultConfig {Config.port = rt.port, Config.cors = rt.cors, Config.wsMaxConnections = rt.wsMaxConnections} + Store.withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + providers <- storeServerProviders cfg metrics store + listening <- newIORef False + let serve = withMetricsServerWithProviders cfg metrics [postgresPing store] providers $ \server -> do + writeIORef listening True + hooks.onListening server.serverPort (capabilitiesFor cfg (providerPresence providers)) + hooks.waitForShutdown + serve `catch` \err -> do + started <- readIORef listening + if started then throwIO (err :: IOException) else throwIO (InspectBindError err) +-- | Only listener setup IO failures carry this marker. Store acquisition and +-- user hooks remain outside that boundary; asynchronous exceptions pass through. +newtype InspectBindError = InspectBindError IOException + deriving stock (Show) + deriving anyclass (Exception) + +-- | Sanitized diagnostic classes, independent of driver messages and SQL text. +data InspectFailure = BindFailure | DatabaseFailure | SchemaFailure | OtherFailure + deriving stock (Eq, Show) + +classifyInspectFailure :: SomeException -> InspectFailure +classifyInspectFailure err + | Just (_ :: InspectBindError) <- fromException err = BindFailure + | Just notifier <- fromException err = case notifier of + NotifierConnectError _ -> DatabaseFailure + NotifierListenError nested -> case fromException nested :: Maybe Pool.UsageError of + Just usage -> classifyStoreFailure (mapGenericUsageError usage) + Nothing -> maybe DatabaseFailure classifyStoreFailure (fromException nested) + | Just usage <- fromException err = classifyStoreFailure (mapGenericUsageError usage) + | Just storeError <- fromException err = classifyStoreFailure storeError + | otherwise = OtherFailure + +classifyStoreFailure :: StoreError -> InspectFailure +classifyStoreFailure = \case + UnexpectedServerError code _ | code == "42P01" || code == "3F000" -> SchemaFailure + UnexpectedServerError _ _ -> DatabaseFailure + ConnectionError _ -> DatabaseFailure + ConnectionLost _ -> DatabaseFailure + PoolAcquisitionTimeout -> DatabaseFailure + TransientTransactionFailure _ _ -> DatabaseFailure + _ -> OtherFailure + +renderInspectFailure :: InspectFailure -> Text +renderInspectFailure failure = "kiroku-inspect: " <> label <> " failure (details redacted)" + where + label = case failure of + BindFailure -> "bind" + DatabaseFailure -> "database" + SchemaFailure -> "schema" + OtherFailure -> "other" + readPosition :: TVar (Maybe Store.KirokuStore) -> STM Store.GlobalPosition readPosition storeVar = readTVar storeVar >>= maybe (pure (Store.GlobalPosition 0)) (publisherPosition . (.publisher)) @@ -172,21 +230,21 @@ -- | Never includes the database URL. The port is the actual bound port. renderStartupBanner :: InspectRuntime -> Int -> Capabilities -> [Text] renderStartupBanner rt boundPort caps = - [ "kiroku-inspect: connected to schema " <> T.pack (show rt.schema) <> "; listening on port " <> T.pack (show boundPort) - , "kiroku-inspect: routes browse=" - <> enabled caps.routes.browse - <> " subscriptions_checkpoints=" - <> enabled caps.routes.subscriptionsCheckpoints - <> " dead_letters=" - <> enabled caps.routes.deadLetters - <> " subscriptions_live=" - <> enabled caps.routes.subscriptionsLive - <> " websocket_events=" - <> enabled caps.routes.websocketEvents - <> " cors=" - <> enabled caps.corsIsEnabled - , "kiroku-inspect: this process runs no subscriptions; /subscriptions, /metrics, and /health reflect only this process" - ] + [ "kiroku-inspect: connected to schema " <> T.pack (show rt.schema) <> "; listening on port " <> T.pack (show boundPort), + "kiroku-inspect: routes browse=" + <> enabled caps.routes.browse + <> " subscriptions_checkpoints=" + <> enabled caps.routes.subscriptionsCheckpoints + <> " dead_letters=" + <> enabled caps.routes.deadLetters + <> " subscriptions_live=" + <> enabled caps.routes.subscriptionsLive + <> " websocket_events=" + <> enabled caps.routes.websocketEvents + <> " cors=" + <> enabled caps.corsIsEnabled, + "kiroku-inspect: this process runs no subscriptions; /subscriptions, /metrics, and /health reflect only this process" + ] where enabled True = "on" enabled False = "off" diff --git a/src/Kiroku/Metrics/Subscriptions.hs b/src/Kiroku/Metrics/Subscriptions.hs --- a/src/Kiroku/Metrics/Subscriptions.hs +++ b/src/Kiroku/Metrics/Subscriptions.hs @@ -1,22 +1,22 @@ -{- | The @GET /subscriptions@ HTTP endpoint (EP-5 / IP-5). - -Serves a worker's __live subscription registry__ as JSON — each running -subscription's name, consumer-group member, current FSM phase, and current global -cursor. The data comes from a caller-supplied 'SubscriptionStatusProvider' closure -(the server stays store-agnostic, exactly as EP-2 keeps 'KirokuStore' out of its -signature). The canonical provider, 'storeSubscriptionStatus', reads the live -registry through the public 'Kiroku.Store.Subscription.subscriptionStates'. - -The wire shape is the CLI's 'SubscriptionStatusRow' JSON (a JSON array of -@{subscription, member, phase, global_position}@), reused via a @build-depends@ on -@kiroku-cli@ so the server encoder and the CLI remote-client decoder share one -codec — the IP-5 contract. --} -module Kiroku.Metrics.Subscriptions ( - SubscriptionStatusProvider, +-- | The @GET /subscriptions@ HTTP endpoint (EP-5 / IP-5). +-- +-- Serves a worker's __live subscription registry__ as JSON — each running +-- subscription's name, consumer-group member, current FSM phase, and current global +-- cursor. The data comes from a caller-supplied 'SubscriptionStatusProvider' closure +-- (the server stays store-agnostic, exactly as EP-2 keeps 'KirokuStore' out of its +-- signature). The canonical provider, 'storeSubscriptionStatus', reads the live +-- registry through the public 'Kiroku.Store.Subscription.subscriptionStates'. +-- +-- The wire shape is the CLI's 'SubscriptionStatusRow' JSON (a JSON array of +-- @{subscription, member, phase, global_position}@), reused via a @build-depends@ on +-- @kiroku-cli@ so the server encoder and the CLI remote-client decoder share one +-- codec — the IP-5 contract. +module Kiroku.Metrics.Subscriptions + ( SubscriptionStatusProvider, storeSubscriptionStatus, subscriptionsApp, -) where + ) +where import Data.Aeson (encode, object, (.=)) import Data.Text (Text) @@ -28,34 +28,31 @@ import Kiroku.Store (KirokuStore) import Kiroku.Store.Subscription (subscriptionStates) -{- | A closure the caller supplies; it reads the live subscription registry on -demand and returns the rows to serve. --} +-- | A closure the caller supplies; it reads the live subscription registry on +-- demand and returns the rows to serve. type SubscriptionStatusProvider = IO [SubscriptionStatusRow] -{- | The canonical provider, built by a caller who owns the 'KirokuStore': -reads the live registry through 'subscriptionStates' and maps it to rows. --} +-- | The canonical provider, built by a caller who owns the 'KirokuStore': +-- reads the live registry through 'subscriptionStates' and maps it to rows. storeSubscriptionStatus :: KirokuStore -> SubscriptionStatusProvider storeSubscriptionStatus store = subscriptionStatusRows <$> subscriptionStates store -{- | WAI app for the subscription-status endpoint. Routes: - - * @GET /subscriptions@ — 200, JSON array of all rows. - * @GET /subscriptions/\@ — 200, JSON array of rows for that name - (possibly empty). - -Any other path returns a 404 with body @{"error":"Not found"}@. This app is mounted by -'Kiroku.Metrics.Server.httpApp' only when a provider is configured. --} +-- | WAI app for the subscription-status endpoint. Routes: +-- +-- * @GET /subscriptions@ — 200, JSON array of all rows. +-- * @GET /subscriptions/\@ — 200, JSON array of rows for that name +-- (possibly empty). +-- +-- Any other path returns a 404 with body @{"error":"Not found"}@. This app is mounted by +-- 'Kiroku.Metrics.Server.httpApp' only when a provider is configured. subscriptionsApp :: SubscriptionStatusProvider -> Application subscriptionsApp provider req respond = - case pathInfo req of - ["subscriptions"] -> do - rows <- provider - respond (jsonResponse status200 (encode rows)) - ["subscriptions", name] -> do - rows <- provider - let filtered = filter (\row -> row.subscription == name) rows - respond (jsonResponse status200 (encode filtered)) - _ -> respond (jsonResponse status404 (encode (object ["error" .= ("Not found" :: Text)]))) + case pathInfo req of + ["subscriptions"] -> do + rows <- provider + respond (jsonResponse status200 (encode rows)) + ["subscriptions", name] -> do + rows <- provider + let filtered = filter (\row -> row.subscription == name) rows + respond (jsonResponse status200 (encode filtered)) + _ -> respond (jsonResponse status404 (encode (object ["error" .= ("Not found" :: Text)]))) diff --git a/src/Kiroku/Metrics/Types.hs b/src/Kiroku/Metrics/Types.hs --- a/src/Kiroku/Metrics/Types.hs +++ b/src/Kiroku/Metrics/Types.hs @@ -1,30 +1,30 @@ -{- | Immutable, JSON-encodable snapshot of a running Kiroku store's operational -metrics. - -A 'MetricsSnapshot' is produced by -'Kiroku.Metrics.Collector.snapshotMetrics' and is the single source of truth -every endpoint renders. It carries three parts: - -* 'StoreGauges' — point-in-time gauges read from the live store handle at - snapshot time: the gap-free global position (which doubles as the total - number of events appended store-wide and the high-water mark), the active - subscriber count, and pool connection gauges/counters. -* 'LifecycleCounters' — monotonic counters accumulated from the store's - 'Kiroku.Store.Observability.KirokuEvent' callback stream. -* a per-subscription map ('SubscriptionMetrics') keyed by subscription name, - carrying each subscription's last-known position, derived lag, database-error - count, and last stop reason. - -The 'ToJSON' instances are written by hand (not derived) so the wire shape is -stable and documented for downstream consumers (EP-2's JSON/Prometheus -renderers and EP-4's user guide). --} -module Kiroku.Metrics.Types ( - MetricsSnapshot (..), +-- | Immutable, JSON-encodable snapshot of a running Kiroku store's operational +-- metrics. +-- +-- A 'MetricsSnapshot' is produced by +-- 'Kiroku.Metrics.Collector.snapshotMetrics' and is the single source of truth +-- every endpoint renders. It carries three parts: +-- +-- * 'StoreGauges' — point-in-time gauges read from the live store handle at +-- snapshot time: the gap-free global position (which doubles as the total +-- number of events appended store-wide and the high-water mark), the active +-- subscriber count, and pool connection gauges/counters. +-- * 'LifecycleCounters' — monotonic counters accumulated from the store's +-- 'Kiroku.Store.Observability.KirokuEvent' callback stream. +-- * a per-subscription map ('SubscriptionMetrics') keyed by subscription name, +-- carrying each subscription's last-known position, derived lag, database-error +-- count, and last stop reason. +-- +-- The 'ToJSON' instances are written by hand (not derived) so the wire shape is +-- stable and documented for downstream consumers (EP-2's JSON/Prometheus +-- renderers and EP-4's user guide). +module Kiroku.Metrics.Types + ( MetricsSnapshot (..), StoreGauges (..), LifecycleCounters (..), SubscriptionMetrics (..), -) where + ) +where import Data.Aeson (ToJSON (..), object, (.=)) import Data.Int (Int64) @@ -33,133 +33,132 @@ -- | A coherent point-in-time view of the store's metrics. data MetricsSnapshot = MetricsSnapshot - { store :: !StoreGauges - , counters :: !LifecycleCounters - , subscriptions :: !(Map Text SubscriptionMetrics) - -- ^ Keyed by 'Kiroku.Store.Subscription.Types.SubscriptionName' text. - } - deriving stock (Eq, Show) + { store :: !StoreGauges, + counters :: !LifecycleCounters, + -- | Keyed by 'Kiroku.Store.Subscription.Types.SubscriptionName' text. + subscriptions :: !(Map Text SubscriptionMetrics) + } + deriving stock (Eq, Show) -- | Gauges read from the live store handle at snapshot time. data StoreGauges = StoreGauges - { globalPosition :: !Int64 - -- ^ Total events appended store-wide (gap-free) == high-water mark. - , activeSubscribers :: !Int - , poolConnecting :: !Int - , poolReady :: !Int - , poolInUse :: !Int - , poolEstablishedTotal :: !Int64 - , poolTerminatedTotal :: !Int64 - } - deriving stock (Eq, Show) - -{- | Monotonic counters accumulated from the 'KirokuEvent' callback stream. + { -- | Total events appended store-wide (gap-free) == high-water mark. + globalPosition :: !Int64, + activeSubscribers :: !Int, + poolConnecting :: !Int, + poolReady :: !Int, + poolInUse :: !Int, + poolEstablishedTotal :: !Int64, + poolTerminatedTotal :: !Int64 + } + deriving stock (Eq, Show) -The constructor set the store emits is richer than counters here name one-to-one: -subscription lifecycle events ('Started', 'CaughtUp', 'Paused', 'Resumed', -'Reconnecting', 'Retrying', 'DeadLettered', 'Stopped' by reason), per-batch -delivery, live fetches, per-phase database errors, notifier reconnects, -publisher pool and loop errors, and hard deletes. --} +-- | Monotonic counters accumulated from the 'KirokuEvent' callback stream. +-- +-- The constructor set the store emits is richer than counters here name one-to-one: +-- subscription lifecycle events ('Started', 'CaughtUp', 'Paused', 'Resumed', +-- 'Reconnecting', 'Retrying', 'DeadLettered', 'Stopped' by reason), per-batch +-- delivery, live fetches, per-phase database errors, notifier reconnects, +-- publisher pool and loop errors, and hard deletes. data LifecycleCounters = LifecycleCounters - { notifierReconnecting :: !Int64 - , notifierReconnected :: !Int64 - , publisherPoolErrors :: !Int64 - , publisherLoopErrors :: !Int64 - , publisherDecodeFailures :: !Int64 - , subscriptionHandlerStalls :: !Int64 - , subscriptionDbErrorsLoad :: !Int64 - , subscriptionDbErrorsFetch :: !Int64 - , subscriptionDbErrorsSave :: !Int64 - , subscriptionsStarted :: !Int64 - , subscriptionsCaughtUp :: !Int64 - , subscriptionsPaused :: !Int64 - , subscriptionsResumed :: !Int64 - , subscriptionsReconnecting :: !Int64 - , subscriptionsRetrying :: !Int64 - , subscriptionsDeadLettered :: !Int64 - , subscriptionsStoppedHandler :: !Int64 - , subscriptionsStoppedCancelled :: !Int64 - , subscriptionsStoppedOverflow :: !Int64 - , subscriptionsStoppedCrashed :: !Int64 - , subscriptionsStoppedUndecodable :: !Int64 - , liveFetches :: !Int64 - -- ^ Count of live-mode DB fetches ('KirokuEventSubscriptionFetched'). - , batchesDelivered :: !Int64 - -- ^ Count of non-empty batches delivered ('KirokuEventSubscriptionDelivered'). - , eventsDelivered :: !Int64 - -- ^ Sum of batch row counts across all deliveries. - , hardDeletesIssued :: !Int64 - } - deriving stock (Eq, Show) + { notifierReconnecting :: !Int64, + notifierReconnected :: !Int64, + publisherPoolErrors :: !Int64, + publisherLoopErrors :: !Int64, + publisherDecodeFailures :: !Int64, + subscriptionHandlerStalls :: !Int64, + subscriptionDbErrorsLoad :: !Int64, + subscriptionDbErrorsFetch :: !Int64, + subscriptionDbErrorsSave :: !Int64, + subscriptionsStarted :: !Int64, + subscriptionsCaughtUp :: !Int64, + subscriptionsPaused :: !Int64, + subscriptionsResumed :: !Int64, + subscriptionsReconnecting :: !Int64, + subscriptionsRetrying :: !Int64, + subscriptionsDeadLettered :: !Int64, + subscriptionsStoppedHandler :: !Int64, + subscriptionsStoppedCancelled :: !Int64, + subscriptionsStoppedOverflow :: !Int64, + subscriptionsStoppedCrashed :: !Int64, + subscriptionsStoppedUndecodable :: !Int64, + -- | Count of live-mode DB fetches ('KirokuEventSubscriptionFetched'). + liveFetches :: !Int64, + -- | Count of non-empty batches delivered ('KirokuEventSubscriptionDelivered'). + batchesDelivered :: !Int64, + -- | Sum of batch row counts across all deliveries. + eventsDelivered :: !Int64, + hardDeletesIssued :: !Int64 + } + deriving stock (Eq, Show) -- | Per-subscription accumulated metrics. data SubscriptionMetrics = SubscriptionMetrics - { lastKnownPosition :: !Int64 - -- ^ Most recent position seen at a lifecycle event (lower bound on true position). - , lag :: !Int64 - -- ^ @max 0 (globalPosition - lastKnownPosition)@ (upper bound on true lag). - , dbErrorCount :: !Int64 - , lastStopReason :: !(Maybe Text) - -- ^ @"handler" | "cancelled" | "overflow" | "crashed"@. - } - deriving stock (Eq, Show) + { -- | Most recent position seen at a lifecycle event (lower bound on true position). + lastKnownPosition :: !Int64, + -- | @max 0 (globalPosition - lastKnownPosition)@ (upper bound on true lag). + lag :: !Int64, + dbErrorCount :: !Int64, + -- | @"handler" | "cancelled" | "overflow" | "crashed"@. + lastStopReason :: !(Maybe Text) + } + deriving stock (Eq, Show) instance ToJSON MetricsSnapshot where - toJSON s = - object - [ "store" .= s.store - , "counters" .= s.counters - , "subscriptions" .= s.subscriptions - ] + toJSON s = + object + [ "store" .= s.store, + "counters" .= s.counters, + "subscriptions" .= s.subscriptions + ] instance ToJSON StoreGauges where - toJSON g = - object - [ "global_position" .= g.globalPosition - , "active_subscribers" .= g.activeSubscribers - , "pool_connecting" .= g.poolConnecting - , "pool_ready" .= g.poolReady - , "pool_in_use" .= g.poolInUse - , "pool_established_total" .= g.poolEstablishedTotal - , "pool_terminated_total" .= g.poolTerminatedTotal - ] + toJSON g = + object + [ "global_position" .= g.globalPosition, + "active_subscribers" .= g.activeSubscribers, + "pool_connecting" .= g.poolConnecting, + "pool_ready" .= g.poolReady, + "pool_in_use" .= g.poolInUse, + "pool_established_total" .= g.poolEstablishedTotal, + "pool_terminated_total" .= g.poolTerminatedTotal + ] instance ToJSON LifecycleCounters where - toJSON c = - object - [ "notifier_reconnecting" .= c.notifierReconnecting - , "notifier_reconnected" .= c.notifierReconnected - , "publisher_pool_errors" .= c.publisherPoolErrors - , "publisher_loop_errors" .= c.publisherLoopErrors - , "publisher_decode_failures" .= c.publisherDecodeFailures - , "subscription_handler_stalls" .= c.subscriptionHandlerStalls - , "subscription_db_errors_load" .= c.subscriptionDbErrorsLoad - , "subscription_db_errors_fetch" .= c.subscriptionDbErrorsFetch - , "subscription_db_errors_save" .= c.subscriptionDbErrorsSave - , "subscriptions_started" .= c.subscriptionsStarted - , "subscriptions_caught_up" .= c.subscriptionsCaughtUp - , "subscriptions_paused" .= c.subscriptionsPaused - , "subscriptions_resumed" .= c.subscriptionsResumed - , "subscriptions_reconnecting" .= c.subscriptionsReconnecting - , "subscriptions_retrying" .= c.subscriptionsRetrying - , "subscriptions_dead_lettered" .= c.subscriptionsDeadLettered - , "subscriptions_stopped_handler" .= c.subscriptionsStoppedHandler - , "subscriptions_stopped_cancelled" .= c.subscriptionsStoppedCancelled - , "subscriptions_stopped_overflow" .= c.subscriptionsStoppedOverflow - , "subscriptions_stopped_crashed" .= c.subscriptionsStoppedCrashed - , "subscriptions_stopped_undecodable" .= c.subscriptionsStoppedUndecodable - , "live_fetches" .= c.liveFetches - , "batches_delivered" .= c.batchesDelivered - , "events_delivered" .= c.eventsDelivered - , "hard_deletes_issued" .= c.hardDeletesIssued - ] + toJSON c = + object + [ "notifier_reconnecting" .= c.notifierReconnecting, + "notifier_reconnected" .= c.notifierReconnected, + "publisher_pool_errors" .= c.publisherPoolErrors, + "publisher_loop_errors" .= c.publisherLoopErrors, + "publisher_decode_failures" .= c.publisherDecodeFailures, + "subscription_handler_stalls" .= c.subscriptionHandlerStalls, + "subscription_db_errors_load" .= c.subscriptionDbErrorsLoad, + "subscription_db_errors_fetch" .= c.subscriptionDbErrorsFetch, + "subscription_db_errors_save" .= c.subscriptionDbErrorsSave, + "subscriptions_started" .= c.subscriptionsStarted, + "subscriptions_caught_up" .= c.subscriptionsCaughtUp, + "subscriptions_paused" .= c.subscriptionsPaused, + "subscriptions_resumed" .= c.subscriptionsResumed, + "subscriptions_reconnecting" .= c.subscriptionsReconnecting, + "subscriptions_retrying" .= c.subscriptionsRetrying, + "subscriptions_dead_lettered" .= c.subscriptionsDeadLettered, + "subscriptions_stopped_handler" .= c.subscriptionsStoppedHandler, + "subscriptions_stopped_cancelled" .= c.subscriptionsStoppedCancelled, + "subscriptions_stopped_overflow" .= c.subscriptionsStoppedOverflow, + "subscriptions_stopped_crashed" .= c.subscriptionsStoppedCrashed, + "subscriptions_stopped_undecodable" .= c.subscriptionsStoppedUndecodable, + "live_fetches" .= c.liveFetches, + "batches_delivered" .= c.batchesDelivered, + "events_delivered" .= c.eventsDelivered, + "hard_deletes_issued" .= c.hardDeletesIssued + ] instance ToJSON SubscriptionMetrics where - toJSON m = - object - [ "last_known_position" .= m.lastKnownPosition - , "lag" .= m.lag - , "db_error_count" .= m.dbErrorCount - , "last_stop_reason" .= m.lastStopReason - ] + toJSON m = + object + [ "last_known_position" .= m.lastKnownPosition, + "lag" .= m.lag, + "db_error_count" .= m.dbErrorCount, + "last_stop_reason" .= m.lastStopReason + ] diff --git a/src/Kiroku/Metrics/WebSocket.hs b/src/Kiroku/Metrics/WebSocket.hs --- a/src/Kiroku/Metrics/WebSocket.hs +++ b/src/Kiroku/Metrics/WebSocket.hs @@ -1,31 +1,30 @@ {-# LANGUAGE ScopedTypeVariables #-} -{- | The WebSocket endpoint for the Kiroku metrics server. - -Fills the IP-3 seam EP-2 left stubbed ('Kiroku.Metrics.Server.stubWebSocketApp') -with a real 'WS.ServerApp' that dispatches on the request path: - - * @\/ws\/metrics@ — the /metrics channel/: a 'MetricsSnapshot' on connect, - then a fresh snapshot every @wsPushIntervalUs@ microseconds; @ping@ → @pong@. - * @\/ws\/events@ — the /event channel/: after a @subscribe_events@ message, a - JSON message per appended 'RecordedEvent' in global-position order, live. - Optionally replays history from a chosen @from_position@ and/or restricts to - a single @category@. - -The event tail is built on the /public/ 'EventPublisher' broadcast -('subscribePublisher') for live "from-now" delivery and the public effectful -reads ('readAllForward' / 'readCategory' via 'runStoreIO') for replay and -category filtering. It creates /no persistent subscription/ and writes nothing to -the @subscriptions@ checkpoint table — transient watchers leave no trace. See the -plan's Decision Log. - -This module owns IP-4: the 'ClientMessage' / 'ServerMessage' protocol and the -explicit 'recordedEventToJSON' encoder (an orphan-free function, not a @ToJSON@ -instance — 'RecordedEvent' has none and @kiroku-store@ keeps its @Types@ module -instance-light). --} -module Kiroku.Metrics.WebSocket ( - -- * Protocol +-- | The WebSocket endpoint for the Kiroku metrics server. +-- +-- Fills the IP-3 seam EP-2 left stubbed ('Kiroku.Metrics.Server.stubWebSocketApp') +-- with a real 'WS.ServerApp' that dispatches on the request path: +-- +-- * @\/ws\/metrics@ — the /metrics channel/: a 'MetricsSnapshot' on connect, +-- then a fresh snapshot every @wsPushIntervalUs@ microseconds; @ping@ → @pong@. +-- * @\/ws\/events@ — the /event channel/: after a @subscribe_events@ message, a +-- JSON message per appended 'RecordedEvent' in global-position order, live. +-- Optionally replays history from a chosen @from_position@ and/or restricts to +-- a single @category@. +-- +-- The event tail is built on the /public/ 'EventPublisher' broadcast +-- ('subscribePublisher') for live "from-now" delivery and the public effectful +-- reads ('readAllForward' / 'readCategory' via 'runStoreIO') for replay and +-- category filtering. It creates /no persistent subscription/ and writes nothing to +-- the @subscriptions@ checkpoint table — transient watchers leave no trace. See the +-- plan's Decision Log. +-- +-- This module owns IP-4: the 'ClientMessage' / 'ServerMessage' protocol and the +-- explicit 'recordedEventToJSON' encoder (an orphan-free function, not a @ToJSON@ +-- instance — 'RecordedEvent' has none and @kiroku-store@ keeps its @Types@ module +-- instance-light). +module Kiroku.Metrics.WebSocket + ( -- * Protocol ClientMessage (..), ServerMessage (..), recordedEventToJSON, @@ -50,12 +49,13 @@ -- * The WebSocket application (the IP-3 seam) websocketApp, -) where + ) +where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (asyncWithUnmask, link, uninterruptibleCancel) -import Control.Concurrent.STM ( - STM, +import Control.Concurrent.STM + ( STM, TVar, atomically, check, @@ -64,11 +64,11 @@ readTBQueue, readTVar, writeTVar, - ) + ) import Control.Exception (bracket, catch, finally, mask, mask_) import Control.Monad (forever) -import Data.Aeson ( - FromJSON (..), +import Data.Aeson + ( FromJSON (..), ToJSON (..), Value (..), eitherDecode', @@ -78,7 +78,7 @@ (.:), (.:?), (.=), - ) + ) import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS @@ -100,8 +100,8 @@ import Kiroku.Metrics.Collector (KirokuMetrics, snapshotMetrics) import Kiroku.Metrics.Config (MetricsServerConfig (..)) import Kiroku.Metrics.Types (MetricsSnapshot) -import Kiroku.Store ( - CategoryName (..), +import Kiroku.Store + ( CategoryName (..), GlobalPosition (..), KirokuStore (..), RecordedEvent (..), @@ -109,90 +109,87 @@ readAllForward, readCategory, runStoreIO, - ) + ) import Kiroku.Store.Settings (DecodedBatch (..), DecodedEvent (..), decodedEventRecorded) -import Kiroku.Store.Subscription.EventPublisher ( - PublisherSubscription (..), +import Kiroku.Store.Subscription.EventPublisher + ( PublisherSubscription (..), SubscriberStatus (..), publisherPosition, subscribePublisherWith, - ) + ) import Kiroku.Store.Subscription.Types (OverflowPolicy (..)) -import Kiroku.Store.Types ( - EventId (..), +import Kiroku.Store.Types + ( EventId (..), EventType (..), StreamId (..), StreamName (..), StreamVersion (..), - ) + ) -------------------------------------------------------------------------------- -- Protocol (IP-4) -------------------------------------------------------------------------------- -{- | Messages from a WebSocket client to the server (tagged on a @"type"@ field). - -The constructors are field-less (positional) on purpose: 'SubscribeEvents' and -'ServerMessage'\'s 'EventStreamStarted' would otherwise both define a -@fromPosition@ record selector, which collides when @Kiroku.Metrics@ re-exports -both @(..)@ lists. --} +-- | Messages from a WebSocket client to the server (tagged on a @"type"@ field). +-- +-- The constructors are field-less (positional) on purpose: 'SubscribeEvents' and +-- 'ServerMessage'\'s 'EventStreamStarted' would otherwise both define a +-- @fromPosition@ record selector, which collides when @Kiroku.Metrics@ re-exports +-- both @(..)@ lists. data ClientMessage - = -- | Keepalive request; answered with 'Pong'. - Ping - | -- | (Metrics channel) request a fresh snapshot now. - SubscribeMetrics - | {- | (Event channel) start streaming. The first field is @from_position@ - ('Nothing' = "from now"); the second is @category@ ('Nothing' = all streams). - -} - SubscribeEvents !(Maybe Int64) !(Maybe Text) - | -- | (Event channel) stop the current tail. - UnsubscribeEvents - | -- | Stop periodic metrics snapshots; subscribe_metrics resumes them. - UnsubscribeMetrics - deriving stock (Eq, Show) + = -- | Keepalive request; answered with 'Pong'. + Ping + | -- | (Metrics channel) request a fresh snapshot now. + SubscribeMetrics + | -- | (Event channel) start streaming. The first field is @from_position@ + -- ('Nothing' = "from now"); the second is @category@ ('Nothing' = all streams). + SubscribeEvents !(Maybe Int64) !(Maybe Text) + | -- | (Event channel) stop the current tail. + UnsubscribeEvents + | -- | Stop periodic metrics snapshots; subscribe_metrics resumes them. + UnsubscribeMetrics + deriving stock (Eq, Show) -- | Messages from the server to a WebSocket client (tagged on a @"type"@ field). data ServerMessage - = -- | Answer to 'Ping'. - Pong - | -- | (Metrics channel) a metrics snapshot, embedded under @"metrics"@. - Snapshot !MetricsSnapshot - | -- | (Event channel) one appended event, embedded under @"event"@. - Event !Value - | {- | (Event channel) acknowledgement that streaming has begun from a - given global position (the @from_position@ field on the wire). - -} - EventStreamStarted !Int64 - | -- | The connection is being torn down. - Goodbye - | -- | A non-fatal error message for the client. - ErrorMsg !Text - | -- | An error with a stable machine-readable code. - CodedError !Text !Text - deriving stock (Eq, Show) + = -- | Answer to 'Ping'. + Pong + | -- | (Metrics channel) a metrics snapshot, embedded under @"metrics"@. + Snapshot !MetricsSnapshot + | -- | (Event channel) one appended event, embedded under @"event"@. + Event !Value + | -- | (Event channel) acknowledgement that streaming has begun from a + -- given global position (the @from_position@ field on the wire). + EventStreamStarted !Int64 + | -- | The connection is being torn down. + Goodbye + | -- | A non-fatal error message for the client. + ErrorMsg !Text + | -- | An error with a stable machine-readable code. + CodedError !Text !Text + deriving stock (Eq, Show) instance FromJSON ClientMessage where - parseJSON = withObject "ClientMessage" $ \v -> do - msgType <- v .: "type" - case msgType :: Text of - "ping" -> pure Ping - "subscribe_metrics" -> pure SubscribeMetrics - "unsubscribe_metrics" -> pure UnsubscribeMetrics - "subscribe_events" -> - SubscribeEvents <$> v .:? "from_position" <*> v .:? "category" - "unsubscribe_events" -> pure UnsubscribeEvents - other -> fail ("Unknown client message type: " <> T.unpack other) + parseJSON = withObject "ClientMessage" $ \v -> do + msgType <- v .: "type" + case msgType :: Text of + "ping" -> pure Ping + "subscribe_metrics" -> pure SubscribeMetrics + "unsubscribe_metrics" -> pure UnsubscribeMetrics + "subscribe_events" -> + SubscribeEvents <$> v .:? "from_position" <*> v .:? "category" + "unsubscribe_events" -> pure UnsubscribeEvents + other -> fail ("Unknown client message type: " <> T.unpack other) instance ToJSON ServerMessage where - toJSON Pong = object ["type" .= ("pong" :: Text)] - toJSON (Snapshot snap) = object ["type" .= ("snapshot" :: Text), "metrics" .= snap] - toJSON (Event ev) = object ["type" .= ("event" :: Text), "event" .= ev] - toJSON (EventStreamStarted p) = - object ["type" .= ("event_stream_started" :: Text), "from_position" .= p] - toJSON Goodbye = object ["type" .= ("goodbye" :: Text)] - toJSON (ErrorMsg msg) = object ["type" .= ("error" :: Text), "message" .= msg] - toJSON (CodedError code msg) = object ["type" .= ("error" :: Text), "code" .= code, "message" .= msg] + toJSON Pong = object ["type" .= ("pong" :: Text)] + toJSON (Snapshot snap) = object ["type" .= ("snapshot" :: Text), "metrics" .= snap] + toJSON (Event ev) = object ["type" .= ("event" :: Text), "event" .= ev] + toJSON (EventStreamStarted p) = + object ["type" .= ("event_stream_started" :: Text), "from_position" .= p] + toJSON Goodbye = object ["type" .= ("goodbye" :: Text)] + toJSON (ErrorMsg msg) = object ["type" .= ("error" :: Text), "message" .= msg] + toJSON (CodedError code msg) = object ["type" .= ("error" :: Text), "code" .= code, "message" .= msg] -- | Published error codes (human messages may change). errorCodeReplayFailed, errorCodeCategoryReadFailed, errorCodeEventStreamOverflowed, errorCodeLiveDecodeFailed :: Text @@ -204,36 +201,35 @@ -- | A notice on any counter change, including a Word64 wrap (modular subtraction). overflowNotice :: Word64 -> Word64 -> Maybe ServerMessage overflowNotice previous current - | previous /= current = - Just - ( CodedError - errorCodeEventStreamOverflowed - ( "event stream overflowed; " - <> T.pack (show (current - previous)) - <> " undelivered batch(es) dropped since the last notice; re-read from your last position" - ) + | previous /= current = + Just + ( CodedError + errorCodeEventStreamOverflowed + ( "event stream overflowed; " + <> T.pack (show (current - previous)) + <> " undelivered batch(es) dropped since the last notice; re-read from your last position" ) - | otherwise = Nothing + ) + | otherwise = Nothing -{- | Encode a 'RecordedEvent' to a JSON 'Value' (IP-4). An explicit function -rather than a @ToJSON@ instance: 'RecordedEvent' has no instance today and a -library-level orphan is undesirable. EP-4's user guide documents this shape. --} +-- | Encode a 'RecordedEvent' to a JSON 'Value' (IP-4). An explicit function +-- rather than a @ToJSON@ instance: 'RecordedEvent' has no instance today and a +-- library-level orphan is undesirable. EP-4's user guide documents this shape. recordedEventToJSON :: RecordedEvent -> Value recordedEventToJSON e = - object - [ "eventId" .= unEventId e.eventId - , "eventType" .= unEventType e.eventType - , "streamVersion" .= unStreamVersion e.streamVersion - , "globalPosition" .= unGlobalPosition e.globalPosition - , "originalStreamId" .= unStreamId e.originalStreamId - , "originalVersion" .= unStreamVersion e.originalVersion - , "payload" .= e.payload - , "metadata" .= e.metadata - , "causationId" .= e.causationId - , "correlationId" .= e.correlationId - , "createdAt" .= e.createdAt - ] + object + [ "eventId" .= unEventId e.eventId, + "eventType" .= unEventType e.eventType, + "streamVersion" .= unStreamVersion e.streamVersion, + "globalPosition" .= unGlobalPosition e.globalPosition, + "originalStreamId" .= unStreamId e.originalStreamId, + "originalVersion" .= unStreamVersion e.originalVersion, + "payload" .= e.payload, + "metadata" .= e.metadata, + "causationId" .= e.causationId, + "correlationId" .= e.correlationId, + "createdAt" .= e.createdAt + ] where unEventId (EventId u) = u unEventType (EventType t) = t @@ -245,28 +241,27 @@ -- Connection limiting (mirrors shibuya-metrics) -------------------------------------------------------------------------------- -{- | Shared state bounding the number of concurrent WebSocket connections. -Allocated once per server in 'Kiroku.Metrics.Server.startMetricsServerWithStore' -and captured by 'websocketApp', so the bound is shared across connections. --} +-- | Shared state bounding the number of concurrent WebSocket connections. +-- Allocated once per server in 'Kiroku.Metrics.Server.startMetricsServerWithStore' +-- and captured by 'websocketApp', so the bound is shared across connections. data WebSocketState = WebSocketState - { connectionCount :: !(TVar Int) - , maxConnections :: !Int - } + { connectionCount :: !(TVar Int), + maxConnections :: !Int + } -- | Create a 'WebSocketState' bounding connections at @maxConns@. newWebSocketState :: Int -> IO WebSocketState newWebSocketState maxConns = do - countVar <- newTVarIO 0 - pure WebSocketState{connectionCount = countVar, maxConnections = maxConns} + countVar <- newTVarIO 0 + pure WebSocketState {connectionCount = countVar, maxConnections = maxConns} -- | Try to claim a connection slot; 'True' on success. acquireConnection :: WebSocketState -> STM Bool acquireConnection st = do - count <- readTVar st.connectionCount - if count < st.maxConnections - then writeTVar st.connectionCount (count + 1) >> pure True - else pure False + count <- readTVar st.connectionCount + if count < st.maxConnections + then writeTVar st.connectionCount (count + 1) >> pure True + else pure False -- | Release a connection slot. releaseConnection :: WebSocketState -> STM () @@ -281,41 +276,40 @@ -- | Dispatch on the request path, ignoring any query string. dispatchPath :: BS.ByteString -> WsPath dispatchPath raw = - case BS.takeWhile (/= 0x3f) raw of -- 0x3f = '?' - p - | p == "/ws/metrics" -> MetricsPath - | p == "/ws/events" -> EventsPath - | otherwise -> UnknownPath + case BS.takeWhile (/= 0x3f) raw of -- 0x3f = '?' + p + | p == "/ws/metrics" -> MetricsPath + | p == "/ws/events" -> EventsPath + | otherwise -> UnknownPath -------------------------------------------------------------------------------- -- The WebSocket application -------------------------------------------------------------------------------- -{- | The real WebSocket app filling the IP-3 seam. Closes over the config, the -collector, the store (for event streaming — EP-2 deliberately kept the store out -of the /server/ signature, so it enters here), and the shared connection-limiting -state. Each upgrade is dispatched by path; an over-capacity upgrade is rejected. --} +-- | The real WebSocket app filling the IP-3 seam. Closes over the config, the +-- collector, the store (for event streaming — EP-2 deliberately kept the store out +-- of the /server/ signature, so it enters here), and the shared connection-limiting +-- state. Each upgrade is dispatched by path; an over-capacity upgrade is rejected. websocketApp :: - MetricsServerConfig -> - KirokuMetrics -> - KirokuStore -> - WebSocketState -> - WS.ServerApp + MetricsServerConfig -> + KirokuMetrics -> + KirokuStore -> + WebSocketState -> + WS.ServerApp websocketApp cfg m store st pending = - case dispatchPath (WS.requestPath (WS.pendingRequest pending)) of - MetricsPath -> guarded (handleMetrics cfg m) - EventsPath -> guarded (handleEvents cfg store) - UnknownPath -> - WS.rejectRequest pending "Unknown WebSocket path; use /ws/metrics or /ws/events" + case dispatchPath (WS.requestPath (WS.pendingRequest pending)) of + MetricsPath -> guarded (handleMetrics cfg m) + EventsPath -> guarded (handleEvents cfg store) + UnknownPath -> + WS.rejectRequest pending "Unknown WebSocket path; use /ws/metrics or /ws/events" where guarded run = do - acquired <- atomically (acquireConnection st) - if not acquired - then WS.rejectRequest pending "Too many connections" - else - (run pending `catch` ignoreClosed) - `finally` atomically (releaseConnection st) + acquired <- atomically (acquireConnection st) + if not acquired + then WS.rejectRequest pending "Too many connections" + else + (run pending `catch` ignoreClosed) + `finally` atomically (releaseConnection st) -- A normal client disconnect surfaces as a 'WS.ConnectionException' from the -- receive loop; treat it as a clean end-of-connection rather than letting it -- escape to the server's exception reporter. @@ -328,218 +322,212 @@ -- | Handle a @/ws/metrics@ connection: snapshot on connect, periodic push, ping/pong. handleMetrics :: MetricsServerConfig -> KirokuMetrics -> WS.PendingConnection -> IO () handleMetrics cfg m pending = do - conn <- WS.acceptRequest pending - WS.withPingThread conn 30 (pure ()) $ - withWorkerSlot $ \start stop -> do - sendMsg conn . Snapshot =<< snapshotMetrics m - start (metricsPushLoop cfg m conn) - metricsReceiveLoop m conn (start (metricsPushLoop cfg m conn)) stop - `finally` (stop >> sendMsg conn Goodbye) + conn <- WS.acceptRequest pending + WS.withPingThread conn 30 (pure ()) $ + withWorkerSlot $ \start stop -> do + sendMsg conn . Snapshot =<< snapshotMetrics m + start (metricsPushLoop cfg m conn) + metricsReceiveLoop m conn (start (metricsPushLoop cfg m conn)) stop + `finally` (stop >> sendMsg conn Goodbye) -{- | Scope one linked worker. Creation and registration are masked, the worker -body is unmasked, and cleanup cancels and joins even during acquisition. Starting -an already occupied slot is a no-op. The receive loop is the sole slot owner. --} +-- | Scope one linked worker. Creation and registration are masked, the worker +-- body is unmasked, and cleanup cancels and joins even during acquisition. Starting +-- an already occupied slot is a no-op. The receive loop is the sole slot owner. withWorkerSlot :: ((IO () -> IO ()) -> IO () -> IO a) -> IO a withWorkerSlot body = mask $ \restore -> do - workerVar <- newTVarIO Nothing - let stop = mask_ $ do - worker <- atomically (readTVar workerVar) - for_ worker uninterruptibleCancel - atomically (writeTVar workerVar Nothing) - start action = mask_ $ do - worker <- atomically (readTVar workerVar) - case worker of - Just _ -> pure () - Nothing -> do - child <- asyncWithUnmask (\unmask -> unmask action) - atomically (writeTVar workerVar (Just child)) - link child - restore (body start stop) `finally` stop + workerVar <- newTVarIO Nothing + let stop = mask_ $ do + worker <- atomically (readTVar workerVar) + for_ worker uninterruptibleCancel + atomically (writeTVar workerVar Nothing) + start action = mask_ $ do + worker <- atomically (readTVar workerVar) + case worker of + Just _ -> pure () + Nothing -> do + child <- asyncWithUnmask (\unmask -> unmask action) + atomically (writeTVar workerVar (Just child)) + link child + restore (body start stop) `finally` stop -- | Periodically push a fresh snapshot every @wsPushIntervalUs@. metricsPushLoop :: MetricsServerConfig -> KirokuMetrics -> WS.Connection -> IO () metricsPushLoop cfg m conn = forever $ do - threadDelay cfg.wsPushIntervalUs - sendMsg conn . Snapshot =<< snapshotMetrics m + threadDelay cfg.wsPushIntervalUs + sendMsg conn . Snapshot =<< snapshotMetrics m -- | Answer @ping@ with @pong@ and @subscribe_metrics@ with a fresh snapshot. metricsReceiveLoop :: KirokuMetrics -> WS.Connection -> IO () -> IO () -> IO () metricsReceiveLoop m conn start stop = forever $ do - cmd <- recvMsg conn - case cmd of - Just Ping -> sendMsg conn Pong - Just SubscribeMetrics -> do - sendMsg conn . Snapshot =<< snapshotMetrics m - start - Just UnsubscribeMetrics -> stop - _ -> pure () + cmd <- recvMsg conn + case cmd of + Just Ping -> sendMsg conn Pong + Just SubscribeMetrics -> do + sendMsg conn . Snapshot =<< snapshotMetrics m + start + Just UnsubscribeMetrics -> stop + _ -> pure () -------------------------------------------------------------------------------- -- Event channel -------------------------------------------------------------------------------- -{- | Handle a @/ws/events@ connection. The connection starts idle; a -@subscribe_events@ message starts (or restarts) a tail, @unsubscribe_events@ -stops it, and @ping@ → @pong@. The tail runs in a child thread tracked in a -'TVar' so the receive loop can cancel and replace it; disconnect tears it down. --} +-- | Handle a @/ws/events@ connection. The connection starts idle; a +-- @subscribe_events@ message starts (or restarts) a tail, @unsubscribe_events@ +-- stops it, and @ping@ → @pong@. The tail runs in a child thread tracked in a +-- 'TVar' so the receive loop can cancel and replace it; disconnect tears it down. handleEvents :: MetricsServerConfig -> KirokuStore -> WS.PendingConnection -> IO () handleEvents cfg store pending = do - conn <- WS.acceptRequest pending - WS.withPingThread conn 30 (pure ()) $ - withWorkerSlot $ \start stop -> - finally - ( forever $ do - cmd <- recvMsg conn - case cmd of - Just Ping -> sendMsg conn Pong - Just (SubscribeEvents from cat) -> stop >> start (eventTail cfg store conn from cat) - Just UnsubscribeEvents -> stop - _ -> pure () - ) - (stop >> sendMsg conn Goodbye) + conn <- WS.acceptRequest pending + WS.withPingThread conn 30 (pure ()) $ + withWorkerSlot $ \start stop -> + finally + ( forever $ do + cmd <- recvMsg conn + case cmd of + Just Ping -> sendMsg conn Pong + Just (SubscribeEvents from cat) -> stop >> start (eventTail cfg store conn from cat) + Just UnsubscribeEvents -> stop + _ -> pure () + ) + (stop >> sendMsg conn Goodbye) -- | A reasonable replay/category page size. eventReadLimit :: Int eventReadLimit = 500 -{- | Stream events to the client. Dispatches on the request shape: - - * no @from@, no @category@: live "from-now" tail via the broadcast. - * @from@, no @category@: replay history from @from@, tracking the highest - delivered position, then live with the broadcast filtered to positions above - that covered boundary. A replay read error sends an @error@ frame and ends - the tail instead of entering live mode with a gap. - * any @category@: a DB-driven loop over 'readCategory' gated on the publisher - position (the broadcast carries no stream names, so it cannot be filtered by - category in-process — see the plan). --} +-- | Stream events to the client. Dispatches on the request shape: +-- +-- * no @from@, no @category@: live "from-now" tail via the broadcast. +-- * @from@, no @category@: replay history from @from@, tracking the highest +-- delivered position, then live with the broadcast filtered to positions above +-- that covered boundary. A replay read error sends an @error@ frame and ends +-- the tail instead of entering live mode with a gap. +-- * any @category@: a DB-driven loop over 'readCategory' gated on the publisher +-- position (the broadcast carries no stream names, so it cannot be filtered by +-- category in-process — see the plan). eventTail :: - MetricsServerConfig -> - KirokuStore -> - WS.Connection -> - Maybe Int64 -> - Maybe Text -> - IO () + MetricsServerConfig -> + KirokuStore -> + WS.Connection -> + Maybe Int64 -> + Maybe Text -> + IO () eventTail cfg store conn mFrom mCategory = do - cache <- newStreamNameCache - case mCategory of - Just cat -> do - start <- case mFrom of - Just p -> pure p - Nothing -> unGP <$> atomically (publisherPosition store.publisher) - sendMsg conn (EventStreamStarted start) - categoryLoop store cache conn (CategoryName cat) start - Nothing -> - bracket - ( atomically $ do - sub <- subscribePublisherWith store.publisher cfg.wsEventQueueCap DropOldest - attachPos <- unGP <$> publisherPosition store.publisher - pure (sub, attachPos) - ) - (unsubscribe . fst) - $ \(sub, attachPos) -> - case mFrom of - Nothing -> do - sendMsg conn (EventStreamStarted attachPos) - broadcastEventsWith (sendMsg conn) cache (lookupNames store) sub (const True) - Just p -> do - sendMsg conn (EventStreamStarted p) - mCovered <- replayHistory store cache conn p attachPos - for_ mCovered $ \covered -> - broadcastEventsWith (sendMsg conn) cache (lookupNames store) sub (\e -> unGP e.globalPosition > covered) + cache <- newStreamNameCache + case mCategory of + Just cat -> do + start <- case mFrom of + Just p -> pure p + Nothing -> unGP <$> atomically (publisherPosition store.publisher) + sendMsg conn (EventStreamStarted start) + categoryLoop store cache conn (CategoryName cat) start + Nothing -> + bracket + ( atomically $ do + sub <- subscribePublisherWith store.publisher cfg.wsEventQueueCap DropOldest + attachPos <- unGP <$> publisherPosition store.publisher + pure (sub, attachPos) + ) + (unsubscribe . fst) + $ \(sub, attachPos) -> + case mFrom of + Nothing -> do + sendMsg conn (EventStreamStarted attachPos) + broadcastEventsWith (sendMsg conn) cache (lookupNames store) sub (const True) + Just p -> do + sendMsg conn (EventStreamStarted p) + mCovered <- replayHistory store cache conn p attachPos + for_ mCovered $ \covered -> + broadcastEventsWith (sendMsg conn) cache (lookupNames store) sub (\e -> unGP e.globalPosition > covered) -{- | Page history from the requested position up to @attachPos@ with -'readAllForward'. Returns @Just covered@, the highest global position the -client is now guaranteed to have received (at least @attachPos@; more when the -final page read past it), or @Nothing@ after a read error, which has already -been surfaced to the client as an 'ErrorMsg'. The caller must terminate the -tail on @Nothing@ rather than continue live with a gap. --} +-- | Page history from the requested position up to @attachPos@ with +-- 'readAllForward'. Returns @Just covered@, the highest global position the +-- client is now guaranteed to have received (at least @attachPos@; more when the +-- final page read past it), or @Nothing@ after a read error, which has already +-- been surfaced to the client as an 'ErrorMsg'. The caller must terminate the +-- tail on @Nothing@ rather than continue live with a gap. replayHistory :: KirokuStore -> StreamNameCache -> WS.Connection -> Int64 -> Int64 -> IO (Maybe Int64) replayHistory store cache conn from attachPos = go from attachPos where go cursor covered - | cursor >= attachPos = pure (Just covered) - | otherwise = do - res <- runStoreIO store (readAllForward (GlobalPosition cursor) (fromIntegral eventReadLimit)) - case res of - Left _ -> do - sendMsg conn (CodedError errorCodeReplayFailed "replay error: history unavailable") - pure Nothing - Right evs - | V.null evs -> pure (Just covered) - | otherwise -> do - sendEvents store cache conn evs - let lastPos = unGP (V.last evs).globalPosition - go lastPos (max covered lastPos) + | cursor >= attachPos = pure (Just covered) + | otherwise = do + res <- runStoreIO store (readAllForward (GlobalPosition cursor) (fromIntegral eventReadLimit)) + case res of + Left _ -> do + sendMsg conn (CodedError errorCodeReplayFailed "replay error: history unavailable") + pure Nothing + Right evs + | V.null evs -> pure (Just covered) + | otherwise -> do + sendEvents store cache conn evs + let lastPos = unGP (V.last evs).globalPosition + go lastPos (max covered lastPos) -{- | Production live delivery with an injectable frame writer and name lookup. -Queue, status and counter are sampled atomically. Loss is signalled before any -surviving event, preserving the client's last contiguous recovery cursor. --} +-- | Production live delivery with an injectable frame writer and name lookup. +-- Queue, status and counter are sampled atomically. Loss is signalled before any +-- surviving event, preserving the client's last contiguous recovery cursor. broadcastEventsWith :: - (ServerMessage -> IO ()) -> - StreamNameCache -> - ([StreamId] -> IO (Map StreamId StreamName)) -> - PublisherSubscription -> - (RecordedEvent -> Bool) -> - IO () + (ServerMessage -> IO ()) -> + StreamNameCache -> + ([StreamId] -> IO (Map StreamId StreamName)) -> + PublisherSubscription -> + (RecordedEvent -> Bool) -> + IO () broadcastEventsWith send cache lookupBatch sub keep = go 0 False where go previous warned = do - (batch, status, dropped) <- - atomically $ - (,,) - <$> readTBQueue sub.subscriptionQueue - <*> readTVar sub.subscriptionStatus - <*> readTVar sub.subscriptionDropped - let notice = case overflowNotice previous dropped of - Just msg -> Just msg - Nothing | status == Overflowed && not warned -> Just (CodedError errorCodeEventStreamOverflowed "event stream overflowed; some events dropped") - Nothing -> Nothing - for_ notice send - let decoded = case batch of - UnchangedBatch events -> Right (V.filter keep events) - TransformedBatch events -> V.mapM unwrap (V.filter (keep . decodedEventRecorded) events) - unwrap (Decoded event) = Right event - unwrap (Undecodable _ failure) = Left failure - case decoded of - Left _ -> send (CodedError errorCodeLiveDecodeFailed "live event decoding failed") - Right events -> do - names <- resolveEventNames cache lookupBatch events - V.mapM_ (send . Event . recordedEventToJSONResolved names) events - go dropped (status == Overflowed) + (batch, status, dropped) <- + atomically $ + (,,) + <$> readTBQueue sub.subscriptionQueue + <*> readTVar sub.subscriptionStatus + <*> readTVar sub.subscriptionDropped + let notice = case overflowNotice previous dropped of + Just msg -> Just msg + Nothing | status == Overflowed && not warned -> Just (CodedError errorCodeEventStreamOverflowed "event stream overflowed; some events dropped") + Nothing -> Nothing + for_ notice send + let decoded = case batch of + UnchangedBatch events -> Right (V.filter keep events) + TransformedBatch events -> V.mapM unwrap (V.filter (keep . decodedEventRecorded) events) + unwrap (Decoded event) = Right event + unwrap (Undecodable _ failure) = Left failure + case decoded of + Left _ -> send (CodedError errorCodeLiveDecodeFailed "live event decoding failed") + Right events -> do + names <- resolveEventNames cache lookupBatch events + V.mapM_ (send . Event . recordedEventToJSONResolved names) events + go dropped (status == Overflowed) -{- | DB-driven category live loop. Mirrors the subscription worker's -@liveLoopDbDriven@: gate on the publisher advancing past the /last observed/ -position (not the cursor) so an unmatched category does not busy-spin, then drain -the category to empty before waiting again. --} +-- | DB-driven category live loop. Mirrors the subscription worker's +-- @liveLoopDbDriven@: gate on the publisher advancing past the /last observed/ +-- position (not the cursor) so an unmatched category does not busy-spin, then drain +-- the category to empty before waiting again. categoryLoop :: KirokuStore -> StreamNameCache -> WS.Connection -> CategoryName -> Int64 -> IO () categoryLoop store cache conn cat startPos = go startPos 0 where go cursor waitFrom = do - pubPos <- atomically $ do - GlobalPosition p <- publisherPosition store.publisher - check (p > waitFrom) - pure p - drained <- drainTo cursor - case drained of - Nothing -> pure () -- a DB error already surfaced; stop the tail - Just cursor' -> go cursor' pubPos + pubPos <- atomically $ do + GlobalPosition p <- publisherPosition store.publisher + check (p > waitFrom) + pure p + drained <- drainTo cursor + case drained of + Nothing -> pure () -- a DB error already surfaced; stop the tail + Just cursor' -> go cursor' pubPos drainTo cursor = do - res <- runStoreIO store (readCategory cat (GlobalPosition cursor) (fromIntegral eventReadLimit)) - case res of - Left _ -> do - sendMsg conn (CodedError errorCodeCategoryReadFailed "category read error: events unavailable") - pure Nothing - Right evs - | V.null evs -> pure (Just cursor) - | otherwise -> do - sendEvents store cache conn evs - drainTo (unGP (V.last evs).globalPosition) + res <- runStoreIO store (readCategory cat (GlobalPosition cursor) (fromIntegral eventReadLimit)) + case res of + Left _ -> do + sendMsg conn (CodedError errorCodeCategoryReadFailed "category read error: events unavailable") + pure Nothing + Right evs + | V.null evs -> pure (Just cursor) + | otherwise -> do + sendEvents store cache conn evs + drainTo (unGP (V.last evs).globalPosition) -------------------------------------------------------------------------------- -- Send / receive helpers @@ -548,8 +536,8 @@ -- | Send each event in a batch as an 'Event' message. sendEvents :: KirokuStore -> StreamNameCache -> WS.Connection -> Vector RecordedEvent -> IO () sendEvents store cache conn events = do - names <- resolveEventNames cache (lookupNames store) events - V.mapM_ (sendMsg conn . Event . recordedEventToJSONResolved names) events + names <- resolveEventNames cache (lookupNames store) events + V.mapM_ (sendMsg conn . Event . recordedEventToJSONResolved names) events -- Typed lookup failures fall back to null names; thrown exceptions propagate. lookupNames :: KirokuStore -> [StreamId] -> IO (Map StreamId StreamName) @@ -567,48 +555,45 @@ -- | Retained map and FIFO sizes (both bounded by 4096). streamNameCacheSize :: StreamNameCache -> IO (Int, Int) streamNameCacheSize (StreamNameCache ref) = do - NameCache names order <- readIORef ref - pure (Map.size names, Seq.length order) + NameCache names order <- readIORef ref + pure (Map.size names, Seq.length order) -{- | Resolve distinct misses in at most one lookup. The temporary encoding map -contains all current-batch names even when that batch exceeds cache capacity. -The tail owns the cache; calls on one cache must be serialized. --} +-- | Resolve distinct misses in at most one lookup. The temporary encoding map +-- contains all current-batch names even when that batch exceeds cache capacity. +-- The tail owns the cache; calls on one cache must be serialized. resolveEventNames :: StreamNameCache -> ([StreamId] -> IO (Map StreamId StreamName)) -> Vector RecordedEvent -> IO (Map StreamId StreamName) resolveEventNames (StreamNameCache ref) lookupBatch events = do - NameCache cached order <- readIORef ref - let wanted = Set.fromList (V.toList (V.map (.originalStreamId) events)) - -- Inspect the requested ids rather than materializing all retained keys - -- for each small batch after the cache has filled. - missing = Set.filter (`Map.notMember` cached) wanted - found <- if Set.null missing then pure Map.empty else Map.restrictKeys <$> lookupBatch (Set.toList missing) <*> pure missing - let current = Map.union cached found - inserted = foldl' (|>) order (Map.keys found) - trimmed = evict current inserted - trimmed `seq` writeIORef ref trimmed - pure (Map.restrictKeys current wanted) + NameCache cached order <- readIORef ref + let wanted = Set.fromList (V.toList (V.map (.originalStreamId) events)) + -- Inspect the requested ids rather than materializing all retained keys + -- for each small batch after the cache has filled. + missing = Set.filter (`Map.notMember` cached) wanted + found <- if Set.null missing then pure Map.empty else Map.restrictKeys <$> lookupBatch (Set.toList missing) <*> pure missing + let current = Map.union cached found + inserted = foldl' (|>) order (Map.keys found) + trimmed = evict current inserted + trimmed `seq` writeIORef ref trimmed + pure (Map.restrictKeys current wanted) where evict names order - | Map.size names <= 4096 = NameCache names order - | otherwise = case Seq.viewl order of - oldest :< rest -> evict (Map.delete oldest names) rest - EmptyL -> NameCache Map.empty Seq.empty + | Map.size names <= 4096 = NameCache names order + | otherwise = case Seq.viewl order of + oldest :< rest -> evict (Map.delete oldest names) rest + EmptyL -> NameCache Map.empty Seq.empty -{- | Send a 'ServerMessage', swallowing a closed-connection exception so cleanup -in a @finally@ never re-throws on an already-dead socket. --} +-- | Send a 'ServerMessage', swallowing a closed-connection exception so cleanup +-- in a @finally@ never re-throws on an already-dead socket. sendMsg :: WS.Connection -> ServerMessage -> IO () sendMsg conn msg = - WS.sendTextData conn (encode msg) - `catch` \(_ :: WS.ConnectionException) -> pure () + WS.sendTextData conn (encode msg) + `catch` \(_ :: WS.ConnectionException) -> pure () -{- | Receive and decode one 'ClientMessage'. 'Nothing' on an undecodable frame -(ignored by the caller). --} +-- | Receive and decode one 'ClientMessage'. 'Nothing' on an undecodable frame +-- (ignored by the caller). recvMsg :: WS.Connection -> IO (Maybe ClientMessage) recvMsg conn = do - raw <- WS.receiveData conn :: IO LBS.ByteString - pure (either (const Nothing) Just (eitherDecode' raw)) + raw <- WS.receiveData conn :: IO LBS.ByteString + pure (either (const Nothing) Just (eitherDecode' raw)) -- | Unwrap a 'GlobalPosition' to its underlying 'Int64'. unGP :: GlobalPosition -> Int64 @@ -617,5 +602,5 @@ -- | The frozen event shape plus the resolved original name (or null). recordedEventToJSONResolved :: Map StreamId StreamName -> RecordedEvent -> Value recordedEventToJSONResolved names event = case recordedEventToJSON event of - Object fields -> Object (KeyMap.insert "original_stream_name" (toJSON (fmap (\(StreamName name) -> name) (Map.lookup event.originalStreamId names))) fields) - _ -> error "recordedEventToJSON must return an object" + Object fields -> Object (KeyMap.insert "original_stream_name" (toJSON (fmap (\(StreamName name) -> name) (Map.lookup event.originalStreamId names))) fields) + _ -> error "recordedEventToJSON must return an object" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,11 @@ module Main (main) where +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar) +import Control.Exception (bracket) +import Control.Monad (void) +import InspectSignals (withInspectSignals) +import System.Environment (getArgs) +import System.IO (hFlush, stdout) import Test.Hspec (hspec) import Kiroku.Test.Postgres (withSharedMigratedPostgres) @@ -17,16 +23,31 @@ import Test.WebSocketSpec qualified as WebSocketSpec main :: IO () -main = withSharedMigratedPostgres $ hspec $ do - StandaloneSpec.spec - CapabilitiesSpec.spec - BrowseSpec.spec - CheckpointsSpec.spec - DeadLettersSpec.spec - CorsSpec.spec - CollectorSpec.spec - IntegrationSpec.spec - ServerSpec.spec - WebSocketConvergenceSpec.spec - WebSocketSpec.spec - SubscriptionsSpec.spec +main = do + args <- getArgs + if args == ["--inspect-signal-fixture"] then signalFixture else runSpecs + +signalFixture :: IO () +signalFixture = do + done <- newEmptyMVar + never <- newEmptyMVar + withInspectSignals (void (tryPutMVar done ())) $ + bracket + (putStrLn "READY" >> hFlush stdout) + (\() -> putStrLn "SHUTTING_DOWN" >> hFlush stdout >> takeMVar never) + (\() -> takeMVar done) + +runSpecs :: IO () +runSpecs = withSharedMigratedPostgres $ hspec $ do + StandaloneSpec.spec + CapabilitiesSpec.spec + BrowseSpec.spec + CheckpointsSpec.spec + DeadLettersSpec.spec + CorsSpec.spec + CollectorSpec.spec + IntegrationSpec.spec + ServerSpec.spec + WebSocketConvergenceSpec.spec + WebSocketSpec.spec + SubscriptionsSpec.spec diff --git a/test/Test/BrowseSpec.hs b/test/Test/BrowseSpec.hs --- a/test/Test/BrowseSpec.hs +++ b/test/Test/BrowseSpec.hs @@ -33,150 +33,157 @@ spec :: Spec spec = describe "Kiroku.Metrics.Browse" $ do - it "validates page limits before construction" $ do - forM_ [(0, 10), (10, 1), (1, 1001)] $ \(def, cap) -> mkBrowseLimits def cap `shouldBe` Left (InvalidBrowseLimits def cap) - fmap maxLimit (mkBrowseLimits 1 1000) `shouldBe` Right 1000 - it "rejects malformed queries before invoking the store" $ do - calls <- newIORef (0 :: Int) - let browser = StoreBrowser (\_ -> modifyIORef' calls (+ 1) >> pure (Left (Store.ConnectionError "secret"))) defaultBrowseLimits - Warp.testWithApplication (pure (browseApp browser)) $ \port -> do - forM_ ["/streams?limit=0", "/streams?limit=1001", "/streams?limit=abc", "/streams?prefix=%00", "/streams?from=%FF", "/events?from=-1", "/events?from=9223372036854775808", "/events?direction=sideways", "/streams/$all/events", "/events/not-a-uuid"] $ \path -> do - response <- get port path - HTTP.responseStatus response `shouldBe` status400 - response <- get port "/streams?limit=1" - HTTP.responseStatus response `shouldBe` status503 - code (HTTP.responseBody response) `shouldBe` Just "store_unavailable" - readIORef calls `shouldReturn` 1 - it "preserves HEAD status/headers, refuses mutations and sanitizes errors" $ do - let app = browseApp (StoreBrowser (\_ -> pure (Left (Store.ConnectionError "postgres://secret"))) defaultBrowseLimits) - (status, headers, responseBody) <- capture app "GET" ["events"] - status `shouldBe` status503 - code responseBody `shouldBe` Just "store_unavailable" - capture app "HEAD" ["events"] `shouldReturn` (status, headers, "") - forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do - (actual, responseHeaders, _) <- capture app method ["events"] - actual `shouldBe` status405 - lookup "Allow" responseHeaders `shouldBe` Just "GET, HEAD" - (disabled, _, disabledBody) <- capture browseNotConfiguredApp "GET" ["streams"] - disabled `shouldBe` status404 - code disabledBody `shouldBe` Just "store_browsing_not_configured" - it "sanitizes typed transient and permanent failures on browse routes" $ do - forM_ [(Store.ConnectionLost "secret", status503, "store_unavailable"), (Store.PoolAcquisitionTimeout, status503, "store_unavailable"), (Store.TransientTransactionFailure "40001" "secret", status503, "store_unavailable"), (Store.TransientTransactionFailure "40P01" "secret", status503, "store_unavailable"), (Store.UnexpectedServerError "42P01" "secret SQL", status500, "store_error")] $ \(err, expected, expectedCode) -> do - let app = browseApp (StoreBrowser (\_ -> pure (Left err)) defaultBrowseLimits) - (status, headers, responseBody) <- capture app "GET" ["events"] - status `shouldBe` expected - code responseBody `shouldBe` Just expectedCode - responseBody `shouldSatisfy` (not . BS.isInfixOf "secret" . LBS.toStrict) - capture app "HEAD" ["events"] `shouldReturn` (status, headers, "") - it "serves all browse routes, names and exclusive pages through the shared server" $ withTestStore $ \store -> do - append store "orders-1" 3 - append store "orders-2" 1 - append store "shipments-1" 1 - metrics <- newKirokuMetrics store - providers <- storeServerProviders defaultConfig metrics store - withMetricsServerWithProviders defaultConfig{Config.port = 0} metrics [] providers $ \server -> do - let fetch = get server.serverPort - first <- fetch "/streams?category=orders&limit=1" - field "next_cursor" (body first) `shouldBe` Just (String "orders-1") - second <- fetch "/streams?category=orders&prefix=orders-&from=orders-1&limit=1" - map (field "name") (items (body second)) `shouldBe` [Just (String "orders-2")] - field "next_cursor" (body second) `shouldBe` Nothing - summary <- fetch "/streams/orders-1" - field "category" (body summary) `shouldBe` Just (String "orders") - streamPage <- fetch "/streams/orders-1/events?limit=2" - map (field "streamVersion") (items (body streamPage)) `shouldBe` [Just (Number 1), Just (Number 2)] - field "next_cursor" (body streamPage) `shouldBe` Just (Number 2) - continuation <- fetch "/streams/orders-1/events?from=2&limit=2" - map (field "streamVersion") (items (body continuation)) `shouldBe` [Just (Number 3)] - backward <- fetch "/streams/orders-1/events?direction=backward" - map (field "streamVersion") (items (body backward)) `shouldBe` map (Just . Number) [3, 2, 1] - cats <- fetch "/categories" - map (field "name") (items (body cats)) `shouldBe` [Just (String "orders"), Just (String "shipments")] - categoryEvents <- fetch "/categories/orders/events" - length (items (body categoryEvents)) `shouldBe` 4 - globals <- fetch "/events?from=3" - map (field "globalPosition") (items (body globals)) `shouldBe` [Just (Number 4), Just (Number 5)] - map (field "original_stream_name") (items (body globals)) `shouldBe` [Just (String "orders-2"), Just (String "shipments-1")] - reverseGlobal <- fetch "/events?direction=backward&limit=2" - map (field "globalPosition") (items (body reverseGlobal)) `shouldBe` [Just (Number 5), Just (Number 4)] - Right recorded <- Store.runStoreIO store $ Store.readAllForward (Store.GlobalPosition 0) 10 - let Store.EventId uuid = V.head recorded ^. #eventId - event <- fetch ("/events/" <> show uuid) - HTTP.responseStatus event `shouldBe` status200 - field "original_stream_name" (body event) `shouldBe` Just (String "orders-1") - forM_ ["/streams/missing", "/streams/missing/events", "/events/00000000-0000-0000-0000-000000000000", "/streams/unknown/path"] $ \path -> do - response <- fetch path - HTTP.responseStatus response `shouldBe` status404 - -- Summary JSON and legacy endpoints remain independently mounted. - legacy <- fetch "/nope" - body legacy `shouldBe` object ["error" .= ("Not found" :: Text)] - it "keeps prefix-mounted browse routes and CORS active when legacy JSON and WebSockets are disabled" $ do - metrics <- newKirokuMetricsWith (pure (Store.GlobalPosition 0)) (pure 0) - let origin = either (error . show) (\value -> value) (allowedOrigin "https://ops.example.com") - cors = corsAllowOrigins [origin] - browser = StoreBrowser (\_ -> pure (Left (Store.ConnectionError "secret"))) defaultBrowseLimits - config = defaultConfig{cors, enableJSON = False, enableWebSocket = False} - providers = defaultServerProviders{storeBrowsing = Just browser} - mounted req respond = combinedAppWithProviders config metrics [] providers (req{Wai.pathInfo = drop 1 (Wai.pathInfo req)}) respond - Warp.testWithApplication (pure mounted) $ \port -> do - manager <- HTTP.newManager HTTP.defaultManagerSettings - request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/inspect/events?from=0") - response <- HTTP.httpLbs request{HTTP.requestHeaders = [("Origin", "https://ops.example.com")]} manager - HTTP.responseStatus response `shouldBe` status503 - lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response) `shouldBe` Just "https://ops.example.com" - code (HTTP.responseBody response) `shouldBe` Just "store_unavailable" - it "trims over-fetch before one distinct-name lookup and skips it on empty pages" $ withTestStore $ \store -> do - append store "orders-1" 2 - append store "orders-2" 1 - Right events <- Store.runStoreIO store $ Store.readAllForward (Store.GlobalPosition 0) 10 - calls <- newIORef ([] :: [[Store.StreamId]]) - let interpreter :: forall a. Eff '[Store, Error Store.StoreError, IOE] a -> Eff '[Error Store.StoreError, IOE] a - interpreter = interpret_ $ \case - ReadAllForward (Store.GlobalPosition cursor) limit -> pure $ V.take (fromIntegral limit) $ V.filter (\event -> let Store.GlobalPosition n = event ^. #globalPosition in n > cursor) events - LookupStreamNames ids -> liftIO (modifyIORef' calls (<> [ids])) >> pure Map.empty - _ -> error "unexpected browse mock operation" - browser = StoreBrowser (runEff . runErrorNoCallStack . interpreter) defaultBrowseLimits - Warp.testWithApplication (pure (browseApp browser)) $ \port -> do - response <- get port "/events?limit=2" - map (field "original_stream_name") (items (body response)) `shouldBe` [Just Null, Just Null] - _ <- get port "/events?from=3" - pure () - readIORef calls `shouldReturn` [[V.head events ^. #originalStreamId]] + it "validates page limits before construction" $ do + forM_ [(0, 10), (10, 1), (1, 1001)] $ \(def, cap) -> mkBrowseLimits def cap `shouldBe` Left (InvalidBrowseLimits def cap) + fmap maxLimit (mkBrowseLimits 1 1000) `shouldBe` Right 1000 + it "rejects malformed queries before invoking the store" $ do + calls <- newIORef (0 :: Int) + let browser = StoreBrowser (\_ -> modifyIORef' calls (+ 1) >> pure (Left (Store.ConnectionError "secret"))) defaultBrowseLimits + Warp.testWithApplication (pure (browseApp browser)) $ \port -> do + forM_ ["/streams?limit=0", "/streams?limit=1001", "/streams?limit=abc", "/streams?prefix=%00", "/streams?from=%FF", "/events?from=-1", "/events?from=9223372036854775808", "/events?direction=sideways", "/streams/$all/events", "/events/not-a-uuid"] $ \path -> do + response <- get port path + HTTP.responseStatus response `shouldBe` status400 + response <- get port "/streams?limit=1" + HTTP.responseStatus response `shouldBe` status503 + code (HTTP.responseBody response) `shouldBe` Just "store_unavailable" + readIORef calls `shouldReturn` 1 + it "preserves HEAD status/headers, refuses mutations and sanitizes errors" $ do + let app = browseApp (StoreBrowser (\_ -> pure (Left (Store.ConnectionError "postgres://secret"))) defaultBrowseLimits) + (status, headers, responseBody) <- capture app "GET" ["events"] + status `shouldBe` status503 + code responseBody `shouldBe` Just "store_unavailable" + capture app "HEAD" ["events"] `shouldReturn` (status, headers, "") + forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do + (actual, responseHeaders, _) <- capture app method ["events"] + actual `shouldBe` status405 + lookup "Allow" responseHeaders `shouldBe` Just "GET, HEAD" + (disabled, _, disabledBody) <- capture browseNotConfiguredApp "GET" ["streams"] + disabled `shouldBe` status404 + code disabledBody `shouldBe` Just "store_browsing_not_configured" + it "sanitizes typed transient and permanent failures on browse routes" $ do + forM_ [(Store.ConnectionLost "secret", status503, "store_unavailable"), (Store.PoolAcquisitionTimeout, status503, "store_unavailable"), (Store.TransientTransactionFailure "40001" "secret", status503, "store_unavailable"), (Store.TransientTransactionFailure "40P01" "secret", status503, "store_unavailable"), (Store.UnexpectedServerError "42P01" "secret SQL", status500, "store_error")] $ \(err, expected, expectedCode) -> do + let app = browseApp (StoreBrowser (\_ -> pure (Left err)) defaultBrowseLimits) + (status, headers, responseBody) <- capture app "GET" ["events"] + status `shouldBe` expected + code responseBody `shouldBe` Just expectedCode + responseBody `shouldSatisfy` (not . BS.isInfixOf "secret" . LBS.toStrict) + capture app "HEAD" ["events"] `shouldReturn` (status, headers, "") + it "serves all browse routes, names and exclusive pages through the shared server" $ withTestStore $ \store -> do + append store "orders-1" 3 + append store "orders-2" 1 + append store "shipments-1" 1 + metrics <- newKirokuMetrics store + providers <- storeServerProviders defaultConfig metrics store + withMetricsServerWithProviders defaultConfig {Config.port = 0} metrics [] providers $ \server -> do + let fetch = get server.serverPort + first <- fetch "/streams?category=orders&limit=1" + field "next_cursor" (body first) `shouldBe` Just (String "orders-1") + second <- fetch "/streams?category=orders&prefix=orders-&from=orders-1&limit=1" + map (field "name") (items (body second)) `shouldBe` [Just (String "orders-2")] + field "next_cursor" (body second) `shouldBe` Nothing + summary <- fetch "/streams/orders-1" + field "category" (body summary) `shouldBe` Just (String "orders") + streamPage <- fetch "/streams/orders-1/events?limit=2" + map (field "streamVersion") (items (body streamPage)) `shouldBe` [Just (Number 1), Just (Number 2)] + field "next_cursor" (body streamPage) `shouldBe` Just (Number 2) + continuation <- fetch "/streams/orders-1/events?from=2&limit=2" + map (field "streamVersion") (items (body continuation)) `shouldBe` [Just (Number 3)] + backward <- fetch "/streams/orders-1/events?direction=backward" + map (field "streamVersion") (items (body backward)) `shouldBe` map (Just . Number) [3, 2, 1] + cats <- fetch "/categories" + map (field "name") (items (body cats)) `shouldBe` [Just (String "orders"), Just (String "shipments")] + categoryEvents <- fetch "/categories/orders/events" + length (items (body categoryEvents)) `shouldBe` 4 + globals <- fetch "/events?from=3" + map (field "globalPosition") (items (body globals)) `shouldBe` [Just (Number 4), Just (Number 5)] + map (field "original_stream_name") (items (body globals)) `shouldBe` [Just (String "orders-2"), Just (String "shipments-1")] + reverseGlobal <- fetch "/events?direction=backward&limit=2" + map (field "globalPosition") (items (body reverseGlobal)) `shouldBe` [Just (Number 5), Just (Number 4)] + Right recorded <- Store.runStoreIO store $ Store.readAllForward (Store.GlobalPosition 0) 10 + let Store.EventId uuid = V.head recorded ^. #eventId + event <- fetch ("/events/" <> show uuid) + HTTP.responseStatus event `shouldBe` status200 + field "original_stream_name" (body event) `shouldBe` Just (String "orders-1") + forM_ ["/streams/missing", "/streams/missing/events", "/events/00000000-0000-0000-0000-000000000000", "/streams/unknown/path"] $ \path -> do + response <- fetch path + HTTP.responseStatus response `shouldBe` status404 + -- Summary JSON and legacy endpoints remain independently mounted. + legacy <- fetch "/nope" + body legacy `shouldBe` object ["error" .= ("Not found" :: Text)] + it "keeps prefix-mounted browse routes and CORS active when legacy JSON and WebSockets are disabled" $ do + metrics <- newKirokuMetricsWith (pure (Store.GlobalPosition 0)) (pure 0) + let origin = either (error . show) (\value -> value) (allowedOrigin "https://ops.example.com") + cors = corsAllowOrigins [origin] + browser = StoreBrowser (\_ -> pure (Left (Store.ConnectionError "secret"))) defaultBrowseLimits + config = defaultConfig {cors, enableJSON = False, enableWebSocket = False} + providers = defaultServerProviders {storeBrowsing = Just browser} + mounted req respond = combinedAppWithProviders config metrics [] providers (req {Wai.pathInfo = drop 1 (Wai.pathInfo req)}) respond + Warp.testWithApplication (pure mounted) $ \port -> do + manager <- HTTP.newManager HTTP.defaultManagerSettings + request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/inspect/events?from=0") + response <- HTTP.httpLbs request {HTTP.requestHeaders = [("Origin", "https://ops.example.com")]} manager + HTTP.responseStatus response `shouldBe` status503 + lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response) `shouldBe` Just "https://ops.example.com" + code (HTTP.responseBody response) `shouldBe` Just "store_unavailable" + it "trims over-fetch before one distinct-name lookup and skips it on empty pages" $ withTestStore $ \store -> do + append store "orders-1" 2 + append store "orders-2" 1 + Right events <- Store.runStoreIO store $ Store.readAllForward (Store.GlobalPosition 0) 10 + calls <- newIORef ([] :: [[Store.StreamId]]) + let interpreter :: forall a. Eff '[Store, Error Store.StoreError, IOE] a -> Eff '[Error Store.StoreError, IOE] a + interpreter = interpret_ $ \case + ReadAllForward (Store.GlobalPosition cursor) limit -> pure $ V.take (fromIntegral limit) $ V.filter (\event -> let Store.GlobalPosition n = event ^. #globalPosition in n > cursor) events + LookupStreamNames ids -> liftIO (modifyIORef' calls (<> [ids])) >> pure Map.empty + _ -> error "unexpected browse mock operation" + browser = StoreBrowser (runEff . runErrorNoCallStack . interpreter) defaultBrowseLimits + Warp.testWithApplication (pure (browseApp browser)) $ \port -> do + response <- get port "/events?limit=2" + map (field "original_stream_name") (items (body response)) `shouldBe` [Just Null, Just Null] + _ <- get port "/events?from=3" + pure () + readIORef calls `shouldReturn` [[V.head events ^. #originalStreamId]] withTestStore :: (Store.KirokuStore -> IO ()) -> IO () withTestStore action = withMigratedTestDatabase $ \connection -> Store.withStore (Store.defaultConnectionSettings connection) action + append :: Store.KirokuStore -> Text -> Int -> IO () append store name count = do - let event = Store.EventData Nothing (Store.EventType "Created") (object []) Nothing Nothing Nothing - result <- Store.runStoreIO store $ Store.appendToStream (Store.StreamName name) Store.NoStream (replicate count event) - result `shouldSatisfy` either (const False) (const True) + let event = Store.EventData Nothing (Store.EventType "Created") (object []) Nothing Nothing Nothing + result <- Store.runStoreIO store $ Store.appendToStream (Store.StreamName name) Store.NoStream (replicate count event) + result `shouldSatisfy` either (const False) (const True) + get :: Int -> String -> IO (HTTP.Response LBS.ByteString) get port path = do - manager <- HTTP.newManager HTTP.defaultManagerSettings - request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) - HTTP.httpLbs request manager + manager <- HTTP.newManager HTTP.defaultManagerSettings + request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) + HTTP.httpLbs request manager + body :: HTTP.Response LBS.ByteString -> Value body response = maybe (error "Invalid JSON response") (\value -> value) (Aeson.decode (HTTP.responseBody response)) + field :: Aeson.Key -> Value -> Maybe Value field key (Object objectValue) = KM.lookup key objectValue field _ _ = Nothing + items :: Value -> [Value] items value = case field "items" value of Just (Array rows) -> V.toList rows; _ -> error "Expected items" + code :: LBS.ByteString -> Maybe Text code bytes = do - value <- Aeson.decode bytes - err <- field "error" value - String actual <- field "code" err - pure actual + value <- Aeson.decode bytes + err <- field "error" value + String actual <- field "code" err + pure actual + capture :: Wai.Application -> Method -> [Text] -> IO (Status, ResponseHeaders, LBS.ByteString) capture app method path = do - result <- newIORef Nothing - _ <- app Wai.defaultRequest{Wai.requestMethod = method, Wai.pathInfo = path} $ \response -> do - let (status, headers, stream) = Wai.responseToStream response - stream $ \send -> do - chunks <- newIORef [] - send (\chunk -> modifyIORef' chunks (<> [toLazyByteString chunk])) (pure ()) - bytes <- mconcat <$> readIORef chunks - modifyIORef' result (const (Just (status, headers, bytes))) - pure ResponseReceived - maybe (error "No response") (\value -> pure value) =<< readIORef result + result <- newIORef Nothing + _ <- app Wai.defaultRequest {Wai.requestMethod = method, Wai.pathInfo = path} $ \response -> do + let (status, headers, stream) = Wai.responseToStream response + stream $ \send -> do + chunks <- newIORef [] + send (\chunk -> modifyIORef' chunks (<> [toLazyByteString chunk])) (pure ()) + bytes <- mconcat <$> readIORef chunks + modifyIORef' result (const (Just (status, headers, bytes))) + pure ResponseReceived + maybe (error "No response") (\value -> pure value) =<< readIORef result diff --git a/test/Test/CapabilitiesSpec.hs b/test/Test/CapabilitiesSpec.hs --- a/test/Test/CapabilitiesSpec.hs +++ b/test/Test/CapabilitiesSpec.hs @@ -30,138 +30,138 @@ spec :: Spec spec = describe "Kiroku.Metrics.Capabilities" $ do - it "pins every wire key, includes Prometheus as process-local, and round-trips" $ do - let caps = capabilitiesFor defaultConfig allPresent - keys = ["metrics", "prometheus", "health", "subscriptions_live", "subscriptions_checkpoints", "dead_letters", "browse", "websocket_metrics", "websocket_events"] - A.toJSON caps - `shouldBe` A.object - [ "package" A..= ("kiroku-metrics" :: Text) - , "version" A..= kirokuMetricsVersion - , "routes" A..= A.object [key A..= True | key <- keys] - , "cors" A..= A.object ["enabled" A..= False] - , "process_local" A..= (["metrics", "prometheus", "health", "subscriptions_live", "websocket_metrics"] :: [Text]) - ] - A.eitherDecode (A.encode caps) `shouldBe` Right caps - kirokuMetricsVersion `shouldSatisfy` (T.isInfixOf ".") - it "derives availability from wiring and switches without invoking any provider" $ do - let plain = capabilitiesFor defaultConfig none - off = capabilitiesFor defaultConfig{enableJSON = False, enablePrometheus = False, enableWebSocket = False} allPresent - plain.routes `shouldBe` RouteAvailability True True True False False False False False False - off.routes `shouldBe` RouteAvailability False False False True True True True False False - origin <- either (fail . show) pure (allowedOrigin "http://a") - (capabilitiesFor defaultConfig{cors = corsAllowOrigins [origin]} none).corsIsEnabled `shouldBe` True - let providers = - defaultServerProviders - { subscriptionStatus = Just (fail "Discovery invoked live provider") - , checkpointInventory = Just (fail "Discovery invoked checkpoint provider") - , storeBrowsing = Just (StoreBrowser (\_ -> fail "Discovery invoked browse provider") defaultBrowseLimits) - , deadLetters = Just (\_ -> fail "Discovery invoked dead-letter provider") - } - m <- emptyMetrics - Warp.testWithApplication (pure (httpAppWithProviders defaultConfig m [] providers)) $ \port -> do - caps <- getCaps port - caps.routes.subscriptionsLive `shouldBe` True - caps.routes.subscriptionsCheckpoints `shouldBe` True - caps.routes.browse `shouldBe` True - caps.routes.deadLetters `shouldBe` True - it "implements GET, bodyless HEAD, exact path and 405 in direct WAI" $ do - let app = capabilitiesApp (capabilitiesFor defaultConfig none) - (s, h, b) <- capture app "GET" ["capabilities"] - s `shouldBe` status200 - capture app "HEAD" ["capabilities"] `shouldReturn` (s, h, "") - b `shouldBe` A.encode (capabilitiesFor defaultConfig none) - forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do - (status, headers, errorBody) <- capture app method ["capabilities"] - status `shouldBe` status405 - errorCode errorBody `shouldBe` Just "method_not_allowed" - lookup "Allow" headers `shouldBe` Just "GET, HEAD" - (unknown, unknownHeaders, unknownBody) <- capture app "GET" ["capabilities", "x"] - unknown `shouldBe` status404 - errorCode unknownBody `shouldBe` Just "not_found" - capture app "HEAD" ["capabilities", "x"] `shouldReturn` (unknown, unknownHeaders, "") - it "reports plain/stub servers honestly and remains reachable with every switch off" $ do - m <- emptyMetrics - forM_ [defaultConfig{port = 0}, defaultConfig{port = 0, enableJSON = False, enablePrometheus = False, enableWebSocket = False}] $ \cfg -> - withMetricsServer cfg m [] $ \server -> do - caps <- getCaps server.serverPort - caps `shouldBe` capabilitiesFor cfg none - it "reports all store providers and the legacy store starter's absent live registry" $ - withMigratedTestDatabase $ \url -> Store.withStore (Store.defaultConnectionSettings url) $ \store -> do - m <- emptyMetrics - let cfg = defaultConfig{port = 0} - providers <- storeServerProviders cfg m store - withMetricsServerWithProviders cfg m [] providers $ \server -> do - getCaps server.serverPort `shouldReturn` capabilitiesFor cfg allPresent - forM_ ["/metrics", "/metrics/prometheus", "/health", "/subscriptions", "/subscription-checkpoints", "/streams", "/subscriptions/missing/dead-letters"] $ \path -> - HTTP.responseStatus <$> get server.serverPort path `shouldReturn` status200 - forM_ ["/ws/metrics", "/ws/events"] $ \path -> - bounded (WS.runClient "127.0.0.1" server.serverPort path (\conn -> WS.sendClose conn ("done" :: Text))) - withMetricsServerWithStore cfg m store [] $ \server -> do - caps <- getCaps server.serverPort - caps.routes.subscriptionsLive `shouldBe` False - caps.routes.websocketMetrics `shouldBe` True - caps.routes.websocketEvents `shouldBe` True - it "honours custom declarations, refuses disabled upgrades and keeps legacy opaque apps conservative" $ do - m <- emptyMetrics - let ws connectionRequest = WS.acceptRequest connectionRequest >>= \conn -> WS.sendTextData conn ("ok" :: Text) - providers = defaultServerProviders{webSocketServer = ws, webSocketChannels = WebSocketChannels False True} - forM_ [True, False] $ \enabled -> do - let cfg = defaultConfig{port = 0, enableWebSocket = enabled} - withMetricsServerWithProviders cfg m [] providers $ \server -> do - caps <- getCaps server.serverPort - caps.routes.websocketEvents `shouldBe` enabled - result <- bounded (try (WS.runClient "127.0.0.1" server.serverPort "/ws/events" (\conn -> WS.receiveData conn :: IO Text)) :: IO (Either SomeException Text)) - if enabled then either (fail . show) (`shouldBe` "ok") result else result `shouldSatisfy` isLeft - let cfg = defaultConfig{port = 0} - Warp.testWithApplication (pure (combinedApp cfg m [] Nothing ws)) $ \port -> do - caps <- getCaps port - caps.routes.websocketEvents `shouldBe` False - it "serves discovery behind a mount prefix and preserves the configured CORS policy" $ do - m <- emptyMetrics - origin <- either (fail . show) pure (allowedOrigin "http://a") - let cfg = defaultConfig{cors = corsAllowOrigins [origin]} - mounted req = combinedAppWithProviders cfg m [] defaultServerProviders req{Wai.pathInfo = drop 1 (Wai.pathInfo req)} - Warp.testWithApplication (pure mounted) $ \port -> do - manager <- HTTP.newManager HTTP.defaultManagerSettings - req <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/kiroku/capabilities") - response <- HTTP.httpLbs req{HTTP.requestHeaders = [("Origin", "http://a")]} manager - HTTP.responseStatus response `shouldBe` status200 - lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response) `shouldBe` Just "http://a" - A.eitherDecode (HTTP.responseBody response) `shouldBe` Right (capabilitiesFor cfg none) + it "pins every wire key, includes Prometheus as process-local, and round-trips" $ do + let caps = capabilitiesFor defaultConfig allPresent + keys = ["metrics", "prometheus", "health", "subscriptions_live", "subscriptions_checkpoints", "dead_letters", "browse", "websocket_metrics", "websocket_events"] + A.toJSON caps + `shouldBe` A.object + [ "package" A..= ("kiroku-metrics" :: Text), + "version" A..= kirokuMetricsVersion, + "routes" A..= A.object [key A..= True | key <- keys], + "cors" A..= A.object ["enabled" A..= False], + "process_local" A..= (["metrics", "prometheus", "health", "subscriptions_live", "websocket_metrics"] :: [Text]) + ] + A.eitherDecode (A.encode caps) `shouldBe` Right caps + kirokuMetricsVersion `shouldSatisfy` (T.isInfixOf ".") + it "derives availability from wiring and switches without invoking any provider" $ do + let plain = capabilitiesFor defaultConfig none + off = capabilitiesFor defaultConfig {enableJSON = False, enablePrometheus = False, enableWebSocket = False} allPresent + plain.routes `shouldBe` RouteAvailability True True True False False False False False False + off.routes `shouldBe` RouteAvailability False False False True True True True False False + origin <- either (fail . show) pure (allowedOrigin "http://a") + (capabilitiesFor defaultConfig {cors = corsAllowOrigins [origin]} none).corsIsEnabled `shouldBe` True + let providers = + defaultServerProviders + { subscriptionStatus = Just (fail "Discovery invoked live provider"), + checkpointInventory = Just (fail "Discovery invoked checkpoint provider"), + storeBrowsing = Just (StoreBrowser (\_ -> fail "Discovery invoked browse provider") defaultBrowseLimits), + deadLetters = Just (\_ -> fail "Discovery invoked dead-letter provider") + } + m <- emptyMetrics + Warp.testWithApplication (pure (httpAppWithProviders defaultConfig m [] providers)) $ \port -> do + caps <- getCaps port + caps.routes.subscriptionsLive `shouldBe` True + caps.routes.subscriptionsCheckpoints `shouldBe` True + caps.routes.browse `shouldBe` True + caps.routes.deadLetters `shouldBe` True + it "implements GET, bodyless HEAD, exact path and 405 in direct WAI" $ do + let app = capabilitiesApp (capabilitiesFor defaultConfig none) + (s, h, b) <- capture app "GET" ["capabilities"] + s `shouldBe` status200 + capture app "HEAD" ["capabilities"] `shouldReturn` (s, h, "") + b `shouldBe` A.encode (capabilitiesFor defaultConfig none) + forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do + (status, headers, errorBody) <- capture app method ["capabilities"] + status `shouldBe` status405 + errorCode errorBody `shouldBe` Just "method_not_allowed" + lookup "Allow" headers `shouldBe` Just "GET, HEAD" + (unknown, unknownHeaders, unknownBody) <- capture app "GET" ["capabilities", "x"] + unknown `shouldBe` status404 + errorCode unknownBody `shouldBe` Just "not_found" + capture app "HEAD" ["capabilities", "x"] `shouldReturn` (unknown, unknownHeaders, "") + it "reports plain/stub servers honestly and remains reachable with every switch off" $ do + m <- emptyMetrics + forM_ [defaultConfig {port = 0}, defaultConfig {port = 0, enableJSON = False, enablePrometheus = False, enableWebSocket = False}] $ \cfg -> + withMetricsServer cfg m [] $ \server -> do + caps <- getCaps server.serverPort + caps `shouldBe` capabilitiesFor cfg none + it "reports all store providers and the legacy store starter's absent live registry" $ + withMigratedTestDatabase $ \url -> Store.withStore (Store.defaultConnectionSettings url) $ \store -> do + m <- emptyMetrics + let cfg = defaultConfig {port = 0} + providers <- storeServerProviders cfg m store + withMetricsServerWithProviders cfg m [] providers $ \server -> do + getCaps server.serverPort `shouldReturn` capabilitiesFor cfg allPresent + forM_ ["/metrics", "/metrics/prometheus", "/health", "/subscriptions", "/subscription-checkpoints", "/streams", "/subscriptions/missing/dead-letters"] $ \path -> + HTTP.responseStatus <$> get server.serverPort path `shouldReturn` status200 + forM_ ["/ws/metrics", "/ws/events"] $ \path -> + bounded (WS.runClient "127.0.0.1" server.serverPort path (\conn -> WS.sendClose conn ("done" :: Text))) + withMetricsServerWithStore cfg m store [] $ \server -> do + caps <- getCaps server.serverPort + caps.routes.subscriptionsLive `shouldBe` False + caps.routes.websocketMetrics `shouldBe` True + caps.routes.websocketEvents `shouldBe` True + it "honours custom declarations, refuses disabled upgrades and keeps legacy opaque apps conservative" $ do + m <- emptyMetrics + let ws connectionRequest = WS.acceptRequest connectionRequest >>= \conn -> WS.sendTextData conn ("ok" :: Text) + providers = defaultServerProviders {webSocketServer = ws, webSocketChannels = WebSocketChannels False True} + forM_ [True, False] $ \enabled -> do + let cfg = defaultConfig {port = 0, enableWebSocket = enabled} + withMetricsServerWithProviders cfg m [] providers $ \server -> do + caps <- getCaps server.serverPort + caps.routes.websocketEvents `shouldBe` enabled + result <- bounded (try (WS.runClient "127.0.0.1" server.serverPort "/ws/events" (\conn -> WS.receiveData conn :: IO Text)) :: IO (Either SomeException Text)) + if enabled then either (fail . show) (`shouldBe` "ok") result else result `shouldSatisfy` isLeft + let cfg = defaultConfig {port = 0} + Warp.testWithApplication (pure (combinedApp cfg m [] Nothing ws)) $ \port -> do + caps <- getCaps port + caps.routes.websocketEvents `shouldBe` False + it "serves discovery behind a mount prefix and preserves the configured CORS policy" $ do + m <- emptyMetrics + origin <- either (fail . show) pure (allowedOrigin "http://a") + let cfg = defaultConfig {cors = corsAllowOrigins [origin]} + mounted req = combinedAppWithProviders cfg m [] defaultServerProviders req {Wai.pathInfo = drop 1 (Wai.pathInfo req)} + Warp.testWithApplication (pure mounted) $ \port -> do + manager <- HTTP.newManager HTTP.defaultManagerSettings + req <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/kiroku/capabilities") + response <- HTTP.httpLbs req {HTTP.requestHeaders = [("Origin", "http://a")]} manager + HTTP.responseStatus response `shouldBe` status200 + lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response) `shouldBe` Just "http://a" + A.eitherDecode (HTTP.responseBody response) `shouldBe` Right (capabilitiesFor cfg none) emptyMetrics :: IO KirokuMetrics emptyMetrics = newKirokuMetricsWith (pure (Store.GlobalPosition 0)) (pure 0) get :: Int -> String -> IO (HTTP.Response LBS.ByteString) get port path = do - manager <- HTTP.newManager HTTP.defaultManagerSettings - req <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) - HTTP.httpLbs req manager + manager <- HTTP.newManager HTTP.defaultManagerSettings + req <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) + HTTP.httpLbs req manager getCaps :: Int -> IO Capabilities getCaps port = do - response <- get port "/capabilities" - HTTP.responseStatus response `shouldBe` status200 - either fail pure (A.eitherDecode (HTTP.responseBody response)) + response <- get port "/capabilities" + HTTP.responseStatus response `shouldBe` status200 + either fail pure (A.eitherDecode (HTTP.responseBody response)) capture :: Wai.Application -> Method -> [Text] -> IO (Status, ResponseHeaders, LBS.ByteString) capture app method path = do - result <- newIORef Nothing - _ <- app Wai.defaultRequest{Wai.requestMethod = method, Wai.pathInfo = path} $ \response -> do - let (status, headers, stream) = Wai.responseToStream response - chunks <- newIORef mempty - stream $ \body -> body (\builder -> modifyIORef' chunks (<> builder)) (pure ()) - bytes <- toLazyByteString <$> readIORef chunks - writeIORef result (Just (status, headers, bytes)) - pure ResponseReceived - readIORef result >>= maybe (fail "No response") pure + result <- newIORef Nothing + _ <- app Wai.defaultRequest {Wai.requestMethod = method, Wai.pathInfo = path} $ \response -> do + let (status, headers, stream) = Wai.responseToStream response + chunks <- newIORef mempty + stream $ \body -> body (\builder -> modifyIORef' chunks (<> builder)) (pure ()) + bytes <- toLazyByteString <$> readIORef chunks + writeIORef result (Just (status, headers, bytes)) + pure ResponseReceived + readIORef result >>= maybe (fail "No response") pure bounded :: IO a -> IO a bounded action = timeout 15_000_000 action >>= maybe (fail "Timed out") pure errorCode :: LBS.ByteString -> Maybe Text errorCode body = do - A.Object root <- A.decode body - A.Object err <- KM.lookup "error" root - A.String code <- KM.lookup "code" err - pure code + A.Object root <- A.decode body + A.Object err <- KM.lookup "error" root + A.String code <- KM.lookup "code" err + pure code diff --git a/test/Test/CheckpointsSpec.hs b/test/Test/CheckpointsSpec.hs --- a/test/Test/CheckpointsSpec.hs +++ b/test/Test/CheckpointsSpec.hs @@ -53,268 +53,268 @@ spec :: Spec spec = describe "Kiroku.Metrics.Checkpoints (/subscription-checkpoints)" $ do - it "pins exact snake_case keys, preserves row order and round-trips lossless Int64 positions" $ do - let response = checkpointInventoryResponse fixture - row name index cp = Aeson.object ["subscription" Aeson..= (name :: Text), "member" Aeson..= (index :: Int32), "checkpoint_position" Aeson..= (cp :: Int64), "updated_at" Aeson..= ("2026-09-10T00:00:00Z" :: Text)] - Aeson.toJSON response `shouldBe` Aeson.object ["store_position" Aeson..= (17 :: Int64), "checkpoints" Aeson..= [row "beta" 1 11, row "alpha" 0 7]] - Aeson.eitherDecode (Aeson.encode response) `shouldBe` Right response - let large = CheckpointInventoryResponse maxBound [CheckpointRow "large" 0 9007199254740993 (UTCTime (fromGregorian 2026 9 10) 0)] - Aeson.eitherDecode (Aeson.encode large) `shouldBe` Right large - it "serves an inventory and a structured standalone 404" $ - Warp.testWithApplication (pure (checkpointsApp (pure (Right fixture)))) $ \port -> do - manager <- HTTP.newManager HTTP.defaultManagerSettings - request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/subscription-checkpoints") - response <- HTTP.httpLbs request manager - HTTP.responseStatus response `shouldBe` status200 - Aeson.eitherDecode (HTTP.responseBody response) `shouldBe` Right (checkpointInventoryResponse fixture) - unknown <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/unknown") >>= flip HTTP.httpLbs manager - HTTP.responseStatus unknown `shouldBe` status404 - Aeson.decode (HTTP.responseBody unknown) `shouldBe` Just (Aeson.object ["error" Aeson..= Aeson.object ["code" Aeson..= ("not_found" :: Text), "message" Aeson..= ("Not found" :: Text)]]) - - it "implements HEAD and 405 directly in WAI and calls the provider once per read" $ do - calls <- newIORef (0 :: Int) - let app = checkpointsApp (modifyIORef' calls (+ 1) >> pure (Right fixture)) - getResponse <- capture app "GET" - (headStatus, headHeaders, headBody) <- capture app "HEAD" - let (getStatus, getHeaders, _) = getResponse - headStatus `shouldBe` getStatus - headHeaders `shouldBe` getHeaders - headBody `shouldBe` "" - forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do - (status, headers, body) <- capture app method - status `shouldBe` status405 - lookup "Allow" headers `shouldBe` Just "GET, HEAD" - code body `shouldBe` Just "method_not_allowed" - readIORef calls `shouldReturn` 2 + it "pins exact snake_case keys, preserves row order and round-trips lossless Int64 positions" $ do + let response = checkpointInventoryResponse fixture + row name index cp = Aeson.object ["subscription" Aeson..= (name :: Text), "member" Aeson..= (index :: Int32), "checkpoint_position" Aeson..= (cp :: Int64), "updated_at" Aeson..= ("2026-09-10T00:00:00Z" :: Text)] + Aeson.toJSON response `shouldBe` Aeson.object ["store_position" Aeson..= (17 :: Int64), "checkpoints" Aeson..= [row "beta" 1 11, row "alpha" 0 7]] + Aeson.eitherDecode (Aeson.encode response) `shouldBe` Right response + let large = CheckpointInventoryResponse maxBound [CheckpointRow "large" 0 9007199254740993 (UTCTime (fromGregorian 2026 9 10) 0)] + Aeson.eitherDecode (Aeson.encode large) `shouldBe` Right large + it "serves an inventory and a structured standalone 404" $ + Warp.testWithApplication (pure (checkpointsApp (pure (Right fixture)))) $ \port -> do + manager <- HTTP.newManager HTTP.defaultManagerSettings + request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/subscription-checkpoints") + response <- HTTP.httpLbs request manager + HTTP.responseStatus response `shouldBe` status200 + Aeson.eitherDecode (HTTP.responseBody response) `shouldBe` Right (checkpointInventoryResponse fixture) + unknown <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/unknown") >>= flip HTTP.httpLbs manager + HTTP.responseStatus unknown `shouldBe` status404 + Aeson.decode (HTTP.responseBody unknown) `shouldBe` Just (Aeson.object ["error" Aeson..= Aeson.object ["code" Aeson..= ("not_found" :: Text), "message" Aeson..= ("Not found" :: Text)]]) - it "sanitizes typed failures and preserves HEAD error status and headers" $ do - let failures = [(Store.ConnectionError "postgres://secret", status503, "checkpoint_inventory_unavailable"), (Store.ConnectionLost "secret", status503, "checkpoint_inventory_unavailable"), (Store.PoolAcquisitionTimeout, status503, "checkpoint_inventory_unavailable"), (Store.TransientTransactionFailure "40001" "secret", status503, "checkpoint_inventory_unavailable"), (Store.TransientTransactionFailure "40P01" "secret", status503, "checkpoint_inventory_unavailable"), (Store.UnexpectedServerError "42P01" "secret SQL", status500, "store_error"), (Store.StreamNotFound (Store.StreamName "secret"), status500, "store_error"), (Store.EventDecodeFailed (DecodeFailure (Store.EventId UUID.nil) "secret"), status500, "event_decode_failed")] - forM_ failures $ \(err, expected, expectedCode) -> do - let app = checkpointsApp (pure (Left err)) - (status, headers, body) <- capture app "GET" - status `shouldBe` expected - code body `shouldBe` Just expectedCode - body `shouldSatisfy` (not . T.isInfixOf "secret" . T.pack . LBSC.unpack) - capture app "HEAD" `shouldReturn` (status, headers, "") + it "implements HEAD and 405 directly in WAI and calls the provider once per read" $ do + calls <- newIORef (0 :: Int) + let app = checkpointsApp (modifyIORef' calls (+ 1) >> pure (Right fixture)) + getResponse <- capture app "GET" + (headStatus, headHeaders, headBody) <- capture app "HEAD" + let (getStatus, getHeaders, _) = getResponse + headStatus `shouldBe` getStatus + headHeaders `shouldBe` getHeaders + headBody `shouldBe` "" + forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do + (status, headers, body) <- capture app method + status `shouldBe` status405 + lookup "Allow" headers `shouldBe` Just "GET, HEAD" + code body `shouldBe` Just "method_not_allowed" + readIORef calls `shouldReturn` 2 - it "does not disguise thrown provider exceptions or cancellation as store errors" $ do - capture (checkpointsApp (throwIO (userError "provider failed"))) "GET" `shouldThrow` anyIOException - capture (checkpointsApp (throwIO Async.AsyncCancelled)) "GET" `shouldThrow` (\(_ :: Async.AsyncCancelled) -> True) + it "sanitizes typed failures and preserves HEAD error status and headers" $ do + let failures = [(Store.ConnectionError "postgres://secret", status503, "checkpoint_inventory_unavailable"), (Store.ConnectionLost "secret", status503, "checkpoint_inventory_unavailable"), (Store.PoolAcquisitionTimeout, status503, "checkpoint_inventory_unavailable"), (Store.TransientTransactionFailure "40001" "secret", status503, "checkpoint_inventory_unavailable"), (Store.TransientTransactionFailure "40P01" "secret", status503, "checkpoint_inventory_unavailable"), (Store.UnexpectedServerError "42P01" "secret SQL", status500, "store_error"), (Store.StreamNotFound (Store.StreamName "secret"), status500, "store_error"), (Store.EventDecodeFailed (DecodeFailure (Store.EventId UUID.nil) "secret"), status500, "event_decode_failed")] + forM_ failures $ \(err, expected, expectedCode) -> do + let app = checkpointsApp (pure (Left err)) + (status, headers, body) <- capture app "GET" + status `shouldBe` expected + code body `shouldBe` Just expectedCode + body `shouldSatisfy` (not . T.isInfixOf "secret" . T.pack . LBSC.unpack) + capture app "HEAD" `shouldReturn` (status, headers, "") - it "keeps a stopped worker durable after its live registry entry disappears" $ - withTestStore $ \store -> do - append store 3 - let name = Store.SubscriptionName "durable-vs-live" - handle <- Store.subscribe store (Store.defaultSubscriptionConfig name Store.AllStreams (\_ -> pure Store.Continue)) - awaitLive store name - Store.cancel handle - stopped <- timeout 10_000_000 (Store.wait handle) - stopped `shouldSatisfy` isJust - states <- Store.subscriptionStates store - Map.member (name, 0) states `shouldBe` False - metrics <- newKirokuMetrics store - let cfg = defaultConfig{port = 0} - providers <- storeServerProviders cfg metrics store - withMetricsServerWithProviders cfg metrics [] providers $ \server -> do - live <- get server.serverPort "/subscriptions" - HTTP.responseStatus live `shouldBe` status200 - Aeson.decode (HTTP.responseBody live) `shouldBe` Just ([] :: [SubscriptionStatusRow]) - inventory <- getInventory server.serverPort - inventory.storePosition `shouldBe` 3 - triples inventory `shouldBe` [("durable-vs-live", 0, 3)] + it "does not disguise thrown provider exceptions or cancellation as store errors" $ do + capture (checkpointsApp (throwIO (userError "provider failed"))) "GET" `shouldThrow` anyIOException + capture (checkpointsApp (throwIO Async.AsyncCancelled)) "GET" `shouldThrow` (\(_ :: Async.AsyncCancelled) -> True) - it "preserves SQL name and numeric member ordering with the captured frontier" $ - withTestStore $ \store -> do - append store 20 - seed store "zeta" 2 7 - seed store "alpha" 10 3 - seed store "alpha" 2 5 - metrics <- newKirokuMetrics store - withMetricsServerWithStore defaultConfig{port = 0} metrics store [] $ \server -> do - inventory <- getInventory server.serverPort - inventory.storePosition `shouldBe` 20 - triples inventory `shouldBe` [("alpha", 2, 5), ("alpha", 10, 3), ("zeta", 2, 7)] + it "keeps a stopped worker durable after its live registry entry disappears" $ + withTestStore $ \store -> do + append store 3 + let name = Store.SubscriptionName "durable-vs-live" + handle <- Store.subscribe store (Store.defaultSubscriptionConfig name Store.AllStreams (\_ -> pure Store.Continue)) + awaitLive store name + Store.cancel handle + stopped <- timeout 10_000_000 (Store.wait handle) + stopped `shouldSatisfy` isJust + states <- Store.subscriptionStates store + Map.member (name, 0) states `shouldBe` False + metrics <- newKirokuMetrics store + let cfg = defaultConfig {port = 0} + providers <- storeServerProviders cfg metrics store + withMetricsServerWithProviders cfg metrics [] providers $ \server -> do + live <- get server.serverPort "/subscriptions" + HTTP.responseStatus live `shouldBe` status200 + Aeson.decode (HTTP.responseBody live) `shouldBe` Just ([] :: [SubscriptionStatusRow]) + inventory <- getInventory server.serverPort + inventory.storePosition `shouldBe` 3 + triples inventory `shouldBe` [("durable-vs-live", 0, 3)] - it "returns equal quiescent inventories across handles with different live providers" $ - withMigratedTestDatabase $ \connStr -> - Store.withStore (Store.defaultConnectionSettings connStr) $ \storeA -> - Store.withStore (Store.defaultConnectionSettings connStr) $ \storeB -> do - append storeA 3 - let name = Store.SubscriptionName "worker-a" - handle <- Store.subscribe storeA (Store.defaultSubscriptionConfig name Store.AllStreams (\_ -> pure Store.Continue)) - awaitLive storeA name - seed storeB "worker-b" 0 2 - metricsA <- newKirokuMetrics storeA - metricsB <- newKirokuMetrics storeB - let cfg = defaultConfig{port = 0} - providersA <- storeServerProviders cfg metricsA storeA - providersB <- storeServerProviders cfg metricsB storeB - withMetricsServerWithProviders cfg metricsA [] providersA $ \serverA -> - withMetricsServerWithProviders cfg metricsB [] providersB $ \serverB -> do - liveBodyA <- HTTP.responseBody <$> get serverA.serverPort "/subscriptions" - liveBodyB <- HTTP.responseBody <$> get serverB.serverPort "/subscriptions" - liveBodyA `shouldNotBe` liveBodyB - -- Stop the worker before comparing separate SQL snapshots. - Store.cancel handle - _ <- Store.wait handle - a <- getInventory serverA.serverPort - b <- getInventory serverB.serverPort - a `shouldBe` b + it "preserves SQL name and numeric member ordering with the captured frontier" $ + withTestStore $ \store -> do + append store 20 + seed store "zeta" 2 7 + seed store "alpha" 10 3 + seed store "alpha" 2 5 + metrics <- newKirokuMetrics store + withMetricsServerWithStore defaultConfig {port = 0} metrics store [] $ \server -> do + inventory <- getInventory server.serverPort + inventory.storePosition `shouldBe` 20 + triples inventory `shouldBe` [("alpha", 2, 5), ("alpha", 10, 3), ("zeta", 2, 7)] - it "serves an empty store without changing the legacy unconfigured live response" $ - withTestStore $ \store -> do - metrics <- newKirokuMetrics store - withMetricsServerWithStore defaultConfig{port = 0} metrics store [] $ \server -> do - getInventory server.serverPort `shouldReturn` CheckpointInventoryResponse 0 [] - live <- get server.serverPort "/subscriptions" - HTTP.responseStatus live `shouldBe` status404 - Aeson.decode (HTTP.responseBody live) `shouldBe` Just (Aeson.object ["error" Aeson..= ("subscription status not configured" :: Text)]) + it "returns equal quiescent inventories across handles with different live providers" $ + withMigratedTestDatabase $ \connStr -> + Store.withStore (Store.defaultConnectionSettings connStr) $ \storeA -> + Store.withStore (Store.defaultConnectionSettings connStr) $ \storeB -> do + append storeA 3 + let name = Store.SubscriptionName "worker-a" + handle <- Store.subscribe storeA (Store.defaultSubscriptionConfig name Store.AllStreams (\_ -> pure Store.Continue)) + awaitLive storeA name + seed storeB "worker-b" 0 2 + metricsA <- newKirokuMetrics storeA + metricsB <- newKirokuMetrics storeB + let cfg = defaultConfig {port = 0} + providersA <- storeServerProviders cfg metricsA storeA + providersB <- storeServerProviders cfg metricsB storeB + withMetricsServerWithProviders cfg metricsA [] providersA $ \serverA -> + withMetricsServerWithProviders cfg metricsB [] providersB $ \serverB -> do + liveBodyA <- HTTP.responseBody <$> get serverA.serverPort "/subscriptions" + liveBodyB <- HTTP.responseBody <$> get serverB.serverPort "/subscriptions" + liveBodyA `shouldNotBe` liveBodyB + -- Stop the worker before comparing separate SQL snapshots. + Store.cancel handle + _ <- Store.wait handle + a <- getInventory serverA.serverPort + b <- getInventory serverB.serverPort + a `shouldBe` b - it "returns structured not-configured errors without shadowing a live name checkpoints" $ do - metrics <- emptyMetrics - let live = pure [SubscriptionStatusRow "checkpoints" 0 "live" 7] - withMetricsServerSubscriptions defaultConfig{port = 0} metrics [] live $ \server -> do - inventory <- get server.serverPort "/subscription-checkpoints" - HTTP.responseStatus inventory `shouldBe` status404 - code (HTTP.responseBody inventory) `shouldBe` Just "checkpoint_inventory_not_configured" - named <- get server.serverPort "/subscriptions/checkpoints" - HTTP.responseStatus named `shouldBe` status200 - Aeson.decode (HTTP.responseBody named) `shouldBe` Just [SubscriptionStatusRow "checkpoints" 0 "live" 7] - let app = httpAppWithProviders defaultConfig metrics [] defaultServerProviders - (status, headers, _) <- capture app "GET" - capture app "HEAD" `shouldReturn` (status, headers, "") - (methodStatus, methodHeaders, _) <- capture app "POST" - methodStatus `shouldBe` status405 - lookup "Allow" methodHeaders `shouldBe` Just "GET, HEAD" + it "serves an empty store without changing the legacy unconfigured live response" $ + withTestStore $ \store -> do + metrics <- newKirokuMetrics store + withMetricsServerWithStore defaultConfig {port = 0} metrics store [] $ \server -> do + getInventory server.serverPort `shouldReturn` CheckpointInventoryResponse 0 [] + live <- get server.serverPort "/subscriptions" + HTTP.responseStatus live `shouldBe` status404 + Aeson.decode (HTTP.responseBody live) `shouldBe` Just (Aeson.object ["error" Aeson..= ("subscription status not configured" :: Text)]) - it "mounts HTTP and the real event WebSocket when the host strips only pathInfo" $ - withTestStore $ \store -> do - metrics <- newKirokuMetrics store - providers <- storeServerProviders defaultConfig metrics store - let composed = combinedAppWithProviders defaultConfig metrics [] providers - mounted req respond = composed req{Wai.pathInfo = drop 1 (Wai.pathInfo req)} respond - Warp.testWithApplication (pure mounted) $ \port -> do - response <- get port "/kiroku/subscription-checkpoints" - HTTP.responseStatus response `shouldBe` status200 - bounded $ WS.runClient "127.0.0.1" port "/kiroku/ws/events" $ \conn -> do - WS.sendTextData conn (Aeson.encode $ Aeson.object ["type" Aeson..= ("subscribe_events" :: Text)]) - raw <- WS.receiveData conn :: IO LBS.ByteString - frameType raw `shouldBe` Just "event_stream_started" + it "returns structured not-configured errors without shadowing a live name checkpoints" $ do + metrics <- emptyMetrics + let live = pure [SubscriptionStatusRow "checkpoints" 0 "live" 7] + withMetricsServerSubscriptions defaultConfig {port = 0} metrics [] live $ \server -> do + inventory <- get server.serverPort "/subscription-checkpoints" + HTTP.responseStatus inventory `shouldBe` status404 + code (HTTP.responseBody inventory) `shouldBe` Just "checkpoint_inventory_not_configured" + named <- get server.serverPort "/subscriptions/checkpoints" + HTTP.responseStatus named `shouldBe` status200 + Aeson.decode (HTTP.responseBody named) `shouldBe` Just [SubscriptionStatusRow "checkpoints" 0 "live" 7] + let app = httpAppWithProviders defaultConfig metrics [] defaultServerProviders + (status, headers, _) <- capture app "GET" + capture app "HEAD" `shouldReturn` (status, headers, "") + (methodStatus, methodHeaders, _) <- capture app "POST" + methodStatus `shouldBe` status405 + lookup "Allow" methodHeaders `shouldBe` Just "GET, HEAD" - it "escapes mounted WebSocket segments and retains the raw query string" $ do - metrics <- emptyMetrics - observed <- newEmptyMVar - let ws pending = do - putMVar observed (WS.requestPath (WS.pendingRequest pending)) - conn <- WS.acceptRequest pending - WS.sendTextData conn ("ok" :: Text) - app = combinedAppWithProviders defaultConfig metrics [] defaultServerProviders{webSocketServer = ws} - mounted req respond = app req{Wai.pathInfo = drop 1 (Wai.pathInfo req)} respond - Warp.testWithApplication (pure mounted) $ \port -> do - bounded $ WS.runClient "127.0.0.1" port "/kiroku/ws/a%20b%2Fc?token=a%2Fb" $ \conn -> do - WS.receiveData conn `shouldReturn` ("ok" :: Text) - takeMVar observed `shouldReturn` "/ws/a%20b%2Fc?token=a%2Fb" + it "mounts HTTP and the real event WebSocket when the host strips only pathInfo" $ + withTestStore $ \store -> do + metrics <- newKirokuMetrics store + providers <- storeServerProviders defaultConfig metrics store + let composed = combinedAppWithProviders defaultConfig metrics [] providers + mounted req respond = composed req {Wai.pathInfo = drop 1 (Wai.pathInfo req)} respond + Warp.testWithApplication (pure mounted) $ \port -> do + response <- get port "/kiroku/subscription-checkpoints" + HTTP.responseStatus response `shouldBe` status200 + bounded $ WS.runClient "127.0.0.1" port "/kiroku/ws/events" $ \conn -> do + WS.sendTextData conn (Aeson.encode $ Aeson.object ["type" Aeson..= ("subscribe_events" :: Text)]) + raw <- WS.receiveData conn :: IO LBS.ByteString + frameType raw `shouldBe` Just "event_stream_started" - it "enforces disabled WebSockets through both legacy and general composition" $ do - metrics <- emptyMetrics - calls <- newIORef (0 :: Int) - let ws pending = modifyIORef' calls (+ 1) >> WS.rejectRequest pending "called" - cfg = defaultConfig{enableWebSocket = False} - forM_ [combinedApp cfg metrics [] Nothing ws, combinedAppWithProviders cfg metrics [] defaultServerProviders{webSocketServer = ws}] $ \app -> - Warp.testWithApplication (pure app) $ \port -> do - result <- bounded $ try (WS.runClient "127.0.0.1" port "/ws/metrics" (\_ -> pure ())) - (result :: Either WS.HandshakeException ()) `shouldSatisfy` isLeft - readIORef calls `shouldReturn` 0 + it "escapes mounted WebSocket segments and retains the raw query string" $ do + metrics <- emptyMetrics + observed <- newEmptyMVar + let ws pending = do + putMVar observed (WS.requestPath (WS.pendingRequest pending)) + conn <- WS.acceptRequest pending + WS.sendTextData conn ("ok" :: Text) + app = combinedAppWithProviders defaultConfig metrics [] defaultServerProviders {webSocketServer = ws} + mounted req respond = app req {Wai.pathInfo = drop 1 (Wai.pathInfo req)} respond + Warp.testWithApplication (pure mounted) $ \port -> do + bounded $ WS.runClient "127.0.0.1" port "/kiroku/ws/a%20b%2Fc?token=a%2Fb" $ \conn -> do + WS.receiveData conn `shouldReturn` ("ok" :: Text) + takeMVar observed `shouldReturn` "/ws/a%20b%2Fc?token=a%2Fb" - it "does no checkpoint work on legacy metrics reads and invokes inventory only on demand" $ do - metrics <- emptyMetrics - calls <- newIORef (0 :: Int) - let provider = modifyIORef' calls (+ 1) >> pure (Right fixture) - providers = defaultServerProviders{checkpointInventory = Just provider} - app = httpAppWithProviders defaultConfig metrics [] providers - metricsApp req respond = app req{Wai.pathInfo = ["metrics"]} respond - forM_ [1 .. 20 :: Int] $ \_ -> do - (status, _, _) <- capture metricsApp "GET" - status `shouldBe` status200 - readIORef calls `shouldReturn` 0 - _ <- capture app "GET" - readIORef calls `shouldReturn` 1 + it "enforces disabled WebSockets through both legacy and general composition" $ do + metrics <- emptyMetrics + calls <- newIORef (0 :: Int) + let ws pending = modifyIORef' calls (+ 1) >> WS.rejectRequest pending "called" + cfg = defaultConfig {enableWebSocket = False} + forM_ [combinedApp cfg metrics [] Nothing ws, combinedAppWithProviders cfg metrics [] defaultServerProviders {webSocketServer = ws}] $ \app -> + Warp.testWithApplication (pure app) $ \port -> do + result <- bounded $ try (WS.runClient "127.0.0.1" port "/ws/metrics" (\_ -> pure ())) + (result :: Either WS.HandshakeException ()) `shouldSatisfy` isLeft + readIORef calls `shouldReturn` 0 - it "inherits exactly one CORS wrap on the provider composition" $ do - metrics <- emptyMetrics - let origin = either (error . show) id (allowedOrigin "https://ops.example.com") - cfg = defaultConfig{cors = corsAllowOrigins [origin]} - app = combinedAppWithProviders cfg metrics [] defaultServerProviders{checkpointInventory = Just (pure (Right fixture))} - Warp.testWithApplication (pure app) $ \port -> do - manager <- HTTP.newManager HTTP.defaultManagerSettings - req <- HTTP.parseRequest (url port "/subscription-checkpoints") - response <- HTTP.httpLbs req{HTTP.requestHeaders = [("Origin", "https://ops.example.com")]} manager - HTTP.responseStatus response `shouldBe` status200 - filter ((== "Access-Control-Allow-Origin") . fst) (HTTP.responseHeaders response) `shouldBe` [("Access-Control-Allow-Origin", "https://ops.example.com")] + it "does no checkpoint work on legacy metrics reads and invokes inventory only on demand" $ do + metrics <- emptyMetrics + calls <- newIORef (0 :: Int) + let provider = modifyIORef' calls (+ 1) >> pure (Right fixture) + providers = defaultServerProviders {checkpointInventory = Just provider} + app = httpAppWithProviders defaultConfig metrics [] providers + metricsApp req respond = app req {Wai.pathInfo = ["metrics"]} respond + forM_ [1 .. 20 :: Int] $ \_ -> do + (status, _, _) <- capture metricsApp "GET" + status `shouldBe` status200 + readIORef calls `shouldReturn` 0 + _ <- capture app "GET" + readIORef calls `shouldReturn` 1 - it "is immediately ready on ephemeral and fixed ports and releases each socket" $ do - metrics <- emptyMetrics - withMetricsServer defaultConfig{port = 0} metrics [] $ \server -> do - HTTP.responseStatus <$> get server.serverPort "/metrics" `shouldReturn` status200 - (port, socket) <- Warp.openFreePort - Socket.close socket - withMetricsServer defaultConfig{port = port} metrics [] $ \server -> - HTTP.responseStatus <$> get server.serverPort "/metrics" `shouldReturn` status200 - assertPortReleased port + it "inherits exactly one CORS wrap on the provider composition" $ do + metrics <- emptyMetrics + let origin = either (error . show) id (allowedOrigin "https://ops.example.com") + cfg = defaultConfig {cors = corsAllowOrigins [origin]} + app = combinedAppWithProviders cfg metrics [] defaultServerProviders {checkpointInventory = Just (pure (Right fixture))} + Warp.testWithApplication (pure app) $ \port -> do + manager <- HTTP.newManager HTTP.defaultManagerSettings + req <- HTTP.parseRequest (url port "/subscription-checkpoints") + response <- HTTP.httpLbs req {HTTP.requestHeaders = [("Origin", "https://ops.example.com")]} manager + HTTP.responseStatus response `shouldBe` status200 + filter ((== "Access-Control-Allow-Origin") . fst) (HTTP.responseHeaders response) `shouldBe` [("Access-Control-Allow-Origin", "https://ops.example.com")] - it "reports an occupied-port failure to acquisition without invoking the callback" $ do - metrics <- emptyMetrics - (port, reserved) <- Warp.openFreePort - Socket.close reserved - bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv4 -> - bracket (Socket.socket Socket.AF_INET6 Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv6 -> do - -- On macOS a loopback listener can coexist with a wildcard listener. - -- Occupy both wildcard addresses, as the server binds host "*". - Socket.bind ipv4 (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))) - Socket.listen ipv4 1 - Socket.setSocketOption ipv6 Socket.IPv6Only 1 - Socket.bind ipv6 (Socket.SockAddrInet6 (fromIntegral port) 0 (0, 0, 0, 0) 0) - Socket.listen ipv6 1 - called <- newIORef False - result <- bounded $ try $ withMetricsServer defaultConfig{port = port} metrics [] (\_ -> writeIORef called True) - (result :: Either SomeException ()) `shouldSatisfy` isLeft - readIORef called `shouldReturn` False + it "is immediately ready on ephemeral and fixed ports and releases each socket" $ do + metrics <- emptyMetrics + withMetricsServer defaultConfig {port = 0} metrics [] $ \server -> do + HTTP.responseStatus <$> get server.serverPort "/metrics" `shouldReturn` status200 + (port, socket) <- Warp.openFreePort + Socket.close socket + withMetricsServer defaultConfig {port = port} metrics [] $ \server -> + HTTP.responseStatus <$> get server.serverPort "/metrics" `shouldReturn` status200 + assertPortReleased port - it "releases the server after callback failure and propagates unexpected termination" $ do - metrics <- emptyMetrics - portRef <- newIORef 0 - result <- bounded $ try $ withMetricsServer defaultConfig{port = 0} metrics [] $ \server -> do - writeIORef portRef server.serverPort - throwIO (userError "callback failed") + it "reports an occupied-port failure to acquisition without invoking the callback" $ do + metrics <- emptyMetrics + (port, reserved) <- Warp.openFreePort + Socket.close reserved + bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv4 -> + bracket (Socket.socket Socket.AF_INET6 Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv6 -> do + -- On macOS a loopback listener can coexist with a wildcard listener. + -- Occupy both wildcard addresses, as the server binds host "*". + Socket.bind ipv4 (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))) + Socket.listen ipv4 1 + Socket.setSocketOption ipv6 Socket.IPv6Only 1 + Socket.bind ipv6 (Socket.SockAddrInet6 (fromIntegral port) 0 (0, 0, 0, 0) 0) + Socket.listen ipv6 1 + called <- newIORef False + result <- bounded $ try $ withMetricsServer defaultConfig {port = port} metrics [] (\_ -> writeIORef called True) (result :: Either SomeException ()) `shouldSatisfy` isLeft - readIORef portRef >>= assertPortReleased - callbackStopped <- newEmptyMVar - result2 <- bounded $ try $ withMetricsServer defaultConfig{port = 0} metrics [] $ \server -> - ( do - writeIORef portRef server.serverPort - Async.cancel server.serverThread - threadDelay 10_000_000 - ) - `finally` putMVar callbackStopped () - (result2 :: Either SomeException ()) `shouldSatisfy` isLeft - bounded (takeMVar callbackStopped) - readIORef portRef >>= assertPortReleased + readIORef called `shouldReturn` False - it "cancels acquisition or its returned lifetime without leaking a fixed-port listener" $ do - metrics <- emptyMetrics - (port, socket) <- Warp.openFreePort - Socket.close socket - -- Exercise the acquisition boundary and the readiness/callback boundary. - forM_ [0, 100, 1000] $ \delay -> do - entered <- newEmptyMVar - thread <- Async.async $ do - putMVar entered () - withMetricsServer defaultConfig{port = port} metrics [] (\_ -> threadDelay 10_000_000) - takeMVar entered - threadDelay delay - bounded (Async.cancel thread) - assertPortReleased port + it "releases the server after callback failure and propagates unexpected termination" $ do + metrics <- emptyMetrics + portRef <- newIORef 0 + result <- bounded $ try $ withMetricsServer defaultConfig {port = 0} metrics [] $ \server -> do + writeIORef portRef server.serverPort + throwIO (userError "callback failed") + (result :: Either SomeException ()) `shouldSatisfy` isLeft + readIORef portRef >>= assertPortReleased + callbackStopped <- newEmptyMVar + result2 <- bounded $ try $ withMetricsServer defaultConfig {port = 0} metrics [] $ \server -> + ( do + writeIORef portRef server.serverPort + Async.cancel server.serverThread + threadDelay 10_000_000 + ) + `finally` putMVar callbackStopped () + (result2 :: Either SomeException ()) `shouldSatisfy` isLeft + bounded (takeMVar callbackStopped) + readIORef portRef >>= assertPortReleased + it "cancels acquisition or its returned lifetime without leaking a fixed-port listener" $ do + metrics <- emptyMetrics + (port, socket) <- Warp.openFreePort + Socket.close socket + -- Exercise the acquisition boundary and the readiness/callback boundary. + forM_ [0, 100, 1000] $ \delay -> do + entered <- newEmptyMVar + thread <- Async.async $ do + putMVar entered () + withMetricsServer defaultConfig {port = port} metrics [] (\_ -> threadDelay 10_000_000) + takeMVar entered + threadDelay delay + bounded (Async.cancel thread) + assertPortReleased port + emptyMetrics :: IO KirokuMetrics emptyMetrics = newKirokuMetricsWith (pure (GlobalPosition 0)) (pure 0) @@ -323,23 +323,23 @@ append :: Store.KirokuStore -> Int -> IO () append store count = do - let ev = Store.EventData Nothing (Store.EventType "E") Aeson.Null Nothing Nothing Nothing - result <- Store.runStoreIO store $ Store.appendToStream (Store.StreamName "orders-1") Store.NoStream (replicate count ev) - result `shouldSatisfy` either (const False) (const True) + let ev = Store.EventData Nothing (Store.EventType "E") Aeson.Null Nothing Nothing Nothing + result <- Store.runStoreIO store $ Store.appendToStream (Store.StreamName "orders-1") Store.NoStream (replicate count ev) + result `shouldSatisfy` either (const False) (const True) seed :: Store.KirokuStore -> Text -> Int32 -> Int64 -> IO () seed store name index position = do - result <- Pool.use store.pool $ Session.statement (name, index, position, max 1 (index + 1), "unbound", Nothing) SQL.saveCheckpointMemberStmt - result `shouldBe` Right () + result <- Pool.use store.pool $ Session.statement (name, index, position, max 1 (index + 1), "unbound", Nothing) SQL.saveCheckpointMemberStmt + result `shouldBe` Right () awaitLive :: Store.KirokuStore -> Store.SubscriptionName -> IO () awaitLive store name = bounded loop where loop = do - states <- Store.subscriptionStates store - case Map.lookup (name, 0) states of - Just view | view.statePhase == "live" -> pure () - _ -> threadDelay 20_000 >> loop + states <- Store.subscriptionStates store + case Map.lookup (name, 0) states of + Just view | view.statePhase == "live" -> pure () + _ -> threadDelay 20_000 >> loop triples :: CheckpointInventoryResponse -> [(Text, Int32, Int64)] triples response = [(row.subscription, row.member, row.checkpointPosition) | row <- response.checkpoints] @@ -349,54 +349,54 @@ get :: Int -> String -> IO (HTTP.Response LBS.ByteString) get port path = do - manager <- HTTP.newManager HTTP.defaultManagerSettings - request <- HTTP.parseRequest (url port path) - HTTP.httpLbs request manager + manager <- HTTP.newManager HTTP.defaultManagerSettings + request <- HTTP.parseRequest (url port path) + HTTP.httpLbs request manager getInventory :: Int -> IO CheckpointInventoryResponse getInventory port = do - response <- get port "/subscription-checkpoints" - HTTP.responseStatus response `shouldBe` status200 - either fail pure (Aeson.eitherDecode (HTTP.responseBody response)) + response <- get port "/subscription-checkpoints" + HTTP.responseStatus response `shouldBe` status200 + either fail pure (Aeson.eitherDecode (HTTP.responseBody response)) code :: LBS.ByteString -> Maybe Text code bytes = do - Aeson.Object root <- Aeson.decode bytes - Aeson.Object err <- KM.lookup "error" root - Aeson.String value <- KM.lookup "code" err - pure value + Aeson.Object root <- Aeson.decode bytes + Aeson.Object err <- KM.lookup "error" root + Aeson.String value <- KM.lookup "code" err + pure value frameType :: LBS.ByteString -> Maybe Text frameType bytes = do - Aeson.Object root <- Aeson.decode bytes - Aeson.String value <- KM.lookup "type" root - pure value + Aeson.Object root <- Aeson.decode bytes + Aeson.String value <- KM.lookup "type" root + pure value capture :: Wai.Application -> Method -> IO (Status, ResponseHeaders, LBS.ByteString) capture app method = do - result <- newIORef Nothing - _ <- app Wai.defaultRequest{Wai.requestMethod = method, Wai.pathInfo = checkpointsPath} $ \response -> do - let (status, headers, stream) = Wai.responseToStream response - chunks <- newIORef mempty - stream $ \body -> body (\builder -> modifyIORef' chunks (<> builder)) (pure ()) - bytes <- toLazyByteString <$> readIORef chunks - writeIORef result (Just (status, headers, bytes)) - pure ResponseReceived - readIORef result >>= maybe (fail "No WAI response") pure + result <- newIORef Nothing + _ <- app Wai.defaultRequest {Wai.requestMethod = method, Wai.pathInfo = checkpointsPath} $ \response -> do + let (status, headers, stream) = Wai.responseToStream response + chunks <- newIORef mempty + stream $ \body -> body (\builder -> modifyIORef' chunks (<> builder)) (pure ()) + bytes <- toLazyByteString <$> readIORef chunks + writeIORef result (Just (status, headers, bytes)) + pure ResponseReceived + readIORef result >>= maybe (fail "No WAI response") pure bounded :: IO a -> IO a bounded action = timeout 15_000_000 action >>= maybe (fail "Timed out") pure assertPortReleased :: Int -> IO () assertPortReleased port = forM_ addresses $ \(family, address) -> - bracket (Socket.socket family Socket.Stream Socket.defaultProtocol) Socket.close $ \sock -> do - Socket.setSocketOption sock Socket.ReuseAddr 1 - if family == Socket.AF_INET6 then Socket.setSocketOption sock Socket.IPv6Only 1 else pure () - Socket.bind sock address - Socket.listen sock 1 + bracket (Socket.socket family Socket.Stream Socket.defaultProtocol) Socket.close $ \sock -> do + Socket.setSocketOption sock Socket.ReuseAddr 1 + if family == Socket.AF_INET6 then Socket.setSocketOption sock Socket.IPv6Only 1 else pure () + Socket.bind sock address + Socket.listen sock 1 where addresses = - [ (Socket.AF_INET, Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (127, 0, 0, 1))) - , (Socket.AF_INET, Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))) - , (Socket.AF_INET6, Socket.SockAddrInet6 (fromIntegral port) 0 (0, 0, 0, 0) 0) - ] + [ (Socket.AF_INET, Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (127, 0, 0, 1))), + (Socket.AF_INET, Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))), + (Socket.AF_INET6, Socket.SockAddrInet6 (fromIntegral port) 0 (0, 0, 0, 0) 0) + ] diff --git a/test/Test/CollectorSpec.hs b/test/Test/CollectorSpec.hs --- a/test/Test/CollectorSpec.hs +++ b/test/Test/CollectorSpec.hs @@ -1,8 +1,7 @@ -{- | Pure unit tests for the metrics collector: feed scripted 'KirokuEvent' and -'Observation' values through the callback wrappers and assert the resulting -snapshot. No store is opened — the two store-level gauges are supplied by fake -STM readers via 'newKirokuMetricsWith'. --} +-- | Pure unit tests for the metrics collector: feed scripted 'KirokuEvent' and +-- 'Observation' values through the callback wrappers and assert the resulting +-- snapshot. No store is opened — the two store-level gauges are supplied by fake +-- STM readers via 'newKirokuMetricsWith'. module Test.CollectorSpec (spec) where import Control.Concurrent.STM (STM) @@ -18,8 +17,8 @@ import Kiroku.Metrics.Prometheus (renderPrometheus) import Test.Hspec -import Kiroku.Metrics ( - LifecycleCounters (..), +import Kiroku.Metrics + ( LifecycleCounters (..), MetricsSnapshot (..), StoreGauges (..), SubscriptionMetrics (..), @@ -27,9 +26,9 @@ metricsObservationHandler, newKirokuMetricsWith, snapshotMetrics, - ) -import Kiroku.Store ( - ConnectionReadyForUseReason (..), + ) +import Kiroku.Store + ( ConnectionReadyForUseReason (..), ConnectionStatus (..), ConnectionTerminationReason (..), KirokuEvent (..), @@ -37,31 +36,33 @@ SubscriptionDbPhase (..), SubscriptionGroupContext (..), SubscriptionStopReason (..), - ) + SubscriptionTarget (..), + ) import Kiroku.Store.Observability (SubscriptionDeliveryPhase (..)) import Kiroku.Store.Settings (DecodeFailure (..)) -import Kiroku.Store.Subscription.Types ( - CheckpointInitialization (..), +import Kiroku.Store.Subscription.Types + ( CheckpointInitialization (..), + InvalidHandlerStallWarnAfter (..), MissingCheckpointPolicy (..), SubscriptionCheckpointKey (..), SubscriptionName (..), - ) + SubscriptionTargetMismatch (..), + ) import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) -{- | A collector whose fake store readers report the given global position and -active-subscriber count, fed the given scripted events and observations. --} +-- | A collector whose fake store readers report the given global position and +-- active-subscriber count, fed the given scripted events and observations. runScript :: - STM GlobalPosition -> - STM Int -> - [KirokuEvent] -> - [Observation] -> - IO MetricsSnapshot + STM GlobalPosition -> + STM Int -> + [KirokuEvent] -> + [Observation] -> + IO MetricsSnapshot runScript readPos readSubs events obs = do - km <- newKirokuMetricsWith readPos readSubs - forM_ events (metricsEventHandler km Nothing) - forM_ obs (metricsObservationHandler km Nothing) - snapshotMetrics km + km <- newKirokuMetricsWith readPos readSubs + forM_ events (metricsEventHandler km Nothing) + forM_ obs (metricsObservationHandler km Nothing) + snapshotMetrics km sub :: SubscriptionName sub = SubscriptionName "p" @@ -79,188 +80,204 @@ spec :: Spec spec = describe "Kiroku.Metrics.Collector" $ do - it "counts notifier reconnect events" $ do - snap <- - runScript - (pure (GlobalPosition 0)) - (pure 0) - [ KirokuEventNotifierReconnecting 1 someExc - , KirokuEventNotifierReconnecting 2 someExc - , KirokuEventNotifierReconnected - ] - [] - snap.counters.notifierReconnecting `shouldBe` 2 - snap.counters.notifierReconnected `shouldBe` 1 + forM_ [False, True] $ \targetRefusal -> + it ("counts one startup crash without Started for target refusal=" <> show targetRefusal) $ do + let mismatch = SubscriptionTargetMismatch sub AllStreams (pure Nothing) + err = if targetRefusal then toException mismatch else toException (InvalidHandlerStallWarnAfter 0) + prefix = if targetRefusal then [KirokuEventSubscriptionTargetMismatch mismatch NonGroup] else [] + snap <- + runScript + (pure (GlobalPosition 12)) + (pure 0) + (prefix <> [KirokuEventSubscriptionStopped sub (GlobalPosition 0) (StopWorkerCrashed err) NonGroup]) + [] + snap.counters.subscriptionsStarted `shouldBe` 0 + snap.counters.subscriptionsStoppedCrashed `shouldBe` 1 + (Map.lookup "p" snap.subscriptions >>= (.lastStopReason)) `shouldBe` Just "crashed" + (Map.lookup "p" snap.subscriptions >>= Just . (.lastKnownPosition)) `shouldBe` Just 0 - it "counts publisher pool and loop errors separately" $ do - snap <- - runScript - (pure (GlobalPosition 0)) - (pure 0) - [ KirokuEventPublisherPoolError dbErr - , KirokuEventPublisherLoopError someExc - , KirokuEventPublisherLoopError someExc - ] - [] - snap.counters.publisherPoolErrors `shouldBe` 1 - snap.counters.publisherLoopErrors `shouldBe` 2 + it "counts notifier reconnect events" $ do + snap <- + runScript + (pure (GlobalPosition 0)) + (pure 0) + [ KirokuEventNotifierReconnecting 1 someExc, + KirokuEventNotifierReconnecting 2 someExc, + KirokuEventNotifierReconnected + ] + [] + snap.counters.notifierReconnecting `shouldBe` 2 + snap.counters.notifierReconnected `shouldBe` 1 - it "counts typed decode failures and undecodable stops separately from programming errors" $ do - let eid = EventId (uuidN 3) - failure = DecodeFailure eid "cannot decrypt" - snap <- - runScript - (pure (GlobalPosition 4)) - (pure 0) - [ KirokuEventPublisherDecodeFailed (GlobalPosition 3) eid failure - , KirokuEventSubscriptionStopped sub (GlobalPosition 2) (StopUndecodable failure) NonGroup - ] - [] - case toJSON snap.counters of - Object fields -> do - KM.lookup "publisher_decode_failures" fields `shouldBe` Just (Number 1) - KM.lookup "subscriptions_stopped_undecodable" fields `shouldBe` Just (Number 1) - other -> expectationFailure ("expected lifecycle object, got " <> show other) - let exposition = LBS.unpack (renderPrometheus snap) - exposition `shouldSatisfy` isInfixOf "kiroku_publisher_decode_failures_total 1" - exposition `shouldSatisfy` isInfixOf "kiroku_subscriptions_stopped_total{reason=\"undecodable\"} 1" - snap.counters.publisherDecodeFailures `shouldBe` 1 - snap.counters.publisherLoopErrors `shouldBe` 0 - snap.counters.subscriptionsStoppedUndecodable `shouldBe` 1 - snap.counters.subscriptionsStoppedCrashed `shouldBe` 0 - (Map.lookup "p" snap.subscriptions >>= (.lastStopReason)) `shouldBe` Just "undecodable" + it "counts publisher pool and loop errors separately" $ do + snap <- + runScript + (pure (GlobalPosition 0)) + (pure 0) + [ KirokuEventPublisherPoolError dbErr, + KirokuEventPublisherLoopError someExc, + KirokuEventPublisherLoopError someExc + ] + [] + snap.counters.publisherPoolErrors `shouldBe` 1 + snap.counters.publisherLoopErrors `shouldBe` 2 - it "counts advisory stalls without advancing the subscription position" $ do - snap <- - runScript - (pure (GlobalPosition 12)) - (pure 1) - [ KirokuEventSubscriptionStarted sub (GlobalPosition 2) NonGroup - , KirokuEventSubscriptionHandlerStalled sub (GlobalPosition 3) (EventId (uuidN 3)) 0.2 NonGroup - ] - [] - snap.counters.subscriptionHandlerStalls `shouldBe` 1 - (Map.lookup "p" snap.subscriptions >>= Just . (.lastKnownPosition)) `shouldBe` Just 2 - case toJSON snap.counters of - Object fields -> KM.lookup "subscription_handler_stalls" fields `shouldBe` Just (Number 1) - other -> expectationFailure ("expected lifecycle object, got " <> show other) - LBS.unpack (renderPrometheus snap) `shouldSatisfy` isInfixOf "kiroku_subscription_handler_stalls_total 1" + it "counts typed decode failures and undecodable stops separately from programming errors" $ do + let eid = EventId (uuidN 3) + failure = DecodeFailure eid "cannot decrypt" + snap <- + runScript + (pure (GlobalPosition 4)) + (pure 0) + [ KirokuEventPublisherDecodeFailed (GlobalPosition 3) eid failure, + KirokuEventSubscriptionStopped sub (GlobalPosition 2) (StopUndecodable failure) NonGroup + ] + [] + case toJSON snap.counters of + Object fields -> do + KM.lookup "publisher_decode_failures" fields `shouldBe` Just (Number 1) + KM.lookup "subscriptions_stopped_undecodable" fields `shouldBe` Just (Number 1) + other -> expectationFailure ("expected lifecycle object, got " <> show other) + let exposition = LBS.unpack (renderPrometheus snap) + exposition `shouldSatisfy` isInfixOf "kiroku_publisher_decode_failures_total 1" + exposition `shouldSatisfy` isInfixOf "kiroku_subscriptions_stopped_total{reason=\"undecodable\"} 1" + snap.counters.publisherDecodeFailures `shouldBe` 1 + snap.counters.publisherLoopErrors `shouldBe` 0 + snap.counters.subscriptionsStoppedUndecodable `shouldBe` 1 + snap.counters.subscriptionsStoppedCrashed `shouldBe` 0 + (Map.lookup "p" snap.subscriptions >>= (.lastStopReason)) `shouldBe` Just "undecodable" - it "records subscription position and derives lag from the global position" $ do - snap <- - runScript - (pure (GlobalPosition 12)) - (pure 3) - [KirokuEventSubscriptionStarted sub (GlobalPosition 5) NonGroup] - [] - snap.store.globalPosition `shouldBe` 12 - snap.store.activeSubscribers `shouldBe` 3 - snap.counters.subscriptionsStarted `shouldBe` 1 - case Map.lookup "p" snap.subscriptions of - Nothing -> expectationFailure "expected subscription \"p\" in snapshot" - Just m -> do - m.lastKnownPosition `shouldBe` 5 - m.lag `shouldBe` 7 + it "counts advisory stalls without advancing the subscription position" $ do + snap <- + runScript + (pure (GlobalPosition 12)) + (pure 1) + [ KirokuEventSubscriptionStarted sub (GlobalPosition 2) NonGroup, + KirokuEventSubscriptionHandlerStalled sub (GlobalPosition 3) (EventId (uuidN 3)) 0.2 NonGroup + ] + [] + snap.counters.subscriptionHandlerStalls `shouldBe` 1 + (Map.lookup "p" snap.subscriptions >>= Just . (.lastKnownPosition)) `shouldBe` Just 2 + case toJSON snap.counters of + Object fields -> KM.lookup "subscription_handler_stalls" fields `shouldBe` Just (Number 1) + other -> expectationFailure ("expected lifecycle object, got " <> show other) + LBS.unpack (renderPrometheus snap) `shouldSatisfy` isInfixOf "kiroku_subscription_handler_stalls_total 1" - it "records the durable position from checkpoint resolution telemetry" $ do - let key = SubscriptionCheckpointKey sub 0 - snap <- - runScript - (pure (GlobalPosition 12)) - (pure 0) - [ KirokuEventSubscriptionCheckpointResolved - (InitializedCheckpoint FromCurrentHead key (GlobalPosition 9)) - NonGroup - ] - [] - case Map.lookup "p" snap.subscriptions of - Nothing -> expectationFailure "expected resolved subscription in snapshot" - Just metrics -> do - metrics.lastKnownPosition `shouldBe` 9 - metrics.lag `shouldBe` 3 + it "records subscription position and derives lag from the global position" $ do + snap <- + runScript + (pure (GlobalPosition 12)) + (pure 3) + [KirokuEventSubscriptionStarted sub (GlobalPosition 5) NonGroup] + [] + snap.store.globalPosition `shouldBe` 12 + snap.store.activeSubscribers `shouldBe` 3 + snap.counters.subscriptionsStarted `shouldBe` 1 + case Map.lookup "p" snap.subscriptions of + Nothing -> expectationFailure "expected subscription \"p\" in snapshot" + Just m -> do + m.lastKnownPosition `shouldBe` 5 + m.lag `shouldBe` 7 - it "advances last-known position monotonically and never reports negative lag" $ do - snap <- - runScript - (pure (GlobalPosition 8)) - (pure 1) - [ KirokuEventSubscriptionStarted sub (GlobalPosition 5) NonGroup - , KirokuEventSubscriptionCaughtUp sub (GlobalPosition 10) NonGroup - ] - [] - case Map.lookup "p" snap.subscriptions of - Nothing -> expectationFailure "expected subscription \"p\"" - Just m -> do - m.lastKnownPosition `shouldBe` 10 - m.lag `shouldBe` 0 -- max 0 (8 - 10) - it "tallies stop reasons and records the last one per subscription" $ do - snap <- - runScript - (pure (GlobalPosition 20)) - (pure 0) - [ KirokuEventSubscriptionStarted sub (GlobalPosition 0) NonGroup - , KirokuEventSubscriptionStopped sub (GlobalPosition 20) StopHandlerRequested NonGroup - ] - [] - snap.counters.subscriptionsStoppedHandler `shouldBe` 1 - (Map.lookup "p" snap.subscriptions >>= (.lastStopReason)) `shouldBe` Just "handler" + it "records the durable position from checkpoint resolution telemetry" $ do + let key = SubscriptionCheckpointKey sub 0 + snap <- + runScript + (pure (GlobalPosition 12)) + (pure 0) + [ KirokuEventSubscriptionCheckpointResolved + (InitializedCheckpoint FromCurrentHead key (GlobalPosition 9)) + NonGroup + ] + [] + case Map.lookup "p" snap.subscriptions of + Nothing -> expectationFailure "expected resolved subscription in snapshot" + Just metrics -> do + metrics.lastKnownPosition `shouldBe` 9 + metrics.lag `shouldBe` 3 - it "tallies per-phase database errors and the per-subscription error count" $ do - snap <- - runScript - (pure (GlobalPosition 0)) - (pure 0) - [ KirokuEventSubscriptionDbError sub LoadCheckpoint dbErr NonGroup - , KirokuEventSubscriptionDbError sub FetchBatch dbErr NonGroup - , KirokuEventSubscriptionDbError sub FetchBatch dbErr NonGroup - ] - [] - snap.counters.subscriptionDbErrorsLoad `shouldBe` 1 - snap.counters.subscriptionDbErrorsFetch `shouldBe` 2 - (Map.lookup "p" snap.subscriptions >>= Just . (.dbErrorCount)) `shouldBe` Just 3 + it "advances last-known position monotonically and never reports negative lag" $ do + snap <- + runScript + (pure (GlobalPosition 8)) + (pure 1) + [ KirokuEventSubscriptionStarted sub (GlobalPosition 5) NonGroup, + KirokuEventSubscriptionCaughtUp sub (GlobalPosition 10) NonGroup + ] + [] + case Map.lookup "p" snap.subscriptions of + Nothing -> expectationFailure "expected subscription \"p\"" + Just m -> do + m.lastKnownPosition `shouldBe` 10 + m.lag `shouldBe` 0 -- max 0 (8 - 10) + it "tallies stop reasons and records the last one per subscription" $ do + snap <- + runScript + (pure (GlobalPosition 20)) + (pure 0) + [ KirokuEventSubscriptionStarted sub (GlobalPosition 0) NonGroup, + KirokuEventSubscriptionStopped sub (GlobalPosition 20) StopHandlerRequested NonGroup + ] + [] + snap.counters.subscriptionsStoppedHandler `shouldBe` 1 + (Map.lookup "p" snap.subscriptions >>= (.lastStopReason)) `shouldBe` Just "handler" - it "counts delivered batches and sums delivered events" $ do - snap <- - runScript - (pure (GlobalPosition 0)) - (pure 0) - [ KirokuEventSubscriptionDelivered sub 3 DeliveredCatchUp NonGroup - , KirokuEventSubscriptionDelivered sub 2 DeliveredLive NonGroup - , KirokuEventSubscriptionFetched sub 2 NonGroup - ] - [] - snap.counters.batchesDelivered `shouldBe` 2 - snap.counters.eventsDelivered `shouldBe` 5 - snap.counters.liveFetches `shouldBe` 1 + it "tallies per-phase database errors and the per-subscription error count" $ do + snap <- + runScript + (pure (GlobalPosition 0)) + (pure 0) + [ KirokuEventSubscriptionDbError sub LoadCheckpoint dbErr NonGroup, + KirokuEventSubscriptionDbError sub FetchBatch dbErr NonGroup, + KirokuEventSubscriptionDbError sub FetchBatch dbErr NonGroup + ] + [] + snap.counters.subscriptionDbErrorsLoad `shouldBe` 1 + snap.counters.subscriptionDbErrorsFetch `shouldBe` 2 + (Map.lookup "p" snap.subscriptions >>= Just . (.dbErrorCount)) `shouldBe` Just 3 - it "tracks pool connection gauges and cumulative counters from observations" $ do - let u = uuidN 1 - snap <- - runScript - (pure (GlobalPosition 0)) - (pure 0) - [] - [ ConnectionObservation u ConnectingConnectionStatus - , ConnectionObservation u (ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason) - , ConnectionObservation u InUseConnectionStatus - ] - snap.store.poolConnecting `shouldBe` 0 - snap.store.poolReady `shouldBe` 0 - snap.store.poolInUse `shouldBe` 1 - snap.store.poolEstablishedTotal `shouldBe` 1 - snap.store.poolTerminatedTotal `shouldBe` 0 + it "counts delivered batches and sums delivered events" $ do + snap <- + runScript + (pure (GlobalPosition 0)) + (pure 0) + [ KirokuEventSubscriptionDelivered sub 3 DeliveredCatchUp NonGroup, + KirokuEventSubscriptionDelivered sub 2 DeliveredLive NonGroup, + KirokuEventSubscriptionFetched sub 2 NonGroup + ] + [] + snap.counters.batchesDelivered `shouldBe` 2 + snap.counters.eventsDelivered `shouldBe` 5 + snap.counters.liveFetches `shouldBe` 1 - it "removes terminated connections from the gauge and bumps the terminated counter" $ do - let u = uuidN 2 - snap <- - runScript - (pure (GlobalPosition 0)) - (pure 0) - [] - [ ConnectionObservation u (ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason) - , ConnectionObservation u (TerminatedConnectionStatus ReleaseConnectionTerminationReason) - ] - snap.store.poolReady `shouldBe` 0 - snap.store.poolInUse `shouldBe` 0 - snap.store.poolEstablishedTotal `shouldBe` 1 - snap.store.poolTerminatedTotal `shouldBe` 1 + it "tracks pool connection gauges and cumulative counters from observations" $ do + let u = uuidN 1 + snap <- + runScript + (pure (GlobalPosition 0)) + (pure 0) + [] + [ ConnectionObservation u ConnectingConnectionStatus, + ConnectionObservation u (ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason), + ConnectionObservation u InUseConnectionStatus + ] + snap.store.poolConnecting `shouldBe` 0 + snap.store.poolReady `shouldBe` 0 + snap.store.poolInUse `shouldBe` 1 + snap.store.poolEstablishedTotal `shouldBe` 1 + snap.store.poolTerminatedTotal `shouldBe` 0 + + it "removes terminated connections from the gauge and bumps the terminated counter" $ do + let u = uuidN 2 + snap <- + runScript + (pure (GlobalPosition 0)) + (pure 0) + [] + [ ConnectionObservation u (ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason), + ConnectionObservation u (TerminatedConnectionStatus ReleaseConnectionTerminationReason) + ] + snap.store.poolReady `shouldBe` 0 + snap.store.poolInUse `shouldBe` 0 + snap.store.poolEstablishedTotal `shouldBe` 1 + snap.store.poolTerminatedTotal `shouldBe` 1 diff --git a/test/Test/CorsSpec.hs b/test/Test/CorsSpec.hs --- a/test/Test/CorsSpec.hs +++ b/test/Test/CorsSpec.hs @@ -47,161 +47,187 @@ spec :: Spec spec = do - describe "Kiroku.Metrics.Cors (configuration)" $ do - it "defaults to disabled and validates normalized HTTP(S) origins" $ do - cors defaultConfig `shouldBe` corsDisabled - corsEnabled corsDisabled `shouldBe` False - allowedOrigin " HTTPS://OPS.Example.Com:443/ " `shouldBe` allowedOrigin "https://ops.example.com" - allowedOrigin "http://localhost:80" `shouldBe` allowedOrigin "http://localhost" - fmap renderAllowedOrigin (allowedOrigin "http://127.0.0.1:5173") `shouldBe` Right "http://127.0.0.1:5173" - originAllowed policy "HTTPS://OPS.EXAMPLE.COM:443" `shouldBe` True - originAllowed policy "https://ops.example.com:8443" `shouldBe` False - it "normalizes IPv6 literals including embedded IPv4" $ do - allowedOrigin "http://[::1]" `shouldBe` allowedOrigin "http://[0:0:0:0:0:0:0:1]:80" - allowedOrigin "https://[2001:DB8::1]:8443" `shouldBe` allowedOrigin "https://[2001:db8:0:0:0:0:0:1]:8443" - allowedOrigin "http://[::ffff:192.0.2.1]" `shouldBe` allowedOrigin "http://[0:0:0:0:0:ffff:c000:201]" - it "rejects wildcards, opaque origins, malformed authorities, paths and Unicode" $ - forM_ ["*", "null", "", "example.com", "://example.com", "ftp://example.com", "http://", "http:///", "https://a/path", "https://a//", "https://a?x", "https://a#x", "https://a b", "https://a\nb", "https://user@a", "https://*.a", "https://a%2eb", "https://a\\b", "https://é.example", "http://:80", "http://a:", "http://a:-1", "http://a:+80", "http://a:65536", "http://a:999999999999999999999999", "http://a:80:90", "http://-a", "http://a-", "http://a..b", "http://256.1.2.3", "http://01.2.3.4", "http://[:::1]", "http://[::1", "http://[1:2:3:4:5:6:7]", "http://[1:2:3:4:5:6:7:8:9]", "http://[::1]:", "http://[::1]x", "http://[fe80::1%eth0]", "http://::1", "http://[192.0.2.1::]"] $ \input -> - allowedOrigin input `shouldSatisfy` isLeft - it "tolerates configuration slash/whitespace but refuses them in request origins" $ do - allowedOrigin " https://ops.example.com/ " `shouldBe` allowedOrigin "https://ops.example.com" - forM_ ["https://ops.example.com/", " https://ops.example.com", "https://ops.example.com ", "https://ops.example.com https://evil.example.com", "https://ops.example.com,https://evil.example.com", "\xff"] $ \raw -> - originAllowed policy raw `shouldBe` False + describe "Kiroku.Metrics.Cors (configuration)" $ do + it "defaults to disabled and validates normalized HTTP(S) origins" $ do + cors defaultConfig `shouldBe` corsDisabled + corsEnabled corsDisabled `shouldBe` False + allowedOrigin " HTTPS://OPS.Example.Com:443/ " `shouldBe` allowedOrigin "https://ops.example.com" + allowedOrigin "http://localhost:80" `shouldBe` allowedOrigin "http://localhost" + fmap renderAllowedOrigin (allowedOrigin "http://127.0.0.1:5173") `shouldBe` Right "http://127.0.0.1:5173" + originAllowed policy "HTTPS://OPS.EXAMPLE.COM:443" `shouldBe` True + originAllowed policy "https://ops.example.com:8443" `shouldBe` False + it "normalizes IPv6 literals including embedded IPv4" $ do + allowedOrigin "http://[::1]" `shouldBe` allowedOrigin "http://[0:0:0:0:0:0:0:1]:80" + allowedOrigin "https://[2001:DB8::1]:8443" `shouldBe` allowedOrigin "https://[2001:db8:0:0:0:0:0:1]:8443" + allowedOrigin "http://[::ffff:192.0.2.1]" `shouldBe` allowedOrigin "http://[0:0:0:0:0:ffff:c000:201]" + it "rejects wildcards, opaque origins, malformed authorities, paths and Unicode" $ + forM_ ["*", "null", "", "example.com", "://example.com", "ftp://example.com", "http://", "http:///", "https://a/path", "https://a//", "https://a?x", "https://a#x", "https://a b", "https://a\nb", "https://user@a", "https://*.a", "https://a%2eb", "https://a\\b", "https://é.example", "http://:80", "http://a:", "http://a:-1", "http://a:+80", "http://a:65536", "http://a:999999999999999999999999", "http://a:80:90", "http://-a", "http://a-", "http://a..b", "http://256.1.2.3", "http://01.2.3.4", "http://[:::1]", "http://[::1", "http://[1:2:3:4:5:6:7]", "http://[1:2:3:4:5:6:7:8:9]", "http://[::1]:", "http://[::1]x", "http://[fe80::1%eth0]", "http://::1", "http://[192.0.2.1::]"] $ \input -> + allowedOrigin input `shouldSatisfy` isLeft + it "tolerates configuration slash/whitespace but refuses them in request origins" $ do + allowedOrigin " https://ops.example.com/ " `shouldBe` allowedOrigin "https://ops.example.com" + forM_ ["https://ops.example.com/", " https://ops.example.com", "https://ops.example.com ", "https://ops.example.com https://evil.example.com", "https://ops.example.com,https://evil.example.com", "\xff"] $ \raw -> + originAllowed policy raw `shouldBe` False - describe "Kiroku.Metrics.Cors (middleware, standalone)" $ do - it "preserves every response byte and header when disabled, including upgrades and preflights" $ do - let original = Wai.responseLBS status201 [("Vary", "Accept"), ("X-Custom", "yes")] "unchanged" - app _ respond = respond original - forM_ [[], [(hOrigin, ops)], [(hOrigin, evil), ("Upgrade", "websocket")], preflight ops "DELETE"] $ \headers -> do - unwrapped <- capture app "OPTIONS" headers - wrapped <- capture (corsMiddleware corsDisabled app) "OPTIONS" headers - wrapped `shouldBe` unwrapped - it "decorates GET and HEAD and varies allowed, disallowed, absent, malformed and duplicate origins" $ do - forM_ ["GET", "HEAD"] $ \method -> do - (_, headers, body) <- capture (corsMiddleware policy baseApp) method [(hOrigin, ops)] - lookup "Access-Control-Allow-Origin" headers `shouldBe` Just ops - lookup hVary headers `shouldBe` Just "Origin" - body `shouldBe` "legacy" - forM_ [[], [(hOrigin, evil)], [(hOrigin, "null")], [(hOrigin, ops <> "/")], [(hOrigin, ops), (hOrigin, ops)]] $ \headers -> do - (status, hs, body) <- capture (corsMiddleware policy baseApp) "GET" headers - status `shouldBe` status200 - body `shouldBe` "legacy" - grants hs `shouldBe` [] - lookup hVary hs `shouldBe` Just "Origin" - it "answers GET/HEAD preflights, reflects validated tokens, and varies on all inputs" $ do - forM_ ["GET", "HEAD"] $ \method -> do - (status, headers, body) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops method <> [("Access-Control-Request-Headers", "Authorization, X-Trace")]) - status `shouldBe` status204 - body `shouldBe` "" - lookup "Access-Control-Allow-Methods" headers `shouldBe` Just "GET, HEAD, OPTIONS" - lookup "Access-Control-Allow-Headers" headers `shouldBe` Just "Authorization, X-Trace" - lookup hVary headers `shouldBe` Just "Origin, Access-Control-Request-Method, Access-Control-Request-Headers" - it "rejects unsupported/duplicate methods and malformed requested header tokens" $ do - (status, _, body) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "POST") - status `shouldBe` status403 - errorCode body `shouldBe` Just (String "cors_method_not_allowed") - forM_ ["", "X Header", "X:Header", "X-Good,", "X-Good, \xff", "X\r\nInjected"] $ \header -> do - (s, _, b) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "GET" <> [("Access-Control-Request-Headers", header)]) - s `shouldBe` status400 - errorCode b `shouldBe` Just (String "invalid_cors_request") - (emptyStatus, _, _) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "GET" <> [("Access-Control-Request-Headers", ""), ("Access-Control-Request-Headers", "Authorization")]) - emptyStatus `shouldBe` status400 - (s, _, _) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "GET" <> [("Access-Control-Request-Method", "HEAD")]) - s `shouldBe` status400 - it "passes plain OPTIONS and disallowed preflights through without grants" $ do - forM_ [[], [(hOrigin, ops)], preflight evil "GET", [(hOrigin, ops), (hOrigin, ops), ("Access-Control-Request-Method", "GET")]] $ \headers -> do - (s, hs, body) <- capture (corsMiddleware policy baseApp) "OPTIONS" headers - s `shouldBe` status200 - body `shouldBe` "legacy" - if headers == [(hOrigin, ops)] then lookup "Access-Control-Allow-Origin" hs `shouldBe` Just ops else grants hs `shouldBe` [] - it "merges existing Vary case-insensitively and preserves wildcard variation" $ do - let app headers _ respond = respond (Wai.responseLBS status200 headers "") - (_, hs, _) <- capture (corsMiddleware policy (app [(hVary, "Accept, origin"), (hVary, "ACCEPT, X-Foo")])) "GET" [] - lookup hVary hs `shouldBe` Just "Accept, origin, X-Foo" - (_, wildcard, _) <- capture (corsMiddleware policy (app [(hVary, "Accept, *")])) "GET" [(hOrigin, ops)] - lookup hVary wildcard `shouldBe` Just "*" - it "owns grants once, adds optional credentials and ignores negative max age" $ do - let app _ respond = respond (Wai.responseLBS status200 [("Access-Control-Allow-Origin", "*"), ("Access-Control-Allow-Origin", evil), ("Access-Control-Allow-Credentials", "true")] "") - (_, hs, _) <- capture (corsMiddleware policy app) "GET" [(hOrigin, ops)] - grants hs `shouldBe` [("Access-Control-Allow-Origin", ops)] - (_, denied, _) <- capture (corsMiddleware policy app) "GET" [(hOrigin, evil)] - grants denied `shouldBe` [] - forM_ [Nothing, Just (-1), Just 0, Just 3600] $ \age -> do - (_, headers, _) <- capture (corsMiddleware (policy{allowCredentials = True, maxAgeSeconds = age}) baseApp) "OPTIONS" (preflight ops "GET") - lookup "Access-Control-Allow-Credentials" headers `shouldBe` Just "true" - lookup "Access-Control-Max-Age" headers `shouldBe` case age of - Just n | n >= 0 -> Just (fromStringInt n) - _ -> Nothing - it "refuses malformed/duplicate/disallowed upgrade origins before invoking the inner app" $ do - calls <- newIORef (0 :: Int) - let app req respond = modifyIORef' calls (+ 1) >> baseApp req respond - forM_ [[(hOrigin, evil)], [(hOrigin, "null")], [(hOrigin, ops <> "/")], [(hOrigin, ops), (hOrigin, ops)]] $ \headers -> do - (s, hs, body) <- capture (corsMiddleware policy app) "GET" (("Upgrade", "websocket") : headers) - s `shouldBe` status403 - lookup hContentType hs `shouldBe` Just "application/json" - errorCode body `shouldBe` Just (String "origin_not_allowed") - readIORef calls `shouldReturn` 0 - forM_ [[], [(hOrigin, ops)]] $ \headers -> do - _ <- capture (corsMiddleware policy app) "GET" (("Upgrade", "websocket") : headers) - pure () - readIORef calls `shouldReturn` 2 - it "never reuses grants between sequential requests with different origins" $ do - forM_ [[], [(hOrigin, ops)], [(hOrigin, evil)], [(hOrigin, ops)], []] $ \headers -> do - (_, hs, _) <- capture (corsMiddleware policy baseApp) "GET" headers - lookup hVary hs `shouldBe` Just "Origin" - lookup "Access-Control-Allow-Origin" hs `shouldBe` if headers == [(hOrigin, ops)] then Just ops else Nothing - it "leaves raw upgrade responses untouched" $ do - let original = Wai.responseRaw (\_ _ -> pure ()) (Wai.responseLBS status500 [] "fallback") - app _ respond = respond original - ref <- newIORef Nothing - _ <- corsMiddleware policy app (Wai.defaultRequest{Wai.requestHeaders = [("Upgrade", "websocket"), (hOrigin, ops)]}) (\r -> writeIORef ref (Just r) >> pure ResponseReceived) - response <- readIORef ref - case response of - Just (ResponseRaw _ _) -> pure () - _ -> expectationFailure "raw response was rewritten" - it "strips HEAD bodies on a real Warp server while preserving grants and status" $ - Warp.testWithApplication (pure (corsMiddleware policy baseApp)) $ \port -> do - manager <- HTTP.newManager HTTP.defaultManagerSettings - get <- networkRequest manager port "GET" [(hOrigin, ops)] - headResponse <- networkRequest manager port "HEAD" [(hOrigin, ops)] - HTTP.responseStatus headResponse `shouldBe` HTTP.responseStatus get - lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders headResponse) `shouldBe` Just ops - HTTP.responseBody headResponse `shouldBe` "" + describe "Kiroku.Metrics.Cors (middleware, standalone)" $ do + it "preserves every response byte and header when disabled, including origin-less upgrades and preflights" $ do + let original = Wai.responseLBS status201 [("Vary", "Accept"), ("X-Custom", "yes")] "unchanged" + app _ respond = respond original + forM_ [[], [(hOrigin, ops)], [("Upgrade", "websocket")], preflight ops "DELETE"] $ \headers -> do + unwrapped <- capture app "OPTIONS" headers + wrapped <- capture (corsMiddleware corsDisabled app) "OPTIONS" headers + wrapped `shouldBe` unwrapped + it "refuses every Origin-bearing upgrade when disabled without calling the app" $ do + calls <- newIORef (0 :: Int) + let app req respond = modifyIORef' calls (+ 1) >> baseApp req respond + forM_ [[(hOrigin, ops)], [(hOrigin, evil)], [(hOrigin, "")], [(hOrigin, "null")], [(hOrigin, ops), (hOrigin, ops)]] $ \headers -> do + (status, hs, body) <- capture (corsMiddleware corsDisabled app) "GET" (("Upgrade", "websocket") : headers) + status `shouldBe` status403 + lookup hContentType hs `shouldBe` Just "application/json" + decode body `shouldBe` Just (errorEnvelope "origin_not_allowed" "The request origin is not allowed." Nothing) + grants hs `shouldBe` [] + readIORef calls `shouldReturn` 0 + it "decorates GET and HEAD and varies allowed, disallowed, absent, malformed and duplicate origins" $ do + forM_ ["GET", "HEAD"] $ \method -> do + (_, headers, body) <- capture (corsMiddleware policy baseApp) method [(hOrigin, ops)] + lookup "Access-Control-Allow-Origin" headers `shouldBe` Just ops + lookup hVary headers `shouldBe` Just "Origin" + body `shouldBe` "legacy" + forM_ [[], [(hOrigin, evil)], [(hOrigin, "null")], [(hOrigin, ops <> "/")], [(hOrigin, ops), (hOrigin, ops)]] $ \headers -> do + (status, hs, body) <- capture (corsMiddleware policy baseApp) "GET" headers + status `shouldBe` status200 + body `shouldBe` "legacy" + grants hs `shouldBe` [] + lookup hVary hs `shouldBe` Just "Origin" + it "answers GET/HEAD preflights, reflects validated tokens, and varies on all inputs" $ do + forM_ ["GET", "HEAD"] $ \method -> do + (status, headers, body) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops method <> [("Access-Control-Request-Headers", "Authorization, X-Trace")]) + status `shouldBe` status204 + body `shouldBe` "" + lookup "Access-Control-Allow-Methods" headers `shouldBe` Just "GET, HEAD, OPTIONS" + lookup "Access-Control-Allow-Headers" headers `shouldBe` Just "Authorization, X-Trace" + lookup hVary headers `shouldBe` Just "Origin, Access-Control-Request-Method, Access-Control-Request-Headers" + it "rejects unsupported/duplicate methods and malformed requested header tokens" $ do + (status, _, body) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "POST") + status `shouldBe` status403 + errorCode body `shouldBe` Just (String "cors_method_not_allowed") + forM_ ["", "X Header", "X:Header", "X-Good,", "X-Good, \xff", "X\r\nInjected"] $ \header -> do + (s, _, b) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "GET" <> [("Access-Control-Request-Headers", header)]) + s `shouldBe` status400 + errorCode b `shouldBe` Just (String "invalid_cors_request") + (emptyStatus, _, _) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "GET" <> [("Access-Control-Request-Headers", ""), ("Access-Control-Request-Headers", "Authorization")]) + emptyStatus `shouldBe` status400 + (s, _, _) <- capture (corsMiddleware policy baseApp) "OPTIONS" (preflight ops "GET" <> [("Access-Control-Request-Method", "HEAD")]) + s `shouldBe` status400 + it "passes plain OPTIONS and disallowed preflights through without grants" $ do + forM_ [[], [(hOrigin, ops)], preflight evil "GET", [(hOrigin, ops), (hOrigin, ops), ("Access-Control-Request-Method", "GET")]] $ \headers -> do + (s, hs, body) <- capture (corsMiddleware policy baseApp) "OPTIONS" headers + s `shouldBe` status200 + body `shouldBe` "legacy" + if headers == [(hOrigin, ops)] then lookup "Access-Control-Allow-Origin" hs `shouldBe` Just ops else grants hs `shouldBe` [] + it "merges existing Vary case-insensitively and preserves wildcard variation" $ do + let app headers _ respond = respond (Wai.responseLBS status200 headers "") + (_, hs, _) <- capture (corsMiddleware policy (app [(hVary, "Accept, origin"), (hVary, "ACCEPT, X-Foo")])) "GET" [] + lookup hVary hs `shouldBe` Just "Accept, origin, X-Foo" + (_, wildcard, _) <- capture (corsMiddleware policy (app [(hVary, "Accept, *")])) "GET" [(hOrigin, ops)] + lookup hVary wildcard `shouldBe` Just "*" + it "owns grants once, adds optional credentials and ignores negative max age" $ do + let app _ respond = respond (Wai.responseLBS status200 [("Access-Control-Allow-Origin", "*"), ("Access-Control-Allow-Origin", evil), ("Access-Control-Allow-Credentials", "true")] "") + (_, hs, _) <- capture (corsMiddleware policy app) "GET" [(hOrigin, ops)] + grants hs `shouldBe` [("Access-Control-Allow-Origin", ops)] + (_, denied, _) <- capture (corsMiddleware policy app) "GET" [(hOrigin, evil)] + grants denied `shouldBe` [] + forM_ [Nothing, Just (-1), Just 0, Just 3600] $ \age -> do + (_, headers, _) <- capture (corsMiddleware (policy {allowCredentials = True, maxAgeSeconds = age}) baseApp) "OPTIONS" (preflight ops "GET") + lookup "Access-Control-Allow-Credentials" headers `shouldBe` Just "true" + lookup "Access-Control-Max-Age" headers `shouldBe` case age of + Just n | n >= 0 -> Just (fromStringInt n) + _ -> Nothing + it "refuses malformed/duplicate/disallowed upgrade origins before invoking the inner app" $ do + calls <- newIORef (0 :: Int) + let app req respond = modifyIORef' calls (+ 1) >> baseApp req respond + forM_ [[(hOrigin, evil)], [(hOrigin, "null")], [(hOrigin, ops <> "/")], [(hOrigin, ops), (hOrigin, ops)]] $ \headers -> do + (s, hs, body) <- capture (corsMiddleware policy app) "GET" (("Upgrade", "websocket") : headers) + s `shouldBe` status403 + lookup hContentType hs `shouldBe` Just "application/json" + errorCode body `shouldBe` Just (String "origin_not_allowed") + readIORef calls `shouldReturn` 0 + forM_ [[], [(hOrigin, ops)]] $ \headers -> do + _ <- capture (corsMiddleware policy app) "GET" (("Upgrade", "websocket") : headers) + pure () + readIORef calls `shouldReturn` 2 + it "never reuses grants between sequential requests with different origins" $ do + forM_ [[], [(hOrigin, ops)], [(hOrigin, evil)], [(hOrigin, ops)], []] $ \headers -> do + (_, hs, _) <- capture (corsMiddleware policy baseApp) "GET" headers + lookup hVary hs `shouldBe` Just "Origin" + lookup "Access-Control-Allow-Origin" hs `shouldBe` if headers == [(hOrigin, ops)] then Just ops else Nothing + it "leaves raw upgrade responses untouched" $ do + let original = Wai.responseRaw (\_ _ -> pure ()) (Wai.responseLBS status500 [] "fallback") + app _ respond = respond original + ref <- newIORef Nothing + _ <- corsMiddleware policy app (Wai.defaultRequest {Wai.requestHeaders = [("Upgrade", "websocket"), (hOrigin, ops)]}) (\r -> writeIORef ref (Just r) >> pure ResponseReceived) + response <- readIORef ref + case response of + Just (ResponseRaw _ _) -> pure () + _ -> expectationFailure "raw response was rewritten" + it "strips HEAD bodies on a real Warp server while preserving grants and status" $ + Warp.testWithApplication (pure (corsMiddleware policy baseApp)) $ \port -> do + manager <- HTTP.newManager HTTP.defaultManagerSettings + get <- networkRequest manager port "GET" [(hOrigin, ops)] + headResponse <- networkRequest manager port "HEAD" [(hOrigin, ops)] + HTTP.responseStatus headResponse `shouldBe` HTTP.responseStatus get + lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders headResponse) `shouldBe` Just ops + HTTP.responseBody headResponse `shouldBe` "" - describe "Kiroku.Metrics.JSON (shared inspection errors)" $ do - it "pins envelope keys and omits optional details" $ do - errorEnvelope "origin_not_allowed" "Denied." Nothing `shouldBe` object ["error" .= object ["code" .= ("origin_not_allowed" :: Text), "message" .= ("Denied." :: Text)]] - errorEnvelope "invalid_query_parameter" "Invalid." (Just (object ["parameter" .= ("limit" :: Text)])) `shouldBe` object ["error" .= object ["code" .= ("invalid_query_parameter" :: Text), "message" .= ("Invalid." :: Text), "details" .= object ["parameter" .= ("limit" :: Text)]]] - it "sanitizes unavailable and other store errors" $ do - forM_ [(ConnectionError "postgres://secret", status503, "store_unavailable"), (ConnectionLost "secret", status503, "store_unavailable"), (PoolAcquisitionTimeout, status503, "store_unavailable"), (TransientTransactionFailure "40001" "secret", status503, "store_unavailable"), (TransientTransactionFailure "40P01" "secret", status503, "store_unavailable"), (UnexpectedServerError "42P01" "secret SQL", status500, "store_error"), (StreamNotFound (StreamName "private"), status500, "store_error"), (EventDecodeFailed (DecodeFailure (EventId UUID.nil) "secret payload"), status500, "event_decode_failed")] $ \(err, expected, code) -> do - (status, _, body) <- capture (\_ respond -> respond (storeErrorResponse "store_unavailable" err)) "GET" [] - status `shouldBe` expected - errorCode body `shouldBe` Just (String code) - body `shouldSatisfy` (not . BS.isInfixOf "secret" . LBS.toStrict) + describe "Kiroku.Metrics.JSON (shared inspection errors)" $ do + it "pins envelope keys and omits optional details" $ do + errorEnvelope "origin_not_allowed" "Denied." Nothing `shouldBe` object ["error" .= object ["code" .= ("origin_not_allowed" :: Text), "message" .= ("Denied." :: Text)]] + errorEnvelope "invalid_query_parameter" "Invalid." (Just (object ["parameter" .= ("limit" :: Text)])) `shouldBe` object ["error" .= object ["code" .= ("invalid_query_parameter" :: Text), "message" .= ("Invalid." :: Text), "details" .= object ["parameter" .= ("limit" :: Text)]]] + it "sanitizes unavailable and other store errors" $ do + forM_ [(ConnectionError "postgres://secret", status503, "store_unavailable"), (ConnectionLost "secret", status503, "store_unavailable"), (PoolAcquisitionTimeout, status503, "store_unavailable"), (TransientTransactionFailure "40001" "secret", status503, "store_unavailable"), (TransientTransactionFailure "40P01" "secret", status503, "store_unavailable"), (UnexpectedServerError "42P01" "secret SQL", status500, "store_error"), (StreamNotFound (StreamName "private"), status500, "store_error"), (EventDecodeFailed (DecodeFailure (EventId UUID.nil) "secret payload"), status500, "event_decode_failed")] $ \(err, expected, code) -> do + (status, _, body) <- capture (\_ respond -> respond (storeErrorResponse "store_unavailable" err)) "GET" [] + status `shouldBe` expected + errorCode body `shouldBe` Just (String code) + body `shouldSatisfy` (not . BS.isInfixOf "secret" . LBS.toStrict) - describe "Kiroku.Metrics.Cors (real server)" $ do - it "decorates store-backed metrics, answers preflights and keeps denied bodies unchanged" $ - withInspection policy $ \port -> do - manager <- HTTP.newManager HTTP.defaultManagerSettings - allowed <- networkRequest manager port "GET" [(hOrigin, ops)] - HTTP.responseStatus allowed `shouldBe` status200 - lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders allowed) `shouldBe` Just ops - denied <- networkRequest manager port "GET" [(hOrigin, evil)] - HTTP.responseStatus denied `shouldBe` status200 - grants (HTTP.responseHeaders denied) `shouldBe` [] - pre <- networkRequest manager port "OPTIONS" (preflight ops "GET") - HTTP.responseStatus pre `shouldBe` status204 - it "upgrades allowed and absent origins but refuses an unlisted browser origin" $ - withInspection policy $ \port -> do - assertSnapshot port [(hOrigin, ops)] - refused <- wsSnapshot port [(hOrigin, evil)] - case refused of - Left (WS.MalformedResponse _ _) -> pure () - other -> expectationFailure ("expected 403 MalformedResponse, got " <> show other) - assertSnapshot port [] - it "keeps upgrades open to any origin under the default disabled policy" $ - withInspection corsDisabled $ \port -> - assertSnapshot port [(hOrigin, evil)] + describe "Kiroku.Metrics.Cors (real server)" $ do + it "decorates store-backed metrics, answers preflights and keeps denied bodies unchanged" $ + withInspection policy $ \port -> do + manager <- HTTP.newManager HTTP.defaultManagerSettings + allowed <- networkRequest manager port "GET" [(hOrigin, ops)] + HTTP.responseStatus allowed `shouldBe` status200 + lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders allowed) `shouldBe` Just ops + denied <- networkRequest manager port "GET" [(hOrigin, evil)] + HTTP.responseStatus denied `shouldBe` status200 + grants (HTTP.responseHeaders denied) `shouldBe` [] + pre <- networkRequest manager port "OPTIONS" (preflight ops "GET") + HTTP.responseStatus pre `shouldBe` status204 + it "upgrades allowed and absent origins but refuses an unlisted browser origin" $ + withInspection policy $ \port -> do + assertSnapshot port [(hOrigin, ops)] + assertEventUpgrade port [(hOrigin, ops)] + refused <- wsSnapshot port [(hOrigin, evil)] + case refused of + Left (WS.MalformedResponse _ _) -> pure () + other -> expectationFailure ("expected 403 MalformedResponse, got " <> show other) + assertSnapshot port [] + it "refuses browser event upgrades by default, preserving HTTP and origin-less clients" $ + withInspection corsDisabled $ \port -> do + assertSnapshot port [] + assertEventUpgrade port [] + refused <- timeout 15_000_000 $ try $ WS.runClientWith "127.0.0.1" port "/ws/events" WS.defaultConnectionOptions [(hOrigin, evil)] (\_ -> pure ()) + case refused of + Just (Left (WS.MalformedResponse _ _)) -> pure () + other -> expectationFailure ("expected failed handshake, got " <> show other) + manager <- HTTP.newManager HTTP.defaultManagerSettings + req <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/ws/events") + response <- HTTP.httpLbs req {HTTP.requestHeaders = [(hOrigin, evil), ("Connection", "Upgrade"), ("Upgrade", "websocket"), ("Sec-WebSocket-Version", "13"), ("Sec-WebSocket-Key", "dGhlIHNhbXBsZSBub25jZQ==")]} manager + HTTP.responseStatus response `shouldBe` status403 + lookup hContentType (HTTP.responseHeaders response) `shouldBe` Just "application/json" + decode (HTTP.responseBody response) `shouldBe` Just (errorEnvelope "origin_not_allowed" "The request origin is not allowed." Nothing) + grants (HTTP.responseHeaders response) `shouldBe` [] + http <- networkRequest manager port "GET" [(hOrigin, evil)] + HTTP.responseStatus http `shouldBe` status200 + grants (HTTP.responseHeaders http) `shouldBe` [] baseApp :: Wai.Application baseApp _ respond = respond (Wai.responseLBS status200 [("X-Legacy", "kept")] "legacy") @@ -214,52 +240,61 @@ capture :: Wai.Application -> Method -> RequestHeaders -> IO (Status, ResponseHeaders, LBS.ByteString) capture app method headers = do - ref <- newIORef Nothing - _ <- app (Wai.defaultRequest{Wai.requestMethod = method, Wai.requestHeaders = headers}) $ \response -> do - let (status, hs, stream) = Wai.responseToStream response - chunks <- newIORef mempty - stream $ \body -> body (\builder -> modifyIORef' chunks (<> builder)) (pure ()) - bytes <- toLazyByteString <$> readIORef chunks - writeIORef ref (Just (status, hs, bytes)) - pure ResponseReceived - readIORef ref >>= maybe (fail "application did not respond") pure + ref <- newIORef Nothing + _ <- app (Wai.defaultRequest {Wai.requestMethod = method, Wai.requestHeaders = headers}) $ \response -> do + let (status, hs, stream) = Wai.responseToStream response + chunks <- newIORef mempty + stream $ \body -> body (\builder -> modifyIORef' chunks (<> builder)) (pure ()) + bytes <- toLazyByteString <$> readIORef chunks + writeIORef ref (Just (status, hs, bytes)) + pure ResponseReceived + readIORef ref >>= maybe (fail "application did not respond") pure errorCode :: LBS.ByteString -> Maybe Value errorCode bytes = do - Object root <- decode bytes - Object err <- KM.lookup "error" root - KM.lookup "code" err + Object root <- decode bytes + Object err <- KM.lookup "error" root + KM.lookup "code" err networkRequest :: HTTP.Manager -> Int -> Method -> RequestHeaders -> IO (HTTP.Response LBS.ByteString) networkRequest manager port method headers = do - request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/metrics") - HTTP.httpLbs (request{HTTP.method = method, HTTP.requestHeaders = headers}) manager + request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/metrics") + HTTP.httpLbs (request {HTTP.method = method, HTTP.requestHeaders = headers}) manager withInspection :: CorsPolicy -> (Int -> IO a) -> IO a withInspection cors action = withMigratedTestDatabase $ \connStr -> do - metrics <- newKirokuMetricsWith (pure (GlobalPosition 0)) (pure 0) - withStore (defaultConnectionSettings connStr) $ \store -> - withMetricsServerWithStore (defaultConfig{Config.port = 0, Config.cors = cors}) metrics store [] $ \server -> do - threadDelay 300_000 - action server.serverPort + metrics <- newKirokuMetricsWith (pure (GlobalPosition 0)) (pure 0) + withStore (defaultConnectionSettings connStr) $ \store -> + withMetricsServerWithStore (defaultConfig {Config.port = 0, Config.cors = cors}) metrics store [] $ \server -> do + threadDelay 300_000 + action server.serverPort wsSnapshot :: Int -> RequestHeaders -> IO (Either WS.HandshakeException (Maybe Value)) wsSnapshot port headers = do - result <- timeout 15_000_000 $ - try $ - WS.runClientWith "127.0.0.1" port "/ws/metrics" WS.defaultConnectionOptions headers $ \conn -> do - raw <- WS.receiveData conn :: IO LBS.ByteString - pure $ do - Object fields <- decode raw - KM.lookup "type" fields - maybe (fail "WebSocket snapshot timed out") pure result + result <- timeout 15_000_000 $ + try $ + WS.runClientWith "127.0.0.1" port "/ws/metrics" WS.defaultConnectionOptions headers $ \conn -> do + raw <- WS.receiveData conn :: IO LBS.ByteString + pure $ do + Object fields <- decode raw + KM.lookup "type" fields + maybe (fail "WebSocket snapshot timed out") pure result fromStringInt :: Int -> ByteString fromStringInt = BS.pack . show assertSnapshot :: Int -> RequestHeaders -> Expectation assertSnapshot port headers = do - result <- wsSnapshot port headers - case result of - Right value -> value `shouldBe` Just (String "snapshot") - Left err -> expectationFailure (show err) + result <- wsSnapshot port headers + case result of + Right value -> value `shouldBe` Just (String "snapshot") + Left err -> expectationFailure (show err) + +-- Exercise the sensitive event channel's successful 101 handshake as well as +-- metrics snapshots, for configured browser and default origin-less clients. +assertEventUpgrade :: Int -> RequestHeaders -> Expectation +assertEventUpgrade port headers = do + result <- timeout 15_000_000 $ + WS.runClientWith "127.0.0.1" port "/ws/events" WS.defaultConnectionOptions headers $ \conn -> + WS.sendClose conn ("done" :: Text) + result `shouldBe` Just () diff --git a/test/Test/DeadLettersSpec.hs b/test/Test/DeadLettersSpec.hs --- a/test/Test/DeadLettersSpec.hs +++ b/test/Test/DeadLettersSpec.hs @@ -42,149 +42,156 @@ spec :: Spec spec = describe "DeadLetters" $ do - it "pins exact snake_case keys, preserves reason JSON and round-trips lossless positions" $ do - let response = deadLetterPageResponse fixture - item = object ["dead_letter_id" .= (7 :: Int), "subscription" .= ("orders" :: Text), "member" .= (9 :: Int), "global_position" .= (9007199254740993 :: Integer), "event_id" .= UUID.nil, "reason" .= object ["kind" .= ("poison" :: Text), "detail" .= ("unknown SKU" :: Text)], "reason_summary" .= ("poison: unknown SKU" :: Text), "attempt_count" .= (1 :: Int), "created_at" .= ("2026-09-10T00:00:00Z" :: Text)] - Aeson.toJSON response `shouldBe` object ["items" .= [item], "next_cursor" .= ("9007199254740993:7" :: Text)] - Aeson.eitherDecode (Aeson.encode response) `shouldBe` Right response - Aeson.toJSON (deadLetterPageResponse (Store.SubscriptionDeadLetterPage V.empty Nothing)) `shouldBe` object ["items" .= ([] :: [Value])] - it "validates decimal cursor components without signed or overflow narrowing" $ do - forM_ ["", "1", "1:", ":1", "1:2:3", "-1:2", "1:-2", "1.5:2", "18446744073709551616:1", "9223372036854775808:1", "1:18446744073709551616", "+1:2", "１:2"] $ \raw -> parseDeadLetterCursor raw `shouldBe` Nothing - forM_ [Store.SubscriptionDeadLetterCursor (Store.GlobalPosition 0) 0, Store.SubscriptionDeadLetterCursor (Store.GlobalPosition maxBound) maxBound] $ \cursor -> parseDeadLetterCursor (renderDeadLetterCursor cursor) `shouldBe` Just cursor - it "passes the complete query once and uses the documented defaults" $ do - calls <- newIORef [] - let provider query = modifyIORef' calls (<> [query]) >> pure (Right fixture) - void $ capture (deadLettersApp provider) "GET" ["subscriptions", "orders", "dead-letters"] [("member", Just "9"), ("from", Just "4211:7"), ("limit", Just "5")] - void $ capture (deadLettersApp provider) "GET" ["subscriptions", "orders", "dead-letters"] [] - recorded <- readIORef calls - recorded `shouldBe` [Store.SubscriptionDeadLetterQuery (Store.SubscriptionName "orders") (Just 9) (Just (Store.SubscriptionDeadLetterCursor (Store.GlobalPosition 4211) 7)) (either (error . show) (\v -> v) (Store.mkSubscriptionDeadLetterLimit 5)), Store.defaultSubscriptionDeadLetterQuery (Store.SubscriptionName "orders")] - it "rejects invalid, duplicate, missing and malformed UTF-8 values before calling a provider" $ do - calls <- newIORef (0 :: Int) - let app = deadLettersApp (\_ -> modifyIORef' calls (+ 1) >> pure (Right fixture)) - forM_ [[("limit", Just raw)] | raw <- ["0", "1001", "abc", "", "-1", "18446744073709551616"]] $ \query -> invalidRequest calls app query - forM_ [[("member", Just "2147483648")], [("member", Just "-1")], [("from", Just "1:9223372036854775808")], [("limit", Nothing)], [("limit", Just "2"), ("limit", Just "3")], [("member", Just "\255")]] $ invalidRequest calls app - readIORef calls `shouldReturn` 0 - (status, _, _) <- capture app "GET" ["subscriptions", "orders", "dead-letters"] [("unknown", Nothing)] - status `shouldBe` status200 - it "implements HEAD and 405 in WAI, including unavailable and unconfigured responses" $ do - calls <- newIORef (0 :: Int) - let app = deadLettersApp (\_ -> modifyIORef' calls (+ 1) >> pure (Right fixture)) - (status, headers, _) <- capture app "GET" route [] - capture app "HEAD" route [] `shouldReturn` (status, headers, "") - forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do - (actual, hs, body) <- capture app method route [] - actual `shouldBe` status405 - lookup "Allow" hs `shouldBe` Just "GET, HEAD" - code body `shouldBe` Just "method_not_allowed" - readIORef calls `shouldReturn` 2 - (missing, _, body) <- capture deadLettersNotConfiguredApp "GET" route [] - missing `shouldBe` status404 - code body `shouldBe` Just "dead_letters_not_configured" - it "sanitizes typed store failures and preserves HEAD error headers" $ do - forM_ [(Store.ConnectionError "postgres://secret", status503, "dead_letters_unavailable"), (Store.ConnectionLost "secret", status503, "dead_letters_unavailable"), (Store.PoolAcquisitionTimeout, status503, "dead_letters_unavailable"), (Store.TransientTransactionFailure "40001" "secret", status503, "dead_letters_unavailable"), (Store.TransientTransactionFailure "40P01" "secret", status503, "dead_letters_unavailable"), (Store.UnexpectedServerError "42P01" "secret SQL", status500, "store_error"), (Store.StreamNotFound (Store.StreamName "secret"), status500, "store_error"), (Store.EventDecodeFailed (Store.DecodeFailure (Store.EventId UUID.nil) "secret"), status500, "event_decode_failed")] $ \(err, expected, expectedCode) -> do - let app = deadLettersApp (\_ -> pure (Left err)) - (status, headers, body) <- capture app "GET" route [] - status `shouldBe` expected - code body `shouldBe` Just expectedCode - body `shouldSatisfy` (not . T.isInfixOf "secret" . T.pack . LBSC.unpack) - capture app "HEAD" route [] `shouldReturn` (status, headers, "") - it "propagates thrown provider exceptions and serves structured unknown-path errors" $ do - result <- try @SomeException $ capture (deadLettersApp (\_ -> throwIO (userError "failure"))) "GET" route [] - result `shouldSatisfy` either (const True) (const False) - (status, _, body) <- capture (deadLettersApp (\_ -> error "must not run")) "GET" ["unknown"] [] - status `shouldBe` status404 - code body `shouldBe` Just "not_found" - it "serves real pages, member filters and legacy behavior from the store-aware server" $ withTestStore $ \store -> do - let event = Store.EventData Nothing (Store.EventType "Created") (object []) Nothing Nothing Nothing - Right _ <- Store.runStoreIO store $ Store.appendToStream (Store.StreamName "orders-1") Store.NoStream (replicate 5 event) - Right events <- Store.runStoreIO store $ Store.readAllForward (Store.GlobalPosition 0) 10 - forM_ (V.toList events) $ \recorded -> seed store "paged/name" 0 recorded - seed store "other" 0 (V.head events) - handle <- Store.subscribe store $ Store.defaultSubscriptionConfig (Store.SubscriptionName "worker") Store.AllStreams $ \recorded -> pure $ case recorded ^. #globalPosition of - Store.GlobalPosition 2 -> Store.DeadLetter (Store.DeadLetterPoison "unknown SKU") - Store.GlobalPosition 5 -> Store.Stop - _ -> Store.Continue - stopped <- timeout 10_000_000 (Store.wait handle) - case stopped of - Just (Right ()) -> pure () - other -> Store.cancel handle >> expectationFailure (show other) - metrics <- newKirokuMetrics store - withMetricsServerWithStore defaultConfig{port = 0} metrics store [] $ \server -> do - workerPage <- get server.serverPort "/subscriptions/worker/dead-letters" >>= decodePage - map (.globalPosition) workerPage.items `shouldBe` [2] - map (.reason) workerPage.items `shouldBe` [object ["kind" .= ("poison" :: Text), "detail" .= ("unknown SKU" :: Text)]] - putStrLn ("Dead-letter worker response: " <> LBSC.unpack (Aeson.encode workerPage)) - first <- get server.serverPort "/subscriptions/paged%2Fname/dead-letters?limit=2" - p1 <- decodePage first - map (.globalPosition) p1.items `shouldBe` [5, 4] - p2 <- get server.serverPort ("/subscriptions/paged%2Fname/dead-letters?limit=2&from=" <> maybe "" T.unpack p1.nextCursor) >>= decodePage - p3 <- get server.serverPort ("/subscriptions/paged%2Fname/dead-letters?limit=2&from=" <> maybe "" T.unpack p2.nextCursor) >>= decodePage - map (.globalPosition) p2.items `shouldBe` [3, 2] - map (.globalPosition) p3.items `shouldBe` [1] - p3.nextCursor `shouldBe` Nothing - empty <- get server.serverPort "/subscriptions/never/dead-letters" >>= decodePage - empty `shouldBe` DeadLetterPageResponse [] Nothing - filtered <- get server.serverPort "/subscriptions/paged%2Fname/dead-letters?member=9" >>= decodePage - filtered `shouldBe` DeadLetterPageResponse [] Nothing - old <- get server.serverPort "/subscriptions" - Aeson.decode (HTTP.responseBody old) `shouldBe` Just (object ["error" .= ("subscription status not configured" :: Text)]) - unknown <- get server.serverPort "/nope" - Aeson.decode (HTTP.responseBody unknown) `shouldBe` Just (object ["error" .= ("Not found" :: Text)]) - providers <- storeServerProviders defaultConfig metrics store - withMetricsServerWithProviders defaultConfig{port = 0} metrics [] providers $ \server -> do - live <- get server.serverPort "/subscriptions" - HTTP.responseStatus live `shouldBe` status200 - void $ get server.serverPort "/subscriptions/paged%2Fname/dead-letters" >>= decodePage - it "inherits mount-relative routing and CORS with legacy switches disabled" $ do - metrics <- newKirokuMetricsWith (pure (Store.GlobalPosition 0)) (pure 0) - let origin = either (error . show) (\v -> v) (allowedOrigin "https://ops.example.com") - config = defaultConfig{cors = corsAllowOrigins [origin], enableJSON = False, enableWebSocket = False} - providers = defaultServerProviders{deadLetters = Just (\_ -> pure (Right fixture))} - mounted req respond = combinedAppWithProviders config metrics [] providers (req{Wai.pathInfo = drop 1 (Wai.pathInfo req)}) respond - Warp.testWithApplication (pure mounted) $ \port -> do - manager <- HTTP.newManager HTTP.defaultManagerSettings - request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/inspect/subscriptions/orders/dead-letters") - response <- HTTP.httpLbs request{HTTP.requestHeaders = [("Origin", "https://ops.example.com")]} manager - HTTP.responseStatus response `shouldBe` status200 - lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response) `shouldBe` Just "https://ops.example.com" + it "pins exact snake_case keys, preserves reason JSON and round-trips lossless positions" $ do + let response = deadLetterPageResponse fixture + item = object ["dead_letter_id" .= (7 :: Int), "subscription" .= ("orders" :: Text), "member" .= (9 :: Int), "global_position" .= (9007199254740993 :: Integer), "event_id" .= UUID.nil, "reason" .= object ["kind" .= ("poison" :: Text), "detail" .= ("unknown SKU" :: Text)], "reason_summary" .= ("poison: unknown SKU" :: Text), "attempt_count" .= (1 :: Int), "created_at" .= ("2026-09-10T00:00:00Z" :: Text)] + Aeson.toJSON response `shouldBe` object ["items" .= [item], "next_cursor" .= ("9007199254740993:7" :: Text)] + Aeson.eitherDecode (Aeson.encode response) `shouldBe` Right response + Aeson.toJSON (deadLetterPageResponse (Store.SubscriptionDeadLetterPage V.empty Nothing)) `shouldBe` object ["items" .= ([] :: [Value])] + it "validates decimal cursor components without signed or overflow narrowing" $ do + forM_ ["", "1", "1:", ":1", "1:2:3", "-1:2", "1:-2", "1.5:2", "18446744073709551616:1", "9223372036854775808:1", "1:18446744073709551616", "+1:2", "１:2"] $ \raw -> parseDeadLetterCursor raw `shouldBe` Nothing + forM_ [Store.SubscriptionDeadLetterCursor (Store.GlobalPosition 0) 0, Store.SubscriptionDeadLetterCursor (Store.GlobalPosition maxBound) maxBound] $ \cursor -> parseDeadLetterCursor (renderDeadLetterCursor cursor) `shouldBe` Just cursor + it "passes the complete query once and uses the documented defaults" $ do + calls <- newIORef [] + let provider query = modifyIORef' calls (<> [query]) >> pure (Right fixture) + void $ capture (deadLettersApp provider) "GET" ["subscriptions", "orders", "dead-letters"] [("member", Just "9"), ("from", Just "4211:7"), ("limit", Just "5")] + void $ capture (deadLettersApp provider) "GET" ["subscriptions", "orders", "dead-letters"] [] + recorded <- readIORef calls + recorded `shouldBe` [Store.SubscriptionDeadLetterQuery (Store.SubscriptionName "orders") (Just 9) (Just (Store.SubscriptionDeadLetterCursor (Store.GlobalPosition 4211) 7)) (either (error . show) (\v -> v) (Store.mkSubscriptionDeadLetterLimit 5)), Store.defaultSubscriptionDeadLetterQuery (Store.SubscriptionName "orders")] + it "rejects invalid, duplicate, missing and malformed UTF-8 values before calling a provider" $ do + calls <- newIORef (0 :: Int) + let app = deadLettersApp (\_ -> modifyIORef' calls (+ 1) >> pure (Right fixture)) + forM_ [[("limit", Just raw)] | raw <- ["0", "1001", "abc", "", "-1", "18446744073709551616"]] $ \query -> invalidRequest calls app query + forM_ [[("member", Just "2147483648")], [("member", Just "-1")], [("from", Just "1:9223372036854775808")], [("limit", Nothing)], [("limit", Just "2"), ("limit", Just "3")], [("member", Just "\255")]] $ invalidRequest calls app + readIORef calls `shouldReturn` 0 + (status, _, _) <- capture app "GET" ["subscriptions", "orders", "dead-letters"] [("unknown", Nothing)] + status `shouldBe` status200 + it "implements HEAD and 405 in WAI, including unavailable and unconfigured responses" $ do + calls <- newIORef (0 :: Int) + let app = deadLettersApp (\_ -> modifyIORef' calls (+ 1) >> pure (Right fixture)) + (status, headers, _) <- capture app "GET" route [] + capture app "HEAD" route [] `shouldReturn` (status, headers, "") + forM_ ["POST", "PUT", "DELETE", "OPTIONS"] $ \method -> do + (actual, hs, body) <- capture app method route [] + actual `shouldBe` status405 + lookup "Allow" hs `shouldBe` Just "GET, HEAD" + code body `shouldBe` Just "method_not_allowed" + readIORef calls `shouldReturn` 2 + (missing, _, body) <- capture deadLettersNotConfiguredApp "GET" route [] + missing `shouldBe` status404 + code body `shouldBe` Just "dead_letters_not_configured" + it "sanitizes typed store failures and preserves HEAD error headers" $ do + forM_ [(Store.ConnectionError "postgres://secret", status503, "dead_letters_unavailable"), (Store.ConnectionLost "secret", status503, "dead_letters_unavailable"), (Store.PoolAcquisitionTimeout, status503, "dead_letters_unavailable"), (Store.TransientTransactionFailure "40001" "secret", status503, "dead_letters_unavailable"), (Store.TransientTransactionFailure "40P01" "secret", status503, "dead_letters_unavailable"), (Store.UnexpectedServerError "42P01" "secret SQL", status500, "store_error"), (Store.StreamNotFound (Store.StreamName "secret"), status500, "store_error"), (Store.EventDecodeFailed (Store.DecodeFailure (Store.EventId UUID.nil) "secret"), status500, "event_decode_failed")] $ \(err, expected, expectedCode) -> do + let app = deadLettersApp (\_ -> pure (Left err)) + (status, headers, body) <- capture app "GET" route [] + status `shouldBe` expected + code body `shouldBe` Just expectedCode + body `shouldSatisfy` (not . T.isInfixOf "secret" . T.pack . LBSC.unpack) + capture app "HEAD" route [] `shouldReturn` (status, headers, "") + it "propagates thrown provider exceptions and serves structured unknown-path errors" $ do + result <- try @SomeException $ capture (deadLettersApp (\_ -> throwIO (userError "failure"))) "GET" route [] + result `shouldSatisfy` either (const True) (const False) + (status, _, body) <- capture (deadLettersApp (\_ -> error "must not run")) "GET" ["unknown"] [] + status `shouldBe` status404 + code body `shouldBe` Just "not_found" + it "serves real pages, member filters and legacy behavior from the store-aware server" $ withTestStore $ \store -> do + let event = Store.EventData Nothing (Store.EventType "Created") (object []) Nothing Nothing Nothing + Right _ <- Store.runStoreIO store $ Store.appendToStream (Store.StreamName "orders-1") Store.NoStream (replicate 5 event) + Right events <- Store.runStoreIO store $ Store.readAllForward (Store.GlobalPosition 0) 10 + forM_ (V.toList events) $ \recorded -> seed store "paged/name" 0 recorded + seed store "other" 0 (V.head events) + handle <- Store.subscribe store $ Store.defaultSubscriptionConfig (Store.SubscriptionName "worker") Store.AllStreams $ \recorded -> pure $ case recorded ^. #globalPosition of + Store.GlobalPosition 2 -> Store.DeadLetter (Store.DeadLetterPoison "unknown SKU") + Store.GlobalPosition 5 -> Store.Stop + _ -> Store.Continue + stopped <- timeout 10_000_000 (Store.wait handle) + case stopped of + Just (Right ()) -> pure () + other -> Store.cancel handle >> expectationFailure (show other) + metrics <- newKirokuMetrics store + withMetricsServerWithStore defaultConfig {port = 0} metrics store [] $ \server -> do + workerPage <- get server.serverPort "/subscriptions/worker/dead-letters" >>= decodePage + map (.globalPosition) workerPage.items `shouldBe` [2] + map (.reason) workerPage.items `shouldBe` [object ["kind" .= ("poison" :: Text), "detail" .= ("unknown SKU" :: Text)]] + putStrLn ("Dead-letter worker response: " <> LBSC.unpack (Aeson.encode workerPage)) + first <- get server.serverPort "/subscriptions/paged%2Fname/dead-letters?limit=2" + p1 <- decodePage first + map (.globalPosition) p1.items `shouldBe` [5, 4] + p2 <- get server.serverPort ("/subscriptions/paged%2Fname/dead-letters?limit=2&from=" <> maybe "" T.unpack p1.nextCursor) >>= decodePage + p3 <- get server.serverPort ("/subscriptions/paged%2Fname/dead-letters?limit=2&from=" <> maybe "" T.unpack p2.nextCursor) >>= decodePage + map (.globalPosition) p2.items `shouldBe` [3, 2] + map (.globalPosition) p3.items `shouldBe` [1] + p3.nextCursor `shouldBe` Nothing + empty <- get server.serverPort "/subscriptions/never/dead-letters" >>= decodePage + empty `shouldBe` DeadLetterPageResponse [] Nothing + filtered <- get server.serverPort "/subscriptions/paged%2Fname/dead-letters?member=9" >>= decodePage + filtered `shouldBe` DeadLetterPageResponse [] Nothing + old <- get server.serverPort "/subscriptions" + Aeson.decode (HTTP.responseBody old) `shouldBe` Just (object ["error" .= ("subscription status not configured" :: Text)]) + unknown <- get server.serverPort "/nope" + Aeson.decode (HTTP.responseBody unknown) `shouldBe` Just (object ["error" .= ("Not found" :: Text)]) + providers <- storeServerProviders defaultConfig metrics store + withMetricsServerWithProviders defaultConfig {port = 0} metrics [] providers $ \server -> do + live <- get server.serverPort "/subscriptions" + HTTP.responseStatus live `shouldBe` status200 + void $ get server.serverPort "/subscriptions/paged%2Fname/dead-letters" >>= decodePage + it "inherits mount-relative routing and CORS with legacy switches disabled" $ do + metrics <- newKirokuMetricsWith (pure (Store.GlobalPosition 0)) (pure 0) + let origin = either (error . show) (\v -> v) (allowedOrigin "https://ops.example.com") + config = defaultConfig {cors = corsAllowOrigins [origin], enableJSON = False, enableWebSocket = False} + providers = defaultServerProviders {deadLetters = Just (\_ -> pure (Right fixture))} + mounted req respond = combinedAppWithProviders config metrics [] providers (req {Wai.pathInfo = drop 1 (Wai.pathInfo req)}) respond + Warp.testWithApplication (pure mounted) $ \port -> do + manager <- HTTP.newManager HTTP.defaultManagerSettings + request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> "/inspect/subscriptions/orders/dead-letters") + response <- HTTP.httpLbs request {HTTP.requestHeaders = [("Origin", "https://ops.example.com")]} manager + HTTP.responseStatus response `shouldBe` status200 + lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response) `shouldBe` Just "https://ops.example.com" route :: [Text] route = ["subscriptions", "orders", "dead-letters"] + invalidRequest :: IORef Int -> Wai.Application -> Query -> IO () invalidRequest calls app query = do - priorCalls <- readIORef calls - (status, _, body) <- capture app "GET" route query - status `shouldBe` status400 - code body `shouldBe` Just "invalid_query_parameter" - readIORef calls `shouldReturn` priorCalls + priorCalls <- readIORef calls + (status, _, body) <- capture app "GET" route query + status `shouldBe` status400 + code body `shouldBe` Just "invalid_query_parameter" + readIORef calls `shouldReturn` priorCalls + code :: LBS.ByteString -> Maybe Text code body = case Aeson.decode body of Just (Object fields) | Just (Object err) <- KM.lookup "error" fields, Just (String value) <- KM.lookup "code" err -> Just value; _ -> Nothing + capture :: Wai.Application -> Method -> [Text] -> Query -> IO (Status, ResponseHeaders, LBS.ByteString) capture app method path query = do - result <- newIORef Nothing - _ <- app Wai.defaultRequest{Wai.requestMethod = method, Wai.pathInfo = path, Wai.queryString = query} $ \response -> do - let (status, headers, stream) = Wai.responseToStream response - stream $ \send -> do - chunks <- newIORef [] - send (\chunk -> modifyIORef' chunks (<> [toLazyByteString chunk])) (pure ()) - bytes <- mconcat <$> readIORef chunks - writeIORef result (Just (status, headers, bytes)) - pure ResponseReceived - maybe (fail "No response") pure =<< readIORef result + result <- newIORef Nothing + _ <- app Wai.defaultRequest {Wai.requestMethod = method, Wai.pathInfo = path, Wai.queryString = query} $ \response -> do + let (status, headers, stream) = Wai.responseToStream response + stream $ \send -> do + chunks <- newIORef [] + send (\chunk -> modifyIORef' chunks (<> [toLazyByteString chunk])) (pure ()) + bytes <- mconcat <$> readIORef chunks + writeIORef result (Just (status, headers, bytes)) + pure ResponseReceived + maybe (fail "No response") pure =<< readIORef result + withTestStore :: (Store.KirokuStore -> IO ()) -> IO () withTestStore action = withMigratedTestDatabase $ \connection -> Store.withStore (Store.defaultConnectionSettings connection) action + get :: Int -> String -> IO (HTTP.Response LBS.ByteString) get port path = do - manager <- HTTP.newManager HTTP.defaultManagerSettings - request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) - HTTP.httpLbs request manager + manager <- HTTP.newManager HTTP.defaultManagerSettings + request <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) + HTTP.httpLbs request manager + decodePage :: HTTP.Response LBS.ByteString -> IO DeadLetterPageResponse decodePage response = do - HTTP.responseStatus response `shouldBe` status200 - either fail pure (Aeson.eitherDecode (HTTP.responseBody response)) + HTTP.responseStatus response `shouldBe` status200 + either fail pure (Aeson.eitherDecode (HTTP.responseBody response)) + seed :: Store.KirokuStore -> Text -> Int32 -> Store.RecordedEvent -> IO () seed store name member recorded = do - let Store.EventId eid = recorded ^. #eventId - Store.GlobalPosition position = recorded ^. #globalPosition - params = SQL.DeadLetterParams name member "unbound" Nothing (member + 1) position eid (object ["kind" .= ("poison" :: Text), "detail" .= ("unknown SKU" :: Text)]) "poison: unknown SKU" 1 - Pool.use (store ^. #pool) (Session.statement params SQL.insertDeadLetterAndCheckpointStmt) >>= either (fail . show) pure + let Store.EventId eid = recorded ^. #eventId + Store.GlobalPosition position = recorded ^. #globalPosition + params = SQL.DeadLetterParams name member "unbound" Nothing (member + 1) position eid (object ["kind" .= ("poison" :: Text), "detail" .= ("unknown SKU" :: Text)]) "poison: unknown SKU" 1 + Pool.use (store ^. #pool) (Session.statement params SQL.insertDeadLetterAndCheckpointStmt) >>= either (fail . show) pure diff --git a/test/Test/IntegrationSpec.hs b/test/Test/IntegrationSpec.hs --- a/test/Test/IntegrationSpec.hs +++ b/test/Test/IntegrationSpec.hs @@ -1,19 +1,18 @@ {-# LANGUAGE OverloadedLabels #-} -{- | Integration test: wire the collector into a real ephemeral -PostgreSQL-backed store, run a live @$all@ subscription, append events, and -assert the snapshot reflects real store activity (not just scripted inputs). - -The ordering wrinkle is that 'newKirokuMetrics' needs the 'KirokuStore' but the -callbacks must be installed on 'ConnectionSettings' before 'withStore' creates -it. We resolve it with a @TVar (Maybe KirokuStore)@ the snapshot-time STM -readers consult; it is filled inside 'withStore'. (A 'TVar', not an 'IORef', -because the readers are 'STM'.) --} +-- | Integration test: wire the collector into a real ephemeral +-- PostgreSQL-backed store, run a live @$all@ subscription, append events, and +-- assert the snapshot reflects real store activity (not just scripted inputs). +-- +-- The ordering wrinkle is that 'newKirokuMetrics' needs the 'KirokuStore' but the +-- callbacks must be installed on 'ConnectionSettings' before 'withStore' creates +-- it. We resolve it with a @TVar (Maybe KirokuStore)@ the snapshot-time STM +-- readers consult; it is filled inside 'withStore'. (A 'TVar', not an 'IORef', +-- because the readers are 'STM'.) module Test.IntegrationSpec (spec) where -import Control.Concurrent.STM ( - STM, +import Control.Concurrent.STM + ( STM, TVar, atomically, check, @@ -22,7 +21,7 @@ readTVar, registerDelay, writeTVar, - ) + ) import Control.Lens ((&), (.~)) import Control.Monad (unless) import Data.Aeson qualified as Aeson @@ -32,8 +31,8 @@ import Data.Text qualified as T import Test.Hspec -import Kiroku.Metrics ( - LifecycleCounters (..), +import Kiroku.Metrics + ( LifecycleCounters (..), MetricsSnapshot (..), StoreGauges (..), SubscriptionMetrics (..), @@ -41,9 +40,9 @@ metricsObservationHandler, newKirokuMetricsWith, snapshotMetrics, - ) -import Kiroku.Store ( - EventData (..), + ) +import Kiroku.Store + ( EventData (..), EventType (..), ExpectedVersion (..), KirokuStore (..), @@ -58,7 +57,7 @@ subscribe, wait, withStore, - ) + ) import Kiroku.Store.Subscription.EventPublisher (EventPublisher (..), publisherPosition) import Kiroku.Store.Subscription.Types (SubscriptionName (..)) import Kiroku.Store.Types (GlobalPosition (..)) @@ -69,58 +68,57 @@ spec :: Spec spec = describe "Kiroku.Metrics.Collector (integration)" $ do - it "observes real store activity: appends, a running subscription, and lag" $ - withMigratedTestDatabase $ \connStr -> do - -- Deferred store handle for the snapshot-time STM readers. - storeVar <- newTVarIO Nothing - km <- - newKirokuMetricsWith - (readPosition storeVar) - (readSubscribers storeVar) - let settings = - defaultConnectionSettings connStr - & #eventHandler .~ Just (metricsEventHandler km Nothing) - & #observationHandler .~ Just (metricsObservationHandler km Nothing) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) + it "observes real store activity: appends, a running subscription, and lag" $ + withMigratedTestDatabase $ \connStr -> do + -- Deferred store handle for the snapshot-time STM readers. + storeVar <- newTVarIO Nothing + km <- + newKirokuMetricsWith + (readPosition storeVar) + (readSubscribers storeVar) + let settings = + defaultConnectionSettings connStr + & #eventHandler .~ Just (metricsEventHandler km Nothing) + & #observationHandler .~ Just (metricsObservationHandler km Nothing) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) - -- Subscribe to $all on an empty store: the worker goes live - -- immediately, so the 5 events we append next flow through the - -- live publisher path and advance publisherPosition. - delivered <- newTVarIO (0 :: Int) - let cfg = - defaultSubscriptionConfig subName AllStreams $ \_event -> do - atomically (modifyCount delivered) - pure Continue - handle <- subscribe store cfg + -- Subscribe to $all on an empty store: the worker goes live + -- immediately, so the 5 events we append next flow through the + -- live publisher path and advance publisherPosition. + delivered <- newTVarIO (0 :: Int) + let cfg = + defaultSubscriptionConfig subName AllStreams $ \_event -> do + atomically (modifyCount delivered) + pure Continue + handle <- subscribe store cfg - appendStoreEvents store (StreamName "metrics-it-stream") 5 - waitForCount delivered 5 10_000_000 + appendStoreEvents store (StreamName "metrics-it-stream") 5 + waitForCount delivered 5 10_000_000 - cancel handle - _ <- wait handle + cancel handle + _ <- wait handle - snap <- snapshotMetrics km - snap.store.globalPosition `shouldSatisfy` (>= 5) - snap.counters.subscriptionsStarted `shouldBe` 1 - snap.counters.subscriptionsStoppedCancelled `shouldBe` 1 - snap.counters.eventsDelivered `shouldSatisfy` (>= 5) - case Map.lookup "metrics-it" snap.subscriptions of - Nothing -> expectationFailure "expected subscription \"metrics-it\" in snapshot" - Just m -> m.lag `shouldSatisfy` (>= 0) + snap <- snapshotMetrics km + snap.store.globalPosition `shouldSatisfy` (>= 5) + snap.counters.subscriptionsStarted `shouldBe` 1 + snap.counters.subscriptionsStoppedCancelled `shouldBe` 1 + snap.counters.eventsDelivered `shouldSatisfy` (>= 5) + case Map.lookup "metrics-it" snap.subscriptions of + Nothing -> expectationFailure "expected subscription \"metrics-it\" in snapshot" + Just m -> m.lag `shouldSatisfy` (>= 0) -{- | Snapshot-time reader for the store global position, defaulting to 0 until -the store is filled in. --} +-- | Snapshot-time reader for the store global position, defaulting to 0 until +-- the store is filled in. readPosition :: TVar (Maybe KirokuStore) -> STM GlobalPosition readPosition storeVar = - readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) + readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) -- | Snapshot-time reader for the active-subscriber count. readSubscribers :: TVar (Maybe KirokuStore) -> STM Int readSubscribers storeVar = - readTVar storeVar - >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) + readTVar storeVar + >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) modifyCount :: TVar Int -> STM () modifyCount v = readTVar v >>= \c -> writeTVar v (c + 1) @@ -128,30 +126,30 @@ -- | Append @n@ trivial events to a fresh stream via the IO store interpreter. appendStoreEvents :: KirokuStore -> StreamName -> Int -> IO () appendStoreEvents store stream n = do - let events = - [ EventData - { eventId = Nothing - , eventType = EventType ("E" <> T.pack (show i)) - , payload = Aeson.Null - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } - | i <- [1 .. n] - ] - result <- runStoreIO store (appendToStream stream NoStream events) - case result of - Right _ -> pure () - Left err -> expectationFailure ("appendStoreEvents failed: " <> show err) + let events = + [ EventData + { eventId = Nothing, + eventType = EventType ("E" <> T.pack (show i)), + payload = Aeson.Null, + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } + | i <- [1 .. n] + ] + result <- runStoreIO store (appendToStream stream NoStream events) + case result of + Right _ -> pure () + Left err -> expectationFailure ("appendStoreEvents failed: " <> show err) -- | Wait until the counter reaches @target@ or the timeout (micros) fires. waitForCount :: TVar Int -> Int -> Int -> IO () waitForCount countVar target timeoutMicros = do - timeoutVar <- registerDelay timeoutMicros - ok <- - atomically $ - (do c <- readTVar countVar; check (c >= target); pure True) - `orElse` (do t <- readTVar timeoutVar; check t; pure False) - unless ok $ do - actual <- atomically (readTVar countVar) - expectationFailure ("Timed out waiting for " <> show target <> ", got " <> show actual) + timeoutVar <- registerDelay timeoutMicros + ok <- + atomically $ + (do c <- readTVar countVar; check (c >= target); pure True) + `orElse` (do t <- readTVar timeoutVar; check t; pure False) + unless ok $ do + actual <- atomically (readTVar countVar) + expectationFailure ("Timed out waiting for " <> show target <> ", got " <> show actual) diff --git a/test/Test/ServerSpec.hs b/test/Test/ServerSpec.hs --- a/test/Test/ServerSpec.hs +++ b/test/Test/ServerSpec.hs @@ -1,14 +1,13 @@ {-# LANGUAGE OverloadedLabels #-} -{- | End-to-end test of the HTTP endpoints: boot a real store with the collector -wired in, run a live subscription, start the server on an OS-assigned port, and -hit every endpoint with an HTTP client asserting status codes and bodies. --} +-- | End-to-end test of the HTTP endpoints: boot a real store with the collector +-- wired in, run a live subscription, start the server on an OS-assigned port, and +-- hit every endpoint with an HTTP client asserting status codes and bodies. module Test.ServerSpec (spec) where import Control.Concurrent (threadDelay) -import Control.Concurrent.STM ( - STM, +import Control.Concurrent.STM + ( STM, TVar, atomically, check, @@ -17,7 +16,7 @@ readTVar, registerDelay, writeTVar, - ) + ) import Control.Lens ((&), (.~)) import Control.Monad (unless) import Data.Aeson (Value (..), decode) @@ -29,20 +28,20 @@ import Data.Scientific (toRealFloat) import Data.Text qualified as T import Data.Text.Encoding qualified as TE -import Network.HTTP.Client ( - Manager, +import Network.HTTP.Client + ( Manager, defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseStatus, - ) + ) import Network.HTTP.Types (statusCode) import Test.Hspec -import Kiroku.Metrics ( - DependencyStatus (..), +import Kiroku.Metrics + ( DependencyStatus (..), MetricsServer (..), defaultConfig, metricsEventHandler, @@ -50,10 +49,10 @@ newKirokuMetricsWith, startMetricsServer, stopMetricsServer, - ) + ) import Kiroku.Metrics.Config (MetricsServerConfig (..)) -import Kiroku.Store ( - EventData (..), +import Kiroku.Store + ( EventData (..), EventType (..), ExpectedVersion (..), KirokuStore (..), @@ -68,7 +67,7 @@ subscribe, wait, withStore, - ) + ) import Kiroku.Store.Subscription.EventPublisher (EventPublisher (..), publisherPosition) import Kiroku.Store.Subscription.Types (SubscriptionName (..)) import Kiroku.Store.Types (GlobalPosition (..)) @@ -79,131 +78,131 @@ spec :: Spec spec = describe "Kiroku.Metrics.Server (endpoints)" $ do - it "serves JSON, Prometheus, and health endpoints over HTTP" $ - withMigratedTestDatabase $ \connStr -> do - storeVar <- newTVarIO Nothing - km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - let settings = - defaultConnectionSettings connStr - & #eventHandler .~ Just (metricsEventHandler km Nothing) - & #observationHandler .~ Just (metricsObservationHandler km Nothing) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - delivered <- newTVarIO (0 :: Int) - let cfg = - defaultSubscriptionConfig subName AllStreams $ \_event -> do - atomically (modifyCount delivered) - pure Continue - handle <- subscribe store cfg - appendStoreEvents store (StreamName "metrics-server-stream") 3 - waitForCount delivered 3 10_000_000 + it "serves JSON, Prometheus, and health endpoints over HTTP" $ + withMigratedTestDatabase $ \connStr -> do + storeVar <- newTVarIO Nothing + km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + let settings = + defaultConnectionSettings connStr + & #eventHandler .~ Just (metricsEventHandler km Nothing) + & #observationHandler .~ Just (metricsObservationHandler km Nothing) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + delivered <- newTVarIO (0 :: Int) + let cfg = + defaultSubscriptionConfig subName AllStreams $ \_event -> do + atomically (modifyCount delivered) + pure Continue + handle <- subscribe store cfg + appendStoreEvents store (StreamName "metrics-server-stream") 3 + waitForCount delivered 3 10_000_000 - mgr <- newManager defaultManagerSettings + mgr <- newManager defaultManagerSettings - -- Healthy server (no dependency checks). - let serverCfg = defaultConfig{port = 0} - srv <- startMetricsServer serverCfg km [] - threadDelay 200_000 - let base = "http://127.0.0.1:" <> show srv.serverPort + -- Healthy server (no dependency checks). + let serverCfg = defaultConfig {port = 0} + srv <- startMetricsServer serverCfg km [] + threadDelay 200_000 + let base = "http://127.0.0.1:" <> show srv.serverPort - (sMetrics, bMetrics) <- get mgr (base <> "/metrics") - sMetrics `shouldBe` 200 - globalPositionOf bMetrics `shouldSatisfy` (>= 3) + (sMetrics, bMetrics) <- get mgr (base <> "/metrics") + sMetrics `shouldBe` 200 + globalPositionOf bMetrics `shouldSatisfy` (>= 3) - (sOne, _) <- get mgr (base <> "/metrics/metrics-server-it") - sOne `shouldBe` 200 + (sOne, _) <- get mgr (base <> "/metrics/metrics-server-it") + sOne `shouldBe` 200 - (sUnknown, _) <- get mgr (base <> "/metrics/does-not-exist") - sUnknown `shouldBe` 404 + (sUnknown, _) <- get mgr (base <> "/metrics/does-not-exist") + sUnknown `shouldBe` 404 - (sProm, bProm) <- get mgr (base <> "/metrics/prometheus") - sProm `shouldBe` 200 - bodyText bProm `shouldSatisfy` T.isInfixOf "kiroku_events_appended_total" + (sProm, bProm) <- get mgr (base <> "/metrics/prometheus") + sProm `shouldBe` 200 + bodyText bProm `shouldSatisfy` T.isInfixOf "kiroku_events_appended_total" - (sLive, _) <- get mgr (base <> "/health/live") - sLive `shouldBe` 200 + (sLive, _) <- get mgr (base <> "/health/live") + sLive `shouldBe` 200 - (sReady, _) <- get mgr (base <> "/health/ready") - sReady `shouldBe` 200 + (sReady, _) <- get mgr (base <> "/health/ready") + sReady `shouldBe` 200 - (sWs, _) <- get mgr (base <> "/ws") - sWs `shouldBe` 404 + (sWs, _) <- get mgr (base <> "/ws") + sWs `shouldBe` 404 - (sNope, _) <- get mgr (base <> "/nope") - sNope `shouldBe` 404 + (sNope, _) <- get mgr (base <> "/nope") + sNope `shouldBe` 404 - stopMetricsServer srv + stopMetricsServer srv - -- A failing dependency check flips readiness to 503. - let failing = pure (DependencyStatus "fake" False Nothing (Just "down")) - srv2 <- startMetricsServer serverCfg km [failing] - threadDelay 200_000 - let base2 = "http://127.0.0.1:" <> show srv2.serverPort - (sReady2, _) <- get mgr (base2 <> "/health/ready") - sReady2 `shouldBe` 503 - stopMetricsServer srv2 + -- A failing dependency check flips readiness to 503. + let failing = pure (DependencyStatus "fake" False Nothing (Just "down")) + srv2 <- startMetricsServer serverCfg km [failing] + threadDelay 200_000 + let base2 = "http://127.0.0.1:" <> show srv2.serverPort + (sReady2, _) <- get mgr (base2 <> "/health/ready") + sReady2 `shouldBe` 503 + stopMetricsServer srv2 - cancel handle - _ <- wait handle - pure () + cancel handle + _ <- wait handle + pure () -- | GET a URL, returning the status code and the body, without throwing on non-2xx. get :: Manager -> String -> IO (Int, ByteString) get mgr url = do - req <- parseRequest url - resp <- httpLbs req mgr - pure (statusCode (responseStatus resp), responseBody resp) + req <- parseRequest url + resp <- httpLbs req mgr + pure (statusCode (responseStatus resp), responseBody resp) -- | Extract @store.global_position@ from a @/metrics@ JSON body. globalPositionOf :: ByteString -> Int globalPositionOf body = - case decode body of - Just (Object o) - | Just (Object store) <- KM.lookup (Key.fromText "store") o - , Just (Number n) <- KM.lookup (Key.fromText "global_position") store -> - truncate (toRealFloat n :: Double) - _ -> -1 + case decode body of + Just (Object o) + | Just (Object store) <- KM.lookup (Key.fromText "store") o, + Just (Number n) <- KM.lookup (Key.fromText "global_position") store -> + truncate (toRealFloat n :: Double) + _ -> -1 bodyText :: ByteString -> T.Text bodyText = TE.decodeUtf8 . LBS.toStrict readPosition :: TVar (Maybe KirokuStore) -> STM GlobalPosition readPosition storeVar = - readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) + readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) readSubscribers :: TVar (Maybe KirokuStore) -> STM Int readSubscribers storeVar = - readTVar storeVar - >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) + readTVar storeVar + >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) modifyCount :: TVar Int -> STM () modifyCount v = readTVar v >>= \c -> writeTVar v (c + 1) appendStoreEvents :: KirokuStore -> StreamName -> Int -> IO () appendStoreEvents store stream n = do - let events = - [ EventData - { eventId = Nothing - , eventType = EventType ("E" <> T.pack (show i)) - , payload = Null - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } - | i <- [1 .. n] - ] - result <- runStoreIO store (appendToStream stream NoStream events) - case result of - Right _ -> pure () - Left err -> expectationFailure ("appendStoreEvents failed: " <> show err) + let events = + [ EventData + { eventId = Nothing, + eventType = EventType ("E" <> T.pack (show i)), + payload = Null, + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } + | i <- [1 .. n] + ] + result <- runStoreIO store (appendToStream stream NoStream events) + case result of + Right _ -> pure () + Left err -> expectationFailure ("appendStoreEvents failed: " <> show err) waitForCount :: TVar Int -> Int -> Int -> IO () waitForCount countVar target timeoutMicros = do - timeoutVar <- registerDelay timeoutMicros - ok <- - atomically $ - (do c <- readTVar countVar; check (c >= target); pure True) - `orElse` (do t <- readTVar timeoutVar; check t; pure False) - unless ok $ do - actual <- atomically (readTVar countVar) - expectationFailure ("Timed out waiting for " <> show target <> ", got " <> show actual) + timeoutVar <- registerDelay timeoutMicros + ok <- + atomically $ + (do c <- readTVar countVar; check (c >= target); pure True) + `orElse` (do t <- readTVar timeoutVar; check t; pure False) + unless ok $ do + actual <- atomically (readTVar countVar) + expectationFailure ("Timed out waiting for " <> show target <> ", got " <> show actual) diff --git a/test/Test/StandaloneSpec.hs b/test/Test/StandaloneSpec.hs --- a/test/Test/StandaloneSpec.hs +++ b/test/Test/StandaloneSpec.hs @@ -4,7 +4,7 @@ import Control.Concurrent.Async qualified as Async import Control.Concurrent.MVar -import Control.Exception (SomeException, bracket, throwIO, try) +import Control.Exception (IOException, SomeException, bracket, catch, finally, throwIO, toException, try) import Control.Monad (forM_, void) import Data.Aeson qualified as A import Data.Aeson.Key qualified as K @@ -22,169 +22,234 @@ import Network.WebSockets qualified as WS import Options.Applicative qualified as O import System.Directory (findExecutable) -import System.Environment (getEnvironment) +import System.Environment (getEnvironment, getExecutablePath) import System.Exit (ExitCode (..)) -import System.IO (hGetLine) -import System.Posix.Signals (sigINT, sigTERM, signalProcess) +import System.IO (Handle, hGetLine) +import System.Posix.Signals (sigINT, sigKILL, sigTERM, signalProcess) import System.Process qualified as Process import System.Timeout (timeout) import Test.Hspec +import Hasql.Errors qualified as Errors +import Hasql.Pool qualified as Pool +import Hasql.Session qualified as Session + import Kiroku.Metrics import Kiroku.Store qualified as Store +import Kiroku.Store.Error (StoreError (..)) +import Kiroku.Store.Notification (NotifierStartError (..)) import Kiroku.Test.Postgres (withMigratedTestDatabase) spec :: Spec spec = do - describe "Kiroku.Metrics.Standalone (options)" $ do - it "parses defaults, repeated origins, and all options" $ do - isRight (parsed []) `shouldBe` True - opts <- requireParsed ["--database-url", "postgresql://x", "--schema", "tenant", "--pool-size", "2", "--port", "0", "--cors-origin", "http://a", "--cors-origin", "http://b", "--no-cors-allow-credentials", "--ws-max-connections", "3"] - opts.databaseUrl `shouldBe` Just "postgresql://x" - opts.schema `shouldBe` Just "tenant" - opts.poolSize `shouldBe` Just 2 - opts.port `shouldBe` Just 0 - opts.corsOrigins `shouldBe` ["http://a", "http://b"] - opts.corsAllowCredentials `shouldBe` Just False - opts.wsMaxConnections `shouldBe` Just 3 - it "rejects signed, non-ASCII, overflowing and out-of-range CLI numbers and conflicting flags" $ do - forM_ ["-1", "+1", "", "１", "18446744073709551616", "65536"] $ \value -> isLeft (parsed ["--port", value]) `shouldBe` True - forM_ ["--pool-size", "--ws-max-connections"] $ \flag -> isLeft (parsed [flag, "0"]) `shouldBe` True - isLeft (parsed ["--cors-allow-credentials", "--no-cors-allow-credentials"]) `shouldBe` True - it "resolves environment defaults and reports a missing or empty database/schema" $ do - opts <- requireParsed [] - isLeft (resolveInspectOptions [] opts) `shouldBe` True - rt <- resolved [("DATABASE_URL", "postgresql://env")] opts - rt.databaseUrl `shouldBe` "postgresql://env" - rt.schema `shouldBe` "kiroku" - rt.poolSize `shouldBe` (Store.defaultConnectionSettings "").poolSize - rt.port `shouldBe` 9091 - rt.cors `shouldBe` corsDisabled - rt.wsMaxConnections `shouldBe` 100 - forM_ [["--database-url", ""], ["--database-url", "x", "--schema", " "]] $ \args -> requireParsed args >>= \o -> isLeft (resolveInspectOptions [] o) `shouldBe` True - it "valid flags override malformed environment values including explicit credentials False" $ do - opts <- requireParsed ["--database-url", "flag", "--port", "0", "--pool-size", "1", "--schema", "tenant", "--ws-max-connections", "1", "--cors-origin", "http://a", "--no-cors-allow-credentials"] - rt <- resolved [("DATABASE_URL", "env"), ("KIROKU_INSPECT_PORT", "bad"), ("KIROKU_INSPECT_POOL_SIZE", "bad"), ("KIROKU_INSPECT_SCHEMA", "bad"), ("KIROKU_INSPECT_WS_MAX_CONNECTIONS", "bad"), ("KIROKU_INSPECT_CORS_ORIGINS", "*"), ("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "bad")] opts - rt.databaseUrl `shouldBe` "flag" - rt.port `shouldBe` 0 - rt.schema `shouldBe` "tenant" - rt.cors.allowCredentials `shouldBe` False - rt2 <- resolved [("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "true")] opts - rt2.cors.allowCredentials `shouldBe` False - it "validates environment numbers and booleans, normalizes origins and refuses wildcard" $ do - opts <- requireParsed ["--database-url", "x"] - forM_ ["KIROKU_INSPECT_POOL_SIZE", "KIROKU_INSPECT_WS_MAX_CONNECTIONS", "KIROKU_INSPECT_PORT"] $ \name -> - forM_ ["abc", "-1", "+1", "９", "18446744073709551616"] $ \value -> isLeft (resolveInspectOptions [(name, value)] opts) `shouldBe` True - isLeft (resolveInspectOptions [("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "yes")] opts) `shouldBe` True - rt <- resolved [("KIROKU_INSPECT_CORS_ORIGINS", "https://Ops.example.com/, http://localhost:5173"), ("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "true")] opts - map renderAllowedOrigin rt.cors.allowedOrigins `shouldBe` ["https://ops.example.com", "http://localhost:5173"] - rt.cors.allowCredentials `shouldBe` True - wild <- requireParsed ["--database-url", "x", "--cors-origin", "*"] - either (T.isInfixOf "wildcard") (const False) (resolveInspectOptions [] wild) `shouldBe` True - empty <- resolved [("KIROKU_INSPECT_PORT", ""), ("KIROKU_INSPECT_SCHEMA", "")] opts - empty.port `shouldBe` 9091 - empty.schema `shouldBe` "kiroku" - describe "Kiroku.Metrics.Standalone (end to end)" $ do - it "serves durable reads, an empty live registry, CORS, and real event tail from a database URL" $ - withMigratedTestDatabase $ \url -> do - rt <- runtime url - ready <- newEmptyMVar - done <- newEmptyMVar - let hooks = InspectHooks (\port caps -> putMVar ready (port, caps)) (takeMVar done) - Async.withAsync (runInspect hooks rt) $ \server -> do - (port, caps) <- bounded (takeMVar ready) - caps.routes `shouldBe` RouteAvailability True True True True True True True True True - caps.corsIsEnabled `shouldBe` True - Store.withStore (Store.defaultConnectionSettings url) $ \writer -> do - append writer "orders-1" 3 - response <- get port "/capabilities" [] - A.eitherDecode (HTTP.responseBody response) `shouldBe` Right caps - LBSC.putStrLn ("standalone discovery capture: " <> HTTP.responseBody response) - streams <- get port "/streams?category=orders" [] - HTTP.responseStatus streams `shouldBe` status200 - (A.decode (HTTP.responseBody streams) >>= key "items") `shouldSatisfy` maybe False (\case A.Array rows -> any (\row -> key "name" row == Just (A.String "orders-1")) rows; _ -> False) - live <- get port "/subscriptions" [] - A.decode (HTTP.responseBody live) `shouldBe` Just (A.toJSON ([] :: [A.Value])) - inventory <- get port "/subscription-checkpoints" [] - case A.eitherDecode (HTTP.responseBody inventory) of - Right (CheckpointInventoryResponse pos rows) -> do - pos `shouldSatisfy` (>= 3) - rows `shouldBe` [] - Left err -> expectationFailure err - forM_ ["/health/ready", "/subscriptions/missing/dead-letters", "/events", "/categories"] $ \path -> HTTP.responseStatus <$> get port path [] `shouldReturn` status200 - forM_ [("http://localhost:5173", Just "http://localhost:5173"), ("http://evil.example", Nothing)] $ \(origin, expected) -> do - response2 <- get port "/metrics" [("Origin", origin)] - lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response2) `shouldBe` expected - (A.decode (HTTP.responseBody response2) >>= key "subscriptions") `shouldBe` Just (A.object []) - bounded $ WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do - WS.sendTextData conn (A.encode (A.object ["type" A..= ("subscribe_events" :: Text)])) - void (frame conn "event_stream_started") - append writer "orders-2" 1 - ev <- frame conn "event" - (key "event" ev >>= key "original_stream_name") `shouldBe` Just (A.String "orders-2") - (key "event" ev >>= key "eventType") `shouldBe` Just (A.String "OrderCreated") - putMVar done () - bounded (Async.wait server) - assertReleased port - it "releases its listener on immediate shutdown, hook exception and cancellation" $ - withMigratedTestDatabase $ \url -> do - rt <- runtime url - forM_ [False, True] $ \shouldFail -> do - portRef <- newIORef 0 - let hooks = InspectHooks (\port _ -> writeIORef portRef port >> if shouldFail then throwIO (userError "hook failed") else pure ()) (pure ()) - result <- bounded (try (runInspect hooks rt) :: IO (Either SomeException ())) - result `shouldSatisfy` (if shouldFail then isLeft else isRight) - readIORef portRef >>= assertReleased - ready <- newEmptyMVar - never <- newEmptyMVar - Async.withAsync (runInspect (InspectHooks (\port _ -> putMVar ready port) (takeMVar never)) rt) $ \server -> do - port <- bounded (takeMVar ready) - bounded (Async.cancel server) - assertReleased port - it "does not call onListening on an occupied port" $ - withMigratedTestDatabase $ \url -> do - rt <- runtime url - withOccupiedPort $ \port -> do - called <- newIORef False - result <- bounded (try (runInspect (InspectHooks (\_ _ -> writeIORef called True) (pure ())) (InspectRuntime rt.databaseUrl rt.schema rt.poolSize port rt.cors rt.wsMaxConnections)) :: IO (Either SomeException ())) - result `shouldSatisfy` isLeft - readIORef called `shouldReturn` False - describe "kiroku-inspect (executable)" $ do - it "exits 2 for usage/resolution errors and redacts runtime connection failures" $ do - exe <- executable - env <- cleanEnvironment - forM_ [[], ["--unknown"], ["--database-url", "x", "--cors-origin", "*"]] $ \args -> do - (exit, _, _) <- bounded (Process.readCreateProcessWithExitCode (Process.proc exe args){Process.env = Just env} "") - exit `shouldBe` ExitFailure 2 - (exit, out, err) <- bounded (Process.readCreateProcessWithExitCode (Process.proc exe ["--database-url", "postgresql://user:secret@127.0.0.1:1/db?connect_timeout=1"]){Process.env = Just env} "") - exit `shouldBe` ExitFailure 1 - out `shouldBe` "" - T.pack err `shouldSatisfy` (not . T.isInfixOf "secret") - it "prints no success banner and exits 1 on bind failure" $ - withMigratedTestDatabase $ \url -> withOccupiedPort $ \port -> do - exe <- executable - env <- cleanEnvironment - (exit, out, err) <- bounded (Process.readCreateProcessWithExitCode (Process.proc exe ["--database-url", T.unpack url, "--port", show port]){Process.env = Just env} "") - exit `shouldBe` ExitFailure 1 - out `shouldBe` "" - err `shouldSatisfy` (not . null) - it "exits 0 after SIGINT or SIGTERM, including repeated signals" $ - withMigratedTestDatabase $ \url -> do - exe <- executable - env <- cleanEnvironment - forM_ [sigINT, sigTERM] $ \signal -> - bracket (Process.createProcess (Process.proc exe ["--database-url", T.unpack url, "--port", "0"]){Process.env = Just env, Process.std_out = Process.CreatePipe, Process.std_err = Process.CreatePipe}) Process.cleanupProcess $ \(_, out, _, process) -> do - handle <- maybe (fail "No stdout") pure out - first <- bounded (hGetLine handle) - first `shouldSatisfy` (T.isInfixOf "listening on port" . T.pack) - void (bounded (hGetLine handle)) - void (bounded (hGetLine handle)) - pid <- Process.getPid process >>= maybe (fail "No PID") pure - signalProcess signal pid - signalProcess signal pid - shutting <- bounded (hGetLine handle) - shutting `shouldBe` "kiroku-inspect: shutting down" - bounded (Process.waitForProcess process) `shouldReturn` ExitSuccess + describe "Kiroku.Metrics.Standalone (options)" $ do + it "parses defaults, repeated origins, and all options" $ do + isRight (parsed []) `shouldBe` True + opts <- requireParsed ["--database-url", "postgresql://x", "--schema", "tenant", "--pool-size", "2", "--port", "0", "--cors-origin", "http://a", "--cors-origin", "http://b", "--no-cors-allow-credentials", "--ws-max-connections", "3"] + opts.databaseUrl `shouldBe` Just "postgresql://x" + opts.schema `shouldBe` Just "tenant" + opts.poolSize `shouldBe` Just 2 + opts.port `shouldBe` Just 0 + opts.corsOrigins `shouldBe` ["http://a", "http://b"] + opts.corsAllowCredentials `shouldBe` Just False + opts.wsMaxConnections `shouldBe` Just 3 + it "rejects signed, non-ASCII, overflowing and out-of-range CLI numbers and conflicting flags" $ do + forM_ ["-1", "+1", "", "１", "18446744073709551616", "65536"] $ \value -> isLeft (parsed ["--port", value]) `shouldBe` True + forM_ ["--pool-size", "--ws-max-connections"] $ \flag -> isLeft (parsed [flag, "0"]) `shouldBe` True + isLeft (parsed ["--cors-allow-credentials", "--no-cors-allow-credentials"]) `shouldBe` True + it "resolves environment defaults and reports a missing or empty database/schema" $ do + opts <- requireParsed [] + isLeft (resolveInspectOptions [] opts) `shouldBe` True + rt <- resolved [("DATABASE_URL", "postgresql://env")] opts + rt.databaseUrl `shouldBe` "postgresql://env" + rt.schema `shouldBe` "kiroku" + rt.poolSize `shouldBe` (Store.defaultConnectionSettings "").poolSize + rt.port `shouldBe` 9091 + rt.cors `shouldBe` corsDisabled + rt.wsMaxConnections `shouldBe` 100 + forM_ [["--database-url", ""], ["--database-url", "x", "--schema", " "]] $ \args -> requireParsed args >>= \o -> isLeft (resolveInspectOptions [] o) `shouldBe` True + it "valid flags override malformed environment values including explicit credentials False" $ do + opts <- requireParsed ["--database-url", "flag", "--port", "0", "--pool-size", "1", "--schema", "tenant", "--ws-max-connections", "1", "--cors-origin", "http://a", "--no-cors-allow-credentials"] + rt <- resolved [("DATABASE_URL", "env"), ("KIROKU_INSPECT_PORT", "bad"), ("KIROKU_INSPECT_POOL_SIZE", "bad"), ("KIROKU_INSPECT_SCHEMA", "bad"), ("KIROKU_INSPECT_WS_MAX_CONNECTIONS", "bad"), ("KIROKU_INSPECT_CORS_ORIGINS", "*"), ("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "bad")] opts + rt.databaseUrl `shouldBe` "flag" + rt.port `shouldBe` 0 + rt.schema `shouldBe` "tenant" + rt.cors.allowCredentials `shouldBe` False + rt2 <- resolved [("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "true")] opts + rt2.cors.allowCredentials `shouldBe` False + it "validates environment numbers and booleans, normalizes origins and refuses wildcard" $ do + opts <- requireParsed ["--database-url", "x"] + forM_ ["KIROKU_INSPECT_POOL_SIZE", "KIROKU_INSPECT_WS_MAX_CONNECTIONS", "KIROKU_INSPECT_PORT"] $ \name -> + forM_ ["abc", "-1", "+1", "９", "18446744073709551616"] $ \value -> isLeft (resolveInspectOptions [(name, value)] opts) `shouldBe` True + isLeft (resolveInspectOptions [("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "yes")] opts) `shouldBe` True + rt <- resolved [("KIROKU_INSPECT_CORS_ORIGINS", "https://Ops.example.com/, http://localhost:5173"), ("KIROKU_INSPECT_CORS_ALLOW_CREDENTIALS", "true")] opts + map renderAllowedOrigin rt.cors.allowedOrigins `shouldBe` ["https://ops.example.com", "http://localhost:5173"] + rt.cors.allowCredentials `shouldBe` True + wild <- requireParsed ["--database-url", "x", "--cors-origin", "*"] + either (T.isInfixOf "wildcard") (const False) (resolveInspectOptions [] wild) `shouldBe` True + empty <- resolved [("KIROKU_INSPECT_PORT", ""), ("KIROKU_INSPECT_SCHEMA", "")] opts + empty.port `shouldBe` 9091 + empty.schema `shouldBe` "kiroku" + describe "Kiroku.Metrics.Standalone (failure classification)" $ do + it "classifies structured failures without reading diagnostic text" $ do + let poolError code = Pool.SessionUsageError (Errors.ScriptSessionError "secret SQL" (Errors.ServerError code "secret server message" Nothing Nothing Nothing)) + connection = Errors.NetworkingConnectionError "secret connection string" + cases = + [ (toException (InspectBindError (userError "secret address")), BindFailure), + (toException (NotifierConnectError connection), DatabaseFailure), + (toException (Pool.ConnectionUsageError connection), DatabaseFailure), + (toException Pool.AcquisitionTimeoutUsageError, DatabaseFailure), + (toException (poolError "42P01"), SchemaFailure), + (toException (poolError "3F000"), SchemaFailure), + (toException (poolError "42501"), DatabaseFailure), + (toException (poolError "40001"), DatabaseFailure), + (toException (NotifierListenError (toException (poolError "42P01"))), SchemaFailure), + (toException (NotifierListenError (toException (UnexpectedServerError "3F000" "secret"))), SchemaFailure), + (toException (NotifierListenError (toException (userError "secret"))), DatabaseFailure), + (toException (ConnectionError "secret"), DatabaseFailure), + (toException (ConnectionLost "secret"), DatabaseFailure), + (toException PoolAcquisitionTimeout, DatabaseFailure), + (toException (TransientTransactionFailure "40P01" "secret"), DatabaseFailure), + (toException (UnexpectedServerError "42P01" "secret"), SchemaFailure), + (toException (UnexpectedServerError "42501" "secret"), DatabaseFailure), + (toException (StreamNotFound (Store.StreamName "secret")), OtherFailure), + (toException (userError "bind database schema secret"), OtherFailure) + ] + forM_ cases $ \(err, expected) -> classifyInspectFailure err `shouldBe` expected + forM_ [(BindFailure, "bind"), (DatabaseFailure, "database"), (SchemaFailure, "schema"), (OtherFailure, "other")] $ \(failure, label) -> + renderInspectFailure failure `shouldBe` "kiroku-inspect: " <> label <> " failure (details redacted)" + describe "Kiroku.Metrics.Standalone (end to end)" $ do + it "serves durable reads, an empty live registry, CORS, and real event tail from a database URL" $ + withMigratedTestDatabase $ \url -> do + rt <- runtime url + ready <- newEmptyMVar + done <- newEmptyMVar + let hooks = InspectHooks (\port caps -> putMVar ready (port, caps)) (takeMVar done) + Async.withAsync (runInspect hooks rt) $ \server -> do + (port, caps) <- bounded (takeMVar ready) + caps.routes `shouldBe` RouteAvailability True True True True True True True True True + caps.corsIsEnabled `shouldBe` True + Store.withStore (Store.defaultConnectionSettings url) $ \writer -> do + append writer "orders-1" 3 + response <- get port "/capabilities" [] + A.eitherDecode (HTTP.responseBody response) `shouldBe` Right caps + LBSC.putStrLn ("standalone discovery capture: " <> HTTP.responseBody response) + streams <- get port "/streams?category=orders" [] + HTTP.responseStatus streams `shouldBe` status200 + (A.decode (HTTP.responseBody streams) >>= key "items") `shouldSatisfy` maybe False (\case A.Array rows -> any (\row -> key "name" row == Just (A.String "orders-1")) rows; _ -> False) + live <- get port "/subscriptions" [] + A.decode (HTTP.responseBody live) `shouldBe` Just (A.toJSON ([] :: [A.Value])) + inventory <- get port "/subscription-checkpoints" [] + case A.eitherDecode (HTTP.responseBody inventory) of + Right (CheckpointInventoryResponse pos rows) -> do + pos `shouldSatisfy` (>= 3) + rows `shouldBe` [] + Left err -> expectationFailure err + forM_ ["/health/ready", "/subscriptions/missing/dead-letters", "/events", "/categories"] $ \path -> HTTP.responseStatus <$> get port path [] `shouldReturn` status200 + forM_ [("http://localhost:5173", Just "http://localhost:5173"), ("http://evil.example", Nothing)] $ \(origin, expected) -> do + response2 <- get port "/metrics" [("Origin", origin)] + lookup "Access-Control-Allow-Origin" (HTTP.responseHeaders response2) `shouldBe` expected + (A.decode (HTTP.responseBody response2) >>= key "subscriptions") `shouldBe` Just (A.object []) + bounded $ WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do + WS.sendTextData conn (A.encode (A.object ["type" A..= ("subscribe_events" :: Text)])) + void (frame conn "event_stream_started") + append writer "orders-2" 1 + ev <- frame conn "event" + (key "event" ev >>= key "original_stream_name") `shouldBe` Just (A.String "orders-2") + (key "event" ev >>= key "eventType") `shouldBe` Just (A.String "OrderCreated") + putMVar done () + bounded (Async.wait server) + assertReleased port + it "releases its listener on immediate shutdown, hook exception and cancellation" $ + withMigratedTestDatabase $ \url -> do + rt <- runtime url + forM_ [False, True] $ \shouldFail -> do + portRef <- newIORef 0 + let hooks = InspectHooks (\port _ -> writeIORef portRef port >> if shouldFail then throwIO (userError "hook failed") else pure ()) (pure ()) + result <- bounded (try (runInspect hooks rt) :: IO (Either SomeException ())) + result `shouldSatisfy` (if shouldFail then isLeft else isRight) + case result of + Left err -> classifyInspectFailure err `shouldBe` OtherFailure + Right () -> pure () + readIORef portRef >>= assertReleased + ready <- newEmptyMVar + never <- newEmptyMVar + Async.withAsync (runInspect (InspectHooks (\port _ -> putMVar ready port) (takeMVar never)) rt) $ \server -> do + port <- bounded (takeMVar ready) + bounded (Async.cancel server) + assertReleased port + it "does not call onListening on an occupied port" $ + withMigratedTestDatabase $ \url -> do + rt <- runtime url + withOccupiedPort $ \port -> do + called <- newIORef False + result <- bounded (try (runInspect (InspectHooks (\_ _ -> writeIORef called True) (pure ())) (InspectRuntime rt.databaseUrl rt.schema rt.poolSize port rt.cors rt.wsMaxConnections)) :: IO (Either SomeException ())) + fmap classifyInspectFailure (either Just (const Nothing) result) `shouldBe` Just BindFailure + readIORef called `shouldReturn` False + describe "kiroku-inspect (executable)" $ do + it "exits 2 for usage/resolution errors and redacts runtime connection failures" $ do + exe <- executable + env <- cleanEnvironment + forM_ [[], ["--unknown"], ["--database-url", "x", "--cors-origin", "*"]] $ \args -> do + (exit, _, _) <- bounded (Process.readCreateProcessWithExitCode (Process.proc exe args) {Process.env = Just env} "") + exit `shouldBe` ExitFailure 2 + (exit, out, err) <- bounded (Process.readCreateProcessWithExitCode (Process.proc exe ["--database-url", "postgresql://user:secret@127.0.0.1:1/db?connect_timeout=1"]) {Process.env = Just env} "") + exit `shouldBe` ExitFailure 1 + out `shouldBe` "" + err `shouldBe` "kiroku-inspect: database failure (details redacted)\n" + T.pack err `shouldSatisfy` (not . T.isInfixOf "secret") + it "prints no success banner and exits 1 on bind failure" $ + withMigratedTestDatabase $ \url -> withOccupiedPort $ \port -> do + exe <- executable + env <- cleanEnvironment + (exit, out, err) <- bounded (Process.readCreateProcessWithExitCode (Process.proc exe ["--database-url", T.unpack url, "--port", show port]) {Process.env = Just env} "") + exit `shouldBe` ExitFailure 1 + out `shouldBe` "" + err `shouldBe` "kiroku-inspect: bind failure (details redacted)\n" + T.pack err `shouldSatisfy` (not . T.isInfixOf url) + it "reports a missing schema without a banner or database details" $ + withMigratedTestDatabase $ \url -> do + Store.withStore (Store.defaultConnectionSettings url) $ \store -> + Pool.use store.pool (Session.script "DO $$ BEGIN IF EXISTS (SELECT 1 FROM pg_namespace WHERE nspname = 'plan101_missing_schema') THEN RAISE EXCEPTION 'fixture schema exists'; END IF; END $$") `shouldReturn` Right () + exe <- executable + env <- cleanEnvironment + (exit, out, err) <- bounded (Process.readCreateProcessWithExitCode (Process.proc exe ["--database-url", T.unpack url, "--schema", "plan101_missing_schema", "--port", "0"]) {Process.env = Just env} "") + exit `shouldBe` ExitFailure 1 + out `shouldBe` "" + err `shouldBe` "kiroku-inspect: schema failure (details redacted)\n" + forM_ [url, "plan101_missing_schema", "streams", "SELECT"] $ \secret -> + T.pack err `shouldSatisfy` (not . T.isInfixOf secret) + forM_ [("SIGINT", sigINT), ("SIGTERM", sigTERM)] $ \(firstName, firstSignal) -> + forM_ [("SIGINT", sigINT), ("SIGTERM", sigTERM)] $ \(secondName, secondSignal) -> + it ("forces exit 130 on " <> firstName <> "/" <> secondName <> " during blocked teardown") $ do + exe <- getExecutablePath + bracket + (Process.createProcess (Process.proc exe ["--inspect-signal-fixture"]) {Process.std_out = Process.CreatePipe, Process.std_err = Process.CreatePipe}) + cleanupFixture + $ \(_, out, _, process) -> do + handle <- maybe (fail "No stdout") pure out + bounded (hGetLine handle) `shouldReturn` "READY" + pid <- Process.getPid process >>= maybe (fail "No PID") pure + signalProcess firstSignal pid + bounded (hGetLine handle) `shouldReturn` "SHUTTING_DOWN" + signalProcess secondSignal pid + timeout 1_000_000 (Process.waitForProcess process) `shouldReturn` Just (ExitFailure 130) + it "exits 0 after a single SIGINT or SIGTERM" $ + withMigratedTestDatabase $ \url -> do + exe <- executable + env <- cleanEnvironment + forM_ [sigINT, sigTERM] $ \signal -> + bracket (Process.createProcess (Process.proc exe ["--database-url", T.unpack url, "--port", "0"]) {Process.env = Just env, Process.std_out = Process.CreatePipe, Process.std_err = Process.CreatePipe}) Process.cleanupProcess $ \(_, out, _, process) -> do + handle <- maybe (fail "No stdout") pure out + first <- bounded (hGetLine handle) + first `shouldSatisfy` (T.isInfixOf "listening on port" . T.pack) + void (bounded (hGetLine handle)) + void (bounded (hGetLine handle)) + pid <- Process.getPid process >>= maybe (fail "No PID") pure + signalProcess signal pid + shutting <- bounded (hGetLine handle) + shutting `shouldBe` "kiroku-inspect: shutting down" + bounded (Process.waitForProcess process) `shouldReturn` ExitSuccess parsed :: [String] -> Either String InspectOptions parsed args = maybe (Left "Parse failed") Right (O.getParseResult (O.execParserPure O.defaultPrefs inspectParserInfo args)) @@ -204,47 +269,59 @@ frame :: WS.Connection -> Text -> IO A.Value frame conn wanted = do - raw <- WS.receiveData conn :: IO LBS.ByteString - case A.decode raw of - Just value | key "type" value == Just (A.String wanted) -> pure value - _ -> frame conn wanted + raw <- WS.receiveData conn :: IO LBS.ByteString + case A.decode raw of + Just value | key "type" value == Just (A.String wanted) -> pure value + _ -> frame conn wanted get :: Int -> String -> RequestHeaders -> IO (HTTP.Response LBS.ByteString) get port path headers = do - manager <- HTTP.newManager HTTP.defaultManagerSettings - req <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) - HTTP.httpLbs req{HTTP.requestHeaders = headers} manager + manager <- HTTP.newManager HTTP.defaultManagerSettings + req <- HTTP.parseRequest ("http://127.0.0.1:" <> show port <> path) + HTTP.httpLbs req {HTTP.requestHeaders = headers} manager append :: Store.KirokuStore -> Text -> Int -> IO () append store name count = do - result <- Store.runStoreIO store (Store.appendToStream (Store.StreamName name) Store.NoStream (replicate count (Store.EventData Nothing (Store.EventType "OrderCreated") A.Null Nothing Nothing Nothing))) - result `shouldSatisfy` isRight + result <- Store.runStoreIO store (Store.appendToStream (Store.StreamName name) Store.NoStream (replicate count (Store.EventData Nothing (Store.EventType "OrderCreated") A.Null Nothing Nothing Nothing))) + result `shouldSatisfy` isRight bounded :: IO a -> IO a bounded action = timeout 15_000_000 action >>= maybe (fail "Timed out") pure assertReleased :: Int -> IO () assertReleased port = - bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close $ \socket -> do - Socket.setSocketOption socket Socket.ReuseAddr 1 - Socket.bind socket (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))) - Socket.listen socket 1 + bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close $ \socket -> do + Socket.setSocketOption socket Socket.ReuseAddr 1 + Socket.bind socket (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))) + Socket.listen socket 1 withOccupiedPort :: (Int -> IO a) -> IO a withOccupiedPort action = do - (port, reserved) <- Warp.openFreePort - Socket.close reserved - bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv4 -> - bracket (Socket.socket Socket.AF_INET6 Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv6 -> do - Socket.bind ipv4 (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))) - Socket.listen ipv4 1 - Socket.setSocketOption ipv6 Socket.IPv6Only 1 - Socket.bind ipv6 (Socket.SockAddrInet6 (fromIntegral port) 0 (0, 0, 0, 0) 0) - Socket.listen ipv6 1 - action port + (port, reserved) <- Warp.openFreePort + Socket.close reserved + bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv4 -> + bracket (Socket.socket Socket.AF_INET6 Socket.Stream Socket.defaultProtocol) Socket.close $ \ipv6 -> do + Socket.bind ipv4 (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (0, 0, 0, 0))) + Socket.listen ipv4 1 + Socket.setSocketOption ipv6 Socket.IPv6Only 1 + Socket.bind ipv6 (Socket.SockAddrInet6 (fromIntegral port) 0 (0, 0, 0, 0) 0) + Socket.listen ipv6 1 + action port executable :: IO FilePath executable = findExecutable "kiroku-inspect" >>= maybe (fail "Cabal build-tool-depends did not supply kiroku-inspect") pure cleanEnvironment :: IO [(String, String)] cleanEnvironment = filter (\(name, _) -> name /= "DATABASE_URL" && not ("KIROKU_INSPECT_" `T.isPrefixOf` T.pack name)) <$> getEnvironment + +-- A fixture intentionally blocks finalization, so cleanup must kill a still-live +-- owned child rather than request another graceful shutdown and wait forever. +cleanupFixture :: (Maybe Handle, Maybe Handle, Maybe Handle, Process.ProcessHandle) -> IO () +cleanupFixture child@(_, _, _, process) = + ( Process.getProcessExitCode process >>= \case + Just _ -> pure () + Nothing -> do + pid <- Process.getPid process + forM_ pid $ \p -> signalProcess sigKILL p `catch` \(_ :: IOException) -> pure () + ) + `finally` Process.cleanupProcess child diff --git a/test/Test/SubscriptionsSpec.hs b/test/Test/SubscriptionsSpec.hs --- a/test/Test/SubscriptionsSpec.hs +++ b/test/Test/SubscriptionsSpec.hs @@ -1,15 +1,14 @@ -{- | EP-5 tests for the @GET /subscriptions@ endpoint and the CLI remote client. - - * Cross-package shape: rows produced by the server-side mapping - ('subscriptionStatusRows') encode and decode back through the shared - @kiroku-cli@ codec — guarding against either side re-encoding locally. - * End-to-end: boot a real store with a live subscription, serve - @\/subscriptions@ from 'storeSubscriptionStatus', and assert the real CLI - client ('fetchRemoteSubscriptionStatusRows') reports the live subscription - with a sane phase and the expected cursor. A raw GET checks the by-name route - (known → one row, unknown → @[]@), and a server with no provider yields the - configured-404. --} +-- | EP-5 tests for the @GET /subscriptions@ endpoint and the CLI remote client. +-- +-- * Cross-package shape: rows produced by the server-side mapping +-- ('subscriptionStatusRows') encode and decode back through the shared +-- @kiroku-cli@ codec — guarding against either side re-encoding locally. +-- * End-to-end: boot a real store with a live subscription, serve +-- @\/subscriptions@ from 'storeSubscriptionStatus', and assert the real CLI +-- client ('fetchRemoteSubscriptionStatusRows') reports the live subscription +-- with a sane phase and the expected cursor. A raw GET checks the by-name route +-- (known → one row, unknown → @[]@), and a server with no provider yields the +-- configured-404. module Test.SubscriptionsSpec (spec) where import Control.Concurrent (threadDelay) @@ -18,26 +17,26 @@ import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T -import Network.HTTP.Client ( - defaultManagerSettings, +import Network.HTTP.Client + ( defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseStatus, - ) + ) import Network.HTTP.Types.Status (statusCode) import Network.Wai.Handler.Warp qualified as Warp import Test.Hspec import Kiroku.Cli.Command (RemoteEndpoint (..)) -import Kiroku.Cli.Subscription.Status ( - SubscriptionStatusRow (..), +import Kiroku.Cli.Subscription.Status + ( SubscriptionStatusRow (..), fetchRemoteSubscriptionStatusRows, subscriptionStatusRows, - ) -import Kiroku.Metrics ( - MetricsServer (..), + ) +import Kiroku.Metrics + ( MetricsServer (..), defaultConfig, newKirokuMetrics, startMetricsServer, @@ -45,10 +44,10 @@ storeSubscriptionStatus, subscriptionsApp, withMetricsServerSubscriptions, - ) + ) import Kiroku.Metrics.Config (MetricsServerConfig (..)) -import Kiroku.Store ( - EventData (..), +import Kiroku.Store + ( EventData (..), EventType (..), ExpectedVersion (..), KirokuStore, @@ -62,7 +61,7 @@ runStoreIO, subscribe, withStore, - ) + ) import Kiroku.Store.Subscription (SubscriptionStateView (..), subscriptionStates) import Kiroku.Store.Subscription.Fsm (SubscriptionState (..)) import Kiroku.Store.Subscription.Types (SubscriptionName (..)) @@ -71,111 +70,111 @@ spec :: Spec spec = describe "Kiroku.Metrics.Subscriptions (/subscriptions)" $ do - it "encodes server-side rows that decode back through the shared CLI codec" $ do - let views = - Map.fromList - [ ((SubscriptionName "beta", 1), mkView "beta" 1 "live" 42) - , ((SubscriptionName "alpha", 0), mkView "alpha" 0 "catching_up" 7) - ] - rows = subscriptionStatusRows views - Aeson.eitherDecode (Aeson.encode rows) `shouldBe` Right rows + it "encodes server-side rows that decode back through the shared CLI codec" $ do + let views = + Map.fromList + [ ((SubscriptionName "beta", 1), mkView "beta" 1 "live" 42), + ((SubscriptionName "alpha", 0), mkView "alpha" 0 "catching_up" 7) + ] + rows = subscriptionStatusRows views + Aeson.eitherDecode (Aeson.encode rows) `shouldBe` Right rows - it "reports a live subscription to the CLI remote client end to end" $ - withMigratedTestDatabase $ \connStr -> - withStore (defaultConnectionSettings connStr) $ \store -> do - m <- newKirokuMetrics store - let name = SubscriptionName "subs-endpoint-it" - Right _ <- - runStoreIO store $ - appendToStream (StreamName "subs-endpoint-1") NoStream [ev "A", ev "B", ev "C"] - handle <- subscribe store (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) - live <- waitUntilPhase 10_000_000 store (name, 0) "live" - live `shouldBe` True + it "reports a live subscription to the CLI remote client end to end" $ + withMigratedTestDatabase $ \connStr -> + withStore (defaultConnectionSettings connStr) $ \store -> do + m <- newKirokuMetrics store + let name = SubscriptionName "subs-endpoint-it" + Right _ <- + runStoreIO store $ + appendToStream (StreamName "subs-endpoint-1") NoStream [ev "A", ev "B", ev "C"] + handle <- subscribe store (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) + live <- waitUntilPhase 10_000_000 store (name, 0) "live" + live `shouldBe` True - withMetricsServerSubscriptions (defaultConfig{port = 0}) m [] (storeSubscriptionStatus store) $ \srv -> do - threadDelay 200_000 - let base = "http://127.0.0.1:" <> show srv.serverPort + withMetricsServerSubscriptions (defaultConfig {port = 0}) m [] (storeSubscriptionStatus store) $ \srv -> do + threadDelay 200_000 + let base = "http://127.0.0.1:" <> show srv.serverPort - -- The real CLI client hits GET /subscriptions and decodes the rows. - rowsResult <- fetchRemoteSubscriptionStatusRows (RemoteEndpoint (T.pack base)) - case rowsResult of - Left err -> expectationFailure ("expected rows, got error: " <> T.unpack err) - Right rows -> - case filter (\r -> r.subscription == "subs-endpoint-it") rows of - [row] -> do - row.phase `shouldBe` "live" - row.globalPosition `shouldBe` 3 - other -> expectationFailure ("expected exactly one matching row, got " <> show other) + -- The real CLI client hits GET /subscriptions and decodes the rows. + rowsResult <- fetchRemoteSubscriptionStatusRows (RemoteEndpoint (T.pack base)) + case rowsResult of + Left err -> expectationFailure ("expected rows, got error: " <> T.unpack err) + Right rows -> + case filter (\r -> r.subscription == "subs-endpoint-it") rows of + [row] -> do + row.phase `shouldBe` "live" + row.globalPosition `shouldBe` 3 + other -> expectationFailure ("expected exactly one matching row, got " <> show other) - -- By-name route: known name → one row, unknown name → []. - known <- getRows (base <> "/subscriptions/subs-endpoint-it") - map (.subscription) known `shouldBe` ["subs-endpoint-it"] - unknown <- getRows (base <> "/subscriptions/does-not-exist") - unknown `shouldBe` [] + -- By-name route: known name → one row, unknown name → []. + known <- getRows (base <> "/subscriptions/subs-endpoint-it") + map (.subscription) known `shouldBe` ["subs-endpoint-it"] + unknown <- getRows (base <> "/subscriptions/does-not-exist") + unknown `shouldBe` [] - cancel handle + cancel handle - it "returns a configured-404 when no provider is wired" $ - withMigratedTestDatabase $ \connStr -> - withStore (defaultConnectionSettings connStr) $ \store -> do - m <- newKirokuMetrics store - srv <- startMetricsServer (defaultConfig{port = 0}) m [] - threadDelay 200_000 - result <- - fetchRemoteSubscriptionStatusRows - (RemoteEndpoint (T.pack ("http://127.0.0.1:" <> show srv.serverPort))) - stopMetricsServer srv - case result of - Left err -> err `shouldSatisfy` T.isInfixOf "404" - Right rows -> expectationFailure ("expected a 404 error, got rows: " <> show rows) + it "returns a configured-404 when no provider is wired" $ + withMigratedTestDatabase $ \connStr -> + withStore (defaultConnectionSettings connStr) $ \store -> do + m <- newKirokuMetrics store + srv <- startMetricsServer (defaultConfig {port = 0}) m [] + threadDelay 200_000 + result <- + fetchRemoteSubscriptionStatusRows + (RemoteEndpoint (T.pack ("http://127.0.0.1:" <> show srv.serverPort))) + stopMetricsServer srv + case result of + Left err -> err `shouldSatisfy` T.isInfixOf "404" + Right rows -> expectationFailure ("expected a 404 error, got rows: " <> show rows) - it "returns the documented 404 JSON body for unknown paths when mounted standalone" $ - Warp.testWithApplication (pure (subscriptionsApp (pure []))) $ \port -> do - mgr <- newManager defaultManagerSettings - req <- parseRequest ("http://127.0.0.1:" <> show port <> "/definitely/not/a/route") - resp <- httpLbs req mgr - statusCode (responseStatus resp) `shouldBe` 404 - Aeson.decode (responseBody resp) - `shouldBe` Just (Aeson.object ["error" Aeson..= ("Not found" :: Text)]) + it "returns the documented 404 JSON body for unknown paths when mounted standalone" $ + Warp.testWithApplication (pure (subscriptionsApp (pure []))) $ \port -> do + mgr <- newManager defaultManagerSettings + req <- parseRequest ("http://127.0.0.1:" <> show port <> "/definitely/not/a/route") + resp <- httpLbs req mgr + statusCode (responseStatus resp) `shouldBe` 404 + Aeson.decode (responseBody resp) + `shouldBe` Just (Aeson.object ["error" Aeson..= ("Not found" :: Text)]) -- | GET a URL and decode the body as @[SubscriptionStatusRow]@ (via the shared codec). getRows :: String -> IO [SubscriptionStatusRow] getRows url = do - mgr <- newManager defaultManagerSettings - req <- parseRequest url - resp <- httpLbs req mgr - case Aeson.eitherDecode (responseBody resp) of - Right rows -> pure rows - Left err -> expectationFailure ("could not decode " <> url <> ": " <> err) >> pure [] + mgr <- newManager defaultManagerSettings + req <- parseRequest url + resp <- httpLbs req mgr + case Aeson.eitherDecode (responseBody resp) of + Right rows -> pure rows + Left err -> expectationFailure ("could not decode " <> url <> ": " <> err) >> pure [] mkView :: Text -> Int32 -> Text -> Int64 -> SubscriptionStateView mkView name member phase position = - SubscriptionStateView - { subscriptionName = SubscriptionName name - , member = member - , state = Live (GlobalPosition position) - , statePhase = phase - , cursor = GlobalPosition position - } + SubscriptionStateView + { subscriptionName = SubscriptionName name, + member = member, + state = Live (GlobalPosition position), + statePhase = phase, + cursor = GlobalPosition position + } ev :: Text -> EventData ev typ = - EventData - { eventId = Nothing - , eventType = EventType typ - , payload = Aeson.Null - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } + EventData + { eventId = Nothing, + eventType = EventType typ, + payload = Aeson.Null, + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } waitUntilPhase :: Int -> KirokuStore -> (SubscriptionName, Int32) -> Text -> IO Bool waitUntilPhase budget store key phase - | budget <= 0 = pure False - | otherwise = do - snapshot <- subscriptionStates store - case Map.lookup key snapshot of - Just status | statePhase status == phase -> pure True - _ -> do - threadDelay 20_000 - waitUntilPhase (budget - 20_000) store key phase + | budget <= 0 = pure False + | otherwise = do + snapshot <- subscriptionStates store + case Map.lookup key snapshot of + Just status | statePhase status == phase -> pure True + _ -> do + threadDelay 20_000 + waitUntilPhase (budget - 20_000) store key phase diff --git a/test/Test/WebSocketConvergenceSpec.hs b/test/Test/WebSocketConvergenceSpec.hs --- a/test/Test/WebSocketConvergenceSpec.hs +++ b/test/Test/WebSocketConvergenceSpec.hs @@ -29,15 +29,15 @@ import System.Timeout (timeout) import Test.Hspec -import Kiroku.Metrics ( - MetricsServer (..), +import Kiroku.Metrics + ( MetricsServer (..), MetricsServerConfig (..), defaultConfig, newKirokuMetricsWith, snapshotMetrics, startMetricsServerWithStore, stopMetricsServer, - ) + ) import Kiroku.Metrics.WebSocket import Kiroku.Store hiding (cancel, id) import Kiroku.Store.Subscription.EventPublisher qualified as Pub @@ -45,235 +45,235 @@ spec :: Spec spec = do - describe "Kiroku.Metrics.WebSocket (frames)" $ do - it "preserves every existing server frame" $ do - toJSON Pong `shouldBe` object ["type" .= ("pong" :: Text)] - toJSON Goodbye `shouldBe` object ["type" .= ("goodbye" :: Text)] - toJSON (EventStreamStarted 7) `shouldBe` object ["type" .= ("event_stream_started" :: Text), "from_position" .= (7 :: Int)] - toJSON (ErrorMsg "x") `shouldBe` object ["type" .= ("error" :: Text), "message" .= ("x" :: Text)] - toJSON (Event (object ["k" .= (1 :: Int)])) `shouldBe` object ["type" .= ("event" :: Text), "event" .= object ["k" .= (1 :: Int)]] - km <- newKirokuMetricsWith (pure (GlobalPosition 0)) (pure 0) - snap <- snapshotMetrics km - look ["type"] (toJSON (Snapshot snap)) `shouldBe` Just (String "snapshot") - look ["metrics"] (toJSON (Snapshot snap)) `shouldBe` Just (toJSON snap) - it "pins coded errors and all four code spellings" $ do - toJSON (CodedError "replay_failed" "boom") `shouldBe` object ["type" .= ("error" :: Text), "code" .= ("replay_failed" :: Text), "message" .= ("boom" :: Text)] - [errorCodeReplayFailed, errorCodeCategoryReadFailed, errorCodeEventStreamOverflowed, errorCodeLiveDecodeFailed] `shouldBe` ["replay_failed", "category_read_failed", "event_stream_overflowed", "live_decode_failed"] - it "accepts every old client frame and unsubscribe_metrics" $ do - let parse raw = eitherDecode raw :: Either String ClientMessage - map parse ["{\"type\":\"ping\"}", "{\"type\":\"subscribe_metrics\"}", "{\"type\":\"unsubscribe_events\"}", "{\"type\":\"unsubscribe_metrics\"}", "{\"type\":\"subscribe_events\"}", "{\"type\":\"subscribe_events\",\"from_position\":7,\"category\":\"orders\"}"] `shouldBe` map Right [Ping, SubscribeMetrics, UnsubscribeEvents, UnsubscribeMetrics, SubscribeEvents Nothing Nothing, SubscribeEvents (Just 7) (Just "orders")] - it "adds exactly original_stream_name and preserves all old event fields" $ do - let event = fixture 9 - original = objectFields (recordedEventToJSON event) - resolved = objectFields (recordedEventToJSONResolved (Map.singleton (StreamId 9) (StreamName "orders-7")) event) - KM.delete "original_stream_name" resolved `shouldBe` original - length (KM.keys resolved) `shouldBe` 12 - KM.lookup "original_stream_name" resolved `shouldBe` Just (String "orders-7") - look ["original_stream_name"] (recordedEventToJSONResolved Map.empty event) `shouldBe` Just Null - it "detects only counter changes, including modular wraparound" $ do - overflowNotice 0 0 `shouldBe` Nothing - overflowNotice 3 3 `shouldBe` Nothing - assertNotice 0 2 "2 undelivered" - assertNotice 2 5 "3 undelivered" - assertNotice maxBound 1 "2 undelivered" + describe "Kiroku.Metrics.WebSocket (frames)" $ do + it "preserves every existing server frame" $ do + toJSON Pong `shouldBe` object ["type" .= ("pong" :: Text)] + toJSON Goodbye `shouldBe` object ["type" .= ("goodbye" :: Text)] + toJSON (EventStreamStarted 7) `shouldBe` object ["type" .= ("event_stream_started" :: Text), "from_position" .= (7 :: Int)] + toJSON (ErrorMsg "x") `shouldBe` object ["type" .= ("error" :: Text), "message" .= ("x" :: Text)] + toJSON (Event (object ["k" .= (1 :: Int)])) `shouldBe` object ["type" .= ("event" :: Text), "event" .= object ["k" .= (1 :: Int)]] + km <- newKirokuMetricsWith (pure (GlobalPosition 0)) (pure 0) + snap <- snapshotMetrics km + look ["type"] (toJSON (Snapshot snap)) `shouldBe` Just (String "snapshot") + look ["metrics"] (toJSON (Snapshot snap)) `shouldBe` Just (toJSON snap) + it "pins coded errors and all four code spellings" $ do + toJSON (CodedError "replay_failed" "boom") `shouldBe` object ["type" .= ("error" :: Text), "code" .= ("replay_failed" :: Text), "message" .= ("boom" :: Text)] + [errorCodeReplayFailed, errorCodeCategoryReadFailed, errorCodeEventStreamOverflowed, errorCodeLiveDecodeFailed] `shouldBe` ["replay_failed", "category_read_failed", "event_stream_overflowed", "live_decode_failed"] + it "accepts every old client frame and unsubscribe_metrics" $ do + let parse raw = eitherDecode raw :: Either String ClientMessage + map parse ["{\"type\":\"ping\"}", "{\"type\":\"subscribe_metrics\"}", "{\"type\":\"unsubscribe_events\"}", "{\"type\":\"unsubscribe_metrics\"}", "{\"type\":\"subscribe_events\"}", "{\"type\":\"subscribe_events\",\"from_position\":7,\"category\":\"orders\"}"] `shouldBe` map Right [Ping, SubscribeMetrics, UnsubscribeEvents, UnsubscribeMetrics, SubscribeEvents Nothing Nothing, SubscribeEvents (Just 7) (Just "orders")] + it "adds exactly original_stream_name and preserves all old event fields" $ do + let event = fixture 9 + original = objectFields (recordedEventToJSON event) + resolved = objectFields (recordedEventToJSONResolved (Map.singleton (StreamId 9) (StreamName "orders-7")) event) + KM.delete "original_stream_name" resolved `shouldBe` original + length (KM.keys resolved) `shouldBe` 12 + KM.lookup "original_stream_name" resolved `shouldBe` Just (String "orders-7") + look ["original_stream_name"] (recordedEventToJSONResolved Map.empty event) `shouldBe` Just Null + it "detects only counter changes, including modular wraparound" $ do + overflowNotice 0 0 `shouldBe` Nothing + overflowNotice 3 3 `shouldBe` Nothing + assertNotice 0 2 "2 undelivered" + assertNotice 2 5 "3 undelivered" + assertNotice maxBound 1 "2 undelivered" - describe "Kiroku.Metrics.WebSocket (bounded delivery)" $ do - it "resolves one cold batch, no warm or empty batches, and bounds FIFO retention" $ do - cache <- newStreamNameCache - calls <- newIORef ([] :: [[StreamId]]) - let lookupBatch ids = do - atomicModifyIORef' calls (\xs -> (xs <> [ids], ())) - pure (Map.fromList [(sid, streamName sid) | sid <- ids]) - events = V.fromList (map fixture [1 .. 5000]) - names <- resolveEventNames cache lookupBatch events - Map.size names `shouldBe` 5000 - Map.lookup (StreamId 1) names `shouldBe` Just (StreamName "stream-1") - Map.lookup (StreamId 5000) names `shouldBe` Just (StreamName "stream-5000") - streamNameCacheSize cache `shouldReturn` (4096, 4096) - _ <- resolveEventNames cache lookupBatch (V.fromList [fixture 5000, fixture 5000]) - _ <- resolveEventNames cache lookupBatch V.empty - length <$> readIORef calls `shouldReturn` 1 - _ <- resolveEventNames cache lookupBatch (V.singleton (fixture 1)) - length <$> readIORef calls `shouldReturn` 2 - streamNameCacheSize cache `shouldReturn` (4096, 4096) - it "does not retain misses and propagates cancellation from a name lookup" $ do - cache <- newStreamNameCache - resolveEventNames cache (const (pure Map.empty)) (V.singleton (fixture 1)) `shouldReturn` Map.empty - streamNameCacheSize cache `shouldReturn` (0, 0) - entered <- newEmptyTMVarIO - withAsync (resolveEventNames cache (\_ -> atomically (putTMVar entered ()) >> atomically retry) (V.singleton (fixture 1))) $ \worker -> do - bounded (atomically (takeTMVar entered)) - cancel worker - streamNameCacheSize cache `shouldReturn` (0, 0) - it "delivers unchanged and transformed batches without false overflow notices" $ do - sub <- fakeSubscription - cache <- newStreamNameCache - frames <- newTVarIO [] - atomically $ do - writeTBQueue sub.subscriptionQueue (UnchangedBatch (V.singleton (fixture 1))) - writeTBQueue sub.subscriptionQueue (TransformedBatch (V.singleton (Decoded (fixture 2)))) - withAsync (broadcastEventsWith (capture frames) cache (pure . Map.fromList . map (\sid -> (sid, streamName sid))) sub (const True)) $ \_ -> do - bounded (atomically (readTVar frames >>= \xs -> check (length xs == 2))) - xs <- readTVarIO frames - map framePosition xs `shouldBe` [Just 1, Just 2] - it "never sends partial data and terminates on an applicable typed decode failure" $ do - sub <- fakeSubscription - cache <- newStreamNameCache - frames <- newTVarIO [] - let failed = fixture 2 - atomically (writeTBQueue sub.subscriptionQueue (TransformedBatch (V.fromList [Decoded (fixture 1), Undecodable failed (DecodeFailure failed.eventId "secret payload")]))) - bounded (broadcastEventsWith (capture frames) cache (\_ -> fail "must not look up partial batch") sub (const True)) - readTVarIO frames `shouldReturn` [CodedError errorCodeLiveDecodeFailed "live event decoding failed"] - it "filters typed failures below the covered replay boundary" $ do - sub <- fakeSubscription - cache <- newStreamNameCache - frames <- newTVarIO [] - let old = fixture 1 - atomically (writeTBQueue sub.subscriptionQueue (TransformedBatch (V.fromList [Undecodable old (DecodeFailure old.eventId "old failure"), Decoded (fixture 2)]))) - withAsync (broadcastEventsWith (capture frames) cache (const (pure Map.empty)) sub (\e -> e.globalPosition > GlobalPosition 1)) $ \_ -> - bounded (atomically (readTVar frames >>= \xs -> check (length xs == 1))) - map framePosition <$> readTVarIO frames `shouldReturn` [Just 2] - it "signals real publisher loss before survivors and recovers from the pre-notice cursor" $ withBareStore $ \store -> - bracket (atomically (Pub.subscribePublisherWith store.publisher 1 DropOldest)) Pub.unsubscribe $ \sub -> do - cache <- newStreamNameCache - frames <- newTVarIO [] - entered <- newEmptyTMVarIO - release <- newEmptyTMVarIO - let writer msg = do - case msg of - Event ev | look ["globalPosition"] ev == Just (toJSON (1 :: Int)) -> atomically (putTMVar entered ()) >> atomically (takeTMVar release) - _ -> pure () - capture frames msg - lookupBatch ids = either (error . show) id <$> runStoreIO store (lookupStreamNames ids) - withAsync (broadcastEventsWith writer cache lookupBatch sub (const True)) $ \_ -> do - appendEvents store "loss-1" 1 - bounded (atomically (takeTMVar entered)) - appendEvents store "loss-2" 1 - waitPosition store 2 - appendEvents store "loss-3" 1 - waitPosition store 3 - readTVarIO sub.subscriptionDropped `shouldReturn` 1 - atomically (putTMVar release ()) - bounded (atomically (readTVar frames >>= \xs -> check (length xs == 3))) - xs <- readTVarIO frames - map framePosition xs `shouldBe` [Just 1, Nothing, Just 3] - case xs of - [_, CodedError code _, _] -> code `shouldBe` errorCodeEventStreamOverflowed - _ -> expectationFailure (show xs) - Right recovered <- runStoreIO store (readAllForward (GlobalPosition 1) 10) - map (.globalPosition) (V.toList recovered) `shouldBe` [GlobalPosition 2, GlobalPosition 3] - sort (nub ([p | Just p <- map framePosition xs] <> map (\e -> let GlobalPosition p = e.globalPosition in p) (V.toList recovered))) `shouldBe` [1, 2, 3] - it "coalesces defensive status overflow and a drop notice in the same delivery" $ do - sub <- fakeSubscription - cache <- newStreamNameCache - frames <- newTVarIO [] - atomically $ do - writeTVar sub.subscriptionStatus Pub.Overflowed - writeTVar sub.subscriptionDropped 1 - writeTBQueue sub.subscriptionQueue (UnchangedBatch (V.singleton (fixture 1))) - writeTBQueue sub.subscriptionQueue (UnchangedBatch (V.singleton (fixture 2))) - withAsync (broadcastEventsWith (capture frames) cache (const (pure Map.empty)) sub (const True)) $ \_ -> - bounded (atomically (readTVar frames >>= \xs -> check (length xs == 3))) - map framePosition <$> readTVarIO frames `shouldReturn` [Nothing, Just 1, Just 2] + describe "Kiroku.Metrics.WebSocket (bounded delivery)" $ do + it "resolves one cold batch, no warm or empty batches, and bounds FIFO retention" $ do + cache <- newStreamNameCache + calls <- newIORef ([] :: [[StreamId]]) + let lookupBatch ids = do + atomicModifyIORef' calls (\xs -> (xs <> [ids], ())) + pure (Map.fromList [(sid, streamName sid) | sid <- ids]) + events = V.fromList (map fixture [1 .. 5000]) + names <- resolveEventNames cache lookupBatch events + Map.size names `shouldBe` 5000 + Map.lookup (StreamId 1) names `shouldBe` Just (StreamName "stream-1") + Map.lookup (StreamId 5000) names `shouldBe` Just (StreamName "stream-5000") + streamNameCacheSize cache `shouldReturn` (4096, 4096) + _ <- resolveEventNames cache lookupBatch (V.fromList [fixture 5000, fixture 5000]) + _ <- resolveEventNames cache lookupBatch V.empty + length <$> readIORef calls `shouldReturn` 1 + _ <- resolveEventNames cache lookupBatch (V.singleton (fixture 1)) + length <$> readIORef calls `shouldReturn` 2 + streamNameCacheSize cache `shouldReturn` (4096, 4096) + it "does not retain misses and propagates cancellation from a name lookup" $ do + cache <- newStreamNameCache + resolveEventNames cache (const (pure Map.empty)) (V.singleton (fixture 1)) `shouldReturn` Map.empty + streamNameCacheSize cache `shouldReturn` (0, 0) + entered <- newEmptyTMVarIO + withAsync (resolveEventNames cache (\_ -> atomically (putTMVar entered ()) >> atomically retry) (V.singleton (fixture 1))) $ \worker -> do + bounded (atomically (takeTMVar entered)) + cancel worker + streamNameCacheSize cache `shouldReturn` (0, 0) + it "delivers unchanged and transformed batches without false overflow notices" $ do + sub <- fakeSubscription + cache <- newStreamNameCache + frames <- newTVarIO [] + atomically $ do + writeTBQueue sub.subscriptionQueue (UnchangedBatch (V.singleton (fixture 1))) + writeTBQueue sub.subscriptionQueue (TransformedBatch (V.singleton (Decoded (fixture 2)))) + withAsync (broadcastEventsWith (capture frames) cache (pure . Map.fromList . map (\sid -> (sid, streamName sid))) sub (const True)) $ \_ -> do + bounded (atomically (readTVar frames >>= \xs -> check (length xs == 2))) + xs <- readTVarIO frames + map framePosition xs `shouldBe` [Just 1, Just 2] + it "never sends partial data and terminates on an applicable typed decode failure" $ do + sub <- fakeSubscription + cache <- newStreamNameCache + frames <- newTVarIO [] + let failed = fixture 2 + atomically (writeTBQueue sub.subscriptionQueue (TransformedBatch (V.fromList [Decoded (fixture 1), Undecodable failed (DecodeFailure failed.eventId "secret payload")]))) + bounded (broadcastEventsWith (capture frames) cache (\_ -> fail "must not look up partial batch") sub (const True)) + readTVarIO frames `shouldReturn` [CodedError errorCodeLiveDecodeFailed "live event decoding failed"] + it "filters typed failures below the covered replay boundary" $ do + sub <- fakeSubscription + cache <- newStreamNameCache + frames <- newTVarIO [] + let old = fixture 1 + atomically (writeTBQueue sub.subscriptionQueue (TransformedBatch (V.fromList [Undecodable old (DecodeFailure old.eventId "old failure"), Decoded (fixture 2)]))) + withAsync (broadcastEventsWith (capture frames) cache (const (pure Map.empty)) sub (\e -> e.globalPosition > GlobalPosition 1)) $ \_ -> + bounded (atomically (readTVar frames >>= \xs -> check (length xs == 1))) + map framePosition <$> readTVarIO frames `shouldReturn` [Just 2] + it "signals real publisher loss before survivors and recovers from the pre-notice cursor" $ withBareStore $ \store -> + bracket (atomically (Pub.subscribePublisherWith store.publisher 1 DropOldest)) Pub.unsubscribe $ \sub -> do + cache <- newStreamNameCache + frames <- newTVarIO [] + entered <- newEmptyTMVarIO + release <- newEmptyTMVarIO + let writer msg = do + case msg of + Event ev | look ["globalPosition"] ev == Just (toJSON (1 :: Int)) -> atomically (putTMVar entered ()) >> atomically (takeTMVar release) + _ -> pure () + capture frames msg + lookupBatch ids = either (error . show) id <$> runStoreIO store (lookupStreamNames ids) + withAsync (broadcastEventsWith writer cache lookupBatch sub (const True)) $ \_ -> do + appendEvents store "loss-1" 1 + bounded (atomically (takeTMVar entered)) + appendEvents store "loss-2" 1 + waitPosition store 2 + appendEvents store "loss-3" 1 + waitPosition store 3 + readTVarIO sub.subscriptionDropped `shouldReturn` 1 + atomically (putTMVar release ()) + bounded (atomically (readTVar frames >>= \xs -> check (length xs == 3))) + xs <- readTVarIO frames + map framePosition xs `shouldBe` [Just 1, Nothing, Just 3] + case xs of + [_, CodedError code _, _] -> code `shouldBe` errorCodeEventStreamOverflowed + _ -> expectationFailure (show xs) + Right recovered <- runStoreIO store (readAllForward (GlobalPosition 1) 10) + map (.globalPosition) (V.toList recovered) `shouldBe` [GlobalPosition 2, GlobalPosition 3] + sort (nub ([p | Just p <- map framePosition xs] <> map (\e -> let GlobalPosition p = e.globalPosition in p) (V.toList recovered))) `shouldBe` [1, 2, 3] + it "coalesces defensive status overflow and a drop notice in the same delivery" $ do + sub <- fakeSubscription + cache <- newStreamNameCache + frames <- newTVarIO [] + atomically $ do + writeTVar sub.subscriptionStatus Pub.Overflowed + writeTVar sub.subscriptionDropped 1 + writeTBQueue sub.subscriptionQueue (UnchangedBatch (V.singleton (fixture 1))) + writeTBQueue sub.subscriptionQueue (UnchangedBatch (V.singleton (fixture 2))) + withAsync (broadcastEventsWith (capture frames) cache (const (pure Map.empty)) sub (const True)) $ \_ -> + bounded (atomically (readTVar frames >>= \xs -> check (length xs == 3))) + map framePosition <$> readTVarIO frames `shouldReturn` [Nothing, Just 1, Just 2] - describe "Kiroku.Metrics.WebSocket (worker lifecycle)" $ do - it "keeps one unmasked worker through repeated start/stop and joins on exit" $ do - active <- newTVarIO (0 :: Int) - masking <- newTVarIO Nothing - let worker = bracket_ (atomically (modifyTVar' active (+ 1))) (atomically (modifyTVar' active (subtract 1))) $ do - state <- getMaskingState - atomically (writeTVar masking (Just state)) - atomically retry - withWorkerSlot $ \start stop -> do - replicateM_ 5 $ do - replicateM_ 3 (start worker) - bounded (atomically (readTVar active >>= check . (== 1))) - bounded (atomically (readTVar masking >>= check . (== Just Unmasked))) - stop >> stop - readTVarIO active `shouldReturn` 0 - start worker - bounded (atomically (readTVar active >>= check . (== 1))) - readTVarIO active `shouldReturn` 0 - it "joins a worker when the connection is cancelled during worker startup" $ do - active <- newTVarIO (0 :: Int) - let worker = bracket_ (atomically (modifyTVar' active (+ 1))) (atomically (modifyTVar' active (subtract 1))) (atomically retry) - withAsync (withWorkerSlot $ \start _ -> start worker >> atomically retry) $ \owner -> do - bounded (atomically (readTVar active >>= check . (== 1))) - cancel owner - readTVarIO active `shouldReturn` 0 - it "propagates unexpected worker failure to the owner" $ do - result <- try (bounded (withWorkerSlot $ \start _ -> start (throwIO (userError "worker failed")) >> atomically retry)) :: IO (Either SomeException ()) - result `shouldSatisfy` either (T.isInfixOf "worker failed" . T.pack . show) (const False) + describe "Kiroku.Metrics.WebSocket (worker lifecycle)" $ do + it "keeps one unmasked worker through repeated start/stop and joins on exit" $ do + active <- newTVarIO (0 :: Int) + masking <- newTVarIO Nothing + let worker = bracket_ (atomically (modifyTVar' active (+ 1))) (atomically (modifyTVar' active (subtract 1))) $ do + state <- getMaskingState + atomically (writeTVar masking (Just state)) + atomically retry + withWorkerSlot $ \start stop -> do + replicateM_ 5 $ do + replicateM_ 3 (start worker) + bounded (atomically (readTVar active >>= check . (== 1))) + bounded (atomically (readTVar masking >>= check . (== Just Unmasked))) + stop >> stop + readTVarIO active `shouldReturn` 0 + start worker + bounded (atomically (readTVar active >>= check . (== 1))) + readTVarIO active `shouldReturn` 0 + it "joins a worker when the connection is cancelled during worker startup" $ do + active <- newTVarIO (0 :: Int) + let worker = bracket_ (atomically (modifyTVar' active (+ 1))) (atomically (modifyTVar' active (subtract 1))) (atomically retry) + withAsync (withWorkerSlot $ \start _ -> start worker >> atomically retry) $ \owner -> do + bounded (atomically (readTVar active >>= check . (== 1))) + cancel owner + readTVarIO active `shouldReturn` 0 + it "propagates unexpected worker failure to the owner" $ do + result <- try (bounded (withWorkerSlot $ \start _ -> start (throwIO (userError "worker failed")) >> atomically retry)) :: IO (Either SomeException ()) + result `shouldSatisfy` either (T.isInfixOf "worker failed" . T.pack . show) (const False) - describe "Kiroku.Metrics.WebSocket (convergence, real server)" $ do - it "stops metrics pushes, resumes them and preserves ping" $ withServer id $ \_ srv -> client srv "/ws/metrics" $ \conn -> do - _ <- waitForType conn "snapshot" - _ <- waitForType conn "snapshot" - replicateM_ 3 (command conn "unsubscribe_metrics") - -- Ping is an ordering barrier: the receive loop has completed cancellation. - command conn "ping" - _ <- waitForType conn "pong" - timeout 700_000 (WS.receiveData conn :: IO LBS.ByteString) `shouldReturn` Nothing - replicateM_ 3 (command conn "subscribe_metrics") - replicateM_ 4 (waitForType conn "snapshot") - command conn "ping" - _ <- waitForType conn "pong" - pure () - it "labels live events on both new and warm streams" $ withServer id $ \store srv -> do - names <- client srv "/ws/events" $ \conn -> do - command conn "subscribe_events" - _ <- waitForType conn "event_stream_started" - appendEvents store "conv-live-1" 2 - appendEvents store "conv-live-2" 1 - replicateM 3 (readEventField conn "original_stream_name") - names `shouldBe` map (Just . String) ["conv-live-1", "conv-live-1", "conv-live-2"] - waitSubscriberCount store 0 - it "labels replay and category events" $ withServer id $ \store srv -> do - appendEvents store "convcat-1" 2 - waitPosition store 2 - replayed <- client srv "/ws/events" $ \conn -> do - sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) - _ <- waitForType conn "event_stream_started" - replicateM 2 (readEventField conn "original_stream_name") - replayed `shouldBe` replicate 2 (Just (String "convcat-1")) - names <- client srv "/ws/events" $ \conn -> do - sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "category" .= ("convcat" :: Text)]) - _ <- waitForType conn "event_stream_started" - appendEvents store "convcat-2" 1 - readEventField conn "original_stream_name" - names `shouldBe` Just (String "convcat-2") - waitSubscriberCount store 0 - it "codes and sanitizes a replay failure and ends its tail" $ withServer id $ \store srv -> do - appendEvents store "conv-fail-1" 1 - waitPosition store 1 - Pool.use store.pool (Session.script "ALTER TABLE events RENAME TO events_hidden") `shouldReturn` Right () - client srv "/ws/events" $ \conn -> do - sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) - err <- waitForType conn "error" - look ["code"] err `shouldBe` Just (String "replay_failed") - look ["message"] err `shouldBe` Just (String "replay error: history unavailable") - timeout 300_000 (WS.receiveData conn :: IO LBS.ByteString) `shouldReturn` Nothing - waitSubscriberCount store 0 - it "codes a category failure without appending to the renamed table" $ withServer id $ \store srv -> do - appendEvents store "convcat-1" 1 - waitPosition store 1 - Pool.use store.pool (Session.script "ALTER TABLE events RENAME TO events_hidden") `shouldReturn` Right () - client srv "/ws/events" $ \conn -> do - sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int), "category" .= ("convcat" :: Text)]) - err <- waitForType conn "error" - look ["code"] err `shouldBe` Just (String "category_read_failed") - look ["message"] err `shouldBe` Just (String "category read error: events unavailable") - timeout 300_000 (WS.receiveData conn :: IO LBS.ByteString) `shouldReturn` Nothing - waitSubscriberCount store 0 - it "codes typed live decode failures without leaking hook details" $ withServer (\settings -> settings & #storeSettings . #decodeHook .~ Just (\e -> pure (Left (DecodeFailure e.eventId "secret")))) $ \store srv -> do - client srv "/ws/events" $ \conn -> do - command conn "subscribe_events" - _ <- waitForType conn "event_stream_started" - appendEvents store "conv-decode" 1 - err <- waitForType conn "error" - look ["code"] err `shouldBe` Just (String "live_decode_failed") - look ["message"] err `shouldBe` Just (String "live event decoding failed") - waitSubscriberCount store 0 + describe "Kiroku.Metrics.WebSocket (convergence, real server)" $ do + it "stops metrics pushes, resumes them and preserves ping" $ withServer id $ \_ srv -> client srv "/ws/metrics" $ \conn -> do + _ <- waitForType conn "snapshot" + _ <- waitForType conn "snapshot" + replicateM_ 3 (command conn "unsubscribe_metrics") + -- Ping is an ordering barrier: the receive loop has completed cancellation. + command conn "ping" + _ <- waitForType conn "pong" + timeout 700_000 (WS.receiveData conn :: IO LBS.ByteString) `shouldReturn` Nothing + replicateM_ 3 (command conn "subscribe_metrics") + replicateM_ 4 (waitForType conn "snapshot") + command conn "ping" + _ <- waitForType conn "pong" + pure () + it "labels live events on both new and warm streams" $ withServer id $ \store srv -> do + names <- client srv "/ws/events" $ \conn -> do + command conn "subscribe_events" + _ <- waitForType conn "event_stream_started" + appendEvents store "conv-live-1" 2 + appendEvents store "conv-live-2" 1 + replicateM 3 (readEventField conn "original_stream_name") + names `shouldBe` map (Just . String) ["conv-live-1", "conv-live-1", "conv-live-2"] + waitSubscriberCount store 0 + it "labels replay and category events" $ withServer id $ \store srv -> do + appendEvents store "convcat-1" 2 + waitPosition store 2 + replayed <- client srv "/ws/events" $ \conn -> do + sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) + _ <- waitForType conn "event_stream_started" + replicateM 2 (readEventField conn "original_stream_name") + replayed `shouldBe` replicate 2 (Just (String "convcat-1")) + names <- client srv "/ws/events" $ \conn -> do + sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "category" .= ("convcat" :: Text)]) + _ <- waitForType conn "event_stream_started" + appendEvents store "convcat-2" 1 + readEventField conn "original_stream_name" + names `shouldBe` Just (String "convcat-2") + waitSubscriberCount store 0 + it "codes and sanitizes a replay failure and ends its tail" $ withServer id $ \store srv -> do + appendEvents store "conv-fail-1" 1 + waitPosition store 1 + Pool.use store.pool (Session.script "ALTER TABLE events RENAME TO events_hidden") `shouldReturn` Right () + client srv "/ws/events" $ \conn -> do + sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) + err <- waitForType conn "error" + look ["code"] err `shouldBe` Just (String "replay_failed") + look ["message"] err `shouldBe` Just (String "replay error: history unavailable") + timeout 300_000 (WS.receiveData conn :: IO LBS.ByteString) `shouldReturn` Nothing + waitSubscriberCount store 0 + it "codes a category failure without appending to the renamed table" $ withServer id $ \store srv -> do + appendEvents store "convcat-1" 1 + waitPosition store 1 + Pool.use store.pool (Session.script "ALTER TABLE events RENAME TO events_hidden") `shouldReturn` Right () + client srv "/ws/events" $ \conn -> do + sendJSON conn (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int), "category" .= ("convcat" :: Text)]) + err <- waitForType conn "error" + look ["code"] err `shouldBe` Just (String "category_read_failed") + look ["message"] err `shouldBe` Just (String "category read error: events unavailable") + timeout 300_000 (WS.receiveData conn :: IO LBS.ByteString) `shouldReturn` Nothing + waitSubscriberCount store 0 + it "codes typed live decode failures without leaking hook details" $ withServer (\settings -> settings & #storeSettings . #decodeHook .~ Just (\e -> pure (Left (DecodeFailure e.eventId "secret")))) $ \store srv -> do + client srv "/ws/events" $ \conn -> do + command conn "subscribe_events" + _ <- waitForType conn "event_stream_started" + appendEvents store "conv-decode" 1 + err <- waitForType conn "error" + look ["code"] err `shouldBe` Just (String "live_decode_failed") + look ["message"] err `shouldBe` Just (String "live event decoding failed") + waitSubscriberCount store 0 fixture :: Int64 -> RecordedEvent fixture n = RecordedEvent (EventId UUID.nil) (EventType "E") (StreamVersion 1) (GlobalPosition n) (StreamId n) (StreamVersion 1) (object []) Nothing Nothing Nothing (UTCTime (fromGregorian 2026 10 10) 0) @@ -283,10 +283,10 @@ assertNotice :: Word64 -> Word64 -> Text -> Expectation assertNotice previous current text = case overflowNotice previous current of - Just (CodedError code msg) -> do - code `shouldBe` errorCodeEventStreamOverflowed - msg `shouldSatisfy` T.isInfixOf text - other -> expectationFailure (show other) + Just (CodedError code msg) -> do + code `shouldBe` errorCodeEventStreamOverflowed + msg `shouldSatisfy` T.isInfixOf text + other -> expectationFailure (show other) fakeSubscription :: IO Pub.PublisherSubscription fakeSubscription = Pub.PublisherSubscription <$> newTBQueueIO 16 <*> newTVarIO Pub.Active <*> newTVarIO 0 <*> pure (pure ()) @@ -296,8 +296,8 @@ framePosition :: ServerMessage -> Maybe Int64 framePosition (Event ev) = case look ["globalPosition"] ev of - Just (Number n) -> Just (round n) - _ -> Nothing + Just (Number n) -> Just (round n) + _ -> Nothing framePosition _ = Nothing bounded :: IO a -> IO a @@ -308,14 +308,14 @@ withServer :: (ConnectionSettings -> ConnectionSettings) -> (KirokuStore -> MetricsServer -> IO a) -> IO a withServer tweak action = withMigratedTestDatabase $ \conn -> do - var <- newTVarIO Nothing - km <- - newKirokuMetricsWith - (readTVar var >>= maybe (pure (GlobalPosition 0)) (Pub.publisherPosition . (.publisher))) - (readTVar var >>= maybe (pure 0) (fmap IntMap.size . readTVar . Pub.subscribers . (.publisher))) - withStore (tweak (defaultConnectionSettings conn)) $ \store -> do - atomically (writeTVar var (Just store)) - bracket (startMetricsServerWithStore (defaultConfig{port = 0, wsPushIntervalUs = 200_000}) km store []) stopMetricsServer (action store) + var <- newTVarIO Nothing + km <- + newKirokuMetricsWith + (readTVar var >>= maybe (pure (GlobalPosition 0)) (Pub.publisherPosition . (.publisher))) + (readTVar var >>= maybe (pure 0) (fmap IntMap.size . readTVar . Pub.subscribers . (.publisher))) + withStore (tweak (defaultConnectionSettings conn)) $ \store -> do + atomically (writeTVar var (Just store)) + bracket (startMetricsServerWithStore (defaultConfig {port = 0, wsPushIntervalUs = 200_000}) km store []) stopMetricsServer (action store) client :: MetricsServer -> String -> (WS.Connection -> IO a) -> IO a client srv path = bounded . WS.runClient "127.0.0.1" srv.serverPort path @@ -328,9 +328,9 @@ waitForType :: WS.Connection -> Text -> IO Value waitForType conn name = do - raw <- WS.receiveData conn :: IO LBS.ByteString - value <- either fail pure (eitherDecode raw) - if look ["type"] value == Just (String name) then pure value else waitForType conn name + raw <- WS.receiveData conn :: IO LBS.ByteString + value <- either fail pure (eitherDecode raw) + if look ["type"] value == Just (String name) then pure value else waitForType conn name readEventField :: WS.Connection -> Text -> IO (Maybe Value) readEventField conn key = look ["event", key] <$> waitForType conn "event" @@ -342,8 +342,8 @@ appendEvents :: KirokuStore -> Text -> Int -> IO () appendEvents store name count = do - result <- runStoreIO store (appendToStream (StreamName name) NoStream [EventData Nothing (EventType ("E" <> T.pack (show n))) (object []) Nothing Nothing Nothing | n <- [1 .. count]]) - either (fail . show) (const (pure ())) result + result <- runStoreIO store (appendToStream (StreamName name) NoStream [EventData Nothing (EventType ("E" <> T.pack (show n))) (object []) Nothing Nothing Nothing | n <- [1 .. count]]) + either (fail . show) (const (pure ())) result waitPosition :: KirokuStore -> Int64 -> IO () waitPosition store target = bounded (atomically (Pub.publisherPosition store.publisher >>= check . (>= GlobalPosition target))) diff --git a/test/Test/WebSocketSpec.hs b/test/Test/WebSocketSpec.hs --- a/test/Test/WebSocketSpec.hs +++ b/test/Test/WebSocketSpec.hs @@ -1,24 +1,23 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-} -{- | End-to-end test of the WebSocket endpoints (EP-3): boot a real store with the -collector wired in, start the store-aware server on an OS-assigned port, then -drive both channels over a real socket with the @websockets@ client. - - * @/ws/events@: subscribe, append three events from the test thread, assert - three @event@ messages arrive in global-position order with the expected - @eventType@s. After the client disconnects, the publisher's transient - broadcast subscriber must be cleaned up (count returns to baseline) — proof - the tail's @finally@ wiring deregisters and that it leaves no trace. - * @/ws/metrics@: connect, receive a @snapshot@, assert @store.global_position@ - reflects the appended events. --} +-- | End-to-end test of the WebSocket endpoints (EP-3): boot a real store with the +-- collector wired in, start the store-aware server on an OS-assigned port, then +-- drive both channels over a real socket with the @websockets@ client. +-- +-- * @/ws/events@: subscribe, append three events from the test thread, assert +-- three @event@ messages arrive in global-position order with the expected +-- @eventType@s. After the client disconnects, the publisher's transient +-- broadcast subscriber must be cleaned up (count returns to baseline) — proof +-- the tail's @finally@ wiring deregisters and that it leaves no trace. +-- * @/ws/metrics@: connect, receive a @snapshot@, assert @store.global_position@ +-- reflects the appended events. module Test.WebSocketSpec (spec) where import Control.Concurrent (myThreadId, threadDelay) import Control.Concurrent.Async (async, asyncThreadId, wait) -import Control.Concurrent.STM ( - STM, +import Control.Concurrent.STM + ( STM, TVar, atomically, check, @@ -28,7 +27,7 @@ readTVarIO, registerDelay, writeTVar, - ) + ) import Control.Exception (finally) import Control.Lens ((&), (.~)) import Control.Monad (replicateM, unless, when) @@ -47,18 +46,18 @@ import System.Timeout (timeout) import Test.Hspec -import Kiroku.Metrics ( - MetricsServer (..), +import Kiroku.Metrics + ( MetricsServer (..), defaultConfig, metricsEventHandler, metricsObservationHandler, newKirokuMetricsWith, startMetricsServerWithStore, stopMetricsServer, - ) + ) import Kiroku.Metrics.Config (MetricsServerConfig (..)) -import Kiroku.Store ( - EventData (..), +import Kiroku.Store + ( EventData (..), EventType (..), ExpectedVersion (..), KirokuStore (..), @@ -68,7 +67,7 @@ defaultConnectionSettings, runStoreIO, withStore, - ) + ) import Kiroku.Store.Settings (DecodeFailure (..)) import Kiroku.Store.Subscription.EventPublisher (EventPublisher (..), publisherPosition, subscribePublisher) import Kiroku.Store.Subscription.Types (OverflowPolicy (..)) @@ -77,198 +76,198 @@ spec :: Spec spec = describe "Kiroku.Metrics.WebSocket (endpoints)" $ do - it "streams appended events over /ws/events and a snapshot over /ws/metrics" $ - withMigratedTestDatabase $ \connStr -> do - storeVar <- newTVarIO Nothing - km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - let settings = - defaultConnectionSettings connStr - & #eventHandler .~ Just (metricsEventHandler km Nothing) - & #observationHandler .~ Just (metricsObservationHandler km Nothing) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - let serverCfg = defaultConfig{port = 0} - srv <- startMetricsServerWithStore serverCfg km store [] - threadDelay 300_000 - let port = srv.serverPort - stream = StreamName "ws-events-stream" + it "streams appended events over /ws/events and a snapshot over /ws/metrics" $ + withMigratedTestDatabase $ \connStr -> do + storeVar <- newTVarIO Nothing + km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + let settings = + defaultConnectionSettings connStr + & #eventHandler .~ Just (metricsEventHandler km Nothing) + & #observationHandler .~ Just (metricsObservationHandler km Nothing) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + let serverCfg = defaultConfig {port = 0} + srv <- startMetricsServerWithStore serverCfg km store [] + threadDelay 300_000 + let port = srv.serverPort + stream = StreamName "ws-events-stream" - -- /ws/events: subscribe, then append three events and read them back. - received <- - requireJust "ws/events client timed out" $ - timeout 15_000_000 $ - WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do - sendJSON conn (object ["type" .= ("subscribe_events" :: Text)]) - _ <- waitForType conn "event_stream_started" - appendThread <- async (appendStoreEvents store stream 3) - evs <- replicateM 3 (readEventType conn) - wait appendThread - pure evs - received `shouldBe` ["E1", "E2", "E3"] + -- /ws/events: subscribe, then append three events and read them back. + received <- + requireJust "ws/events client timed out" $ + timeout 15_000_000 $ + WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do + sendJSON conn (object ["type" .= ("subscribe_events" :: Text)]) + _ <- waitForType conn "event_stream_started" + appendThread <- async (appendStoreEvents store stream 3) + evs <- replicateM 3 (readEventType conn) + wait appendThread + pure evs + received `shouldBe` ["E1", "E2", "E3"] - -- The tail uses the public broadcast and unsubscribes on disconnect; - -- the publisher's subscriber count must return to baseline (0). - waitForSubscriberCount store 0 5_000_000 + -- The tail uses the public broadcast and unsubscribes on disconnect; + -- the publisher's subscriber count must return to baseline (0). + waitForSubscriberCount store 0 5_000_000 - -- /ws/metrics: the snapshot reflects the three appended events. - gpos <- - requireJust "ws/metrics client timed out" $ - timeout 15_000_000 $ - WS.runClient "127.0.0.1" port "/ws/metrics" $ \conn -> do - snap <- waitForType conn "snapshot" - pure (globalPositionOf snap) - gpos `shouldSatisfy` (>= 3) + -- /ws/metrics: the snapshot reflects the three appended events. + gpos <- + requireJust "ws/metrics client timed out" $ + timeout 15_000_000 $ + WS.runClient "127.0.0.1" port "/ws/metrics" $ \conn -> do + snap <- waitForType conn "snapshot" + pure (globalPositionOf snap) + gpos `shouldSatisfy` (>= 3) - stopMetricsServer srv + stopMetricsServer srv - it "reports a typed live decode failure and releases the publisher queue" $ - withMigratedTestDatabase $ \connStr -> do - storeVar <- newTVarIO Nothing - km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - let settings = - defaultConnectionSettings connStr - & #storeSettings . #decodeHook .~ Just (\event -> pure (Left (DecodeFailure event.eventId "cannot decrypt"))) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - srv <- startMetricsServerWithStore (defaultConfig{port = 0}) km store [] - result <- requireJust "ws decode failure timed out" $ - timeout 15_000_000 $ - WS.runClient "127.0.0.1" srv.serverPort "/ws/events" $ \conn -> do - sendJSON conn (object ["type" .= ("subscribe_events" :: Text)]) - _ <- waitForType conn "event_stream_started" - appendStoreEvents store (StreamName "ws-decode") 1 - waitForType conn "error" - case result of - Object fields -> KM.lookup "type" fields `shouldBe` Just (String "error") - other -> expectationFailure ("expected error frame, got " <> show other) - waitForSubscriberCount store 0 5_000_000 - waitForPublisherPosition store 1 5_000_000 - stopMetricsServer srv + it "reports a typed live decode failure and releases the publisher queue" $ + withMigratedTestDatabase $ \connStr -> do + storeVar <- newTVarIO Nothing + km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + let settings = + defaultConnectionSettings connStr + & #storeSettings . #decodeHook .~ Just (\event -> pure (Left (DecodeFailure event.eventId "cannot decrypt"))) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + srv <- startMetricsServerWithStore (defaultConfig {port = 0}) km store [] + result <- requireJust "ws decode failure timed out" $ + timeout 15_000_000 $ + WS.runClient "127.0.0.1" srv.serverPort "/ws/events" $ \conn -> do + sendJSON conn (object ["type" .= ("subscribe_events" :: Text)]) + _ <- waitForType conn "event_stream_started" + appendStoreEvents store (StreamName "ws-decode") 1 + waitForType conn "error" + case result of + Object fields -> KM.lookup "type" fields `shouldBe` Just (String "error") + other -> expectationFailure ("expected error frame, got " <> show other) + waitForSubscriberCount store 0 5_000_000 + waitForPublisherPosition store 1 5_000_000 + stopMetricsServer srv - it "replays history from a position then continues live without duplicating the boundary" $ - withMigratedTestDatabase $ \connStr -> do - storeVar <- newTVarIO Nothing - km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - let settings = - defaultConnectionSettings connStr - & #eventHandler .~ Just (metricsEventHandler km Nothing) - & #observationHandler .~ Just (metricsObservationHandler km Nothing) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - let serverCfg = defaultConfig{port = 0} - srv <- startMetricsServerWithStore serverCfg km store [] - threadDelay 300_000 - let port = srv.serverPort + it "replays history from a position then continues live without duplicating the boundary" $ + withMigratedTestDatabase $ \connStr -> do + storeVar <- newTVarIO Nothing + km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + let settings = + defaultConnectionSettings connStr + & #eventHandler .~ Just (metricsEventHandler km Nothing) + & #observationHandler .~ Just (metricsObservationHandler km Nothing) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + let serverCfg = defaultConfig {port = 0} + srv <- startMetricsServerWithStore serverCfg km store [] + threadDelay 300_000 + let port = srv.serverPort - -- Two events exist before the client connects (stream A); they must - -- be replayed. The live event lands on a second stream (B) so the - -- @NoStream@ append helper does not conflict. - appendStoreEvents store (StreamName "ws-replay-a") 2 - received <- - requireJust "ws/events replay client timed out" $ - timeout 15_000_000 $ - WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do - sendJSON - conn - (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) - _ <- waitForType conn "event_stream_started" - -- Two replayed (A's E1,E2), then one appended live - -- (B's E1) — three in global-position order, with no - -- duplicate at the replay/live boundary. - replayed <- replicateM 2 (readEventType conn) - liveThread <- async (appendStoreEvents store (StreamName "ws-replay-b") 1) - live <- readEventType conn - wait liveThread - pure (replayed <> [live]) - received `shouldBe` ["E1", "E2", "E1"] + -- Two events exist before the client connects (stream A); they must + -- be replayed. The live event lands on a second stream (B) so the + -- @NoStream@ append helper does not conflict. + appendStoreEvents store (StreamName "ws-replay-a") 2 + received <- + requireJust "ws/events replay client timed out" $ + timeout 15_000_000 $ + WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do + sendJSON + conn + (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) + _ <- waitForType conn "event_stream_started" + -- Two replayed (A's E1,E2), then one appended live + -- (B's E1) — three in global-position order, with no + -- duplicate at the replay/live boundary. + replayed <- replicateM 2 (readEventType conn) + liveThread <- async (appendStoreEvents store (StreamName "ws-replay-b") 1) + live <- readEventType conn + wait liveThread + pure (replayed <> [live]) + received `shouldBe` ["E1", "E2", "E1"] - stopMetricsServer srv + stopMetricsServer srv - it "delivers each global position exactly once when the replay overlaps live appends" $ - withMigratedTestDatabase $ \connStr -> do - gateVar <- newTVarIO True - storeVar <- newTVarIO Nothing - let publisherGate e = do - mStore <- readTVarIO storeVar - for_ mStore $ \s -> do - tid <- myThreadId - when (tid == asyncThreadId (publisherThread s.publisher)) $ - atomically (readTVar gateVar >>= check) - pure (Right e) - settings = - defaultConnectionSettings connStr - & #storeSettings . #decodeHook .~ Just publisherGate - km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - let serverCfg = defaultConfig{port = 0} - srv <- startMetricsServerWithStore serverCfg km store [] - threadDelay 300_000 - let port = srv.serverPort + it "delivers each global position exactly once when the replay overlaps live appends" $ + withMigratedTestDatabase $ \connStr -> do + gateVar <- newTVarIO True + storeVar <- newTVarIO Nothing + let publisherGate e = do + mStore <- readTVarIO storeVar + for_ mStore $ \s -> do + tid <- myThreadId + when (tid == asyncThreadId (publisherThread s.publisher)) $ + atomically (readTVar gateVar >>= check) + pure (Right e) + settings = + defaultConnectionSettings connStr + & #storeSettings . #decodeHook .~ Just publisherGate + km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + let serverCfg = defaultConfig {port = 0} + srv <- startMetricsServerWithStore serverCfg km store [] + threadDelay 300_000 + let port = srv.serverPort - appendStoreEvents store (StreamName "ws-race-a") 2 - waitForPublisherPosition store 2 5_000_000 + appendStoreEvents store (StreamName "ws-race-a") 2 + waitForPublisherPosition store 2 5_000_000 - (_, _, unsubscribeDummy) <- atomically (subscribePublisher store.publisher 16 DropOldest) - received <- - flip finally unsubscribeDummy $ - do - atomically (writeTVar gateVar False) - appendStoreEvents store (StreamName "ws-race-b") 3 + (_, _, unsubscribeDummy) <- atomically (subscribePublisher store.publisher 16 DropOldest) + received <- + flip finally unsubscribeDummy $ + do + atomically (writeTVar gateVar False) + appendStoreEvents store (StreamName "ws-race-b") 3 - requireJust "ws/events exactly-once client timed out" $ - timeout 15_000_000 $ - WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do - sendJSON - conn - (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) - _ <- waitForType conn "event_stream_started" - replayed <- replicateM 5 (readEventPosition conn) + requireJust "ws/events exactly-once client timed out" $ + timeout 15_000_000 $ + WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do + sendJSON + conn + (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) + _ <- waitForType conn "event_stream_started" + replayed <- replicateM 5 (readEventPosition conn) - atomically (writeTVar gateVar True) - appendStoreEvents store (StreamName "ws-race-c") 1 - live <- readEventPosition conn - quiet <- timeout 500_000 (WS.receiveData conn :: IO LBS.ByteString) - quiet `shouldBe` Nothing - pure (replayed <> [live]) - received `shouldBe` [1, 2, 3, 4, 5, 6] + atomically (writeTVar gateVar True) + appendStoreEvents store (StreamName "ws-race-c") 1 + live <- readEventPosition conn + quiet <- timeout 500_000 (WS.receiveData conn :: IO LBS.ByteString) + quiet `shouldBe` Nothing + pure (replayed <> [live]) + received `shouldBe` [1, 2, 3, 4, 5, 6] - stopMetricsServer srv + stopMetricsServer srv - it "terminates the tail after a replay error instead of streaming with a gap" $ - withMigratedTestDatabase $ \connStr -> do - storeVar <- newTVarIO Nothing - km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) - let settings = - defaultConnectionSettings connStr - & #eventHandler .~ Just (metricsEventHandler km Nothing) - & #observationHandler .~ Just (metricsObservationHandler km Nothing) - withStore settings $ \store -> do - atomically (writeTVar storeVar (Just store)) - let serverCfg = defaultConfig{port = 0} - srv <- startMetricsServerWithStore serverCfg km store [] - threadDelay 300_000 - let port = srv.serverPort + it "terminates the tail after a replay error instead of streaming with a gap" $ + withMigratedTestDatabase $ \connStr -> do + storeVar <- newTVarIO Nothing + km <- newKirokuMetricsWith (readPosition storeVar) (readSubscribers storeVar) + let settings = + defaultConnectionSettings connStr + & #eventHandler .~ Just (metricsEventHandler km Nothing) + & #observationHandler .~ Just (metricsObservationHandler km Nothing) + withStore settings $ \store -> do + atomically (writeTVar storeVar (Just store)) + let serverCfg = defaultConfig {port = 0} + srv <- startMetricsServerWithStore serverCfg km store [] + threadDelay 300_000 + let port = srv.serverPort - appendStoreEvents store (StreamName "ws-err-a") 2 - waitForPublisherPosition store 2 5_000_000 - renamed <- Pool.use store.pool (Session.script "ALTER TABLE events RENAME TO events_hidden") - renamed `shouldBe` Right () + appendStoreEvents store (StreamName "ws-err-a") 2 + waitForPublisherPosition store 2 5_000_000 + renamed <- Pool.use store.pool (Session.script "ALTER TABLE events RENAME TO events_hidden") + renamed `shouldBe` Right () - requireJust "ws/events replay-error client timed out" $ - timeout 15_000_000 $ - WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do - sendJSON - conn - (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) - _ <- waitForType conn "event_stream_started" - err <- waitForType conn "error" - case look ["message"] err of - Just (String msg) -> msg `shouldSatisfy` T.isInfixOf "replay error" - other -> expectationFailure ("error without message: " <> show other) - waitForSubscriberCount store 0 5_000_000 + requireJust "ws/events replay-error client timed out" $ + timeout 15_000_000 $ + WS.runClient "127.0.0.1" port "/ws/events" $ \conn -> do + sendJSON + conn + (object ["type" .= ("subscribe_events" :: Text), "from_position" .= (0 :: Int)]) + _ <- waitForType conn "event_stream_started" + err <- waitForType conn "error" + case look ["message"] err of + Just (String msg) -> msg `shouldSatisfy` T.isInfixOf "replay error" + other -> expectationFailure ("error without message: " <> show other) + waitForSubscriberCount store 0 5_000_000 - stopMetricsServer srv + stopMetricsServer srv -- | Fail the example with a message if the timed action returned 'Nothing'. requireJust :: String -> IO (Maybe a) -> IO a @@ -279,34 +278,34 @@ recvValue :: WS.Connection -> IO Value recvValue conn = do - raw <- WS.receiveData conn :: IO LBS.ByteString - case decode raw of - Just v -> pure v - Nothing -> expectationFailure ("undecodable frame: " <> show raw) >> error "undecodable" + raw <- WS.receiveData conn :: IO LBS.ByteString + case decode raw of + Just v -> pure v + Nothing -> expectationFailure ("undecodable frame: " <> show raw) >> error "undecodable" -- | Read server messages until one with the given @"type"@ arrives; return it. waitForType :: WS.Connection -> Text -> IO Value waitForType conn want = go where go = do - v <- recvValue conn - if look ["type"] v == Just (String want) then pure v else go + v <- recvValue conn + if look ["type"] v == Just (String want) then pure v else go -- | Read until an @event@ message, returning its @event.eventType@. readEventType :: WS.Connection -> IO Text readEventType conn = do - v <- waitForType conn "event" - case look ["event", "eventType"] v of - Just (String t) -> pure t - other -> expectationFailure ("event without eventType: " <> show other) >> error "no eventType" + v <- waitForType conn "event" + case look ["event", "eventType"] v of + Just (String t) -> pure t + other -> expectationFailure ("event without eventType: " <> show other) >> error "no eventType" -- | Read until an @event@ message, returning its @event.globalPosition@. readEventPosition :: WS.Connection -> IO Int readEventPosition conn = do - v <- waitForType conn "event" - case look ["event", "globalPosition"] v of - Just (Number n) -> pure (truncate (toRealFloat n :: Double)) - other -> expectationFailure ("event without globalPosition: " <> show other) >> error "no position" + v <- waitForType conn "event" + case look ["event", "globalPosition"] v of + Just (Number n) -> pure (truncate (toRealFloat n :: Double)) + other -> expectationFailure ("event without globalPosition: " <> show other) >> error "no position" -- | Navigate nested object keys. look :: [Text] -> Value -> Maybe Value @@ -317,67 +316,67 @@ -- | Extract @metrics.store.global_position@ from a @snapshot@ message. globalPositionOf :: Value -> Int globalPositionOf v = - case look ["metrics", "store", "global_position"] v of - Just (Number n) -> truncate (toRealFloat n :: Double) - _ -> -1 + case look ["metrics", "store", "global_position"] v of + Just (Number n) -> truncate (toRealFloat n :: Double) + _ -> -1 readPosition :: TVar (Maybe KirokuStore) -> STM GlobalPosition readPosition storeVar = - readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) + readTVar storeVar >>= maybe (pure (GlobalPosition 0)) (publisherPosition . (.publisher)) readSubscribers :: TVar (Maybe KirokuStore) -> STM Int readSubscribers storeVar = - readTVar storeVar - >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) + readTVar storeVar + >>= maybe (pure 0) (\s -> IntMap.size <$> readTVar (subscribers s.publisher)) -- | Block until the publisher's subscriber count reaches @target@ or time out. waitForSubscriberCount :: KirokuStore -> Int -> Int -> IO () waitForSubscriberCount store target timeoutMicros = do - timeoutVar <- registerDelay timeoutMicros - ok <- - atomically $ - ( do - c <- IntMap.size <$> readTVar (subscribers store.publisher) - check (c == target) - pure True - ) - `orElse` (readTVar timeoutVar >>= \t -> check t >> pure False) - unless ok $ do - actual <- atomically (IntMap.size <$> readTVar (subscribers store.publisher)) - expectationFailure - ("subscriber count did not reach " <> show target <> "; still " <> show actual) + timeoutVar <- registerDelay timeoutMicros + ok <- + atomically $ + ( do + c <- IntMap.size <$> readTVar (subscribers store.publisher) + check (c == target) + pure True + ) + `orElse` (readTVar timeoutVar >>= \t -> check t >> pure False) + unless ok $ do + actual <- atomically (IntMap.size <$> readTVar (subscribers store.publisher)) + expectationFailure + ("subscriber count did not reach " <> show target <> "; still " <> show actual) -- | Block until the publisher cursor reaches @target@ or time out. waitForPublisherPosition :: KirokuStore -> Int -> Int -> IO () waitForPublisherPosition store target timeoutMicros = do - timeoutVar <- registerDelay timeoutMicros - ok <- - atomically $ - ( do - GlobalPosition p <- publisherPosition store.publisher - check (p >= fromIntegral target) - pure True - ) - `orElse` (readTVar timeoutVar >>= \t -> check t >> pure False) - unless ok $ do - GlobalPosition actual <- atomically (publisherPosition store.publisher) - expectationFailure - ("publisher position did not reach " <> show target <> "; still " <> show actual) + timeoutVar <- registerDelay timeoutMicros + ok <- + atomically $ + ( do + GlobalPosition p <- publisherPosition store.publisher + check (p >= fromIntegral target) + pure True + ) + `orElse` (readTVar timeoutVar >>= \t -> check t >> pure False) + unless ok $ do + GlobalPosition actual <- atomically (publisherPosition store.publisher) + expectationFailure + ("publisher position did not reach " <> show target <> "; still " <> show actual) appendStoreEvents :: KirokuStore -> StreamName -> Int -> IO () appendStoreEvents store stream n = do - let events = - [ EventData - { eventId = Nothing - , eventType = EventType ("E" <> T.pack (show i)) - , payload = Null - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } - | i <- [1 .. n] - ] - result <- runStoreIO store (appendToStream stream NoStream events) - case result of - Right _ -> pure () - Left err -> expectationFailure ("appendStoreEvents failed: " <> show err) + let events = + [ EventData + { eventId = Nothing, + eventType = EventType ("E" <> T.pack (show i)), + payload = Null, + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } + | i <- [1 .. n] + ] + result <- runStoreIO store (appendToStream stream NoStream events) + case result of + Right _ -> pure () + Left err -> expectationFailure ("appendStoreEvents failed: " <> show err)