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

feat: support for ldap primary keys

Browse Source
This commit is contained in:
Gregor Kleen 2020-08-28 14:00:26 +02:00
parent fdaad16e71
commit bbfd182ed9
10 changed files with 79 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/de-de-formal.msg
View File

@ -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

3
messages/uniworx/en-eu.msg
View File

@ -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

1
models/users.model
View File

@ -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

5
src/Auth/LDAP.hs
View File

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

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

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

16
src/Handler/Profile.hs
View File

@ -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")

1
src/Handler/Users/Add.hs
View File

@ -81,6 +81,7 @@ postAdminUserAddR = do
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = Nothing
, userLastAuthentication = Nothing
, userEmail = aufEmail
, userDisplayName = aufDisplayName

1
src/Model/Migration.hs
View File

@ -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

3
src/Utils/DB.hs
View File

@ -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

54
templates/profileData.hamlet
View File

@ -1,27 +1,49 @@
$newline never
<section .profile>
<dl .deflist.profile-dl>
<dt .deflist__dt> _{MsgName}
<dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
$maybe matnr <- userMatrikelnummer
<dt .deflist__dt> _{MsgMatrikelNr}
<dd .deflist__dd> #{matnr}
<dt .deflist__dt> _{MsgEMail}
<dd .deflist__dd> #{mailtoHtml userEmail}
<dt .deflist__dt> _{MsgIdent}
<dd .deflist__dd> #{userIdent}
<dt .deflist__dt> _{MsgLastLogin}
<dt .deflist__dt>
_{MsgIdent}
<dd .deflist__dd .email>
#{userIdent}
<dt .deflist__dt>
_{MsgName}
<dd .deflist__dd>
$maybe llogin <- lastLogin
#{llogin}
$nothing
_{MsgNever}
^{nameWidget userDisplayName userSurname}
$maybe matnr <- userMatrikelnummer
<dt .deflist__dt>
_{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}