diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/servant-health.cabal b/servant-health.cabal new file mode 100644 --- /dev/null +++ b/servant-health.cabal @@ -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 diff --git a/src/Servant/Health.hs b/src/Servant/Health.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Health.hs @@ -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))) diff --git a/src/Servant/Health/Check.hs b/src/Servant/Health/Check.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Health/Check.hs @@ -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) diff --git a/src/Servant/Health/Paths.hs b/src/Servant/Health/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Health/Paths.hs @@ -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] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/testkit/Servant/Health/TestKit.hs b/testkit/Servant/Health/TestKit.hs new file mode 100644 --- /dev/null +++ b/testkit/Servant/Health/TestKit.hs @@ -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 (/= ';'))