{-# LANGUAGE AllowAmbiguousTypes #-}

module Jobs.HealthReport
  ( generateHealthReport
  ) where

import Import

import Data.List (genericLength)

import qualified Data.Aeson as Aeson
import Data.Proxy (Proxy(..))

import qualified Data.ByteArray as ByteArray

import Utils.Lens

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 Data.Pool (withResource)


generateHealthReport :: Handler HealthReport
generateHealthReport
  = runConcurrently $ HealthReport
    <$> Concurrently matchingClusterConfig
    <*> Concurrently httpReachable
    <*> Concurrently ldapAdmins
    <*> Concurrently smtpConnect
    <*> Concurrently widgetMemcached
  
matchingClusterConfig :: Handler Bool
-- ^ Can the cluster configuration be read from the database and does it match our configuration?
matchingClusterConfig = 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 ClusterClientSessionKey = do
      ourSetting <- getsYesod appSessionKey
      dbSetting <- clusterSetting @'ClusterClientSessionKey
      return $ Just ourSetting == dbSetting
    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
    

    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


httpReachable :: Handler (Maybe Bool)
httpReachable = do
  staticAppRoot <- getsYesod $ view _appRoot
  doHTTP <- getsYesod $ view _appHealthCheckHTTP
  for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> 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


ldapAdmins :: Handler (Maybe Rational)
ldapAdmins = do
  ldapPool' <- getsYesod appLdapPool
  ldapConf' <- getsYesod $ view _appLdapConf
  ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
    E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
    E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
    return $ user E.^. UserIdent
  case (,) <$> ldapPool' <*> ldapConf' of
    Just (ldapPool, ldapConf)
      | not $ null 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 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent [])
          return . Just $ numResolved % numAdmins
    _other -> return Nothing


smtpConnect :: Handler (Maybe Bool)
smtpConnect = 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


widgetMemcached :: Handler (Maybe Bool)
widgetMemcached = do
  memcachedConn <- getsYesod appWidgetMemcached
  for memcachedConn $ \_memcachedConn' -> do
    let ext = "bin"
        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