From c2a83812785e9f8f2ad948a551527df95e24d118 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 14 Oct 2019 15:34:43 +0200 Subject: [PATCH] feat(users): sex --- config/settings.yml | 1 + messages/uniworx/de.msg | 21 +++++- models/users.model | 2 + src/Auth/LDAP.hs | 5 +- src/Foundation.hs | 17 +++++ src/Handler/Course/User.hs | 13 +++- src/Handler/Course/Users.hs | 112 +++++++++++++++++------------ src/Handler/Profile.hs | 4 ++ src/Handler/Tutorial/Users.hs | 18 ++--- src/Handler/Users.hs | 27 +++++++ src/Handler/Users/Add.hs | 4 ++ src/Handler/Utils.hs | 3 + src/Handler/Utils/Table/Columns.hs | 16 +++++ src/Model/Types/Misc.hs | 54 ++++++++++++++ src/Settings.hs | 1 + src/Utils/Form.hs | 1 + templates/course-user.hamlet | 4 ++ templates/i18n/changelog/de.hamlet | 1 + templates/users.hamlet | 4 +- test/Database.hs | 12 ++++ test/Model/TypesSpec.hs | 3 + test/ModelSpec.hs | 1 + test/TestImport.hs | 1 + 23 files changed, 263 insertions(+), 62 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 0e2dbe810..63d2fcd88 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -130,6 +130,7 @@ user-defaults: time-format: "%R" download-files: false warning-days: 1209600 + show-sex: false # During central allocations lecturer-given ratings of applications (as # ExamGrades) are combined with a central priority. diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index dd4410b51..306ac800c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -687,6 +687,7 @@ CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Tite CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Campus-Logins keine Studiengänge ermitteln CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Campus-Logins keine Institute ermitteln +CampusUserInvalidSex: Konnte anhand des Campus-Logins kein Geschlecht ermitteln CorrectorNormal: Normal CorrectorMissing: Abwesend @@ -1559,6 +1560,7 @@ CsvColumnExamUserCourseNote: Notizen zum Teilnehmer CsvColumnUserName: Voller Name des Teilnehmers CsvColumnUserMatriculation: Matrikelnummer des Teilnehmers +CsvColumnUserSex: Geschlecht CsvColumnUserEmail: E-Mail Addresse des Teilnehmers CsvColumnUserStudyFeatures: Alle aktiven Studiendaten des Teilnehmers als Semikolon (;) separierte Liste CsvColumnUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat @@ -1769,7 +1771,9 @@ SchoolExamOffice: Prüfungsamt ApplicationEditTip: Während des Bewerbungszeitraums können eigene Bewerbungen beliebig angepasst und auch wieder zurückgezogen werden. UserLdapSync: LDAP-Synchronisieren +AllUsersLdapSync: Alle LDAP-Synchronisieren SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer" "Benutzern"} angestoßen +SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzern angestoßen UserHijack: Sitzung übernehmen MailSubjectAllocationStaffRegister allocation@AllocationName: Sie können nun Kurse für die Zentralameldung „#{allocation}“ registrieren @@ -1820,6 +1824,7 @@ AdminUserDisplayEmail: Anzeige-E-Mail AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserMatriculation: Matrikelnummer +AdminUserSex: Geschlecht AuthKindLDAP: Campus-Kennung AuthKindPWHash: Uni2work-Kennung UserAdded: Benutzer erfolgreich angelegt @@ -1945,4 +1950,18 @@ CourseEventDeleteQuestion: Wollen Sie den unten aufgeführten Termin wirklich l CourseEventDeleted: Kurstermin erfolgreich gelöscht UserSimplifiedFeaturesOfStudyCsv: Vereinfachte Studiengangsdaten -UserSimplifiedFeaturesOfStudyCsvTip: Sollen Abschluss, Studiengang und Semester zur einfacheren Verarbeitung als separate Spalten exportiert werden? Es wird dann nur jeweils das Fach exportiert, dass der Student bei der Anmeldung ausgewählt hat. \ No newline at end of file +UserSimplifiedFeaturesOfStudyCsvTip: Sollen Abschluss, Studiengang und Semester zur einfacheren Verarbeitung als separate Spalten exportiert werden? Es wird dann nur jeweils das Fach exportiert, dass der Student bei der Anmeldung ausgewählt hat. + +Sex: Geschlecht +SexNotKnown: Unbekannt +SexMale: Männlich +SexFemale: Weiblich +SexNotApplicable: Keine Angabe + +ShortSexNotKnown: unb. +ShortSexMale: m +ShortSexFemale: w +ShortSexNotApplicable: k.A. + +ShowSex: Geschlechter anderer Nutzer anzeigen +ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden? \ No newline at end of file diff --git a/models/users.model b/models/users.model index 86fa7fd9f..216f9ecb8 100644 --- a/models/users.model +++ b/models/users.model @@ -32,6 +32,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos csvOptions CsvOptions "default='{}'::jsonb" + sex Sex Maybe + showSex Bool default=false UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 1ba6af9e7..3538b184d 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -7,7 +7,7 @@ module Auth.LDAP , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName - , ldapUserSchoolAssociation + , ldapUserSchoolAssociation, ldapSex ) where import Import.NoFoundation @@ -59,7 +59,7 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not , Ldap.derefAliases Ldap.DerefAlways ] -ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr +ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex :: Ldap.Attr ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserEmail = Ldap.Attr "mail" ldapUserDisplayName = Ldap.Attr "displayName" @@ -70,6 +70,7 @@ ldapUserTitle = Ldap.Attr "title" ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString" ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" +ldapSex = Ldap.Attr "schacGender" data CampusUserException = CampusUserLdapError LdapPoolError diff --git a/src/Foundation.hs b/src/Foundation.hs index d2d3601fe..13433ea3a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -339,9 +339,13 @@ embedRenderMessage ''UniWorX ''SchoolFunction id embedRenderMessage ''UniWorX ''CsvPreset id embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) embedRenderMessage ''UniWorX ''FavouriteReason id +embedRenderMessage ''UniWorX ''Sex id embedRenderMessage ''UniWorX ''AuthenticationMode id +newtype ShortSex = ShortSex Sex +embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) + newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -3347,6 +3351,7 @@ data CampusUserConversionException | CampusUserInvalidSurname | CampusUserInvalidTitle | CampusUserInvalidMatriculation + | CampusUserInvalidSex | CampusUserInvalidFeaturesOfStudy Text | CampusUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -3366,6 +3371,7 @@ upsertCampusUser ldapData Creds{..} = do userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ] + userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ] userAuthentication | isPWHash = error "PWHash should only work for users that are already known" @@ -3412,6 +3418,16 @@ upsertCampusUser ldapData Creds{..} = do -> return Nothing | otherwise -> throwM CampusUserInvalidMatriculation + userSex <- if + | [bs] <- userSex' + , Right userSex'' <- Text.decodeUtf8' bs + , Just userSex''' <- readMay userSex'' + , Just userSex <- userSex''' ^? iso5218 + -> return $ Just userSex + | [] <- userSex' + -> return Nothing + | otherwise + -> throwM CampusUserInvalidSex let newUser = User @@ -3424,6 +3440,7 @@ upsertCampusUser ldapData Creds{..} = do , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex , userNotificationSettings = def , userMailLanguages = def , userCsvOptions = def diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index fabc5ce6a..95f50f3a9 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -32,7 +32,7 @@ postCUserR tid ssh csh uCId = do -- - User is a tutor for course -- - User is a lecturer for course let currentRoute = CourseR tid ssh csh (CUserR uCId) - dozentId <- requireAuthId + Entity dozentId (userShowSex -> showSex) <- requireAuth uid <- decrypt uCId -- DB reads (cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do @@ -180,8 +180,15 @@ postCUserR tid ssh csh uCId = do -- generate output let headingLong - | is _Just mRegistration = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|] - | otherwise = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|] + | is _Just mRegistration + , Just sex <- guardOn showSex =<< userSex + = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|] + | is _Just mRegistration + = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|] + | Just sex <- guardOn showSex =<< userSex + = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|] + | otherwise + = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|] headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName siteLayout headingLong $ do setTitleI headingShort diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index d70bc1983..4cf536f2e 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -4,7 +4,7 @@ module Handler.Course.Users ( queryUser , makeCourseUserTable , postCUsersR, getCUsersR - , colUserDegreeShort, colUserField, colUserSemester + , colUserDegreeShort, colUserField, colUserSemester, colUserSex' ) where import Import @@ -144,6 +144,9 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) +colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserSex' = colUserSex $ hasUser . _userSex + data UserTableCsvStudyFeature = UserTableCsvStudyFeature { csvUserField :: Text @@ -155,6 +158,7 @@ makeLenses_ ''UserTableCsvStudyFeature data UserTableCsv = UserTableCsv { csvUserName :: Text + , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe Text , csvUserEmail :: CI Email , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature) @@ -167,6 +171,7 @@ makeLenses_ ''UserTableCsv instance Csv.ToNamedRecord UserTableCsv where toNamedRecord UserTableCsv{..} = Csv.namedRecord $ [ "name" Csv..= csvUserName + , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation , "email" Csv..= csvUserEmail ] ++ case csvUserStudyFeatures of @@ -194,6 +199,7 @@ instance Csv.ToNamedRecord UserTableCsv where instance CsvColumnsExplained UserTableCsv where csvColumnsExplanations _ = mconcat [ single "name" MsgCsvColumnUserName + , single "sex" MsgCsvColumnUserSex , single "matriculation" MsgCsvColumnUserMatriculation , single "email" MsgCsvColumnUserEmail , single "study-features" MsgCsvColumnUserStudyFeatures @@ -214,9 +220,11 @@ newtype UserCsvExportData = UserCsvExportData instance Default UserCsvExportData where def = UserCsvExportData True -userTableCsvHeader :: UserCsvExportData -> [Entity Tutorial] -> Csv.Header -userTableCsvHeader UserCsvExportData{..} tuts = Csv.header $ - [ "name", "matriculation", "email" +userTableCsvHeader :: Bool -> UserCsvExportData -> [Entity Tutorial] -> Csv.Header +userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $ + [ "name" ] ++ + [ "sex" | showSex ] ++ + [ "matriculation", "email" ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ @@ -264,6 +272,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand) tutorials <- selectList [ TutorialCourse ==. cid ] [] -- -- psValidator has default sorting and filtering + showSex <- getShowSex let dbtIdent = "courseUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) @@ -276,24 +285,25 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts) dbtColonnade = colChoices - dbtSorting = Map.fromList - [ sortUserNameLink queryUser -- slower sorting through clicking name column header - , sortUserSurname queryUser -- needed for initial sorting - , sortUserDisplayName queryUser -- needed for initial sorting - , sortUserEmail queryUser - , sortUserMatriclenr queryUser - , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) - , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) - , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) - , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) - , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date + dbtSorting = mconcat + [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header + , single $ sortUserSurname queryUser -- needed for initial sorting + , single $ sortUserDisplayName queryUser -- needed for initial sorting + , single $ sortUserEmail queryUser + , single $ sortUserMatriclenr queryUser + , sortUserSex (to queryUser . to (E.^. UserSex)) + , single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) + , single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) + , single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) + , single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) + , single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date E.sub_select . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime ) - , ("tutorials" , SortColumn $ queryUser >>> \user -> + , single $ ("tutorials" , SortColumn $ queryUser >>> \user -> E.sub_select . E.from $ \(tutorial `E.InnerJoin` participant) -> do E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial E.&&. tutorial E.^. TutorialCourse E.==. E.val cid @@ -301,39 +311,44 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do return . E.min_ $ tutorial E.^. TutorialName ) ] - dbtFilter = Map.fromList - [ fltrUserNameLink queryUser - , fltrUserEmail queryUser - , fltrUserMatriclenr queryUser - , fltrUserNameEmail queryUser - , ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) - , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) - , ("field" , FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName) - , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand) - , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) - ] ) - , ("degree" , FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName) - , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand) - , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) - ] ) - , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - , ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion -> - E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) - E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId - ) + where single = uncurry Map.singleton + dbtFilter = mconcat + [ single $ fltrUserNameLink queryUser + , single $ fltrUserEmail queryUser + , single $ fltrUserMatriclenr queryUser + , single $ fltrUserNameEmail queryUser + , fltrUserSex (to queryUser . to (E.^. UserSex)) + , single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) + , single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) + , single $ ("field" , FilterColumn $ E.anyFilter + [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName) + , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand) + , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) + ] ) + , single $ ("degree" , FilterColumn $ E.anyFilter + [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName) + , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand) + , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) + ] ) + , single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion -> + E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) + E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId + ) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO ] - dbtFilterUI mPrev = mconcat + where single = uncurry Map.singleton + dbtFilterUI mPrev = mconcat $ [ fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev - , prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree) + ] ++ + [ fltrUserSexUI mPrev | showSex ] ++ + [ prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree) , prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial) ] @@ -358,6 +373,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userDisplayName) + <*> view (hasUser . _userSex) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userEmail) <*> if @@ -395,7 +411,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials) , dbtCsvName = unpack csvName , dbtCsvNoExportData = Nothing - , dbtCsvHeader = return . Vector.filter csvColumns' . flip userTableCsvHeader tutorials . fromMaybe def + , dbtCsvHeader = return . Vector.filter csvColumns' . flip (userTableCsvHeader showSex) tutorials . fromMaybe def } where userNote = runMaybeT $ do @@ -424,6 +440,7 @@ courseUserDeregisterForm cid = wFormToAForm $ do getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do + showSex <- getShowSex (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh @@ -431,6 +448,7 @@ postCUsersR tid ssh csh = do let colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) + , guardOn showSex $ colUserSex' , pure $ colUserEmail , pure $ colUserMatriclenr , pure $ colUserDegreeShort diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 9487e9b55..fe3319ceb 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -39,6 +39,7 @@ data SettingsForm = SettingsForm , stgTime :: DateTimeFormat , stgDownloadFiles :: Bool , stgWarningDays :: NominalDiffTime + , stgShowSex :: Bool , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings } @@ -96,6 +97,7 @@ makeSettingForm template html = do <*> areq daysField (fslI MsgWarningDays & setTooltip MsgWarningDaysTip ) (stgWarningDays <$> template) + <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template) <* aformSection MsgFormNotifications <*> schoolsForm (stgSchools <$> template) <*> notificationForm (stgNotificationSettings <$> template) @@ -257,6 +259,7 @@ postProfileR = do , stgSchools = userSchools , stgNotificationSettings = userNotificationSettings , stgWarningDays = userWarningDays + , stgShowSex = userShowSex } ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate @@ -273,6 +276,7 @@ postProfileR = do , UserDownloadFiles =. stgDownloadFiles , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings + , UserShowSex =. stgShowSex ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] when (stgDisplayEmail /= userDisplayEmail) $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index b4af46bc7..532c38fd6 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -33,16 +33,18 @@ embedRenderMessage ''UniWorX ''TutorialUserAction id getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do + showSex <- getShowSex (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn - let colChoices = mconcat - [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) - , colUserName - , colUserEmail - , colUserMatriclenr - , colUserDegreeShort - , colUserField - , colUserSemester + let colChoices = mconcat $ catMaybes + [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) + , pure colUserName + , guardOn showSex colUserSex' + , pure colUserEmail + , pure colUserMatriclenr + , pure colUserDegreeShort + , pure colUserField + , pure colUserSemester ] psValidator = def & defaultSortingByName diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index af6339dbc..2d405561e 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -34,6 +34,8 @@ import Data.Aeson hiding (Result(..)) import Handler.Users.Add as Handler.Users +import qualified Data.Conduit.List as C + hijackUserForm :: Form () hijackUserForm csrf = do @@ -54,6 +56,18 @@ instance Finite UserAction nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id + +data AllUsersAction = AllUsersLdapSync + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe AllUsersAction +instance Finite AllUsersAction +nullaryPathPiece ''AllUsersAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''AllUsersAction id + +instance Button UniWorX AllUsersAction where + btnClasses _ = [BCIsButton, BCPrimary] + getUsersR, postUsersR :: Handler Html getUsersR = postUsersR postUsersR = do @@ -213,6 +227,19 @@ postUsersR = do hijackUser uid >>= sendResponse _other -> error "Should not be possible" + ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm + + formResult allUsersRes $ \case + AllUsersLdapSync -> do + runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) + addMessageI Success $ MsgSynchroniseLdapAllUsersQueued + redirect UsersR + let allUsersWgt' = wrapForm allUsersWgt def + { formSubmit = FormNoSubmit + , formAction = Just $ SomeRoute UsersR + , formEncoding = allUsersEnctype + } + defaultLayout $ do setTitleI MsgUserListTitle $(widgetFile "users") diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 9e7ce758b..96fe9e8a7 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -18,6 +18,7 @@ data AdminUserForm = AdminUserForm , aufDisplayName :: UserDisplayName , aufDisplayEmail :: UserEmail , aufMatriculation :: Maybe UserMatriculation + , aufSex :: Maybe Sex , aufEmail :: UserEmail , aufIdent :: UserIdent , aufAuth :: AuthenticationKind @@ -47,6 +48,7 @@ adminUserForm template = renderAForm FormStandard <*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (aufDisplayName <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template) + <*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (aufSex <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP) @@ -72,6 +74,7 @@ postAdminUserAddR = do , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex , userNotificationSettings = def , userMailLanguages = def , userCsvOptions = def @@ -85,6 +88,7 @@ postAdminUserAddR = do , userFirstName = aufFirstName , userSurname = aufSurname , userTitle = aufTitle + , userSex = aufSex , userMatrikelnummer = aufMatriculation , userAuthentication = mkAuthMode aufAuth } diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index ef9c804ee..07ba75a72 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -145,3 +145,6 @@ studyFeaturesWidget featId = do _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} |] + +getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool +getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index ec3f171c0..a5a0f72e2 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -475,6 +475,22 @@ fltrUserNameUI' :: DBFilterUI fltrUserNameUI' mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI MsgUserDisplayName) +colUserSex :: OpticColonnade (Maybe Sex) +colUserSex resultSex = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "user-sex") (i18nCell MsgSex) + body = views resultSex $ maybe mempty i18nCell + +sortUserSex :: OpticSortColumn (Maybe Sex) +sortUserSex querySex = singletonMap "user-sex" . SortColumn $ view querySex + +fltrUserSex :: OpticFilterColumn' t (Set Sex) (E.SqlExpr (E.Value (Maybe Sex))) +fltrUserSex querySex = singletonMap "user-sex" . FilterColumn $ mkExactFilterWith Just (view querySex) + +fltrUserSexUI :: DBFilterUI +fltrUserSexUI mPrev = prismAForm (singletonFilter "user-sex" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler $ selectField optionsFinite :: Field _ Sex) (fslI MsgSex) + + colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 9a11e1379..4dc1c899e 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -22,6 +22,8 @@ import qualified Data.Csv as Csv import qualified Data.Aeson as JSON +import Database.Persist.Sql (PersistFieldSql(..)) + data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) @@ -145,3 +147,55 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } ''FavouriteReason derivePersistFieldJSON ''FavouriteReason + + +data Sex + = SexNotKnown + | SexMale + | SexFemale + | SexNotApplicable + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe Sex +instance Finite Sex +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''Sex +nullaryPathPiece ''Sex $ camelToPathPiece' 1 + +iso5218 :: Integral n => Prism' n Sex +iso5218 = prism' sexToWord sexFromWord + where + sexToWord = \case + SexNotKnown -> 0 + SexMale -> 1 + SexFemale -> 2 + SexNotApplicable -> 9 + sexFromWord = \case + 0 -> Just SexNotKnown + 1 -> Just SexMale + 2 -> Just SexFemale + 9 -> Just SexNotApplicable + _ -> Nothing + +instance PersistField Sex where + toPersistValue = PersistInt64 . review iso5218 + fromPersistValue (PersistInt64 n) + | Just s <- n ^? iso5218 + = Right s + fromPersistValue (PersistDouble (toRational -> n)) + | fromInteger (round n) == n + , Just s <- (round n :: Integer) ^? iso5218 + = Right s + fromPersistValue (PersistRational n) + | fromInteger (round n) == n + , Just s <- (round n :: Integer) ^? iso5218 + = Right s + fromPersistValue x = Left $ "Could not convert “" <> tshow x <> "” to Sex" + +instance PersistFieldSql Sex where + sqlType _ = SqlNumeric 1 0 + +instance Csv.ToField Sex where + toField = Csv.toField . toPathPiece +instance Csv.FromField Sex where + parseField = maybe (fail "Could not parse Field of type Sex") return . fromPathPiece <=< Csv.parseField diff --git a/src/Settings.hs b/src/Settings.hs index 9fc92048b..aeae40ff2 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -175,6 +175,7 @@ data UserDefaultConf = UserDefaultConf , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDownloadFiles :: Bool , userDefaultWarningDays :: NominalDiffTime + , userDefaultShowSex :: Bool } deriving (Show) data PWHashConf = PWHashConf diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 76e7b70e6..eb212bc1a 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -227,6 +227,7 @@ data FormIdentifier | FIDCommunication | FIDAssignSubmissions | FIDUserAuthMode + | FIDAllUsersAction deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/templates/course-user.hamlet b/templates/course-user.hamlet index d4d057f4a..2748e248b 100644 --- a/templates/course-user.hamlet +++ b/templates/course-user.hamlet @@ -1,6 +1,10 @@ +$newline never
+ $maybe sex <- guardOn showSex =<< userSex +
_{MsgSex} +
_{sex}
_{MsgEMail}
#{mailtoHtml userEmail}
_{MsgMatrikelNr} diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index 9f6a0e80a..c31cab31d 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -5,6 +5,7 @@ $newline never
  • Kontrolle über Einstellungen eines Tutoriums kann an Tutoren deligiert werden +
  • Optionale Anzeige des Geschlechts in Teilnehmerlisten u.Ä.
    ^{formatGregorianW 2019 10 10} diff --git a/templates/users.hamlet b/templates/users.hamlet index 65d2d57c7..09e918a5f 100644 --- a/templates/users.hamlet +++ b/templates/users.hamlet @@ -1,2 +1,4 @@ -
    +
    + ^{allUsersWgt'} +
    ^{userList} diff --git a/test/Database.hs b/test/Database.hs index 9bcb32520..62d26c2c7 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -113,6 +113,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userCsvOptions = csvPreset # CsvPresetRFC + , userSex = Just SexMale + , userShowSex = userDefaultShowSex } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" @@ -139,6 +141,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userCsvOptions = csvPreset # CsvPresetExcel + , userSex = Just SexMale + , userShowSex = userDefaultShowSex } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" @@ -164,7 +168,9 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userSex = Just SexMale , userCsvOptions = def + , userShowSex = userDefaultShowSex } maxMuster <- insert User { userIdent = "max@campus.lmu.de" @@ -191,6 +197,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userCsvOptions = def + , userSex = Just SexMale + , userShowSex = userDefaultShowSex } tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" @@ -217,6 +225,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userCsvOptions = def + , userSex = Just SexNotApplicable + , userShowSex = userDefaultShowSex } svaupel <- insert User { userIdent = "vaupel.sarah@campus.lmu.de" @@ -243,6 +253,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userCsvOptions = def + , userSex = Just SexFemale + , userShowSex = userDefaultShowSex } void . repsert (TermKey summer2017) $ Term { termName = summer2017 diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 2aac97b8d..f5f7d2efd 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -275,6 +275,9 @@ instance Arbitrary CsvPreset where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary Sex where + arbitrary = genericArbitrary + spec :: Spec spec = do diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 4df026a92..b6c48bd3d 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -91,6 +91,7 @@ instance Arbitrary User where userSurname <- unwords <$> sublistOf names userFirstName <- unwords <$> sublistOf names userTitle <- fmap (pack . getPrintableString) <$> arbitrary + userSex <- arbitrary userMaxFavourites <- getNonNegative <$> arbitrary userMaxFavouriteTerms <- getNonNegative <$> arbitrary diff --git a/test/TestImport.hs b/test/TestImport.hs index 99cb1f246..b4211b093 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -142,6 +142,7 @@ createUser adjUser = do userCreated = now userLastLdapSynchronisation = Nothing userCsvOptions = def + userSex = Nothing runDB . insertEntity $ adjUser User{..} lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec