users have surnames now!

db.hs

@@ -71,6 +71,7 @@ fillDb = do
     , userMatrikelnummer = Nothing
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
+    , userSurname = "Kleen"
     , userMaxFavourites = 6
     , userTheme = ThemeDefault
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -84,6 +85,7 @@ fillDb = do
     , userMatrikelnummer = Nothing
     , userEmail  = "felix.hamann@campus.lmu.de"
     , userDisplayName = "Felix Hamann"
+    , userSurname = "Hamann"
     , userMaxFavourites = userDefaultMaxFavourites
     , userTheme = ThemeDefault
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -97,6 +99,7 @@ fillDb = do
     , userMatrikelnummer = Nothing
     , userEmail  = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
+    , userSurname = "Jost"
     , userMaxFavourites = 14
     , userTheme = ThemeMossGreen
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -110,6 +113,7 @@ fillDb = do
     , userMatrikelnummer = Nothing
     , userEmail  = "max@campus.lmu.de"
     , userDisplayName = "Max Musterstudent"
+    , userSurname = "Musterstudent"
     , userMaxFavourites = 7
     , userTheme = ThemeAberdeenReds
     , userDateTimeFormat = userDefaultDateTimeFormat
@@ -117,6 +121,21 @@ fillDb = do
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
     }
+  void . insert $ Term
+  void . insert $ User
+    { userPlugin = "LDAP"
+    , userIdent  = "tester@campus.lmu.de"
+    , userMatrikelnummer = "999"
+    , userEmail  = "tester@campus.lmu.de"
+    , userDisplayName = "Tina Tester"
+    , userSurname = "von Terror"
+    , userMaxFavourites = 5
+    , userTheme = ThemeAberdeenReds
+    , userDateTimeFormat = userDefaultDateTimeFormat
+    , userDateFormat = userDefaultDateFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
+    }
   void . insert $ Term
     { termName     = summer2017
     , termStart    = fromGregorian 2017 04 09

models

@@ -4,6 +4,7 @@ User json
     matrikelnummer Text Maybe
     email          (CI Text)
     displayName    Text
+    surname        Text
     maxFavourites  Int default=12
     theme          Theme default='Default'
     dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"

src/Foundation.hs

@@ -1177,6 +1177,7 @@ instance YesodAuth UniWorX where
             userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
             userEmail' = lookup (Attr "mail") ldapData
             userDisplayName' = lookup (Attr "displayName") ldapData
+            userSurname' = lookup (Attr "sn") ldapData
 
           userEmail <- if
             | Just [bs] <- userEmail'
@@ -1190,6 +1191,12 @@ instance YesodAuth UniWorX where
               -> return userDisplayName
             | otherwise
               -> throwError $ ServerError "Could not retrieve user name"
+          userSurname <- if
+            | Just [bs] <- userSurname'
+            , Right userSurname <- Text.decodeUtf8' bs
+              -> return userSurname
+            | otherwise
+              -> throwError $ ServerError "Could not retrieve user surname"
           userMatrikelnummer <- if
             | Just [bs] <- userMatrikelnummer'
             , Right userMatrikelnummer <- Text.decodeUtf8' bs

src/Handler/Corrections.hs

@@ -23,6 +23,7 @@ import Import
 
 import Handler.Utils
 import Handler.Utils.Submission
+import Handler.Utils.Table.Cells
 -- import Handler.Utils.Zip
 
 import Data.Set (Set)
@@ -103,7 +104,7 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
 colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
   DBRow{ dbrOutput = (_, _, _, Nothing  , _) } -> cell mempty
-  DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr
+  DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname
 
 colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
@@ -183,7 +184,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do
                        , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
                        )
                      , ( "corrector"
-                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName
+                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
                        )
                      , ( "rating"
                        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints

src/Handler/Utils.hs

@@ -11,6 +11,8 @@ module Handler.Utils
 
 import Import
 
+import qualified Data.Text as T
+
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils
@@ -31,3 +33,15 @@ downloadFiles = do
     Nothing -> do
       AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
       return userDefaultDownloadFiles
+
+
+nameWidget :: Text -> Text -> Widget
+nameWidget displayName surname
+  | null surname = toWidget displayName
+  | otherwise = case reverse $ T.splitOn surname displayName of
+      [_notContained] -> [whamlet|#{displayName} (<b .surname>#{surname}</b>)|]
+      (suffix:prefixes) ->
+        let prefix = T.intercalate surname $ reverse prefixes
+        in [whamlet|#{prefix}<b .surname>#{surname}</b>#{suffix}|]
+      [] -> error "Data.Text.splitOn returned empty list in violation of specification."
+

src/Handler/Utils/Table/Cells.hs

@@ -28,6 +28,9 @@ indicatorCell = mempty & cellContents %~ (tell (Any True) *>)
 timeCell :: IsDBTable m a => UTCTime -> DBCell m a
 timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
 
+userCell :: IsDBTable m a => Text -> Text -> DBCell m a
+userCell displayName surname = cell $ nameWidget displayName surname
+
 -- Just for documentation purposes; inline this code instead:
 maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
 maybeTimeCell = maybe mempty timeCell

src/Model/Migration.hs

@@ -12,6 +12,8 @@ module Model.Migration
 
 import ClassyPrelude.Yesod
 
+import Utils (lastMaybe)
+
 import Model
 import Model.Migration.Version
 import Data.Map (Map)
@@ -153,7 +155,7 @@ customMigrations = Map.fromListWith (>>)
           |]
     )
   , ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|]
-    , whenM (tableExists "sheet_corrector") $ do
+    , whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now.
         correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |]
         forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of
           Just load -> update uid [SheetCorrectorLoad =. load]
@@ -162,6 +164,16 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json;
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|]
+    , whenM (tableExists "user") $ do
+        userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
+        [executeQQ|
+          ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' ';
+        |]
+        forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
+          Just name -> update uid [UserSurname =. name]
+          _other    -> error $ "Empty userDisplayName found"
+    )
   ]