From ceed070e35f8ef4decc0afcfc338abbfdb8a46ac Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 26 Jul 2019 11:36:56 +0200 Subject: [PATCH] feat(users): store first names and titles --- messages/uniworx/de.msg | 7 ++++--- models/users | 2 ++ src/Foundation.hs | 17 +++++++++++++++++ src/Handler/Exam/Users.hs | 8 +++++--- src/Model/Migration.hs | 33 ++++++++++++++++++++++++++++----- test/Database.hs | 12 ++++++++++++ 6 files changed, 68 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4d43a6a1e..250ebf672 100644 --- a/messages/uniworx/de.msg +++ b/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 -CsvColumnExamUserName: Voller Name des Teilnehmers (inkl. Nachname) +CsvColumnExamUserSurname: Nachname(n) des Teilnehmers +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 diff --git a/models/users b/models/users index f0b3e683e..33a92adf1 100644 --- a/models/users +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 8e0cb2ae1..f00ac3484 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 3bfecea7c..1b63eab32 100644 --- a/src/Handler/Exam/Users.hs +++ b/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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 755434aa3..743e774e3 100644 --- a/src/Model/Migration.hs +++ b/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 - ) => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) +customMigrations :: forall 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 + ) ] diff --git a/test/Database.hs b/test/Database.hs index 6efa2748b..47aff8610 100755 --- a/test/Database.hs +++ b/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