97 lines
3.9 KiB
Haskell
97 lines
3.9 KiB
Haskell
module Handler.Health where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Aeson.Encode.Pretty as Aeson
|
|
import qualified Data.Text.Lazy.Builder as Builder
|
|
|
|
import qualified Data.UUID as UUID
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Control.Concurrent.STM.Delay
|
|
|
|
|
|
getHealthR :: Handler TypedContent
|
|
getHealthR = do
|
|
reportStore <- getsYesod appHealthReport
|
|
healthReports' <- liftIO $ readTVarIO reportStore
|
|
interval <- getsYesod $ view _appHealthCheckInterval
|
|
|
|
case fromNullable healthReports' of
|
|
Nothing -> do
|
|
let Min (NTop minInterval) = ofoldMap1 (Min . NTop) $ impureNonNull interval
|
|
delay <- for minInterval $ \minInterval' -> liftIO . newDelay . round $ toRational minInterval' * 1e6
|
|
waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
|
|
case waitResult of
|
|
Left False -> sendResponseStatus noContent204 ()
|
|
Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text)
|
|
Right _ -> redirect HealthR
|
|
Just healthReports -> do
|
|
let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports
|
|
reportNextUpdate (lastCheck, classifyHealthReport -> kind)
|
|
= fromMaybe 0 (interval kind) `addUTCTime` lastCheck
|
|
Max nextUpdate = ofoldMap1 (Max . reportNextUpdate) healthReports
|
|
instanceId <- getsYesod appInstanceID
|
|
|
|
setWeakEtagHashable (instanceId, lastUpdated)
|
|
expiresAt nextUpdate
|
|
setLastModified lastUpdated
|
|
|
|
let status'
|
|
| HealthSuccess <- status
|
|
= ok200
|
|
| otherwise
|
|
= internalServerError500
|
|
sendResponseStatus status' <=< selectRep $ do
|
|
provideRep . siteLayoutMsg MsgHealthReport $ do
|
|
setTitleI MsgHealthReport
|
|
[whamlet|
|
|
$newline never
|
|
<dl .deflist>
|
|
$forall (_, report) <- healthReports'
|
|
$case report
|
|
$of HealthMatchingClusterConfig passed
|
|
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
|
|
<dd .deflist__dd>#{boolSymbol passed}
|
|
$of HealthHTTPReachable (Just passed)
|
|
<dt .deflist__dt>_{MsgHealthHTTPReachable}
|
|
<dd .deflist__dd>#{boolSymbol passed}
|
|
$of HealthLDAPAdmins (Just found)
|
|
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
|
|
<dd .deflist__dd>#{textPercent found 1}
|
|
$of HealthSMTPConnect (Just passed)
|
|
<dt .deflist__dt>_{MsgHealthSMTPConnect}
|
|
<dd .deflist__dd>#{boolSymbol passed}
|
|
$of HealthWidgetMemcached (Just passed)
|
|
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
|
|
<dd .deflist__dd>#{boolSymbol passed}
|
|
$of HealthActiveJobExecutors (Just active)
|
|
<dt .deflist__dt>_{MsgHealthActiveJobExecutors}
|
|
<dd .deflist__dd>#{textPercent active 1}
|
|
$of _
|
|
|]
|
|
provideJson healthReports
|
|
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
|
|
|
|
getInstanceR :: Handler TypedContent
|
|
getInstanceR = do
|
|
instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID
|
|
|
|
setWeakEtagHashable (clusterId, instanceId)
|
|
|
|
selectRep $ do
|
|
provideRep $
|
|
siteLayoutMsg MsgInstanceIdentification $ do
|
|
setTitleI MsgInstanceIdentification
|
|
[whamlet|
|
|
$newline never
|
|
<dl .deflist>
|
|
<dt .deflist__dt>_{MsgClusterId}
|
|
<dd .deflist__dd style="font-family: monospace">#{UUID.toText clusterId}
|
|
<dt .deflist__dt>_{MsgInstanceId}
|
|
<dd .deflist__dd style="font-family: monospace">#{UUID.toText instanceId}
|
|
|]
|
|
provideJson instanceInfo
|
|
provideRep . return $ tshow instanceInfo
|