From 369c2227a036ef3179a651507e720df6350be68c Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Tue, 30 Apr 2019 19:36:43 +0200
Subject: [PATCH] healthLDAPAdmins

---
 src/Handler/Utils/Form.hs  |  1 -
 src/Import/NoFoundation.hs |  4 +++-
 src/Jobs/HealthReport.hs   | 31 +++++++++++++++++++++++++++++++
 src/Model/Types.hs         |  7 ++++++-
 4 files changed, 40 insertions(+), 3 deletions(-)

diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index bc0817d50..94504f1ea 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -37,7 +37,6 @@ import Control.Monad.Trans.Except (throwE, runExceptT)
 import Control.Monad.Writer.Class
 
 import Data.Scientific (Scientific)
-import Data.Ratio
 import Text.Read (readMaybe)
 import Data.Either (partitionEithers)
 
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index d0a4e7fa4..e057be569 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -53,7 +53,7 @@ import Data.List.NonEmpty.Instances as Import ()
 import Data.NonNull.Instances as Import ()
 import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
-import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..))
+import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..))
 import Data.Monoid.Instances  as Import ()
 import Data.Set.Instances     as Import ()
 import Data.HashMap.Strict.Instances as Import ()
@@ -95,6 +95,8 @@ import Time.Types.Instances as Import ()
 
 import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
 
+import Data.Ratio as Import ((%))
+
 
 import Control.Monad.Trans.RWS (RWST)
 
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 2c10b8f82..e54de26e1 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -6,6 +6,8 @@ module Jobs.HealthReport
 
 import Import
 
+import Data.List (genericLength)
+
 import qualified Data.Aeson as Aeson
 import Data.Proxy (Proxy(..))
 
@@ -16,11 +18,18 @@ import Utils.Lens
 import Network.HTTP.Simple (httpJSON)
 import qualified Network.HTTP.Simple as HTTP
 
+import qualified Database.Esqueleto as E
+
+import Auth.LDAP
+
+import qualified Data.CaseInsensitive as CI
+
 
 generateHealthReport :: Handler HealthReport
 generateHealthReport = HealthReport
   <$> matchingClusterConfig
   <*> httpReachable
+  <*> ldapAdmins
   
 matchingClusterConfig :: Handler Bool
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
@@ -58,6 +67,7 @@ matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
         Just (Aeson.Success c) -> return $ Just c
         _other                 -> return Nothing
 
+
 httpReachable :: Handler (Maybe Bool)
 httpReachable = do
   staticAppRoot <- getsYesod $ view _appRoot
@@ -69,3 +79,24 @@ httpReachable = do
           & 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
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index ac780c123..e7834a59f 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -932,7 +932,11 @@ data HealthReport = HealthReport
   , healthHTTPReachable :: Maybe Bool
     -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
     --
-    -- Can be nothing if we don't have a static configuration setting `appRoot` or if check is disabled in settings
+    -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings
+  , healthLDAPAdmins :: Maybe Rational
+    -- ^ Proportion of school admins that could be found in LDAP
+    --
+    -- Is `Nothing` if LDAP is not configured or no users are school admins
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
@@ -955,6 +959,7 @@ classifyHealthReport :: HealthReport -> HealthStatus
 classifyHealthReport HealthReport{..} = getMin . execWriter $ do
   unless healthMatchingClusterConfig . tell $ Min HealthFailure
   unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
+  unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
 
 
 -- Type synonyms