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