93 lines
3.0 KiB
Haskell
93 lines
3.0 KiB
Haskell
{-
|
|
©AngelaMos | 2026
|
|
HealthCheck.hs
|
|
-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Aenebris.HealthCheck
|
|
( HealthCheckConfig(..)
|
|
, defaultHealthCheckConfig
|
|
, startHealthChecker
|
|
, stopHealthChecker
|
|
, performHealthCheck
|
|
) where
|
|
|
|
import Aenebris.Backend
|
|
import Aenebris.Connection (httpOkStatusCode, microsPerSecond)
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.STM
|
|
import Control.Monad (forever, zipWithM_)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Network.HTTP.Client
|
|
import Network.HTTP.Types.Status (statusCode)
|
|
import System.Timeout (timeout)
|
|
|
|
defaultHealthCheckIntervalSeconds :: Int
|
|
defaultHealthCheckIntervalSeconds = 10
|
|
|
|
defaultHealthCheckTimeoutSeconds :: Int
|
|
defaultHealthCheckTimeoutSeconds = 2
|
|
|
|
defaultHealthCheckMaxFailures :: Int
|
|
defaultHealthCheckMaxFailures = 3
|
|
|
|
defaultHealthCheckRecoveryAttempts :: Int
|
|
defaultHealthCheckRecoveryAttempts = 2
|
|
|
|
defaultHealthCheckEndpoint :: Text
|
|
defaultHealthCheckEndpoint = "/health"
|
|
|
|
data HealthCheckConfig = HealthCheckConfig
|
|
{ hcInterval :: !Int
|
|
, hcTimeout :: !Int
|
|
, hcEndpoint :: !Text
|
|
, hcMaxFailures :: !Int
|
|
, hcRecoveryAttempts :: !Int
|
|
}
|
|
|
|
defaultHealthCheckConfig :: HealthCheckConfig
|
|
defaultHealthCheckConfig = HealthCheckConfig
|
|
{ hcInterval = defaultHealthCheckIntervalSeconds
|
|
, hcTimeout = defaultHealthCheckTimeoutSeconds
|
|
, hcEndpoint = defaultHealthCheckEndpoint
|
|
, hcMaxFailures = defaultHealthCheckMaxFailures
|
|
, hcRecoveryAttempts = defaultHealthCheckRecoveryAttempts
|
|
}
|
|
|
|
startHealthChecker
|
|
:: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO (Async ())
|
|
startHealthChecker manager config backends =
|
|
async (healthCheckLoop manager config backends)
|
|
|
|
stopHealthChecker :: Async () -> IO ()
|
|
stopHealthChecker = cancel
|
|
|
|
healthCheckLoop :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO ()
|
|
healthCheckLoop manager config backends = forever $ do
|
|
results <- mapConcurrently (performHealthCheck manager config) backends
|
|
atomically $ zipWithM_ (updateBackendState config) backends results
|
|
threadDelay (hcInterval config * microsPerSecond)
|
|
|
|
performHealthCheck :: Manager -> HealthCheckConfig -> RuntimeBackend -> IO Bool
|
|
performHealthCheck manager config backend = do
|
|
let url = "http://" ++ T.unpack (rbHost backend) ++ T.unpack (hcEndpoint config)
|
|
result <- timeout (hcTimeout config * microsPerSecond) $ do
|
|
req <- parseRequest url
|
|
response <- httpLbs req manager
|
|
pure (statusCode (responseStatus response) == httpOkStatusCode)
|
|
now <- getCurrentTime
|
|
atomically $ writeTVar (rbLastHealthCheck backend) (Just now)
|
|
pure $ case result of
|
|
Just True -> True
|
|
_ -> False
|
|
|
|
updateBackendState :: HealthCheckConfig -> RuntimeBackend -> Bool -> STM ()
|
|
updateBackendState config backend healthy =
|
|
if healthy
|
|
then recordSuccess backend (hcRecoveryAttempts config)
|
|
else recordFailure backend (hcMaxFailures config)
|