feat(users): store first names and titles

messages/uniworx/de.msg

@@ -1239,8 +1239,9 @@ Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * p
 
 CsvColumnsExplanationsLabel: Spalten
 CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten
-CsvColumnExamUserSurname: Nachname des Teilnehmers
+CsvColumnExamUserSurname: Nachname(n) des Teilnehmers
-CsvColumnExamUserName: Voller Name des Teilnehmers (inkl. Nachname)
+CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers
+CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n))
 CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers
 CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
 CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt
@@ -1250,7 +1251,7 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun
 CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Klausurtermin erreichen hätte können
 CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
 CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können
-CsvColumnExamResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
+CsvColumnExamUserResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
 
 Action: Aktion
 

models/users

@@ -16,6 +16,8 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     email          (CI Text)                -- Case-insensitive eMail address
     displayName    Text                     -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
     surname        Text                     -- Display user names always through 'nameWidget displayName surname'
+    firstName      Text                     -- For export in tables, pre-split firstName from displayName
+    title          Text Maybe               -- For upcoming name customisation
     maxFavourites  Int default=12           -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
     theme          Theme default='Default'  -- Color-theme of the frontend; user-defined
     dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined

src/Foundation.hs

@@ -33,6 +33,7 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode)
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as Lazy.ByteString
+import qualified Data.ByteString as ByteString
 
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -2748,7 +2749,9 @@ instance YesodAuth UniWorX where
             userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
             userEmail' = lookup (Attr "mail") ldapData
             userDisplayName' = lookup (Attr "displayName") ldapData
+            userFirstName' = lookup (Attr "givenName") ldapData
             userSurname' = lookup (Attr "sn") ldapData
+            userTitle' = lookup (Attr "title") ldapData
 
             userAuthentication
               | isPWHash  = error "PWHash should only work for users that are already known"
@@ -2767,12 +2770,26 @@ instance YesodAuth UniWorX where
               -> return userDisplayName
             | otherwise
               -> throwError $ ServerError "Could not retrieve user name"
+          userFirstName <- if
+            | Just [bs] <- userFirstName'
+            , Right userFirstName <- Text.decodeUtf8' bs
+              -> return userFirstName
+            | otherwise
+              -> throwError $ ServerError "Could not retrieve user given name"
           userSurname <- if
             | Just [bs] <- userSurname'
             , Right userSurname <- Text.decodeUtf8' bs
               -> return userSurname
             | otherwise
               -> throwError $ ServerError "Could not retrieve user surname"
+          userTitle <- if
+            | maybe True (all ByteString.null) userTitle'
+              -> return Nothing
+            | Just [bs] <- userTitle'
+            , Right userTitle <- Text.decodeUtf8' bs
+              -> return $ Just userTitle
+            | otherwise
+              -> throwError $ ServerError "Could not retrieve user title"
           userMatrikelnummer <- if
             | Just [bs] <- userMatrikelnummer'
             , Right userMatrikelnummer <- Text.decodeUtf8' bs

src/Handler/Exam/Users.hs

@@ -92,6 +92,7 @@ resultExamResult = _dbrOutput . _7 . _Just
 
 data ExamUserTableCsv = ExamUserTableCsv
   { csvEUserSurname :: Maybe Text
+  , csvEUserFirstName :: Maybe Text
   , csvEUserName :: Maybe Text
   , csvEUserMatriculation :: Maybe Text
   , csvEUserField :: Maybe Text
@@ -122,6 +123,7 @@ instance DefaultOrdered ExamUserTableCsv where
 instance CsvColumnsExplained ExamUserTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
     [ ('csvEUserSurname             , MsgCsvColumnExamUserSurname           )
+    , ('csvEUserFirstName           , MsgCsvColumnExamUserFirstName         )
     , ('csvEUserName                , MsgCsvColumnExamUserName              )
     , ('csvEUserMatriculation       , MsgCsvColumnExamUserMatriculation     )
     , ('csvEUserField               , MsgCsvColumnExamUserField             )
@@ -132,7 +134,7 @@ instance CsvColumnsExplained ExamUserTableCsv where
     , ('csvEUserExerciseNumPasses   , MsgCsvColumnExamUserExercisePasses    )
     , ('csvEUserExercisePointsMax   , MsgCsvColumnExamUserExercisePointsMax )
     , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
-    , ('csvEUserExamResult          , MsgCsvColumnExamResult                )
+    , ('csvEUserExamResult          , MsgCsvColumnExamUserResult            )
     ]
 
 data ExamUserAction = ExamUserDeregister
@@ -253,8 +255,6 @@ postEUsersR tid ssh csh examn = do
             ]
           dbtSorting = Map.fromList
             [ sortUserNameLink     queryUser
-            , sortUserSurname      queryUser
-            , sortUserDisplayName  queryUser
             , sortUserMatriclenr   queryUser
             , sortField            queryStudyField
             , sortDegreeShort      queryStudyDegree
@@ -325,6 +325,7 @@ postEUsersR tid ssh csh examn = do
           dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
           dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
             <$> view (resultUser . _entityVal . _userSurname . to Just)
+            <*> view (resultUser . _entityVal . _userFirstName . to Just)
             <*> view (resultUser . _entityVal . _userDisplayName . to Just)
             <*> view (resultUser . _entityVal . _userMatrikelnummer)
             <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
@@ -511,6 +512,7 @@ postEUsersR tid ssh csh examn = do
                     [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
                     , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
                     , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
+                    , (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName
                     ]
                   let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
                         E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse

src/Model/Migration.hs

@@ -16,6 +16,10 @@ import qualified Data.Map as Map
 import Data.Set ()
 import qualified Data.Set as Set
 
+import qualified Data.Text as Text
+
+import qualified Data.Conduit.List as C
+
 import Database.Persist.Sql
 import Database.Persist.Postgresql
 
@@ -61,7 +65,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
 
 migrateAll :: ( MonadLogger m
               , MonadBaseControl IO m
-              , MonadIO m
+              , MonadResource m
               )
            => ReaderT SqlBackend m ()
 migrateAll = do
@@ -86,7 +90,7 @@ migrateAll = do
 requiresMigration :: forall m.
                      ( MonadLogger m
                      , MonadBaseControl IO m
-                     , MonadIO m
+                     , MonadResource m
                      )
                   => ReaderT SqlBackend m Bool
 requiresMigration = mapReaderT (exceptT return return) $ do
@@ -117,7 +121,7 @@ getMissingMigrations :: forall m m'.
                         ( MonadLogger m
                         , MonadBaseControl IO m
                         , MonadIO m
-                        , MonadIO m'
+                        , MonadResource m'
                         )
                      => ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ()))
 getMissingMigrations = do
@@ -134,8 +138,9 @@ getMissingMigrations = do
 -}
 
 
-customMigrations :: ( MonadIO m
+customMigrations :: forall m.
-                    ) => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
+                    MonadResource m
+                 => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
 customMigrations = Map.fromListWith (>>)
   [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
     , whenM (columnExists "user" "theme") $ do -- New theme format
@@ -318,6 +323,24 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|14.0.0|] [version|15.0.0|]
+    , whenM (tableExists "user") $ do
+        [executeQQ|
+          ALTER TABLE "user" ADD COLUMN "first_name" text NOT NULL DEFAULT '';
+          ALTER TABLE "user" ADD COLUMN "title" text DEFAULT null;
+        |]
+        let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] []
+            updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|]
+            splitFirstName :: [PersistValue] -> Maybe (UserId, Text)
+            splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if
+              | Just givenName <- Text.stripSuffix surname displayName
+                              <|> Text.stripPrefix surname displayName
+                -> Text.strip givenName
+              | otherwise
+                -> Text.replace surname "…" displayName
+            splitFirstName _ = Nothing
+        runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser
+    )
   ]
 
 

test/Database.hs

@@ -95,6 +95,8 @@ fillDb = do
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
     , userSurname = "Kleen"
+    , userFirstName = "Gregor Julius Arthur"
+    , userTitle = Nothing
     , userMaxFavourites = 6
     , userTheme = ThemeDefault
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -113,6 +115,8 @@ fillDb = do
     , userEmail  = "felix.hamann@campus.lmu.de"
     , userDisplayName = "Felix Hamann"
     , userSurname = "Hamann"
+    , userFirstName = "Felix"
+    , userTitle = Nothing
     , userMaxFavourites = userDefaultMaxFavourites
     , userTheme = ThemeDefault
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -131,6 +135,8 @@ fillDb = do
     , userEmail  = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
     , userSurname = "Jost"
+    , userFirstName = "Steffen"
+    , userTitle = Just "Dr."
     , userMaxFavourites = 14
     , userTheme = ThemeMossGreen
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -149,6 +155,8 @@ fillDb = do
     , userEmail  = "max@campus.lmu.de"
     , userDisplayName = "Max Musterstudent"
     , userSurname = "Musterstudent"
+    , userFirstName = "Max"
+    , userTitle = Nothing
     , userMaxFavourites = 7
     , userTheme = ThemeAberdeenReds
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -167,6 +175,8 @@ fillDb = do
     , userEmail  = "tester@campus.lmu.de"
     , userDisplayName = "Tina Tester"
     , userSurname = "von Terror"
+    , userFirstName = "Sabrina"
+    , userTitle = Just "Magister"
     , userMaxFavourites = 5
     , userTheme = ThemeAberdeenReds
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -185,6 +195,8 @@ fillDb = do
     , userEmail  = "vaupel.sarah@campus.lmu.de"
     , userDisplayName = "Sarah Vaupel"
     , userSurname = "Vaupel"
+    , userFirstName = "Sarah"
+    , userTitle = Nothing
     , userMaxFavourites = 14
     , userTheme = ThemeMossGreen
     , userDateTimeFormat = userDefaultDateTimeFormat