chore(ldap): use separate source-id for ldap instance identification

src/Handler/SAP.hs

@@ -100,13 +100,8 @@ getQualificationSAPDirectR = do
   let
     ldapSources = case userAuthConf of
       UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
-        -> [ AuthSourceIdLdap
-             { authSourceIdLdapHost = tshow ldapConfHost -- TODO: ugh... what to do in case of tls?
-             , authSourceIdLdapPort = fromInteger $ toInteger ldapConfPort -- TODO: ugh...
-             }
-           ]
-      _other
-        -> mempty
+        -> singleton $ AuthSourceIdLdap ldapConfSourceId
+      _other -> mempty
     ldapCutoff = addDiffDaysRollOver (fromMonths $ -3) now
 
   qualUsers <- runDB $ E.select $ do

src/Jobs/HealthReport.hs

@@ -110,10 +110,13 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
 dispatchHealthCheckLDAPAdmins :: Handler HealthReport
 dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
   ldapPool' <- getsYesod appLdapPool
---reTestAfter <- getsYesod $ view _appUserdbRetestFailover
+  userAuthConf <- getsYesod $ view _appUserAuthConf
   case ldapPool' of
     Just ldapPool -> do
-      currentLdapSources <- return [] -- TODO: fetch from current user-auth config
+      let currentLdapSources = case userAuthConf of
+            UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
+              -> singleton $ AuthSourceIdLdap ldapConfSourceId
+            _other -> mempty
       ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
         E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
         E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin

src/Model/Types/Auth.hs

@@ -43,7 +43,6 @@ import Data.Universe
 import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
 import Data.UUID (UUID)
-import Data.Word (Word16)
 
 import Database.Persist.Sql
 
@@ -79,8 +78,7 @@ data AuthSourceIdent
     { authSourceIdAzureClientId :: UUID
     }
   | AuthSourceIdLdap
-    { authSourceIdLdapHost :: Text    -- See comment above for why we do not use Ldap.Host directly
-    , authSourceIdLdapPort :: Word16  -- See comment above for why we do not use Ldap.PortNumber directly
+    { authSourceIdLdapHost :: Text -- normally either just the hostname, or hostname and port
     }
   deriving (Eq, Ord, Read, Show, Data, Generic)
   deriving anyclass (NFData)

src/Settings/Ldap.hs

@@ -26,6 +26,7 @@ import Ldap.Client.Instances ()
 data LdapConf = LdapConf
   { ldapConfHost     :: Ldap.Host
   , ldapConfPort     :: Ldap.PortNumber
+  , ldapConfSourceId :: Text -- ^ Some unique identifier for this LDAP instance, e.g. hostname or hostname:port
   , ldapConfDn       :: Ldap.Dn
   , ldapConfPassword :: Ldap.Password
   , ldapConfBase     :: Ldap.Dn
@@ -48,8 +49,12 @@ instance FromJSON LdapConf where
         | null spec          -> return Nothing
       Nothing                -> return Nothing
       _otherwise             -> fail "Could not parse LDAP TLSSettings"
-    ldapConfHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= ""
-    ldapConfPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+    hostname :: Text <- o .: "host"
+    port :: Int <- o .: "port"
+    let
+      ldapConfHost = maybe Ldap.Plain (flip Ldap.Tls) tlsSettings $ show hostname
+      ldapConfPort = fromIntegral port
+    ldapConfSourceId <- o .:? "source-id" .!= hostname
     ldapConfDn <- Ldap.Dn <$> o .:? "user" .!= ""
     ldapConfPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
     ldapConfBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""

templates/profileData.hamlet

@@ -134,7 +134,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
                   $case sourceIdent
                     $of AuthSourceIdAzure _clientId
                       _{MsgAuthKindAzure}: #
-                    $of AuthSourceIdLdap _host _port
+                    $of AuthSourceIdLdap _sourceId
                       _{MsgAuthKindLDAP}: #
                   #{authIdent} #
                   <span .comment>