From 667677731e25c289e5c12e9cd4ffeb18d33116d8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Tue, 30 Apr 2019 20:18:54 +0200
Subject: [PATCH] healthSMTPConnect

---
 src/Jobs/HealthReport.hs | 25 +++++++++++++++++++++----
 src/Model/Types.hs       | 12 +++++++++++-
 2 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index e54de26e1..1e8cfa4b9 100644
--- a/src/Jobs/HealthReport.hs
+++ b/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
-  <$> matchingClusterConfig
-  <*> httpReachable
-  <*> ldapAdmins
+generateHealthReport
+  = runConcurrently $ HealthReport
+    <$> Concurrently matchingClusterConfig
+    <*> 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
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 8978b16d6..0e0cb2884 100644
--- a/src/Model/Types.hs
+++ b/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