servant-health (empty) → 0.1.0.0

raw patch · 8 files changed

+1475/−0 lines, 8 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, http-client, http-types, openapi-hs, servant, servant-health, servant-openapi-hs, servant-server, sop-core, tasty, tasty-hunit, text, time, wai, warp

Files

• CHANGELOG.md +45/−0
• README.md +233/−0
• servant-health.cabal +107/−0
• src/Servant/Health.hs +133/−0
• src/Servant/Health/Check.hs +142/−0
• src/Servant/Health/Paths.hs +28/−0
• test/Main.hs +506/−0
• testkit/Servant/Health/TestKit.hs +281/−0

@@ -0,0 +1,45 @@+# Changelog for servant-health++This project follows the [Haskell PVP](https://pvp.haskell.org/).++## 0.1.0.0 — 2026-07-24++First release.++### New Features++- **Probe routes and wire contract.** `Servant.Health` exports `HealthApi`, a+  `NamedRoutes` record mounted under `"health"` that answers `GET /health/live`+  and `GET /health/ready`. Responses are typed via `MultiVerb`+  (`ProbeResponses`), and the passed/failed → 200/503 mapping lives in the one+  `AsUnion ProbeResponses ProbeResult` instance. The `ProbeStatus` body is a+  fixed key set — `status`, `check`, `failingSince` — with `failingSince` null+  while healthy.+- **Injectable check seam.** `type ProbeCheck = IO ProbeVerdict` plus+  `healthServer` and `runProbe`. The package ships no checks of its own; checks+  are run afresh on every request and nothing caches a verdict.+- **Check combinators.** `Servant.Health.Check` provides `boolCheck`,+  `sequenceChecks` (short-circuiting, empty list is healthy), `safeCheck`+  (synchronous exceptions become failed probes, asynchronous ones are re-thrown),+  `withProbeTimeout`, and `newFailureTracker` for reporting the original onset of+  a failing run rather than the latest observation.+- **Path constants.** `Servant.Health.Paths` exports `healthMountSegment`,+  `liveRawPath`, `readyRawPath`, and `healthRawPaths` for request-logger+  exclusions and conformance-test exemption lists.+- **OpenAPI schema.** A non-orphan `ToSchema ProbeStatus` instance derived from+  the same `probeJsonOptions` value as the JSON codec, so the published schema+  and the bytes on the wire cannot disagree.+- **`testkit` public sublibrary.** `servant-health:testkit` exports+  `probeContractTests`, which drives a real Warp server built from the+  consumer's own application builder and asserts the full probe matrix —+  including the cross-assertions that catch an umbrella record wiring the two+  probe routes to each other's checks. Depend on it from test stanzas only.++### Other Changes++- Supports a single OpenAPI cohort: `openapi-hs >=5.0 && <5.1`, with+  `servant-openapi-hs >=5.1 && <5.2` used test-only. See+  [ADR 7](https://github.com/shinzui/servant-health/blob/master/docs/adr/7-single-cohort-openapi-support.md); the 4.1 cohort was+  dropped before this first release.+- Added `README.md`, plus `homepage`, `bug-reports`, and a `source-repository+  head` stanza to the cabal file.

@@ -0,0 +1,233 @@+# servant-health++Kubernetes liveness and readiness probe endpoints for [servant][].++Every service that runs under Kubernetes writes the same eighty lines: two+routes, a JSON status body, a 503 mapping, and the wiring that keeps them+apart. This package provides that surface once — a fixed probe wire type, typed+200/503 responses via `MultiVerb`, an injectable check seam, path constants, and+a conformance kit — and deliberately ships **no checks of its own**. What+"healthy" means for your service is yours to decide.++```+GET /health/live   →  200 {"status":"ok","check":"all","failingSince":null}+GET /health/ready  →  503 {"status":"failed","check":"database","failingSince":"2026-07-24T12:03:41Z"}+```++## Installation++```cabal+build-depends:+  , servant-health  ^>=0.1+```++Requires GHC 9.12 (`base >=4.21`, `GHC2024`) and servant 0.20.++`servant-health` depends on [`openapi-hs`][openapi-hs] (`>=5.0 && <5.1`), a fork+of `openapi3`, because the `ToSchema` instance for the probe body is non-orphan.+Upstream `servant-openapi3` has no `HasOpenApi` instance for `MultiVerb` at all,+so a service deriving an OpenAPI document for these routes needs+[`servant-openapi-hs`][servant-openapi-hs] (`>=5.1 && <5.2`) rather than the+upstream package. Both forks are on Hackage. See+[ADR 7](https://github.com/shinzui/servant-health/blob/master/docs/adr/7-single-cohort-openapi-support.md) for why only this cohort is+supported.++## Quick start++Mount `HealthApi` under `"health"` on your umbrella route record and hand+`healthServer` a liveness check and a readiness check, in that order:++```haskell+{-# LANGUAGE DataKinds #-}++import GHC.Generics (Generic)+import Network.Wai (Application)+import Servant.API (NamedRoutes, (:>))+import Servant.API.Generic ((:-))+import Servant.Health (HealthApi, ProbeCheck, healthServer)+import Servant.Server.Generic (genericServe)++data MyServiceApi mode = MyServiceApi+  { health :: mode :- "health" :> NamedRoutes HealthApi+  , orders :: mode :- "orders" :> NamedRoutes OrdersApi+  }+  deriving stock (Generic)++mkApp :: ProbeCheck -> ProbeCheck -> IO Application+mkApp livenessCheck readinessCheck =+  pure $+    genericServe+      MyServiceApi+        { health = healthServer livenessCheck readinessCheck+        , orders = ordersServer+        }+```++Both checks are run afresh on every request; nothing here caches a verdict.++## The wire contract++Both probes answer with the same body shape — exactly `status`, `check`, and+`failingSince`, with `failingSince` null while healthy — so dashboards and+runbooks can read either route the same way:++```haskell+data ProbeStatus = ProbeStatus+  { status :: !Text          -- "ok" | "failed"+  , check :: !Text           -- "all" when passing, else the failed check's name+  , failingSince :: !(Maybe UTCTime)+  }+```++A passing check answers **200**, a failing one answers **503** with the same+shape. That mapping lives in exactly one place — the `AsUnion ProbeResponses+ProbeResult` instance — because both alternatives carry the same body type.++The body is not extensible per service. Diagnostics belong in logs and metrics;+see [ADR 2](https://github.com/shinzui/servant-health/blob/master/docs/adr/2-probe-wire-contract-and-status-mapping.md).++## Writing checks++A check is just `type ProbeCheck = IO ProbeVerdict`, where a verdict is+`Healthy` or `Unhealthy` carrying the failed check's name and when the failure+began. `Servant.Health.Check` supplies the generic glue every service otherwise+reinvents:++| Combinator | What it does |+| --- | --- |+| `boolCheck name test` | Name a boolean test; `False` becomes `Unhealthy name`. |+| `sequenceChecks checks` | Run left to right, report the first failure, skip the rest. An empty list is `Healthy`. |+| `safeCheck name action` | Turn a thrown synchronous exception into a failed probe instead of a 500. Async exceptions are re-thrown. |+| `withProbeTimeout micros name action` | Bound a check; on expiry it reports `Unhealthy`. |+| `newFailureTracker` | Build a wrapper that makes `failingSince` report the *original* onset of a failing run, not the current observation. |++Assembling them for production, with the service's own `databaseCheck` and+friends:++```haskell+import Servant.Health.Check (safeCheck, sequenceChecks, withProbeTimeout)++runService :: ConnectionPool -> IO ()+runService pool = do+  application <-+    mkApp+      (withProbeTimeout 2_000_000 "liveness" (safeCheck "liveness" (eventLoopCheck pool)))+      (safeCheck "readiness" (sequenceChecks [databaseCheck pool, cacheCheck]))+  Warp.run 8080 application+```++Two things worth getting right:++- **Wrap every check in `safeCheck`.** An exception escaping a check becomes a+  500, which pages an operator with a stack trace instead of telling them which+  dependency is down.+- **Put `withProbeTimeout` *outside* `safeCheck`.** The timeout interrupts by+  throwing an asynchronous exception, and `safeCheck` deliberately lets those+  through. Nested the other way round, a deadlocked process would hang its+  liveness probe instead of failing it — the opposite of what liveness is for.+  `timeout` also cannot interrupt a foreign call unless the program is built+  with `-threaded`.++To report the onset of a failure rather than the moment it was last observed,+give liveness and readiness their own trackers:++```haskell+trackLiveness <- newFailureTracker+trackReadiness <- newFailureTracker+pure (healthServer (trackLiveness livenessCheck) (trackReadiness readinessCheck))+```++## Path constants++`Servant.Health.Paths` exports `healthMountSegment`, `liveRawPath`,+`readyRawPath`, and `healthRawPaths` — for request-logger exclusion predicates+and conformance-test exemption lists, instead of restating string literals.++## Proving your wiring: the `testkit` sublibrary++Mounting `HealthApi` leaves one thing unproven: that *your* assembled+application really answers both paths, and that the two routes were not wired to+each other's checks. Both probe routes have the same handler type, so an+umbrella record that swaps them compiles cleanly — only a request that+distinguishes them catches it.++`servant-health:testkit` is a public sublibrary shipped inside this package.+Depend on it from your test stanza only, so production builds never acquire its+`tasty` and `warp` dependencies:++```cabal+test-suite myservice-test+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , base+    , servant-health+    , servant-health:testkit+    , tasty+```++The kit supplies the checks it wants mounted, so it takes your app *builder*+rather than a finished application:++```haskell+main :: IO ()+main = defaultMain (probeContractTests "myservice probes" mkApp)+```++It drives a real Warp server on an ephemeral port and asserts the whole matrix:+both checks healthy → both probes 200; readiness failing → `/health/ready` 503+while `/health/live` stays 200; liveness failing → the mirror image. Those two+"still answers 200" assertions are the dispatch proof. The `-threaded` flag is+checked as its own test case, because without it Warp's timer manager fails with+an error that says nothing about the missing flag.++## What this package does not do++`servant-health` provides the probe *surface* and nothing that decides what a+probe means. Deliberately out of scope+([ADR 3](https://github.com/shinzui/servant-health/blob/master/docs/adr/3-scope-boundaries-and-deliberate-exclusions.md)):++- **Checks themselves** — no database ping, no lag check. The `ProbeCheck` seam+  is how you supply your own.+- **Readiness policy** — whether a degraded cache should remove a pod from load+  balancing is a per-service judgment.+- **Kubernetes manifests and probe tuning** — periods, thresholds, and the+  Kubernetes-side timeouts are deployment configuration.+- **A bare `/health` route** — a single combined route cannot express the+  distinction Kubernetes acts on: liveness failure restarts the container,+  readiness failure only removes it from load balancing. A test pins `GET+  /health` at 404.+- **RFC 9457 problem details** — a probe body is a status report, not an error+  document.++The library's dependency budget is `base`, `aeson`, `bytestring`, `openapi-hs`,+`servant`, `servant-server`, `sop-core`, `text`, and `time`. A proposal to add+one should be read as a proposal to cross one of these boundaries.++## Development++```sh+nix develop        # dev shell (GHC 9.12, cabal, HLS, fourmolu)+cabal build all    # library, testkit sublibrary, and test suite+just test          # cabal test — the single entry point CI runs+just show-versions # which openapi cohort the build actually resolved to+just build-nix     # nix build: packages.default, with the pinned openapi overlay+nix fmt            # treefmt: nixpkgs-fmt + fourmolu + cabal-fmt+nix flake check    # treefmt + pre-commit gates+```++`nix build` evaluates the git tree, so new files must be `git add`-ed before it+can see them.++Design decisions are recorded in [`docs/adr/`](https://github.com/shinzui/servant-health/blob/master/docs/adr/), and the plans that+produced them in [`docs/plans/`](https://github.com/shinzui/servant-health/blob/master/docs/plans/).++## License++BSD-3-Clause.++[servant]: https://hackage.haskell.org/package/servant+[openapi-hs]: https://hackage.haskell.org/package/openapi-hs+[servant-openapi-hs]: https://hackage.haskell.org/package/servant-openapi-hs

@@ -0,0 +1,107 @@+cabal-version:   3.4+name:            servant-health+version:         0.1.0.0+synopsis:+  Kubernetes liveness and readiness probe endpoints for servant++description:+  Standard Kubernetes probe endpoints as a reusable servant surface: a fixed+  probe wire type, typed 200/503 responses via MultiVerb, an injectable check+  seam, and path constants. See the README for the fleet standard it encodes.++license:         BSD-3-Clause+author:          Nadeem Bitar+maintainer:      nadeem@gmail.com+homepage:        https://github.com/shinzui/servant-health+bug-reports:     https://github.com/shinzui/servant-health/issues+category:        Web, Servant+build-type:      Simple+tested-with:     GHC ==9.12.4+extra-doc-files:+  CHANGELOG.md+  README.md++source-repository head+  type:     git+  location: https://github.com/shinzui/servant-health.git++common common+  default-language:   GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    OverloadedLabels+    OverloadedStrings++  ghc-options:        -Wall -Werror=missing-fields -Werror=missing-methods++library+  import:          common+  hs-source-dirs:  src+  exposed-modules:+    Servant.Health+    Servant.Health.Check+    Servant.Health.Paths++  build-depends:+    , aeson           >=2.2   && <2.4+    , base            >=4.21  && <5+    , bytestring      >=0.12  && <0.13+    , openapi-hs      >=5.0   && <5.1+    , servant         ^>=0.20+    , servant-server  ^>=0.20+    , sop-core        >=0.5   && <0.6+    , text            >=2.1   && <2.2+    , time            >=1.12  && <1.15++-- The conformance kit consumers use to prove their own probe wiring. A public+-- sublibrary rather than a separate package: one Hackage unit for a tiny+-- surface, and consumers reference it only from test stanzas so production+-- builds never acquire its tasty/warp dependencies.+library testkit+  import:          common+  visibility:      public+  hs-source-dirs:  testkit+  exposed-modules: Servant.Health.TestKit+  build-depends:+    , aeson           >=2.2  && <2.4+    , base            >=4.21 && <5+    , bytestring      >=0.12 && <0.13+    , http-client     >=0.7  && <0.8+    , http-types      >=0.12 && <0.13+    , servant-health+    , tasty           >=1.4  && <1.6+    , tasty-hunit     >=0.10 && <0.11+    , text            >=2.1  && <2.2+    , time            >=1.12 && <1.15+    , wai             >=3.2  && <3.3+    , warp            >=3.3  && <3.5++test-suite servant-health-test+  import:         common+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs++  -- The round-trip tests run a real Warp server; Warp's timer manager+  -- requires the threaded runtime.+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , aeson+    , base+    , bytestring+    , http-client+    , http-types+    , openapi-hs+    , servant+    , servant-health+    , servant-health:testkit+    , servant-openapi-hs      >=5.1   && <5.2+    , servant-server          ^>=0.20+    , sop-core+    , tasty+    , tasty-hunit+    , text+    , time+    , wai+    , warp

@@ -0,0 +1,133 @@+-- | Kubernetes liveness and readiness probe endpoints for servant.+--+-- A service mounts 'HealthApi' under @"health"@ on its umbrella route record+-- and supplies two 'ProbeCheck' actions. It then answers @GET \/health\/live@+-- and @GET \/health\/ready@ with HTTP 200 and a 'ProbeStatus' body when the+-- check passes, and HTTP 503 with the same body shape when it fails.+module Servant.Health+  ( -- * Wire contract+    ProbeStatus (..),+    probeJsonOptions,++    -- * Check seam+    ProbeVerdict (..),+    ProbeCheck,++    -- * Routes+    ProbeResponses,+    ProbeResult (..),+    HealthApi (..),++    -- * Server+    healthServer,+    runProbe,+  )+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (FromJSON (..), Options, ToJSON (..), defaultOptions, genericParseJSON, genericToJSON)+import Data.OpenApi (ToSchema (..), fromAesonOptions, genericDeclareNamedSchema)+import Data.SOP (I (..), NS (S, Z))+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics (Generic)+import Servant.API (JSON, StdMethod (GET), (:>))+import Servant.API.Generic ((:-))+import Servant.API.MultiVerb (AsUnion (..), MultiVerb, Respond)+import Servant.Server.Generic (AsServerT)++-- | The probe report every fleet service answers with. The key set is a wire+-- contract consumed by dashboards and runbooks: exactly @status@, @check@,+-- @failingSince@, with @failingSince@ null while healthy.+data ProbeStatus = ProbeStatus+  { status :: !Text,+    check :: !Text,+    failingSince :: !(Maybe UTCTime)+  }+  deriving stock (Generic, Eq, Show)++-- | The one Options value driving the codec (and, in a later plan, the+-- schema). Field names are used verbatim.+probeJsonOptions :: Options+probeJsonOptions = defaultOptions++instance ToJSON ProbeStatus where+  toJSON = genericToJSON probeJsonOptions++instance FromJSON ProbeStatus where+  parseJSON = genericParseJSON probeJsonOptions++-- | Derived from the same 'Options' value as the codec above, so the published+-- schema and the bytes on the wire cannot disagree. Non-orphan on purpose: an+-- instance next to its type can never be forgotten or duplicated by a+-- consumer generating a document.+instance ToSchema ProbeStatus where+  declareNamedSchema = genericDeclareNamedSchema (fromAesonOptions probeJsonOptions)++-- | What a check reports. @since@ is when the failure began, which feeds the+-- wire type's @failingSince@.+data ProbeVerdict+  = Healthy+  | Unhealthy {failedCheck :: !Text, since :: !UTCTime}+  deriving stock (Generic, Eq, Show)++-- | The injectable seam: services supply these, this library never runs+-- anything it invented itself.+type ProbeCheck = IO ProbeVerdict++-- | The two alternatives a probe route can answer with.+type ProbeResponses =+  '[ Respond 200 "Probe passed" ProbeStatus,+     Respond 503 "Probe failed" ProbeStatus+   ]++-- | The handler-side sum matching 'ProbeResponses'.+data ProbeResult+  = ProbePassed !ProbeStatus+  | ProbeFailed !ProbeStatus+  deriving stock (Generic, Eq, Show)++-- | Hand-written on purpose. Both alternatives carry the same body type, so+-- this instance is the only place that decides passed=200, failed=503.+instance AsUnion ProbeResponses ProbeResult where+  toUnion = \case+    ProbePassed body -> Z (I body)+    ProbeFailed body -> S (Z (I body))+  fromUnion = \case+    Z (I body) -> ProbePassed body+    S (Z (I body)) -> ProbeFailed body+    S (S impossible) -> case impossible of {}++-- | Mount under @"health"@ on the service's umbrella NamedRoutes record.+data HealthApi mode = HealthApi+  { live :: mode :- "live" :> MultiVerb 'GET '[JSON] ProbeResponses ProbeResult,+    ready :: mode :- "ready" :> MultiVerb 'GET '[JSON] ProbeResponses ProbeResult+  }+  deriving stock (Generic)++-- | Build the probe server from a liveness check and a readiness check, in+-- that order.+--+-- Both checks are run afresh on every request; nothing here caches a verdict.+--+-- Wrap every check you mount in @Servant.Health.Check.safeCheck@. An exception+-- escaping a check becomes a 500 rather than a probe report, which pages an+-- operator with a stack trace instead of telling them which dependency is+-- down. The same module has combinators for sequencing several readiness+-- checks, bounding a liveness check with a timeout, and reporting when a+-- failure began.+healthServer :: (MonadIO m) => ProbeCheck -> ProbeCheck -> HealthApi (AsServerT m)+healthServer liveCheck readyCheck =+  HealthApi+    { live = runProbe liveCheck,+      ready = runProbe readyCheck+    }++-- | Run one check and turn its verdict into the response sum.+runProbe :: (MonadIO m) => ProbeCheck -> m ProbeResult+runProbe checkAction =+  liftIO checkAction >>= \case+    Healthy ->+      pure (ProbePassed (ProbeStatus "ok" "all" Nothing))+    Unhealthy failed began ->+      pure (ProbeFailed (ProbeStatus "failed" failed (Just began)))

@@ -0,0 +1,142 @@+-- | Combinators for building the 'ProbeCheck' actions a service hands to+-- 'Servant.Health.healthServer'.+--+-- This module contains only the generic glue every service otherwise+-- reinvents: running several checks in order, bounding a check with a timeout,+-- turning a thrown exception into a failed probe rather than a 500, and+-- remembering when a failure began. The checks themselves — pinging a+-- database, measuring subscription lag — belong to the service.+module Servant.Health.Check+  ( -- * Building checks+    boolCheck,++    -- * Composing checks+    sequenceChecks,++    -- * Hardening checks+    safeCheck,+    withProbeTimeout,++    -- * Reporting failure onset+    newFailureTracker,+  )+where++import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try)+import Data.IORef (atomicModifyIORef', atomicWriteIORef, newIORef)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Time (getCurrentTime)+import Servant.Health (ProbeCheck, ProbeVerdict (Healthy, Unhealthy))+import System.Timeout (timeout)++-- | Report a failure of the named check, observed now.+unhealthyNow :: Text -> IO ProbeVerdict+unhealthyNow name = Unhealthy name <$> getCurrentTime++-- | Name a boolean test. 'True' is 'Healthy'; 'False' is 'Unhealthy' under the+-- given name, with the failure onset recorded as the moment of observation.+--+-- To report the /original/ onset across repeated probe calls rather than the+-- most recent observation, wrap the result with a tracker from+-- 'newFailureTracker'.+boolCheck :: Text -> IO Bool -> ProbeCheck+boolCheck name test = do+  passed <- test+  if passed+    then pure Healthy+    else unhealthyNow name++-- | Run checks left to right and report the first failure, skipping the rest.+--+-- An empty list is 'Healthy', which makes this a sensible default for a+-- service that has no readiness dependencies yet. Short-circuiting is part of+-- the contract: a readiness check that has already failed should not spend a+-- database round trip confirming the next dependency is also unhappy.+sequenceChecks :: [ProbeCheck] -> ProbeCheck+sequenceChecks = go+  where+    go [] = pure Healthy+    go (action : rest) =+      action >>= \case+        Healthy -> go rest+        failure -> pure failure++-- | Convert a thrown synchronous exception into a failed probe under the given+-- name. Every check a service mounts should be wrapped in this: an exception+-- escaping a probe handler becomes a 500, which Kubernetes reads as a probe+-- failure anyway but which pages an operator with a stack trace instead of a+-- status report.+--+-- Asynchronous exceptions are re-thrown rather than swallowed, so a probe never+-- delays process shutdown. This is also what lets 'withProbeTimeout' work from+-- the outside: 'System.Timeout.timeout' interrupts by throwing an asynchronous+-- exception, and a 'safeCheck' nested inside it must let that through.+--+-- The distinction is the standard one drawn by 'SomeAsyncException': an+-- exception type whose 'Control.Exception.toException' goes through+-- 'Control.Exception.asyncExceptionToException' is asynchronous. A synchronous+-- exception type delivered by 'Control.Concurrent.throwTo' is indistinguishable+-- from an ordinary failure and will be reported as one.+safeCheck :: Text -> ProbeCheck -> ProbeCheck+safeCheck name action = do+  outcome <- try action+  case outcome of+    Right verdict -> pure verdict+    Left err+      | isAsync err -> throwIO err+      | otherwise -> unhealthyNow name+  where+    isAsync :: SomeException -> Bool+    isAsync err = case fromException err of+      Just (_ :: SomeAsyncException) -> True+      Nothing -> False++-- | Bound a check with a timeout, in microseconds. On expiry the check reports+-- 'Unhealthy' under the given name.+--+-- This is what the fleet standard asks for on liveness: a deadlocked process+-- should /fail/ its liveness probe so Kubernetes restarts it, rather than hang+-- the probe and leave the pod wedged until the kubelet's own timeout fires.+--+-- The microsecond unit matches kiroku's @livenessTimeoutUs@ convention.+--+-- Note that 'System.Timeout.timeout' cannot interrupt a foreign call unless the+-- program is built with the threaded runtime. Fleet executables already are —+-- the OpenTelemetry standard requires it — but a test suite that exercises this+-- combinator needs @-threaded@ in its @ghc-options@.+withProbeTimeout :: Int -> Text -> ProbeCheck -> ProbeCheck+withProbeTimeout micros name action =+  timeout micros action >>= \case+    Just verdict -> pure verdict+    Nothing -> unhealthyNow name++-- | Build a wrapper that makes the wire type's @failingSince@ field mean what+-- it says.+--+-- A bare check reports the onset it observed on /this/ call, so a probe that+-- has been failing for an hour reports a fresh onset every time Kubernetes+-- asks. The wrapper returned here remembers the first failure of a consecutive+-- run and rewrites later failures to carry that original onset, so a dashboard+-- reads @failingSince: 12:03:41Z@ rather than @failingSince: now@. A 'Healthy'+-- result clears the memory, so the next failure starts a new run.+--+-- Each call to 'newFailureTracker' creates one independent memory, so liveness+-- and readiness need their own:+--+-- > trackLiveness <- newFailureTracker+-- > trackReadiness <- newFailureTracker+-- > pure (healthServer (trackLiveness livenessCheck) (trackReadiness readinessCheck))+newFailureTracker :: IO (ProbeCheck -> ProbeCheck)+newFailureTracker = do+  onsetRef <- newIORef Nothing+  pure $ \action ->+    action >>= \case+      Healthy -> do+        atomicWriteIORef onsetRef Nothing+        pure Healthy+      Unhealthy failed observed -> do+        onset <- atomicModifyIORef' onsetRef $ \stored ->+          let effective = fromMaybe observed stored+           in (Just effective, effective)+        pure (Unhealthy failed onset)

@@ -0,0 +1,28 @@+-- | Raw paths of the probe routes, assuming the standard "health" mount.+-- Use these in request-logger exclusion predicates and conformance-test+-- exemption lists instead of restating string literals.+module Servant.Health.Paths+  ( healthMountSegment,+    liveRawPath,+    readyRawPath,+    healthRawPaths,+  )+where++import Data.ByteString (ByteString)++-- | The path segment the 'Servant.Health.HealthApi' record is mounted under.+healthMountSegment :: ByteString+healthMountSegment = "health"++-- | Raw path of the liveness probe.+liveRawPath :: ByteString+liveRawPath = "/health/live"++-- | Raw path of the readiness probe.+readyRawPath :: ByteString+readyRawPath = "/health/ready"++-- | Both probe paths, for exclusion predicates that treat them alike.+healthRawPaths :: [ByteString]+healthRawPaths = [liveRawPath, readyRawPath]

@@ -0,0 +1,506 @@+module Main (main) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (AsyncException (ThreadKilled), SomeException, fromException, throwIO, try)+import Data.Aeson (Value (Null, Object), decode, toJSON)+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as Char8+import Data.ByteString.Lazy qualified as LazyByteString+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.List qualified as List+import Data.OpenApi (validateToJSON)+import Data.Proxy (Proxy (Proxy))+import Data.SOP (I (..), NS (S, Z))+import Data.Text (Text)+import Data.Time (UTCTime (..), addUTCTime, fromGregorian, secondsToDiffTime)+import GHC.Generics (Generic)+import Network.HTTP.Client+  ( Manager,+    Response,+    checkResponse,+    defaultManagerSettings,+    httpLbs,+    newManager,+    parseRequest,+    responseBody,+    responseHeaders,+    responseStatus,+  )+import Network.HTTP.Types.Header (hContentType)+import Network.HTTP.Types.Status (statusCode)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (Port, testWithApplication)+import Servant.API (NamedRoutes, (:>))+import Servant.API.Generic ((:-))+import Servant.API.MultiVerb (AsUnion (..))+import Servant.Health+  ( HealthApi,+    ProbeCheck,+    ProbeResponses,+    ProbeResult (..),+    ProbeStatus (..),+    ProbeVerdict (..),+    healthServer,+    runProbe,+  )+import Servant.Health.Check+  ( boolCheck,+    newFailureTracker,+    safeCheck,+    sequenceChecks,+    withProbeTimeout,+  )+import Servant.Health.Paths (healthRawPaths, liveRawPath, readyRawPath)+import Servant.Health.TestKit (probeContractTests)+import Servant.OpenApi (toOpenApi)+import Servant.Server.Generic (genericServe)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "servant-health"+    [ pathTests,+      wireContractTests,+      unionMappingTests,+      runProbeTests,+      probeContractTests "probe contract (via servant-health:testkit)" mkTestApp,+      roundTripTests,+      checkCombinatorTests,+      failureTrackerTests,+      schemaTests,+      documentTests+    ]++-- | The published schema and the JSON codec are derived from one shared+-- 'Servant.Health.probeJsonOptions' value, so they cannot disagree by+-- construction. 'validateToJSON' is what proves the construction actually+-- holds: it checks a real encoded value against the declared schema and+-- returns the mismatches, so an empty list means the document a service+-- publishes describes the bytes it really sends.+schemaTests :: TestTree+schemaTests =+  testGroup+    "ToSchema ProbeStatus"+    [ testCase "a healthy body validates against the declared schema" $+        validateToJSON (ProbeStatus "ok" "all" Nothing) @?= [],+      testCase "a failing body validates against the declared schema" $+        validateToJSON (ProbeStatus "failed" "postgres" (Just failureOnset)) @?= []+    ]++-- | The OpenAPI document a consumer gets by mounting the probe routes under+-- @"health"@, as the JSON it would actually publish.+--+-- Asserting against the encoded JSON rather than the @OpenApi@ data model is+-- deliberate. It is what a service's generated artifact really contains, and it+-- avoids the one place the two fleet openapi cohorts genuinely differ: the 4.1+-- cohort ships optics-based accessors in @Data.OpenApi.Optics@ that the 5.x+-- cohort deletes. Navigating JSON touches neither accessor set, so this test+-- compiles and passes identically under both.+probeDocument :: Value+probeDocument = toJSON (toOpenApi (Proxy @("health" :> NamedRoutes HealthApi)))++-- | The document shape a consumer publishes. These assertions are what catch a+-- future change silently dropping the 503 from the published contract — a+-- service's generated document would then promise callers that a probe only+-- ever succeeds.+documentTests :: TestTree+documentTests =+  testGroup+    "generated OpenAPI document"+    [ testCase "declares exactly the two probe paths" $+        objectKeys (objectField "paths" probeDocument)+          @?= ["/health/live", "/health/ready"],+      testCase "the liveness path exposes a GET and nothing else" $+        objectKeys (pathItem "/health/live") @?= ["get"],+      testCase "the readiness path exposes a GET and nothing else" $+        objectKeys (pathItem "/health/ready") @?= ["get"],+      testCase "the liveness GET declares exactly the 200 and 503 responses" $+        responseCodes "/health/live" @?= ["200", "503"],+      testCase "the readiness GET declares exactly the 200 and 503 responses" $+        responseCodes "/health/ready" @?= ["200", "503"]+    ]+  where+    pathItem path = objectField path (objectField "paths" probeDocument)+    responseCodes path = objectKeys (objectField "responses" (objectField "get" (pathItem path)))++-- | A fixed instant used wherever a failure onset is needed.+failureOnset :: UTCTime+failureOnset =+  UTCTime (fromGregorian 2026 7 24) (secondsToDiffTime (12 * 3600 + 34 * 60 + 56))++-- | The keys of a JSON object, sorted so assertions do not depend on the+-- encoder's ordering.+objectKeys :: Value -> [String]+objectKeys = \case+  Object keyMap -> List.sort (map Key.toString (KeyMap.keys keyMap))+  other -> error ("expected a JSON object, got: " <> show other)++-- | Look up a key in a JSON object, absent or not.+objectLookup :: String -> Value -> Maybe Value+objectLookup key = \case+  Object keyMap -> KeyMap.lookup (Key.fromString key) keyMap+  other -> error ("expected a JSON object, got: " <> show other)++-- | Look up a key that the caller expects to be present.+objectField :: String -> Value -> Value+objectField key value =+  case objectLookup key value of+    Just found -> found+    Nothing -> error ("expected a " <> show key <> " key in: " <> show value)++pathTests :: TestTree+pathTests =+  testGroup+    "Servant.Health.Paths"+    [ testCase "liveRawPath is /health/live" $+        liveRawPath @?= "/health/live",+      testCase "readyRawPath is /health/ready" $+        readyRawPath @?= "/health/ready",+      testCase "healthRawPaths lists both probe paths" $+        healthRawPaths @?= [liveRawPath, readyRawPath]+    ]++-- | The probe body's key set is a wire contract. These tests fail if a later+-- change to 'Servant.Health.probeJsonOptions' renames, drops, or conditionally+-- omits a member.+wireContractTests :: TestTree+wireContractTests =+  testGroup+    "ProbeStatus JSON wire contract"+    [ testCase "healthy body has exactly status, check, failingSince" $+        objectKeys (toJSON (ProbeStatus "ok" "all" Nothing))+          @?= ["check", "failingSince", "status"],+      testCase "failingSince is present and null when healthy" $+        objectLookup "failingSince" (toJSON (ProbeStatus "ok" "all" Nothing))+          @?= Just Null,+      testCase "failing body has the same key set" $+        objectKeys (toJSON (ProbeStatus "failed" "postgres" (Just failureOnset)))+          @?= ["check", "failingSince", "status"],+      testCase "failing body encodes the onset as an ISO-8601 string" $+        objectLookup "failingSince" (toJSON (ProbeStatus "failed" "postgres" (Just failureOnset)))+          @?= Just (toJSON failureOnset)+    ]++-- | The status mapping. Both alternatives carry the same body type, so the+-- 'AsUnion' instance is the only thing standing between a failing probe and a+-- 200 response. These tests assert union /positions/, not just round-tripping:+-- swapping the two arms of 'toUnion' must break them.+unionMappingTests :: TestTree+unionMappingTests =+  testGroup+    "AsUnion ProbeResponses ProbeResult"+    [ testCase "ProbePassed maps to the first alternative (200)" $+        case toUnion @ProbeResponses (ProbePassed passedBody) of+          Z (I body) -> body @?= passedBody+          S _ -> assertFailure "ProbePassed did not map to the first (200) alternative",+      testCase "ProbeFailed maps to the second alternative (503)" $+        case toUnion @ProbeResponses (ProbeFailed failedBody) of+          S (Z (I body)) -> body @?= failedBody+          Z _ -> assertFailure "ProbeFailed mapped to the first (200) alternative"+          S (S impossible) -> case impossible of {},+      testCase "fromUnion . toUnion is identity on ProbePassed" $+        fromUnion @ProbeResponses (toUnion @ProbeResponses (ProbePassed passedBody))+          @?= ProbePassed passedBody,+      testCase "fromUnion . toUnion is identity on ProbeFailed" $+        fromUnion @ProbeResponses (toUnion @ProbeResponses (ProbeFailed failedBody))+          @?= ProbeFailed failedBody+    ]+  where+    passedBody = ProbeStatus "ok" "all" Nothing+    failedBody = ProbeStatus "failed" "postgres" (Just failureOnset)++-- | The verdict-to-body translation, independent of HTTP.+runProbeTests :: TestTree+runProbeTests =+  testGroup+    "runProbe"+    [ testCase "Healthy becomes a passed probe reporting all checks ok" $ do+        result <- runProbe (pure Healthy)+        result @?= ProbePassed (ProbeStatus "ok" "all" Nothing),+      testCase "Unhealthy becomes a failed probe naming the check and onset" $ do+        result <- runProbe (pure (Unhealthy "postgres" failureOnset))+        result @?= ProbeFailed (ProbeStatus "failed" "postgres" (Just failureOnset))+    ]++-- | A stand-in for a consumer's umbrella route record: one field mounting the+-- probe routes under @"health"@, exactly as the fleet standard prescribes.+newtype TestApi mode = TestApi+  { health :: mode :- "health" :> NamedRoutes HealthApi+  }+  deriving stock (Generic)++-- | The application builder this package hands to the test kit, and the one+-- 'withProbeServer' serves for the cases the kit does not cover. It is exactly+-- what a consuming service writes: an umbrella record with one field mounting+-- the probe routes under @"health"@, parameterized over the two checks so a+-- test can decide their verdicts.+mkTestApp :: ProbeCheck -> ProbeCheck -> IO Application+mkTestApp liveCheck readyCheck =+  pure $+    genericServe+      TestApi+        { health = healthServer liveCheck readyCheck+        }++-- | Run a real Warp server on an ephemeral port for the duration of the+-- action, handing it the two verdict cells and an HTTP client manager.+withProbeServer ::+  ProbeVerdict ->+  ProbeVerdict ->+  (IORef ProbeVerdict -> IORef ProbeVerdict -> Manager -> Port -> IO a) ->+  IO a+withProbeServer liveVerdict readyVerdict action = do+  liveRef <- newIORef liveVerdict+  readyRef <- newIORef readyVerdict+  manager <- newManager defaultManagerSettings+  testWithApplication+    (mkTestApp (readIORef liveRef) (readIORef readyRef))+    (action liveRef readyRef manager)++-- | GET a raw probe path off the running server. The response check is+-- disabled so that a 503 comes back as an ordinary response rather than an+-- exception.+getProbe :: Manager -> Port -> ByteString -> IO (Response LazyByteString.ByteString)+getProbe manager port rawPath = do+  request <- parseRequest ("http://127.0.0.1:" <> show port <> Char8.unpack rawPath)+  httpLbs request {checkResponse = \_ _ -> pure ()} manager++-- | Assert the status code, JSON body, and content type of one probe response.+-- The expected body is given as literal JSON so the assertion states the wire+-- shape independently of this library's encoder.+assertProbe :: Int -> LazyByteString.ByteString -> Response LazyByteString.ByteString -> IO ()+assertProbe expectedStatus expectedBody response = do+  statusCode (responseStatus response) @?= expectedStatus+  decode (responseBody response) @?= (decode expectedBody :: Maybe Value)+  mediaType (lookup hContentType (responseHeaders response)) @?= Just "application/json"+  where+    mediaType = fmap (Char8.takeWhile (/= ';'))++healthyBody :: LazyByteString.ByteString+healthyBody = "{\"status\":\"ok\",\"check\":\"all\",\"failingSince\":null}"++-- | The failing body for 'failureOnset', with the instant spelled out as the+-- ISO-8601 string a dashboard or a human curling the probe would read.+failingBody :: LazyByteString.ByteString -> LazyByteString.ByteString+failingBody failedCheckName =+  "{\"status\":\"failed\",\"check\":\""+    <> failedCheckName+    <> "\",\"failingSince\":\"2026-07-24T12:34:56Z\"}"++-- | End-to-end proof over a real Warp server for the two properties the test+-- kit does not cover.+--+-- The 200/503 matrix and the dispatch cross-assertions moved into+-- 'Servant.Health.TestKit.probeContractTests', which this suite runs above+-- against the same 'mkTestApp' builder a consuming service would write — so+-- the kit is proven by the package it ships with rather than only by its own+-- documentation.+--+-- What stays here is what the kit deliberately does not assert, because both+-- are statements about this library rather than about a consumer's wiring: that+-- a verdict is never cached across requests, and that no bare @\/health@ route+-- exists (see docs/adr/3-scope-boundaries-and-deliberate-exclusions.md).+roundTripTests :: TestTree+roundTripTests =+  testGroup+    "Warp round trip (beyond the test kit's matrix)"+    [ testCase "checks are re-run per request, not cached" $+        withProbeServer Healthy Healthy $ \_ readyRef manager port -> do+          getProbe manager port readyRawPath >>= assertProbe 200 healthyBody+          writeIORef readyRef (Unhealthy "postgres" failureOnset)+          getProbe manager port readyRawPath+            >>= assertProbe 503 (failingBody "postgres")+          writeIORef readyRef Healthy+          getProbe manager port readyRawPath >>= assertProbe 200 healthyBody,+      testCase "an unmounted path under the health prefix is a 404" $+        withProbeServer Healthy Healthy $ \_ _ manager port -> do+          response <- getProbe manager port "/health"+          statusCode (responseStatus response) @?= 404+    ]++-- | The failing check's name, or 'Nothing' when healthy. Most combinator+-- assertions are about /which/ check failed, not when it was observed, and the+-- observation time of a combinator that calls 'getCurrentTime' is not+-- something a test can pin.+verdictName :: ProbeVerdict -> Maybe Text+verdictName = \case+  Healthy -> Nothing+  Unhealthy failed _ -> Just failed++-- | A check that records the fact it ran, so a test can prove which checks a+-- combinator did and did not reach.+tracingCheck :: IORef [Text] -> Text -> ProbeVerdict -> ProbeCheck+tracingCheck traceRef name verdict = do+  modifyIORef' traceRef (<> [name])+  pure verdict++checkCombinatorTests :: TestTree+checkCombinatorTests =+  testGroup+    "Servant.Health.Check"+    [ testGroup+        "boolCheck"+        [ testCase "True is healthy" $ do+            verdict <- boolCheck "db" (pure True)+            verdict @?= Healthy,+          testCase "False is unhealthy under the given name" $ do+            verdict <- boolCheck "db" (pure False)+            verdictName verdict @?= Just "db"+        ],+      testGroup+        "sequenceChecks"+        [ testCase "an empty list is healthy" $ do+            verdict <- sequenceChecks []+            verdict @?= Healthy,+          testCase "all healthy is healthy, and every check runs" $ do+            traceRef <- newIORef []+            verdict <-+              sequenceChecks+                [ tracingCheck traceRef "first" Healthy,+                  tracingCheck traceRef "second" Healthy,+                  tracingCheck traceRef "third" Healthy+                ]+            verdict @?= Healthy+            readIORef traceRef >>= (@?= ["first", "second", "third"]),+          testCase "the first failure wins and its successors do not run" $ do+            traceRef <- newIORef []+            verdict <-+              sequenceChecks+                [ tracingCheck traceRef "first" Healthy,+                  tracingCheck traceRef "second" (Unhealthy "second" failureOnset),+                  tracingCheck traceRef "third" (Unhealthy "third" failureOnset)+                ]+            verdict @?= Unhealthy "second" failureOnset+            readIORef traceRef >>= (@?= ["first", "second"]),+          testCase "a failure in the head short-circuits everything" $ do+            traceRef <- newIORef []+            verdict <-+              sequenceChecks+                [ tracingCheck traceRef "first" (Unhealthy "first" failureOnset),+                  tracingCheck traceRef "second" Healthy+                ]+            verdictName verdict @?= Just "first"+            readIORef traceRef >>= (@?= ["first"])+        ],+      testGroup+        "safeCheck"+        [ testCase "a healthy check passes through untouched" $ do+            verdict <- safeCheck "wrapper" (pure Healthy)+            verdict @?= Healthy,+          testCase "a failing check passes through with its own name" $ do+            verdict <- safeCheck "wrapper" (pure (Unhealthy "postgres" failureOnset))+            verdict @?= Unhealthy "postgres" failureOnset,+          testCase "an imprecise error becomes a failure under the wrapper's name" $ do+            verdict <- safeCheck "wrapper" (error "boom")+            verdictName verdict @?= Just "wrapper",+          testCase "a thrown IOException becomes a failure, not an escape" $ do+            verdict <- safeCheck "wrapper" (throwIO (userError "connection refused"))+            verdictName verdict @?= Just "wrapper",+          testCase "an asynchronous exception is not swallowed" $ do+            outcomeVar <- newEmptyMVar+            checkStarted <- newEmptyMVar+            threadId <- forkIO $ do+              outcome <-+                try $+                  safeCheck "wrapper" $ do+                    putMVar checkStarted ()+                    threadDelay 5_000_000+                    pure Healthy+              putMVar outcomeVar (outcome :: Either SomeException ProbeVerdict)+            takeMVar checkStarted+            killThread threadId+            outcome <- takeMVar outcomeVar+            case outcome of+              Right verdict ->+                assertFailure+                  ("safeCheck swallowed the async exception and returned: " <> show verdict)+              Left err ->+                fromException err @?= Just ThreadKilled+        ],+      testGroup+        "withProbeTimeout"+        [ testCase "a prompt check passes through untouched" $ do+            verdict <- withProbeTimeout 1_000_000 "liveness" (pure Healthy)+            verdict @?= Healthy,+          testCase "a check that overruns fails under the timeout's name" $ do+            verdict <-+              withProbeTimeout 10_000 "liveness" $ do+                threadDelay 500_000+                pure Healthy+            verdictName verdict @?= Just "liveness",+          testCase "a nested safeCheck does not defeat the timeout" $ do+            -- timeout interrupts by throwing an asynchronous exception, so a+            -- safeCheck inside it must re-throw rather than report a failure+            -- under its own name. If this regresses, the verdict comes back+            -- named "inner" and a deadlocked process hangs its liveness probe.+            verdict <-+              withProbeTimeout 10_000 "liveness" $+                safeCheck "inner" $ do+                  threadDelay 500_000+                  pure Healthy+            verdictName verdict @?= Just "liveness"+        ]+    ]++-- | The failure tracker turns "failing now" into "failing since". Every case+-- here drives the wrapped check from a mutable cell holding a fabricated+-- verdict, so the assertions compare exact timestamps rather than wall-clock+-- reads.+failureTrackerTests :: TestTree+failureTrackerTests =+  testGroup+    "newFailureTracker"+    [ testCase "a healthy check is passed through" $ do+        track <- newFailureTracker+        verdict <- track (pure Healthy)+        verdict @?= Healthy,+      testCase "consecutive failures all report the first onset" $ do+        track <- newFailureTracker+        verdictRef <- newIORef (Unhealthy "postgres" onsetT0)+        first <- track (readIORef verdictRef)+        writeIORef verdictRef (Unhealthy "postgres" onsetT1)+        second <- track (readIORef verdictRef)+        writeIORef verdictRef (Unhealthy "postgres" onsetT2)+        third <- track (readIORef verdictRef)+        [first, second, third]+          @?= [ Unhealthy "postgres" onsetT0,+                Unhealthy "postgres" onsetT0,+                Unhealthy "postgres" onsetT0+              ],+      testCase "an intervening healthy result resets the onset" $ do+        track <- newFailureTracker+        verdictRef <- newIORef (Unhealthy "postgres" onsetT0)+        before <- track (readIORef verdictRef)+        writeIORef verdictRef Healthy+        recovered <- track (readIORef verdictRef)+        writeIORef verdictRef (Unhealthy "postgres" onsetT2)+        after <- track (readIORef verdictRef)+        before @?= Unhealthy "postgres" onsetT0+        recovered @?= Healthy+        after @?= Unhealthy "postgres" onsetT2,+      testCase "the failing check's own name is preserved, only the onset is rewritten" $ do+        track <- newFailureTracker+        verdictRef <- newIORef (Unhealthy "postgres" onsetT0)+        _ <- track (readIORef verdictRef)+        writeIORef verdictRef (Unhealthy "redis" onsetT1)+        second <- track (readIORef verdictRef)+        second @?= Unhealthy "redis" onsetT0,+      testCase "separate trackers do not share memory" $ do+        trackLiveness <- newFailureTracker+        trackReadiness <- newFailureTracker+        _ <- trackLiveness (pure (Unhealthy "deadlock" onsetT0))+        readinessVerdict <- trackReadiness (pure (Unhealthy "postgres" onsetT2))+        readinessVerdict @?= Unhealthy "postgres" onsetT2+    ]+  where+    onsetT0 = failureOnset+    onsetT1 = addUTCTime 30 failureOnset+    onsetT2 = addUTCTime 90 failureOnset

@@ -0,0 +1,281 @@+-- | A ready-made conformance test for a service that mounts this package's+-- probe routes.+--+-- Mounting @Servant.Health.HealthApi@ leaves a service one thing to prove: that+-- /its own/ assembled application really answers @GET \/health\/live@ and+-- @GET \/health\/ready@, that a failing readiness check produces a 503 while+-- liveness stays 200, and that the two routes were not wired to each other's+-- checks. That last hazard is the reason this kit exists. Both probe routes+-- have the same handler type, so an umbrella route record that swaps them+-- compiles cleanly and type-checks cleanly; only a request that distinguishes+-- them catches it.+--+-- 'probeContractTests' drives a real HTTP server built from the consumer's own+-- application and asserts the whole matrix, including the two cross-assertions+-- that fail when the routes are transposed.+--+-- == Wiring it into a service+--+-- Depend on the kit from the test stanza only, so production builds never+-- acquire its @tasty@ and @warp@ dependencies. The test suite must be built+-- with the threaded runtime: Warp's timer manager requires it, and without+-- @-threaded@ every request dies with @getSystemTimerManager: the TimerManager+-- requires linking against the threaded runtime@.+--+-- > test-suite myservice-test+-- >   type:           exitcode-stdio-1.0+-- >   hs-source-dirs: test+-- >   main-is:        Main.hs+-- >   ghc-options:    -threaded -rtsopts -with-rtsopts=-N+-- >   build-depends:+-- >     , base+-- >     , servant-health+-- >     , servant-health:testkit+-- >     , tasty+--+-- The kit supplies the two checks it wants mounted, so it needs a /builder/ for+-- the application rather than a finished one. Parameterizing the service's app+-- builder over its two probe checks is the only change most services need:+--+-- > module Main (main) where+-- >+-- > import GHC.Generics (Generic)+-- > import Network.Wai (Application)+-- > import Servant.API (NamedRoutes, (:>))+-- > import Servant.API.Generic ((:-))+-- > import Servant.Health (HealthApi, ProbeCheck, healthServer)+-- > import Servant.Health.TestKit (probeContractTests)+-- > import Servant.Server.Generic (genericServe)+-- > import Test.Tasty (defaultMain)+-- >+-- > -- Your service's umbrella route record. Normally this and 'mkApp' are+-- > -- imported from the service's own library rather than defined in the test+-- > -- file; they are inlined here so the example is complete.+-- > data MyServiceApi mode = MyServiceApi+-- >   { health :: mode :- "health" :> NamedRoutes HealthApi+-- >     -- , orders :: mode :- "orders" :> NamedRoutes OrdersApi+-- >   }+-- >   deriving stock (Generic)+-- >+-- > mkApp :: ProbeCheck -> ProbeCheck -> IO Application+-- > mkApp livenessCheck readinessCheck =+-- >   pure $+-- >     genericServe+-- >       MyServiceApi+-- >         { health = healthServer livenessCheck readinessCheck+-- >         }+-- >+-- > main :: IO ()+-- > main = defaultMain (probeContractTests "myservice probes" mkApp)+--+-- In production the same builder is called with the service's real checks,+-- assembled from "Servant.Health.Check". Note the nesting order: the timeout+-- goes /outside/ the exception wrapper, because+-- 'Servant.Health.Check.withProbeTimeout' interrupts by throwing an+-- asynchronous exception and 'Servant.Health.Check.safeCheck' deliberately lets+-- those through rather than swallowing them. Nested the other way round, a+-- deadlocked process would hang its liveness probe instead of failing it.+--+-- @ConnectionPool@, @eventLoopCheck@, @databaseCheck@, and @cacheCheck@ below+-- are the service's own — this package deliberately ships no checks:+--+-- > import Servant.Health.Check (safeCheck, sequenceChecks, withProbeTimeout)+-- >+-- > runService :: ConnectionPool -> IO ()+-- > runService pool = do+-- >   application <-+-- >     mkApp+-- >       (withProbeTimeout 2_000_000 "liveness" (safeCheck "liveness" (eventLoopCheck pool)))+-- >       (safeCheck "readiness" (sequenceChecks [databaseCheck pool, cacheCheck]))+-- >   Warp.run 8080 application+--+-- == What the builder must do+--+-- The builder must mount the checks it is handed, in the order it is handed+-- them — liveness first, readiness second — and it must mount them under+-- @"health"@ so the routes answer at 'Servant.Health.Paths.liveRawPath' and+-- 'Servant.Health.Paths.readyRawPath'. A builder that ignores its arguments and+-- mounts the service's real checks proves nothing and will fail these tests.+--+-- The builder is called once per test case, each time against a fresh server on+-- an ephemeral port, so cases are independent and safe to run in parallel. Keep+-- it cheap: a builder that opens a real database connection will open one per+-- case.+module Servant.Health.TestKit+  ( probeContractTests,+  )+where++import Control.Concurrent (rtsSupportsBoundThreads)+import Data.Aeson (Value, decode, object, (.=))+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as Char8+import Data.ByteString.Lazy qualified as LazyByteString+import Data.IORef (newIORef, readIORef)+import Data.Text (Text)+import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import Network.HTTP.Client+  ( Manager,+    Response,+    checkResponse,+    defaultManagerSettings,+    httpLbs,+    newManager,+    parseRequest,+    responseBody,+    responseHeaders,+    responseStatus,+  )+import Network.HTTP.Types.Header (hContentType)+import Network.HTTP.Types.Status (statusCode)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (Port, testWithApplication)+import Servant.Health (ProbeCheck, ProbeVerdict (Healthy, Unhealthy))+import Servant.Health.Paths (liveRawPath, readyRawPath)+import Test.Tasty (TestName, TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++-- | Prove that an assembled application answers the probe contract.+--+-- The second argument builds the application under test from a liveness check+-- and a readiness check, in that order. The kit owns those checks so that it+-- can decide their verdicts case by case; see the module documentation for a+-- complete example.+--+-- The returned group contains one case per scenario. Both checks healthy: both+-- probes answer 200 with the healthy body. Readiness failing: @\/health\/ready@+-- answers 503 naming the failed check while @\/health\/live@ still answers 200.+-- Liveness failing: the mirror image. The two \"still answers 200\" assertions+-- are the dispatch proof — they are what fails when an umbrella record wires+-- the probe routes to each other's checks.+probeContractTests ::+  TestName ->+  -- | Build the consumer's application from a liveness check and a readiness+  -- check. The kit owns the checks so it can flip them between cases.+  (ProbeCheck -> ProbeCheck -> IO Application) ->+  TestTree+probeContractTests groupName mkApp =+  testGroup+    groupName+    [ testCase "the test suite is built with the threaded runtime" $+        assertBool threadedRuntimeAdvice rtsSupportsBoundThreads,+      testCase "both checks healthy: both probes answer 200" $+        withProbeApp mkApp Healthy Healthy $ \manager port -> do+          getProbe manager port liveRawPath+            >>= assertProbe liveRawPath 200 healthyBody+          getProbe manager port readyRawPath+            >>= assertProbe readyRawPath 200 healthyBody,+      testCase "readiness failing: ready answers 503, live still 200" $+        withProbeApp mkApp Healthy (failing readinessCheckName) $ \manager port -> do+          getProbe manager port readyRawPath+            >>= assertProbe readyRawPath 503 (failingBody readinessCheckName)+          getProbe manager port liveRawPath+            >>= assertProbe liveRawPath 200 healthyBody,+      testCase "liveness failing: live answers 503, ready still 200" $+        withProbeApp mkApp (failing livenessCheckName) Healthy $ \manager port -> do+          getProbe manager port liveRawPath+            >>= assertProbe liveRawPath 503 (failingBody livenessCheckName)+          getProbe manager port readyRawPath+            >>= assertProbe readyRawPath 200 healthyBody+    ]+  where+    failing name = Unhealthy name probeFailureOnset++-- | What to say when the suite was linked without @-threaded@. Warp's timer+-- manager needs the threaded runtime, so without the flag every request in+-- every case below dies with a @getSystemTimerManager@ error that says nothing+-- about the missing flag.+threadedRuntimeAdvice :: String+threadedRuntimeAdvice =+  "This test suite was linked without the threaded runtime, so the probe "+    <> "server cannot run. Add -threaded -rtsopts -with-rtsopts=-N to the test "+    <> "suite's ghc-options in your .cabal file."++-- | The name the kit fails the liveness check under. Distinct from the+-- readiness name so a transposed wiring is named in the failure message rather+-- than merely counted.+livenessCheckName :: Text+livenessCheckName = "testkit-live"++-- | The name the kit fails the readiness check under.+readinessCheckName :: Text+readinessCheckName = "testkit-ready"++-- | The instant every failure the kit fabricates is dated with. Fixed rather+-- than read from the clock, so a failed assertion prints a stable expected+-- value.+probeFailureOnset :: UTCTime+probeFailureOnset =+  UTCTime (fromGregorian 2026 7 24) (secondsToDiffTime (12 * 3600 + 34 * 60 + 56))++-- | The body both probes answer with while their checks pass.+healthyBody :: Value+healthyBody =+  object+    [ "status" .= ("ok" :: Text),+      "check" .= ("all" :: Text),+      "failingSince" .= (Nothing :: Maybe UTCTime)+    ]++-- | The body a probe answers with when its check failed under the given name.+failingBody :: Text -> Value+failingBody failedCheckName =+  object+    [ "status" .= ("failed" :: Text),+      "check" .= failedCheckName,+      "failingSince" .= probeFailureOnset+    ]++-- | Build the consumer's application with checks that report the given+-- verdicts, serve it on an ephemeral port for the duration of the action, and+-- hand the action an HTTP client manager and the port.+--+-- The checks are backed by mutable cells read on every call, so an application+-- that caches a verdict at build time fails the cases above rather than passing+-- them by accident.+withProbeApp ::+  (ProbeCheck -> ProbeCheck -> IO Application) ->+  ProbeVerdict ->+  ProbeVerdict ->+  (Manager -> Port -> IO a) ->+  IO a+withProbeApp mkApp liveVerdict readyVerdict action = do+  liveRef <- newIORef liveVerdict+  readyRef <- newIORef readyVerdict+  application <- mkApp (readIORef liveRef) (readIORef readyRef)+  manager <- newManager defaultManagerSettings+  testWithApplication (pure application) (action manager)++-- | GET a raw probe path off the running server. The client's response check is+-- disabled so that a 503 arrives as an ordinary response rather than an+-- exception.+getProbe :: Manager -> Port -> ByteString -> IO (Response LazyByteString.ByteString)+getProbe manager port rawPath = do+  request <- parseRequest ("http://127.0.0.1:" <> show port <> Char8.unpack rawPath)+  httpLbs request {checkResponse = \_ _ -> pure ()} manager++-- | Assert the status code, JSON body, and content type of one probe response,+-- labelling each assertion with the path it was made against so a failure names+-- the probe rather than just the expected value.+assertProbe ::+  ByteString ->+  Int ->+  Value ->+  Response LazyByteString.ByteString ->+  IO ()+assertProbe rawPath expectedStatus expectedBody response = do+  assertEqual+    (label "status code")+    expectedStatus+    (statusCode (responseStatus response))+  assertEqual+    (label "JSON body")+    (Just expectedBody)+    (decode (responseBody response))+  assertEqual+    (label "content type")+    (Just "application/json")+    (mediaType (lookup hContentType (responseHeaders response)))+  where+    label what = "GET " <> Char8.unpack rawPath <> ": " <> what+    mediaType = fmap (Char8.takeWhile (/= ';'))