Set health endpoint to unhealthy on shutdown signal

gitlab-ci-build-statuses.cabal

@@ -103,6 +103,7 @@ library
     , servant-server
     , time
     , transformers
+    , unix
     , unliftio
     , validation-selective
     , wai-extra

src/App.hs

@@ -11,7 +11,7 @@ import Inbound.HTTP.Server (startServer)
 import Inbound.Jobs.Updating (updateStatusesRegularly)
 import Katip hiding (getEnvironment)
 import Logger
-import Metrics.Health (initThreads)
+import Metrics.Health (initHealth, initThreads)
 import Metrics.Metrics
 import Outbound.Gitlab.GitlabAPI (initCache, pipelinesApiToIO, projectsApiToIO)
 import Outbound.Storage.InMemory (buildStatusesApiToIO, initStorage)
@@ -59,10 +59,11 @@ run = do
   statuses <- initStorage
   healthThreads <- initThreads
   metrics <- registerMetrics
+  health <- initHealth
   case parseConfigFromEnv environment of
     Success config ->
       withLogEnv (logLevel config) $ \lE -> do
-        let backbone = initBackbone metrics statuses healthThreads (LogConfig mempty mempty lE)
+        let backbone = initBackbone metrics statuses healthThreads health (LogConfig mempty mempty lE)
         singleLog lE InfoS $ "Using config: " <> show config
         singleLog lE InfoS $ "Running version: " <> show (gitCommit backbone)
         startWithConfig config backbone

src/Config/Backbone.hs

@@ -20,9 +20,9 @@ import Katip (LogContexts, LogEnv, Namespace)
 import Metrics.Metrics
 import Relude hiding (lookupEnv)
 
-initBackbone :: Metrics -> IORef BuildStatuses -> IORef [(ThreadId, Text)] -> LogConfig -> Backbone
-initBackbone metrics iorefBuilds iorefThreads logConfig =
-  Backbone metrics iorefBuilds logConfig (GitCommit $ giTag gitCommit <> "/" <> giBranch gitCommit <> "@" <> giHash gitCommit) iorefThreads
+initBackbone :: Metrics -> IORef BuildStatuses -> IORef [(ThreadId, Text)] -> IORef Bool -> LogConfig -> Backbone
+initBackbone metrics iorefBuilds iorefThreads health logConfig =
+  Backbone metrics iorefBuilds logConfig (GitCommit $ giTag gitCommit <> "/" <> giBranch gitCommit <> "@" <> giHash gitCommit) iorefThreads health
   where
     gitCommit = $$tGitInfoCwd
 
@@ -31,7 +31,8 @@ data Backbone = Backbone
     statuses :: IORef BuildStatuses,
     logConfig :: LogConfig,
     gitCommit :: GitCommit,
-    threads :: IORef [(ThreadId, Text)]
+    threads :: IORef [(ThreadId, Text)],
+    health :: IORef Bool
   }
 
 data LogConfig = LogConfig

src/Inbound/HTTP/Server.hs

@@ -27,6 +27,7 @@ import Polysemy.Time (Time, interpretTimeGhc)
 import Relude
 import Servant
 import Servant.HTML.Blaze
+import System.Posix.Signals hiding (Handler)
 import qualified Text.Blaze.Html5 as H
 
 type API = "health" :> Get '[JSON] HealthStatus :<|> "statuses" :> QueryFlag "norefresh" :> Get '[HTML] H.Html :<|> "static" :> Raw
@@ -42,14 +43,14 @@ norefreshFlag True = NoRefresh
 norefreshFlag False = Refresh
 
 hoist :: Config -> Backbone -> ServerT API Handler
-hoist Config {..} Backbone {..} = hoistServer api (liftServer statuses threads) (server dataUpdateIntervalSecs uiUpdateIntervalSecs gitCommit)
+hoist Config {..} Backbone {..} = hoistServer api (liftServer statuses health threads) (server dataUpdateIntervalSecs uiUpdateIntervalSecs gitCommit)
 
-liftServer :: IORef BuildStatuses -> IORef [(ThreadId, Text)] -> Sem '[BuildStatusesApi, Time UTCTime Day, Health, Embed IO] a -> Handler a
-liftServer statuses threads sem =
+liftServer :: IORef BuildStatuses -> IORef Bool -> IORef [(ThreadId, Text)] -> Sem '[BuildStatusesApi, Time UTCTime Day, Health, Embed IO] a -> Handler a
+liftServer statuses health threads sem =
   sem
     & buildStatusesApiToIO statuses
     & interpretTimeGhc
-    & healthToIO threads
+    & healthToIO health threads
     & runM
     & Handler . ExceptT . try
 
@@ -58,4 +59,9 @@ startServer config backbone =
   serve api (hoist config backbone)
     & prometheus def
     & gzip def
-    & runSettings ((setPort 8282 . setGracefulShutdownTimeout (Just 1)) defaultSettings)
+    & runSettings (setPort 8282 . setGracefulShutdownTimeout (Just 2) . setShutdownHandlerDisablingHealth (health backbone) $ defaultSettings)
+
+setShutdownHandlerDisablingHealth :: IORef Bool -> Settings -> Settings
+setShutdownHandlerDisablingHealth health = setInstallShutdownHandler shutdownHandler
+  where
+    shutdownHandler closeSocket = void $ installHandler sigTERM (CatchOnce $ atomicWriteIORef health False >> closeSocket) Nothing

src/Metrics/Health.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Metrics.Health (getCurrentHealthStatus, initThreads, healthToIO, HealthStatus) where
+module Metrics.Health (getCurrentHealthStatus, initThreads, initHealth, healthToIO, HealthStatus) where
 
 import Control.Concurrent (ThreadId)
 import Control.Exception (throw)
@@ -30,18 +30,22 @@ getCurrentHealthStatus = ifM isHealthy (pure healthy) (throw errorResponse)
           errHeaders = [(hContentType, "application/json;charset=utf-8")]
         }
 
-healthToIO :: Member (Embed IO) r => IORef [(ThreadId, Text)] -> InterpreterFor Health r
-healthToIO ioref = interpret $ \case
+healthToIO :: Member (Embed IO) r => IORef Bool -> IORef [(ThreadId, Text)] -> InterpreterFor Health r
+healthToIO healthIORef threadsIORef = interpret $ \case
   IsHealthy -> embed $ do
-    threads <- readIORef ioref
-    allM (isThreadHealthy . fst) threads
+    threads <- readIORef threadsIORef
+    health <- readIORef healthIORef
+    (&&) health <$> allM (isThreadHealthy . fst) threads
 
 isThreadHealthy :: ThreadId -> IO Bool
 isThreadHealthy = fmap (`notElem` [ThreadFinished, ThreadDied]) . threadStatus
 
 initThreads :: IO (IORef [(ThreadId, Text)])
 initThreads = newIORef []
 
+initHealth :: IO (IORef Bool)
+initHealth = newIORef True
+
 data HealthStatus = HealthStatus {status :: Status, build :: String} deriving (Generic, ToJSON)
 
 healthy :: HealthStatus