fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(ldap): some minor code cleaning

Browse Source
This commit is contained in:
Steffen Jost 2024-07-30 15:57:43 +02:00
parent 8b0466e74e
commit 6ccbb3b7ff
1 changed files with 14 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/Foundation/Yesod/Auth.hs
View File

@ -107,7 +107,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
_other -> return res
$logDebugS "auth" $ tshow Creds{..}
$logDebugS "auth" $ tshow Creds{..}
ldapPool' <- getsYesod $ view _appLdapPool
flip catches excHandlers $ case ldapPool' of
@ -153,9 +153,9 @@ _upsertCampusUserMode mMode cs@Creds{..}
defaultOther = apHash
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
ldapLookupAndUpsert ident =
getsYesod (view _appLdapPool) >>= \case
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
@ -188,15 +188,15 @@ upsertCampusUser upsertMode ldapData = do
user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
unless (validDisplayName (newUser ^. _userTitle)
unless (validDisplayName (newUser ^. _userTitle)
(newUser ^. _userFirstName)
(newUser ^. _userSurname)
(newUser ^. _userSurname)
(userRec ^. _userDisplayName)) $
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
when (validEmail' (userRec ^. _userEmail)) $ do
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] -- update invalid display names only
when (validEmail' (userRec ^. _userEmail)) $ do -- RECALL: userRec already contains basic updates
let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ]
unless (null emUps) $ update userId emUps
update userId emUps -- update already checks whether list is empty
-- Attempt to update ident, too:
unless (validEmail' (userRec ^. _userIdent)) $
void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
@ -227,7 +227,7 @@ decodeUserTest mbIdent ldapData = do
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
let
userTelephone = decodeLdap ldapUserTelephone <&> canonicalPhone
userMobile = decodeLdap ldapUserMobile <&> canonicalPhone
@ -266,7 +266,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
-- -> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
userLdapPrimaryKey <- if
| [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
@ -305,13 +305,13 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
, userPrefersPostal = userDefaultPrefersPostal
, ..
}
userUpdate =
userUpdate =
[ UserLastAuthentication =. Just now | isLogin ] ++
[ UserEmail =. userEmail | validEmail' userEmail ] ++
[
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 191
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserSurname =. userSurname
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile