From 8e2a98c12b7e2d8d8a00080f5b96d5a3fe3e7124 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <sarah.vaupel@uniworx.de>
Date: Tue, 30 Jan 2024 11:42:45 +0100
Subject: [PATCH] chore(foundation): fix ldap auth and user lookup

---
 src/Foundation/Yesod/Auth.hs | 36 ++++++++++++++++++------------------
 1 file changed, 18 insertions(+), 18 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 541cf7857..9d0ffeed8 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -4,11 +4,11 @@
 
 module Foundation.Yesod.Auth
   ( authenticate
-  -- , ldapLookupAndUpsert
+  , ldapLookupAndUpsert
   , upsertLdapUser, upsertAzureUser
   , decodeLdapUserTest, decodeAzureUserTest
   , CampusUserConversionException(..)
-  , campusUserFailoverMode, updateUserLanguage
+  , updateUserLanguage
   ) where
 
 import Import.NoFoundation hiding (authenticate)
@@ -36,7 +36,6 @@ import qualified Data.Text.Encoding as Text
 import qualified Data.ByteString as ByteString
 import qualified Data.Set as Set
 import qualified Data.Map as Map
-import qualified Data.List.PointedList as PointedList
 import qualified Data.UUID as UUID
 
 
@@ -110,10 +109,8 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
     UserSourceConfSingleSource (UserSourceLdap _)
       | Just upsertMode' <- upsertMode -> do
-          -- TODO WIP
           ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
-          ldapConf <- mkFailover $ PointedList.singleton ldapPool
-          ldapData <- ldapUser ldapConf FailoverNone Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
+          ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
           $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData
           Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData
     _other
@@ -158,15 +155,21 @@ _upsertUserMode mMode cs@Creds{..}
     defaultOther = apHash
 
 
--- TODO: rewrite
--- ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
--- ldapLookupAndUpsert ident = 
---   getsYesod (view _appLdapPool) >>= \case 
---     Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
---     Just ldapPool ->
---       campusUser'' ldapPool campusUserFailoverMode ident >>= \case
---         Nothing -> throwM CampusUserNoResult
---         Just ldapResponse -> upsertLdapUser UpsertCampusUserGuessUser ldapResponse
+ldapLookupAndUpsert :: forall m.
+                       ( MonadHandler m
+                       , HandlerSite m ~ UniWorX
+                       , MonadMask m
+                       , MonadUnliftIO m
+                       )
+                    => Text
+                    -> SqlPersistT m (Entity User)
+ldapLookupAndUpsert ident = 
+  getsYesod (view _appLdapPool) >>= \case 
+    Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
+    Just ldapPool ->
+      ldapUser'' ldapPool ident >>= \case
+        Nothing -> throwM CampusUserNoResult
+        Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse
 
 
 -- | Upsert User DB according to given LDAP data (does not query LDAP itself)
@@ -579,7 +582,4 @@ updateUserLanguage Nothing = runMaybeT $ do
   setRegisteredCookie CookieLang lang
   return lang
 
-campusUserFailoverMode :: FailoverMode
-campusUserFailoverMode = FailoverUnlimited
-
 embedRenderMessage ''UniWorX ''CampusUserConversionException id