From 5f65e68b26b3c1125cb34361ece25f7ba20d3111 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 26 Aug 2022 11:54:43 +0200 Subject: [PATCH] refactor(ldap): completed refactoring, userDisplayName no longer contains a comma --- src/Foundation/Yesod/Auth.hs | 152 +++++++++++++---------------------- 1 file changed, 56 insertions(+), 96 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index de23399eb..675fe7cce 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -157,29 +157,34 @@ upsertCampusUser upsertMode ldapData = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults let - ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] + ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) - userEmail' :: [Ldap.AttrValue] - userEmail' = lookupSome ldapMap $ toList ldapUserEmail - userLdapPrimaryKey' :: [Ldap.AttrValue] -- ~ [ByteString] - userLdapPrimaryKey' = ldapMap !!! ldapPrimaryKey - userIdent'' = ldapMap !!! ldapUserPrincipalName - userDisplayName'' = ldapMap !!! ldapUserDisplayName - -- userFirstName' = ldapMap !!! ldapUserFirstName - userSurname' = ldapMap !!! ldapUserSurname - userTitle' = ldapMap !!! ldapUserTitle - userTelephone' = ldapMap !!! ldapUserTelephone - userMobile' = ldapMap !!! ldapUserMobile - userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer - userFraportAbteilung' = ldapMap !!! ldapUserFraportAbteilung - -- TODO: continue here - -- decodeLdap1 :: (Exception e) => Ldap.Attr -> e -> m Text + -- only accept a single result, throw error otherwise + -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text decodeLdap1 attr err | [bs] <- ldapMap !!! attr , Right t <- Text.decodeUtf8' bs = return t - | otherwise = throwM err + | otherwise = throwM err + + -- accept any successful decoding or empty; only throw an error if all decodings fail + -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text + decodeLdap' attr err + | [] <- vs = return Nothing + | (h:_) <- rights vs = return $ Just h + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> ldapMap !!! attr + + -- just returns Nothing on error, pure + decodeLdap :: Ldap.Attr -> Maybe Text + decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr + + userTelephone = decodeLdap ldapUserTelephone + userMobile = decodeLdap ldapUserMobile + userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer + userCompanyDepartment = decodeLdap ldapUserFraportAbteilung userAuthentication | is _UpsertCampusUserLoginOther upsertMode @@ -189,7 +194,7 @@ upsertCampusUser upsertMode ldapData = do isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode userIdent <- if - | [bs] <- userIdent'' + | [bs] <- ldapMap !!! ldapUserPrincipalName , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode -> return userIdent' @@ -197,66 +202,21 @@ upsertCampusUser upsertMode ldapData = do -> return userIdent' | otherwise -> throwM CampusUserInvalidIdent + userEmail <- if - | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail' + | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName - --userFirstName <- if - -- | [bs] <- userFirstName' - -- , Right userFirstName <- Text.decodeUtf8' bs - -- -> return userFirstName - -- | otherwise - -- -> throwM CampusUserInvalidGivenName - userSurname <- if - | [bs] <- userSurname' - , Right userSurname <- Text.decodeUtf8' bs - -> return userSurname - | otherwise - -> throwM CampusUserInvalidSurname - userTitle <- if - | [] <- userTitle' - -> return Nothing - | [bs] <- userTitle' - , Right userTitle <- Text.decodeUtf8' bs - -> return $ Just userTitle - | otherwise - -> throwM CampusUserInvalidTitle - userDisplayName' <- if - | [bs] <- userDisplayName'' - , Right userDisplayName1 <- Text.decodeUtf8' bs - , Just userDisplayName2 <- checkDisplayName userTitle userFirstName userSurname userDisplayName1 - -> return userDisplayName2 - | otherwise - -> throwM CampusUserInvalidDisplayName - userTelephone <- if - | [bs] <- userTelephone' - , Right userTelephone <- Text.decodeUtf8' bs - -> return $ Just userTelephone - | otherwise - -> return Nothing - userMobile <- if - | [bs] <- userMobile' - , Right userMobile <- Text.decodeUtf8' bs - -> return $ Just userMobile - | otherwise - -> return Nothing - userCompanyPersonalNumber <- if - | [bs] <- userFraportPersonalnummer' - , Right dt <- Text.decodeUtf8' bs - -> return $ Just dt - | otherwise - -> return Nothing - userCompanyDepartment <- if - | [bs] <- userFraportAbteilung' - , Right dt <- Text.decodeUtf8' bs - -> return $ Just dt - | otherwise - -> return Nothing + userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname + userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle + + userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= + (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) userLdapPrimaryKey <- if - | [bs] <- userLdapPrimaryKey' + | [bs] <- ldapMap !!! ldapPrimaryKey , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' -> return $ Just userLdapPrimaryKey''' @@ -265,33 +225,33 @@ upsertCampusUser upsertMode ldapData = do let newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userSex = Nothing - , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced - , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Just now - , userDisplayName = userDisplayName' - , userDisplayEmail = userEmail - , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userPrefersPostal = False + { userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userSex = Nothing + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + , userNotificationSettings = def + , userLanguages = Nothing + , userCsvOptions = def + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Just now + , userDisplayName = userDisplayName' + , userDisplayEmail = userEmail + , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO + , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO + , userPrefersPostal = False , .. } userUpdate = [ - -- UserDisplayName =. userDisplayName -- never updated, since users are allowed to change their DisplayName + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 UserFirstName =. userFirstName , UserSurname =. userSurname , UserEmail =. userEmail @@ -309,7 +269,7 @@ upsertCampusUser upsertMode ldapData = do user@(Entity userId userRec) <- case oldUsers of Just [oldUserId] -> updateGetEntity oldUserId userUpdate _other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate - unless (validDisplayName Nothing userFirstName userSurname $ userDisplayName userRec) $ + unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ update userId [ UserDisplayName =. userDisplayName' ] let