diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 1a687b865..640a791f4 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2494,6 +2494,9 @@ StudyTermsDefaultFieldType: Default Typ MenuLanguage: Sprache LanguageChanged: Sprache erfolgreich geändert +ProfileLastLdapSynchronisation: Letzte LDAP-Synchronisation +ProfileLdapPrimaryKey: LDAP-Primärschlüssel + ProfileCorrector: Korrektor ProfileCourses: Eigene Kurse ProfileCourseParticipations: Kursanmeldungen diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index a33b05a8f..372c993ee 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2494,6 +2494,9 @@ StudyTermsDefaultFieldType: Default type MenuLanguage: Language LanguageChanged: Language changed successfully +ProfileLastLdapSynchronisation: Last LDAP synchronisation +ProfileLdapPrimaryKey: LDAP primary key + ProfileCorrector: Corrector ProfileCourses: Own courses ProfileCourseParticipations: Course registrations diff --git a/models/users.model b/models/users.model index 2d18206b3..b3b92e2d3 100644 --- a/models/users.model +++ b/models/users.model @@ -17,6 +17,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create lastAuthentication UTCTime Maybe -- last login date created UTCTime default=now() lastLdapSynchronisation UTCTime Maybe + ldapPrimaryKey Text Maybe tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) firstName Text -- For export in tables, pre-split firstName from displayName diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 57270e2c6..ec0822c0a 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -10,7 +10,7 @@ module Auth.LDAP , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex - , ldapAffiliation + , ldapAffiliation, ldapPrimaryKey ) where import Import.NoFoundation @@ -69,7 +69,7 @@ userSearchSettings LdapConf{..} = mconcat , Ldap.derefAliases Ldap.DerefAlways ] -ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester, ldapAffiliation :: Ldap.Attr +ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester, ldapAffiliation, ldapPrimaryKey :: Ldap.Attr ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserDisplayName = Ldap.Attr "displayName" ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" @@ -82,6 +82,7 @@ ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" ldapSex = Ldap.Attr "schacGender" ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" ldapAffiliation = Ldap.Attr "eduPersonAffiliation" +ldapPrimaryKey = Ldap.Attr "eduPersonPrincipalName" ldapUserEmail :: NonEmpty Ldap.Attr ldapUserEmail = Ldap.Attr "mail" :| diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 0b9455eb0..1c8bd1e61 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -160,6 +160,7 @@ upsertCampusUser upsertMode ldapData = do let userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ] userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ] + userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ] userEmail' = fold $ do k' <- toList ldapUserEmail (k, v) <- ldapData @@ -236,6 +237,13 @@ upsertCampusUser upsertMode ldapData = do -> return Nothing | otherwise -> throwM CampusUserInvalidSex + userLdapPrimaryKey <- if + | [bs] <- userLdapPrimaryKey' + , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs + , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' + -> return $ Just userLdapPrimaryKey''' + | otherwise + -> return Nothing let newUser = User @@ -266,10 +274,15 @@ upsertCampusUser upsertMode ldapData = do , UserEmail =. userEmail , UserSex =. userSex , UserLastLdapSynchronisation =. Just now + , UserLdapPrimaryKey =. userLdapPrimaryKey ] ++ [ UserLastAuthentication =. Just now | isLogin ] - user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate + oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] + + user@(Entity userId userRec) <- case oldUsers of + Just [oldUserId] -> updateGetEntity oldUserId userUpdate + _other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ update userId [ UserDisplayName =. userDisplayName' ] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 1f4aa9606..04518240d 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -373,7 +373,8 @@ getProfileDataR :: Handler Html getProfileDataR = do userEnt <- requireAuth dataWidget <- runDB $ makeProfileData userEnt - defaultLayout + defaultLayout $ do + setTitleI MsgMenuProfileData dataWidget makeProfileData :: Entity User -> DB Widget @@ -396,10 +397,17 @@ makeProfileData (Entity uid User{..}) = do submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben - let examTable = [whamlet|_{MsgPersonalInfoExamAchievementsWip}|] - let ownTutorialTable = [whamlet|_{MsgPersonalInfoOwnTutorialsWip}|] - let tutorialTable = [whamlet|_{MsgPersonalInfoTutorialsWip}|] + let examTable, ownTutorialTable, tutorialTable :: Widget + examTable = i18n MsgPersonalInfoExamAchievementsWip + ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip + tutorialTable = i18n MsgPersonalInfoTutorialsWip lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication + lastLdapSync <- traverse (formatTime SelFormatDateTime) userLastLdapSynchronisation + + cID <- encrypt uid + mCRoute <- getCurrentRoute + showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) + let profileRemarks = $(i18nWidgetFile "profile-remarks") return $(widgetFile "profileData") diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index bcdd889ce..ab7364388 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -81,6 +81,7 @@ postAdminUserAddR = do , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Nothing + , userLdapPrimaryKey = Nothing , userLastAuthentication = Nothing , userEmail = aufEmail , userDisplayName = aufDisplayName diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 6b74de437..711fffde2 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -159,6 +159,7 @@ migrateManual = do , ("user_lower_ident", "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))" ) , ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" ) , ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" ) + , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) ] where addIndex :: Text -> Sql -> Migration diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 08a70924e..6847ea0cf 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -78,6 +78,9 @@ updateBy uniq updates = do key <- getKeyBy uniq for_ key $ flip update updates +updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record) +updateGetEntity k = fmap (Entity k) . updateGet k + -- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible, -- and 'Just key' for the successfully replaced record uniqueReplace :: ( MonadIO m diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 231082dbc..42a61bcba 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -1,27 +1,49 @@ $newline never
-
_{MsgName} -
^{nameWidget userDisplayName userSurname} - $maybe matnr <- userMatrikelnummer -
_{MsgMatrikelNr} -
#{matnr} -
_{MsgEMail} -
#{mailtoHtml userEmail} -
_{MsgIdent} -
#{userIdent} -
_{MsgLastLogin} +
+ _{MsgIdent} +
+ #{userIdent} +
+ _{MsgName}
- $maybe llogin <- lastLogin - #{llogin} - $nothing - _{MsgNever} + ^{nameWidget userDisplayName userSurname} + $maybe matnr <- userMatrikelnummer +
+ _{MsgMatrikelNr} +
+ #{matnr} +
+ _{MsgEMail} +
+ #{mailtoHtml userEmail} + $if showAdminInfo +
+ _{MsgLastLogin} +
+ $maybe llogin <- lastLogin + #{llogin} + $nothing + _{MsgNever} +
+ _{MsgProfileLastLdapSynchronisation} +
+ $maybe lsync <- lastLdapSync + #{lsync} + $nothing + _{MsgNever} + $maybe pKey <- userLdapPrimaryKey +
+ _{MsgProfileLdapPrimaryKey} +
+ #{pKey} $forall (function, schools) <- Map.toList functions
_{function}
-
    +
      $forall ssh <- schools -
    • +
    • #{ssh} $if not $ null lecture_corrector
      _{MsgProfileCorrector}