feat: support for ldap primary keys

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

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

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

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" :|

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' ]
 

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 examTable, ownTutorialTable, tutorialTable :: Widget
-  let ownTutorialTable = [whamlet|_{MsgPersonalInfoOwnTutorialsWip}|]
+      examTable        = i18n MsgPersonalInfoExamAchievementsWip
-  let tutorialTable    = [whamlet|_{MsgPersonalInfoTutorialsWip}|]
+      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")
 

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

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

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

templates/profileData.hamlet

@@ -1,27 +1,49 @@
 $newline never
 <section .profile>
   <dl .deflist.profile-dl>
-      <dt .deflist__dt> _{MsgName}
+      <dt .deflist__dt>
-      <dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
+        _{MsgIdent}
-      $maybe matnr <- userMatrikelnummer
+      <dd .deflist__dd .email>
-        <dt .deflist__dt> _{MsgMatrikelNr}
+        #{userIdent}
-        <dd .deflist__dd> #{matnr}
+      <dt .deflist__dt>
-      <dt .deflist__dt> _{MsgEMail}
+        _{MsgName}
-      <dd .deflist__dd> #{mailtoHtml userEmail}
-      <dt .deflist__dt> _{MsgIdent}
-      <dd .deflist__dd> #{userIdent}
-      <dt .deflist__dt> _{MsgLastLogin}
       <dd .deflist__dd>
-        $maybe llogin <- lastLogin
+        ^{nameWidget userDisplayName userSurname}
-          #{llogin}
+      $maybe matnr <- userMatrikelnummer
-        $nothing
+        <dt .deflist__dt>
-          _{MsgNever}
+          _{MsgMatrikelNr}
+        <dd .deflist__dd>
+          #{matnr}
+      <dt .deflist__dt>
+        _{MsgEMail}
+      <dd .deflist__dd>
+        #{mailtoHtml userEmail}
+      $if showAdminInfo
+        <dt .deflist__dt>
+          _{MsgLastLogin}
+        <dd .deflist__dd>
+          $maybe llogin <- lastLogin
+            #{llogin}
+          $nothing
+            _{MsgNever}
+        <dt .deflist__dt>
+          _{MsgProfileLastLdapSynchronisation}
+        <dd .deflist__dd>
+          $maybe lsync <- lastLdapSync
+            #{lsync}
+          $nothing
+            _{MsgNever}
+        $maybe pKey <- userLdapPrimaryKey
+          <dt .deflist__dt>
+            _{MsgProfileLdapPrimaryKey}
+          <dd .deflist__dd .ldap-primary-key>
+            #{pKey}
     $forall (function, schools) <- Map.toList functions
       <dt .deflist__dt>_{function}
       <dd .deflist__dd>
-        <ul .list-ul>
+        <ul .list--inline .list--iconless .list--comma-separated>
           $forall ssh <- schools
-            <li .list-ul__item>
+            <li>
               #{ssh}
     $if not $ null lecture_corrector
       <dt .deflist__dt>_{MsgProfileCorrector}