138 lines
5.2 KiB
Haskell
138 lines
5.2 KiB
Haskell
{-# 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 :: HealthCheck -> Handler HealthReport
|
|
generateHealthReport = $(dispatchTH ''HealthCheck)
|
|
|
|
dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport
|
|
-- ^ Can the cluster configuration be read from the database and does it match our configuration?
|
|
dispatchHealthCheckMatchingClusterConfig
|
|
= fmap HealthMatchingClusterConfig . 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
|
|
|
|
|
|
dispatchHealthCheckHTTPReachable :: Handler HealthReport
|
|
dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> 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 = HealthLDAPAdmins <$> 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
|
|
|
|
|
|
dispatchHealthCheckSMTPConnect :: Handler HealthReport
|
|
dispatchHealthCheckSMTPConnect = HealthSMTPConnect <$> 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 = HealthWidgetMemcached <$> 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
|
|
|