fraport/fradrive-old
Archived
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 ] | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
_other -> return res _other -> return res
$logDebugS "auth" $ tshow Creds{..} $logDebugS "auth" $ tshow Creds{..}
ldapPool' <- getsYesod $ view _appLdapPool ldapPool' <- getsYesod $ view _appLdapPool
flip catches excHandlers $ case ldapPool' of flip catches excHandlers $ case ldapPool' of
@ -153,9 +153,9 @@ _upsertCampusUserMode mMode cs@Creds{..}
defaultOther = apHash defaultOther = apHash
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
ldapLookupAndUpsert ident = ldapLookupAndUpsert ident =
getsYesod (view _appLdapPool) >>= \case getsYesod (view _appLdapPool) >>= \case
Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
Just ldapPool -> Just ldapPool ->
campusUser'' ldapPool campusUserFailoverMode ident >>= \case campusUser'' ldapPool campusUserFailoverMode ident >>= \case
@ -188,15 +188,15 @@ upsertCampusUser upsertMode ldapData = do
user@(Entity userId userRec) <- case oldUsers of user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate Just [oldUserId] -> updateGetEntity oldUserId userUpdate
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
unless (validDisplayName (newUser ^. _userTitle) unless (validDisplayName (newUser ^. _userTitle)
(newUser ^. _userFirstName) (newUser ^. _userFirstName)
(newUser ^. _userSurname) (newUser ^. _userSurname)
(userRec ^. _userDisplayName)) $ (userRec ^. _userDisplayName)) $
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] -- update invalid display names only
when (validEmail' (userRec ^. _userEmail)) $ do when (validEmail' (userRec ^. _userEmail)) $ do -- RECALL: userRec already contains basic updates
let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ] ++ [ 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: -- Attempt to update ident, too:
unless (validEmail' (userRec ^. _userIdent)) $ unless (validEmail' (userRec ^. _userIdent)) $
void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) 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 :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
decodeUser now UserDefaultConf{..} upsertMode ldapData = do decodeUser now UserDefaultConf{..} upsertMode ldapData = do
let let
userTelephone = decodeLdap ldapUserTelephone <&> canonicalPhone userTelephone = decodeLdap ldapUserTelephone <&> canonicalPhone
userMobile = decodeLdap ldapUserMobile <&> canonicalPhone userMobile = decodeLdap ldapUserMobile <&> canonicalPhone
@ -266,7 +266,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
-- -> return $ CI.mk userEmail -- -> return $ CI.mk userEmail
| otherwise | otherwise
-> throwM CampusUserInvalidEmail -> throwM CampusUserInvalidEmail
userLdapPrimaryKey <- if userLdapPrimaryKey <- if
| [bs] <- ldapMap !!! ldapPrimaryKey | [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
@ -305,13 +305,13 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
, userPrefersPostal = userDefaultPrefersPostal , userPrefersPostal = userDefaultPrefersPostal
, .. , ..
} }
userUpdate = userUpdate =
[ UserLastAuthentication =. Just now | isLogin ] ++ [ UserLastAuthentication =. Just now | isLogin ] ++
[ UserEmail =. userEmail | validEmail' userEmail ] ++ [ 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 UserFirstName =. userFirstName
, UserSurname =. userSurname , UserSurname =. userSurname
, UserLastLdapSynchronisation =. Just now , UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey , UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile , UserMobile =. userMobile