fradrive-old/src/Handler/Health.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Health where

import Import

import Handler.Utils.DateTime (formatTimeW)

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 System.Environment (lookupEnv) -- while git version number is not working

-- 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) -- can this ever happen after it was non-null?
        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'
            | HealthFailure <- status
            = internalServerError500
            | otherwise
            = ok200
      sendResponseStatus status' <=< selectRep $ do
        provideRep . siteLayoutMsg MsgHealthReport $ do
          setTitleI MsgHealthReport
          [whamlet|
            $newline never
            <h2>
              $case status
                $of HealthSuccess
                  _{MsgMessageSuccess}
                $of HealthInactive
                  _{MsgMessageWarning}
                $of _
                  _{MsgMessageError}
            <hr>
            <dl .deflist>
              $forall (lUp, report) <- healthReports'
                $case healthReportStatus report
                  $of HealthInactive
                  $of hcstatus
                    <dt .deflist__dt>
                      _{classifyHealthReport report}
                    <dd .deflist__dd>
                      #{boolSymbol (healthOk hcstatus)} #
                      $case report
                        $of HealthLDAPAdmins (Just found)
                          #{textPercent found 1}  
                        $of HealthActiveJobExecutors (Just active)
                          #{textPercent active 1}
                        $of _
                      <div>
                        ^{formatTimeW SelFormatDateTime lUp}                      
          |]
        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, but it always delivers 200
getStatusR :: Handler Html
getStatusR = do
  starttime <- getsYesod appStartTime
  (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
  -- ft <- formatTime'  "%Y-%m-%d %H:%M:%S" currtime
  withUrlRenderer 
    [hamlet|
      $doctype 5
      <html lang=en>
        <head>        
          <title>Status
        <body>
          $maybe env_ver <- env_version
            <p>
              Environment version #{env_ver}
          <p> 
            Current Time <br> 
            #{show currtime} <br>     
          <p>
            Instance Start <br> 
            #{show starttime} #
            Uptime: #{show $ ddays starttime currtime} days.
          <p>
            Compile Time <br>
            #{show cTime} #
            Build age: #{show $ ddays cTime currtime} days.
    |]
  where 
    -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction  
    cTime :: UTCTime
    cTime = $compileTime

    ddays :: UTCTime -> UTCTime -> Double
    ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)