kiroku-metrics 0.3.0.1 → 0.4.0.0

raw patch · 35 files changed

+4322/−4045 lines, 35 filesdep ~kiroku-clidep ~kiroku-storePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: kiroku-cli, kiroku-store

API changes (from Hackage documentation)

Files

• CHANGELOG.md +40/−1
• app-inspect/InspectSignals.hs +20/−0
• app-inspect/Main.hs +19/−21
• bench/WebSocketTail.hs +66/−65
• example/Main.hs +159/−160
• kiroku-metrics.cabal +18/−16
• src/Kiroku/Metrics.hs +8/−8
• src/Kiroku/Metrics/Browse.hs +155/−139
• src/Kiroku/Metrics/Capabilities.hs +86/−85
• src/Kiroku/Metrics/Checkpoints.hs +34/−35
• src/Kiroku/Metrics/Collector.hs +237/−239
• src/Kiroku/Metrics/Config.hs +46/−47
• src/Kiroku/Metrics/Cors.hs +151/−147
• src/Kiroku/Metrics/DeadLetters.hs +68/−55
• src/Kiroku/Metrics/Health.hs +88/−91
• src/Kiroku/Metrics/JSON.hs +34/−36
• src/Kiroku/Metrics/Prometheus.hs +85/−85
• src/Kiroku/Metrics/Server.hs +110/−115
• src/Kiroku/Metrics/Standalone.hs +175/−117
• src/Kiroku/Metrics/Subscriptions.hs +38/−41
• src/Kiroku/Metrics/Types.hs +137/−138
• src/Kiroku/Metrics/WebSocket.hs +353/−368
• test/Main.hs +34/−13
• test/Test/BrowseSpec.hs +136/−129
• test/Test/CapabilitiesSpec.hs +117/−117
• test/Test/CheckpointsSpec.hs +284/−284
• test/Test/CollectorSpec.hs +218/−201
• test/Test/CorsSpec.hs +218/−183
• test/Test/DeadLettersSpec.hs +136/−129
• test/Test/IntegrationSpec.hs +81/−83
• test/Test/ServerSpec.hs +104/−105
• test/Test/StandaloneSpec.hs +253/−176
• test/Test/SubscriptionsSpec.hs +111/−112
• test/Test/WebSocketConvergenceSpec.hs +248/−248
• test/Test/WebSocketSpec.hs +255/−256

@@ -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 <public-page-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 

@@ -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

@@ -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

@@ -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)

@@ -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))

@@ -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

@@ -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

@@ -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) "<invalid UTF-8>" "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) "<invalid UTF-8>" "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)

@@ -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

@@ -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

@@ -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+    }

@@ -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+    }

@@ -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)

@@ -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 "<invalid UTF-8>" "Expected valid UTF-8.")-            Right raw -> maybe (Left (invalid key raw reason)) (Right . Just) (parser raw)-        [Nothing] -> Left (invalid key "" reason)-        _ -> Left (invalid key "<duplicate>" "Parameter must occur at most once.")+      [] -> Right Nothing+      [Just bytes] -> case TE.decodeUtf8' bytes of+        Left _ -> Left (invalid key "<invalid UTF-8>" "Expected valid UTF-8.")+        Right raw -> maybe (Left (invalid key raw reason)) (Right . Just) (parser raw)+      [Nothing] -> Left (invalid key "" reason)+      _ -> Left (invalid key "<duplicate>" "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

@@ -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)))

@@ -1,13 +1,13 @@-{- | JSON HTTP endpoints: @GET /metrics@ (the full snapshot) and-@GET /metrics/\<name\>@ (one subscription's metrics, or 404).--}-module Kiroku.Metrics.JSON (-    jsonApp,+-- | JSON HTTP endpoints: @GET /metrics@ (the full snapshot) and+-- @GET /metrics/\<name\>@ (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/\<name\>@; any other path returns a 404 JSON body.--}+-- | WAI application for the JSON metrics endpoints. Routes @/metrics@ and+-- @/metrics/\<name\>@; 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

@@ -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

@@ -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/<name>/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/<name>/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

@@ -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"

@@ -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/\<name\>@ — 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/\<name\>@ — 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)])))

@@ -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+      ]

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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)+      ]

@@ -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

@@ -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 ()

@@ -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

@@ -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)