healthSMTPConnect

src/Jobs/HealthReport.hs

@@ -24,12 +24,17 @@ import Auth.LDAP
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Network.HaskellNet.SMTP as SMTP
+import Data.Pool (withResource)
+
 
 generateHealthReport :: Handler HealthReport
-generateHealthReport = HealthReport
+generateHealthReport
-  <$> matchingClusterConfig
+  = runConcurrently $ HealthReport
-  <*> httpReachable
+    <$> Concurrently matchingClusterConfig
-  <*> ldapAdmins
+    <*> Concurrently httpReachable
+    <*> Concurrently ldapAdmins
+    <*> Concurrently smtpConnect
   
 matchingClusterConfig :: Handler Bool
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
@@ -100,3 +105,15 @@ ldapAdmins = do
             \(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

src/Model/Types.hs

@@ -937,6 +937,8 @@ data HealthReport = HealthReport
     -- ^ Proportion of school admins that could be found in LDAP
     --
     -- Is `Nothing` if LDAP is not configured or no users are school admins
+  , healthSMTPConnect :: Maybe Bool
+    -- ^ Can we connect to the SMTP server and say @NOOP@?
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
@@ -944,6 +946,12 @@ deriveJSON defaultOptions
   , omitNothingFields  = True
   } ''HealthReport
 
+-- | `HealthReport` classified (`classifyHealthReport`) by badness
+--
+-- > a < b = a `worseThan` b
+--
+-- Currently all consumers of this type check for @(== HealthSuccess)@; this
+-- needs to be adjusted on a case-by-case basis if new constructors are added
 data HealthStatus = HealthFailure | HealthSuccess
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 
@@ -956,10 +964,12 @@ deriveJSON defaultOptions
 nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
 
 classifyHealthReport :: HealthReport -> HealthStatus
-classifyHealthReport HealthReport{..} = getMin . execWriter $ do
+-- ^ Classify `HealthReport` by badness
+classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point
   unless healthMatchingClusterConfig . tell $ Min HealthFailure
   unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
   unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
+  unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure
 
 
 -- Type synonyms