79 lines
3.0 KiB
Haskell
79 lines
3.0 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 Utils.Lens
|
|
|
|
import qualified Data.UUID as UUID
|
|
|
|
|
|
getHealthR :: Handler TypedContent
|
|
getHealthR = do
|
|
healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport
|
|
case healthReport' of
|
|
Nothing -> do
|
|
interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval
|
|
reportStore <- getsYesod appHealthReport
|
|
waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just)
|
|
case waitResult of
|
|
Left () -> fail "System is not generating HealthReports"
|
|
Right _ -> redirect HealthR
|
|
Just (lastUpdated, healthReport) -> do
|
|
rContent <- selectRep $ do
|
|
provideRep $
|
|
siteLayoutMsg MsgHealthReport $ do
|
|
setTitleI MsgHealthReport
|
|
let HealthReport{..} = healthReport
|
|
[whamlet|
|
|
$newline never
|
|
<dl .deflist>
|
|
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
|
|
<dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
|
|
$maybe httpReachable <- healthHTTPReachable
|
|
<dt .deflist__dt>_{MsgHealthHTTPReachable}
|
|
<dd .deflist__dd>#{boolSymbol httpReachable}
|
|
$maybe ldapAdmins <- healthLDAPAdmins
|
|
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
|
|
<dd .deflist__dd>#{textPercent ldapAdmins}
|
|
$maybe smtpConnect <- healthSMTPConnect
|
|
<dt .deflist__dt>_{MsgHealthSMTPConnect}
|
|
<dd .deflist__dd>#{boolSymbol smtpConnect}
|
|
$maybe widgetMemcached <- healthWidgetMemcached
|
|
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
|
|
<dd .deflist__dd>#{boolSymbol widgetMemcached}
|
|
|]
|
|
provideJson healthReport
|
|
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport
|
|
|
|
interval <- getsYesod $ view _appHealthCheckInterval
|
|
expiresAt $ interval `addUTCTime` lastUpdated
|
|
addHeader "Last-Modified" $ formatRFC1123 lastUpdated
|
|
let
|
|
status
|
|
| HealthSuccess <- classifyHealthReport healthReport
|
|
= ok200
|
|
| otherwise
|
|
= internalServerError500
|
|
sendResponseStatus status rContent
|
|
|
|
getInstanceR :: Handler TypedContent
|
|
getInstanceR = do
|
|
instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID
|
|
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
|