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

feat(users): sex

Browse Source
This commit is contained in:
Gregor Kleen 2019-10-14 15:34:43 +02:00
parent 66460487f5
commit c2a8381278
23 changed files with 263 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
config/settings.yml
View File

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

21
messages/uniworx/de.msg
View File

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

2
models/users.model
View File

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

5
src/Auth/LDAP.hs
View File

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

17
src/Foundation.hs
View File

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

13
src/Handler/Course/User.hs
View File

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

112
src/Handler/Course/Users.hs
View File

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

4
src/Handler/Profile.hs
View File

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

18
src/Handler/Tutorial/Users.hs
View File

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

27
src/Handler/Users.hs
View File

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

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

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

3
src/Handler/Utils.hs
View File

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

16
src/Handler/Utils/Table/Columns.hs
View File

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

54
src/Model/Types/Misc.hs
View File

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

1
src/Settings.hs
View File

@ -175,6 +175,7 @@ data UserDefaultConf = UserDefaultConf
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
, userDefaultDownloadFiles :: Bool
, userDefaultWarningDays :: NominalDiffTime
, userDefaultShowSex :: Bool
} deriving (Show)
data PWHashConf = PWHashConf

1
src/Utils/Form.hs
View File

@ -227,6 +227,7 @@ data FormIdentifier
| FIDCommunication
| FIDAssignSubmissions
| FIDUserAuthMode
| FIDAllUsersAction
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where

4
templates/course-user.hamlet
View File

@ -1,6 +1,10 @@
$newline never
<section>
<div .profile>
<dl .deflist.profile-dl>
$maybe sex <- guardOn showSex =<< userSex
<dt .deflist__dt> _{MsgSex}
<dd .deflist__dd> _{sex}
<dt .deflist__dt> _{MsgEMail}
<dd .deflist__dd> #{mailtoHtml userEmail}
<dt .deflist__dt> _{MsgMatrikelNr}

1
templates/i18n/changelog/de.hamlet
View File

@ -5,6 +5,7 @@ $newline never
<dd .deflist__dd>
<ul>
<li>Kontrolle über Einstellungen eines Tutoriums kann an Tutoren deligiert werden
<li>Optionale Anzeige des Geschlechts in Teilnehmerlisten u.Ä.
<dt .deflist__dt>
^{formatGregorianW 2019 10 10}

4
templates/users.hamlet
View File

@ -1,2 +1,4 @@
<div .ui.container>
<section>
^{allUsersWgt'}
<section>
^{userList}

12
test/Database.hs
View File

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

3
test/Model/TypesSpec.hs
View File

@ -275,6 +275,9 @@ instance Arbitrary CsvPreset where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Sex where
arbitrary = genericArbitrary
spec :: Spec
spec = do

1
test/ModelSpec.hs
View File

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

1
test/TestImport.hs
View File

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