138 lines
5.1 KiB
Haskell
138 lines
5.1 KiB
Haskell
module Handler.Health where
|
|
|
|
import Import
|
|
|
|
-- import Handler.Utils
|
|
|
|
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
|
|
|
|
import Language.Haskell.TH (stringE,runIO)
|
|
|
|
-- import Data.FileEmbed (embedStringFile)
|
|
|
|
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 .uuid>#{UUID.toText clusterId}
|
|
<dt .deflist__dt>_{MsgInstanceId}
|
|
<dd .deflist__dd .uuid>#{UUID.toText instanceId}
|
|
|]
|
|
provideJson instanceInfo
|
|
provideRep . return $ tshow instanceInfo
|
|
|
|
|
|
-- Most simple page for simple liveness checks
|
|
getStatusR :: Handler Html
|
|
getStatusR = do
|
|
starttime <- getsYesod appStartTime
|
|
currtime <- liftIO getCurrentTime
|
|
-- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime
|
|
withUrlRenderer
|
|
[hamlet|
|
|
$doctype 5
|
|
<html lang=en>
|
|
<head>
|
|
<title>Status
|
|
<body>
|
|
<p>
|
|
Current Time <br>
|
|
#{show currtime} <br>
|
|
<p>
|
|
Instance Start <br>
|
|
#{show starttime} #
|
|
Uptime: #{show $ ddays starttime currtime} days.
|
|
<p>
|
|
Compile Time <br>
|
|
#{comptime} #
|
|
$maybe ctime <- readMay comptime
|
|
Build age: #{show $ ddays ctime currtime} days.
|
|
|]
|
|
where
|
|
-- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
|
|
|
|
comptime :: Text
|
|
comptime = $(stringE =<< runIO (show <$> getCurrentTime))
|
|
|
|
ddays :: UTCTime -> UTCTime -> Double
|
|
ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)
|