feat(users): sex

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.

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

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

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

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

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}|]
+        | is _Just mRegistration
-        | otherwise = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
+        , 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

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 :: Bool -> UserCsvExportData -> [Entity Tutorial] -> Csv.Header
-userTableCsvHeader UserCsvExportData{..} tuts = Csv.header $
+userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $
-  [ "name", "matriculation", "email"
+  [ "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
+        dbtSorting   = mconcat
-          [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
+          [ single $ sortUserNameLink    queryUser -- slower sorting through clicking name column header
-          , sortUserSurname     queryUser -- needed for initial sorting
+          , single $ sortUserSurname     queryUser -- needed for initial sorting
-          , sortUserDisplayName queryUser -- needed for initial sorting
+          , single $ sortUserDisplayName queryUser -- needed for initial sorting
-          , sortUserEmail       queryUser
+          , single $ sortUserEmail       queryUser
-          , sortUserMatriclenr  queryUser
+          , single $ sortUserMatriclenr  queryUser
-          , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+          , sortUserSex (to queryUser . to (E.^. UserSex))
-          , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+          , single $ ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
-          , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+          , single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
-          , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+          , single $ ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
-          , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+          , single $ ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
-          , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+          , single $ ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-          , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+          , 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
+          where single = uncurry Map.singleton
-          [ fltrUserNameLink    queryUser
+        dbtFilter    = mconcat
-          , fltrUserEmail       queryUser
+          [ single $ fltrUserNameLink    queryUser
-          , fltrUserMatriclenr  queryUser
+          , single $ fltrUserEmail       queryUser
-          , fltrUserNameEmail   queryUser
+          , single $ fltrUserMatriclenr  queryUser
-          , ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
+          , single $ fltrUserNameEmail   queryUser
-          , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+          , fltrUserSex (to queryUser . to (E.^. UserSex))
-          , ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
+          , single $ ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
-          , ("field"       , FilterColumn $ E.anyFilter
+          , single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
-                                 [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
+          , single $ ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
-                                 , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
+          , single $ ("field"       , FilterColumn $ E.anyFilter
-                                 , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
+                                        [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
-                                 ] )
+                                        , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
-          , ("degree"      , FilterColumn $ E.anyFilter
+                                        , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
-                                 [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
+                                        ] )
-                                 , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
+          , single $ ("degree"      , FilterColumn $ E.anyFilter
-                                 , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
+                                        [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
-                                 ] )
+                                        , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
-          , ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+                                        , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
-          , ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
+                                        ] )
-                E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
+          , single $ ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
-                  E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
+          , single $ ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
-                  E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
+                         E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
-                       E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
+                           E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
-                       E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
+                           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

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

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
+    let colChoices  = mconcat $ catMaybes
-          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , colUserName
+          , pure   colUserName
-          , colUserEmail
+          , guardOn showSex colUserSex'
-          , colUserMatriclenr
+          , pure  colUserEmail
-          , colUserDegreeShort
+          , pure  colUserMatriclenr
-          , colUserField
+          , pure  colUserDegreeShort
-          , colUserSemester
+          , pure  colUserField
+          , pure  colUserSemester
           ]
         psValidator = def
           & defaultSortingByName

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

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
         }

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

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
 

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

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

src/Utils/Form.hs

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

templates/course-user.hamlet

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

templates/i18n/changelog/de.hamlet

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

templates/users.hamlet

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

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

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

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

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