fradrive/src/Jobs/HealthReport.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Jobs.HealthReport
  ( generateHealthReport
  ) where

import Import

import Data.List (genericLength)
import qualified Data.Map.Strict as Map

import qualified Data.Aeson as Aeson

import qualified Data.ByteArray as ByteArray

import Network.HTTP.Simple (httpJSON, httpLBS)
import qualified Network.HTTP.Simple as HTTP

import qualified Database.Esqueleto as E

import Auth.LDAP

import qualified Data.CaseInsensitive as CI

import qualified Network.HaskellNet.SMTP as SMTP
import UnliftIO.Pool (withResource)

import Jobs.Queue

import UnliftIO.Concurrent (myThreadId)


generateHealthReport :: HealthCheck -> Handler HealthReport
generateHealthReport = withHealthReportMetrics . $(dispatchTH ''HealthCheck)

  
dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport
-- ^ Can the cluster configuration be read from the database and does it match our configuration?
dispatchHealthCheckMatchingClusterConfig
  = fmap HealthMatchingClusterConfig . yesodTimeout (^. _appHealthCheckMatchingClusterConfigTimeout) False . runDB $ and <$> forM universeF clusterSettingMatches
  where
    clusterSettingMatches ClusterCryptoIDKey = do
      ourSetting <- getsYesod appCryptoIDKey
      dbSetting <- clusterSetting @'ClusterCryptoIDKey
      return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting
    clusterSettingMatches ClusterServerSessionKey = do
      ourSetting <- getsYesod . preview $ _appSessionStore . _SessionStorageMemcachedSql . _mcdSqlMemcachedKey
      dbSetting <- clusterSetting @'ClusterServerSessionKey
      return $ maybe True ((== dbSetting) . Just) ourSetting
    clusterSettingMatches ClusterSecretBoxKey = do
      ourSetting <- getsYesod appSecretBoxKey
      dbSetting <- clusterSetting @'ClusterSecretBoxKey
      return $ Just ourSetting == dbSetting
    clusterSettingMatches ClusterJSONWebKeySet = do
      ourSetting <- getsYesod appJSONWebKeySet
      dbSetting <- clusterSetting @'ClusterJSONWebKeySet
      return $ Just ourSetting == dbSetting
    clusterSettingMatches ClusterId = do
      ourSetting <- getsYesod appClusterID
      dbSetting <- clusterSetting @'ClusterId
      return $ Just ourSetting == dbSetting
    clusterSettingMatches ClusterMemcachedKey = do
      ourSetting <- getsYesod $ fmap fst . appMemcached
      dbSetting <- clusterSetting @'ClusterMemcachedKey
      return $ maybe True ((== dbSetting) . Just) ourSetting
    

    clusterSetting :: forall key.
                      ( ClusterSetting key
                      )
                   => DB (Maybe (ClusterSettingValue key))
    clusterSetting = do
      current' <- get . ClusterConfigKey $ knownClusterSetting (Proxy @key)
      case Aeson.fromJSON . clusterConfigValue <$> current' of
        Just (Aeson.Success c) -> return $ Just c
        _other                 -> return Nothing


dispatchHealthCheckHTTPReachable :: Handler HealthReport
dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _appHealthCheckHTTPReachableTimeout) (Just False) $ do
  staticAppRoot <- getsYesod $ view _appRoot
  doHTTP <- getsYesod $ view _appHealthCheckHTTP
  for (staticAppRoot <* guard doHTTP) $ \_ -> do
    url <- getUrlRender <*> pure InstanceR
    baseRequest <- HTTP.parseRequest $ unpack url
    httpManager' <- getsYesod appHttpManager
    let httpRequest = baseRequest
          & HTTP.setRequestManager httpManager'
    (clusterId, _ :: InstanceId) <- responseBody <$> httpJSON httpRequest
    getsYesod $ (== clusterId) . appClusterID


dispatchHealthCheckLDAPAdmins :: Handler HealthReport
dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
  ldapPool' <- getsYesod appLdapPool
  reTestAfter <- getsYesod $ view _appLdapReTestFailover
  case ldapPool' of
    Just ldapPool -> do
      ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
        E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
        E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
        E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
        return $ user E.^. UserIdent
      for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
        let numAdmins = genericLength ldapAdminUsers
            hCampusExc :: CampusUserException -> Handler (Sum Integer)
            hCampusExc _ = return $ Sum 0
        Sum numResolved <- fmap fold . forM ldapAdminUsers $
          \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
        return $ numResolved % numAdmins
    _other -> return Nothing


dispatchHealthCheckSMTPConnect :: Handler HealthReport
dispatchHealthCheckSMTPConnect = fmap HealthSMTPConnect . yesodTimeout (^. _appHealthCheckSMTPConnectTimeout) (Just False) $ do
  smtpPool <- getsYesod appSmtpPool
  for smtpPool . flip withResource $ \smtpConn -> do
    response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP
    case rCode of
      250 -> return True
      _   -> do 
        $logErrorS "Mail" $ "NOOP failed: " <> tshow response
        return False


dispatchHealthCheckWidgetMemcached :: Handler HealthReport
dispatchHealthCheckWidgetMemcached = fmap HealthWidgetMemcached . yesodTimeout (^. _appHealthCheckActiveWidgetMemcachedTimeout) (Just False) $ do
  memcachedConn <- getsYesod appWidgetMemcached
  for memcachedConn $ \_memcachedConn' -> do
    let ext :: Text
        ext = "bin"
        mimeType :: Text
        mimeType = "application/octet-stream"
    content <- pack . take 256 <$> liftIO getRandoms
    staticLink <- addStaticContent ext mimeType content
    doHTTP <- getsYesod $ view _appHealthCheckHTTP
    case staticLink of
      _ | not doHTTP -> return True
      Just (Left url) -> do
        baseRequest <- HTTP.parseRequest $ unpack url
        httpManager' <- getsYesod appHttpManager
        let httpRequest = baseRequest
              & HTTP.setRequestManager httpManager'
        (== content) . responseBody <$> httpLBS httpRequest
      _other -> return False
      

dispatchHealthCheckActiveJobExecutors :: Handler HealthReport
dispatchHealthCheckActiveJobExecutors = HealthActiveJobExecutors <$> do
  app <- getYesod
  jState <- atomically . tryReadTMVar $ appJobState app
  let configuredNumber = app ^. _appJobWorkers
      timeoutLength = app ^. _appHealthCheckActiveJobExecutorsTimeout
  case jState of
    Nothing
      | configuredNumber == 0 -> return Nothing
    Nothing -> return $ Just 0
    Just JobState{jobWorkers, jobWorkerName} -> do
      tid <- myThreadId
      let workers' = Map.fromSet jobWorkerName (Map.keysSet jobWorkers)
          workers = Map.filterWithKey (\a _ -> asyncThreadId a /= tid) workers'
      $logDebugS "HealthCheckActiveJobExecutors" . tshow . map showWorkerId $ Map.elems workers'
      responders <- fmap (getSum . fold) . liftIO . forConcurrently (Map.toList workers) $ \(_, wName)
        -> diffTimeout timeoutLength (Sum 0) (runReaderT ?? app $ Sum 1 <$ writeJobCtlBlock' (writeJobCtl' wName) JobCtlTest)
      if
        | Map.null workers -> return Nothing
        | otherwise        -> return . Just $ responders % fromIntegral (Map.size workers)