fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(ldap): migrate more campusUser usages

Browse Source
This commit is contained in:
Sarah Vaupel 2024-01-30 14:01:54 +01:00
parent af09e02801
commit c8350722a4
5 changed files with 17 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Handler/Admin/Ldap.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -16,7 +16,7 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
import Foundation.Yesod.Auth (decodeLdapUserTest,ldapLookupAndUpsert,CampusUserConversionException())
import Handler.Utils
import qualified Ldap.Client as Ldap
@ -36,8 +36,8 @@ postAdminLdapR = do
Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
Just ldapPool -> do
addMessage Info $ text2Html "Input for LDAP test received."
ldapData <- campusUser'' ldapPool campusUserFailoverMode lid
decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
ldapData <- ldapUser'' ldapPool lid
decodedErr <- decodeLdapUserTest (pure $ CI.mk lid) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
mbLdapData <- formResultMaybe presult procFormPerson

5
src/Handler/Utils/Avs.hs
View File

@ -421,7 +421,7 @@ upsertAvsUserById api = do
(_:_) -> throwM $ AvsUserAmbiguous api
[] -> do
upsRes :: Either SomeException (Entity User)
<- try $ ldapLookupAndUpsert persNo
<- try $ ldapLookupAndUpsert persNo -- TODO: do azure lookup and upsert if appropriate
$logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
case upsRes of
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
@ -460,7 +460,8 @@ upsertAvsUserById api = do
, audPinPassword = userPin
, audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
, audIdent = fakeIdent -- use AvsPersonId instead
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
, audAuth = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
, audAzureId = Nothing -- TODO
}
mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
whenIsJust mbUid $ \uid -> runDB $ do

6
src/Handler/Utils/Users.hs
View File

@ -25,7 +25,7 @@ module Handler.Utils.Users
import Import
import Auth.LDAP (ldapUserMatr')
import Foundation.Yesod.Auth (upsertCampusUser)
import Foundation.Yesod.Auth (upsertLdapUser)
import Crypto.Hash (hashlazy)
@ -241,8 +241,8 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
doLdap userMatr = do
ldapPool' <- getsYesod $ view _appLdapPool
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- ldapUserMatr' ldapPool FailoverUnlimited userMatr
for ldapData $ upsertCampusUser UpsertCampusUserGuessUser
ldapData <- ldapUserMatr' ldapPool userMatr
for ldapData $ upsertLdapUser UpsertUserGuessUser
let
getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation

10
src/Jobs/Handler/SynchroniseUserdb.hs
View File

@ -13,7 +13,7 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C
import Auth.LDAP
import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser)
import Foundation.Yesod.Auth (CampusUserConversionException, upsertLdapUser, upsertAzureUser)
import Jobs.Queue
@ -53,14 +53,14 @@ dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do
$logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with LDAP|]
-- reTestAfter <- getsYesod $ view _appUserdbRetestFailover
-- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user
ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user
void . lift $ upsertLdapUser (UpsertLdapUserLdapSync upsertIdent) ldapAttrs
UserSourceConfSingleSource (UserSourceAzure azureConf) ->
ldapAttrs <- MaybeT $ ldapUser ldapConf user
void . lift $ upsertLdapUser (UpsertUserSync upsertIdent) ldapAttrs
UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) ->
runDB . void . runMaybeT . handleExc $ do
user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser
let upsertIdent = maybe userIdent CI.mk userAzurePrimaryKey
$logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|]
void . lift $ upsertAzureUser (UpsertAzureUserSync upsertIdent) azureConf
void . lift $ upsertAzureUser (UpsertUserSync upsertIdent) azureConf
where
handleExc :: MaybeT DB a -> MaybeT DB a
handleExc

3
src/Jobs/HealthReport.hs
View File

@ -123,7 +123,8 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea
Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) ->
let hCampusExc :: CampusUserException -> Handler (Sum Integer)
hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
in handle hCampusExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent [])
in handle hCampusExc $ Sum 1 <$ ldapUser ldapPool (Creds apLdap adminIdent [])
--in handle hCampusExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent [])
if
| numAdmins >= 1 -> return $ numResolved % numAdmins
| otherwise -> return 0