chore(profile): towards #169

- distinguished reroute icon - profile cleaned/reordered
2024-07-01 16:24:38 +02:00 · 2024-07-01 16:24:38 +02:00 · 6d49ea092b
commit 6d49ea092b
parent d4f3ce7bf3
8 changed files with 187 additions and 194 deletions
--- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg
+++ b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg
@ -28,7 +28,10 @@ ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
 Remarks: Hinweise

 ProfileSupervisor: Übergeordnete Ansprechpartner
+ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden.
 ProfileSupervisee: Ist Ansprechpartner für
+ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand.
+ProfileSuperviseeReroute: Umleitungen erfolgen per 

 UserTelephone: Telefon
 UserMobile: Mobiltelefon
--- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg
+++ b/messages/uniworx/categories/settings/personal_settings/en-eu.msg
@ -28,7 +28,10 @@ ProfileCorrections: List of all assigned corrections
 Remarks: Remarks

 ProfileSupervisor: Supervised by
+ProfileNoSupervisor: Is not supervised by anynone.
 ProfileSupervisee: Supervises
+ProfileNoSupervisee: Does not supervise anynone.
+ProfileSuperviseeReroute: Reroutes reach this supervisor via 

 UserTelephone: Phone
 UserMobile: Mobile
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@ -585,6 +585,42 @@ getForProfileDataR cID = do
    setTitleI $ MsgHeadingForProfileData $ userDisplayName user
    dataWidget

+-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
+-- a poor man's record subsitute
+
+{-
+type TableHasData = (Bool, Widget)
+tableHasRows :: TableHasData -> Bool
+tableHasRows = fst
+tableWidget :: TableHasData -> Widget
+tableWidget  = snd
+-}
+
+maybeTable :: (RenderMessage UniWorX a)
+           => a -> (Bool, Widget) -> Widget
+maybeTable m = maybeTable' m Nothing Nothing
+
+maybeTable' :: (RenderMessage UniWorX a)
+           => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
+-- maybeTable' _   Nothing       _ (False, _ ) = mempty
+-- maybeTable' _   (Just nodata) _ (False, _ ) =
+--   [whamlet|
+--     <div .container>
+--       _{nodata}
+--   |]
+-- maybeTable' hdr _ mbRemark      (True ,tbl) =
+maybeTable' hdr _ mbRemark      (_ ,tbl) =
+  [whamlet|
+    <div .container>
+      <h2> _{hdr}
+      <div .container>
+        ^{tbl}
+        $maybe remark <- mbRemark
+          <em>_{MsgProfileRemark}
+          \ ^{remark}
+  |]
+
+
 makeProfileData :: Entity User -> DB Widget
 makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
  now <- liftIO getCurrentTime
@ -605,25 +641,25 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
      return  (studyfeat, studydegree, studyterms)
  companies <- wgtCompanies uid
-  supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-      E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
-      E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid      
-      E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
-      return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
-  let numSupervisors = length supervisors'
-      supervisors = intersperse (text2widget ", ") $ 
-        (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
-      icnReroute = text2widget " " <> toWgt (icon IconLetter)
-  supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-      E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
-      E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid      
-      return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
-  let numSupervisees = length supervisees'
-      supervisees = intersperse (text2widget ", ") $ 
-        (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
-      -- icnReroute = text2widget " " <> toWgt (icon IconLetter)
+  -- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+  --     E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
+  --     E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
+  --     E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
+  --     return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+  -- let numSupervisors = length supervisors'
+  --     supervisors = intersperse (text2widget ", ") $
+  --       (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
+  --     icnReroute = text2widget " " <> toWgt (icon IconReroute)
+  -- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+  --     E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
+  --     E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
+  --     return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+  -- let numSupervisees = length supervisees'
+  --     supervisees = intersperse (text2widget ", ") $
+  --       (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
+  --     -- icnReroute = text2widget " " <> toWgt (icon IconReroute)
  --Tables
-  (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+  ownedCoursesTable    <- mkOwnedCoursesTable         uid -- Tabelle mit eigenen Kursen
  enrolledCoursesTable <- mkEnrolledCoursesTable      uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
  submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
  submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
@ -631,10 +667,10 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
  qualificationsTable  <- mkQualificationsTable  now  uid -- Tabelle mit allen Qualifikationen
  supervisorsTable     <- mkSupervisorsTable          uid -- Tabelle mit allen Supervisors
  superviseesTable     <- mkSuperviseesTable          uid -- Tabelle mit allen Supervisees
-  let examTable, ownTutorialTable, tutorialTable :: Widget
-      examTable        = i18n MsgPersonalInfoExamAchievementsWip
-      ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
-      tutorialTable    = i18n MsgPersonalInfoTutorialsWip
+  -- let examTable, ownTutorialTable, tutorialTable :: Widget
+  --     examTable        = i18n MsgPersonalInfoExamAchievementsWip
+  --     ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
+  --     tutorialTable    = i18n MsgPersonalInfoTutorialsWip

  cID <- encrypt uid
  mCRoute <- getCurrentRoute
@ -698,7 +734,7 @@ mkOwnedCoursesTable =


 -- | Table listing all courses that the given user is enrolled in
-mkEnrolledCoursesTable :: UserId -> DB Widget
+mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
 mkEnrolledCoursesTable =
  let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
               -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
@ -706,7 +742,7 @@ mkEnrolledCoursesTable =

      validator = def & defaultSorting [SortDescBy "time"]

-  in \uid -> dbTableWidget' validator
+  in \uid -> (_1 %~ getAny) <$> dbTableWidget validator
    DBTable
      { dbtIdent     = "courseMembership" :: Text
      , dbtSQLQuery  = \(course `E.InnerJoin` participant) -> do
@ -750,7 +786,7 @@ mkEnrolledCoursesTable =


 -- | Table listing all submissions for the given user
-mkSubmissionTable :: UserId -> DB Widget
+mkSubmissionTable :: UserId -> DB (Bool, Widget)
 mkSubmissionTable =
  let dbtIdent = "submissions" :: Text
      dbtStyle = def
@ -828,14 +864,10 @@ mkSubmissionTable =
      dbtExtraReps = []
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                  dbtSorting  = dbtSorting'  uid
-              in  dbTableWidget' validator DBTable{..}
--   in do dbtSQLQuery <- dbtSQLQuery'
--         dbtSorting  <- dbtSorting'
--         return $ dbTableWidget' validator $ DBTable {..}
-
+              in   (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}

 -- | Table listing all submissions for the given user
-mkSubmissionGroupTable :: UserId -> DB Widget
+mkSubmissionGroupTable :: UserId -> DB (Bool, Widget)
 mkSubmissionGroupTable =
  let dbtIdent = "subGroups" :: Text
      dbtStyle = def
@ -887,10 +919,10 @@ mkSubmissionGroupTable =
      dbtCsvDecode = Nothing
      dbtExtraReps = []
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator DBTable{..}
+              in  (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}


-mkCorrectionsTable :: UserId -> DB Widget
+mkCorrectionsTable :: UserId -> DB (Bool, Widget)
 mkCorrectionsTable =
  let dbtIdent = "corrections" :: Text
      dbtStyle = def
@ -960,7 +992,7 @@ mkCorrectionsTable =
      dbtCsvDecode = Nothing
      dbtExtraReps = []
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator DBTable{..}
+              in  (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}


 -- | Table listing all qualifications that the given user is enrolled in
@ -1027,8 +1059,8 @@ instance HasUser TblSupervisorData where
  hasUser = _dbrOutput . _1 . _entityVal

 -- | Table listing all supervisor of the given user
-mkSupervisorsTable :: UserId -> DB Widget
-mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
+mkSupervisorsTable :: UserId -> DB (Bool, Widget)
+mkSupervisorsTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..}
  where
    dbtIdent = "userSupervisedBy" :: Text
    dbtStyle = def
@ -1043,8 +1075,8 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
    dbtColonnade = mconcat
        [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR
        , colUserEmail
+        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
        , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
-        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
        , sortable (Just "cshort")      (i18nCell MsgTableCompany)        $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
        , sortable (Just "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
        ]
@ -1068,8 +1100,8 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}


 -- | Table listing all persons supervised by the given user
-mkSuperviseesTable :: UserId -> DB Widget
-mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
+mkSuperviseesTable :: UserId -> DB (Bool, Widget)
+mkSuperviseesTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..}
  where
    dbtIdent = "userSupervisedBy" :: Text
    dbtStyle = def
@ -1084,8 +1116,8 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
    dbtColonnade = mconcat
        [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
        -- , colUserEmail
+        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
        -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
-        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
        , sortable (Just "cshort")      (i18nCell MsgTableCompany)        $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
        , sortable (Just "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
        ]
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@ -128,7 +128,7 @@ postUsersR = do
              return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
            let supervisors = intersperse (text2widget ", ") $
                  (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
-                icnReroute = text2widget " " <> toWgt (icon IconLetter)
+                icnReroute = text2widget " " <> toWgt (icon IconReroute)
            pure $ mconcat supervisors
      , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
      , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -412,6 +412,10 @@ citext2widget t = [whamlet|#{CI.original t}|]
 str2widget :: String -> WidgetFor site ()
 str2widget s = [whamlet|#{s}|]

+-- | hamlet does not like quotes
+spaceWidget :: WidgetFor site ()
+spaceWidget = str2widget " "
+
 int2widget :: Int64 -> WidgetFor site ()
 int2widget i = [whamlet|#{tshow i}|]

--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@ -106,19 +106,21 @@ data Icon
  | IconBlocked
  | IconCertificate
  | IconPrintCenter
-  | IconLetter
+  | IconLetter            -- only to be used for postal matters
  | IconAt
  | IconSupervisor
  | IconSupervisorForeign
+  | IconSuperior          -- supervisor and head of department
  --  IconWaitingForUser
  | IconExpired
  | IconLocked
  | IconUnlocked
-  | IconResetTries -- also see IconReset
+  | IconResetTries        -- also see IconReset
  | IconCompany
  | IconEdit
  | IconUserEdit
-  --  IconMagic      -- indicates automatic updates
+  --  IconMagic           -- indicates automatic updates
+  | IconReroute           -- for notification rerouting

  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
  deriving anyclass (Universe, Finite, NFData)
@ -158,7 +160,7 @@ iconText = \case
    IconSFTHint                 -> "life-ring"          -- for SheetFileType only
    IconSFTSolution             -> "exclamation-circle" -- for SheetFileType only
    IconSFTMarking              -> "check-circle"       -- for SheetFileType only
-    IconEmail                   -> "envelope" -- envelope is no longer unamibuous, use IconAt or IconLetter if email and postal need to be distinguished
+    IconEmail                   -> "envelope" -- envelope is no longer unambiguous, use IconAt or IconLetter if email and postal need to be distinguished
    IconRegisterTemplate        -> "file-alt"
    IconNoCorrectors            -> "user-slash"
    IconRemoveUser              -> "user-slash"
@ -207,6 +209,7 @@ iconText = \case
    IconAt                      -> "at"        -- alternative for IconEmail to distinguish from IconLetter
    IconSupervisor              -> "head-side" -- must be notably different to user
    IconSupervisorForeign       -> "alien"
+    IconSuperior                -> "user-tie"  -- user-crown
    -- IconWaitingForUser          -> "user-cog"  -- Waiting on a user to do something
    IconExpired                 -> "hourglass-end"
    IconLocked                  -> "lock"
@ -216,7 +219,7 @@ iconText = \case
    IconEdit                    -> "edit"
    IconUserEdit                -> "user-edit"
    -- IconMagic                   -> "wand-magic"
-
+    IconReroute                 -> "directions"
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon

@ -316,6 +319,8 @@ iconExamRegister :: Bool -> Markup
 iconExamRegister True  = icon IconExamRegisterTrue
 iconExamRegister False = icon IconExamRegisterFalse

+-- | indicator whether notifications are sent by letter or email
+--   use iconReroute if type of rerouting is unclear
 iconLetterOrEmail :: Bool -> Markup
 iconLetterOrEmail True  = icon IconLetter
 iconLetterOrEmail False = icon IconAt
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@ -114,18 +114,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
          _{MsgCompany}
        <dd .deflist__dd>
          ^{compWgt}
-      $if numSupervisors > 0
-        <dt .deflist__dt>_{MsgProfileSupervisor}
-          $if numSupervisors > 3
-            \ #{numSupervisors}
-        <dd .deflist__dd>
-          ^{mconcat supervisors}
-      $if numSupervisees > 0
-        <dt .deflist__dt>_{MsgProfileSupervisee}
-          $if length supervisees > 3
-            \ #{numSupervisees}
-        <dd .deflist__dd>
-          ^{mconcat supervisees}
      $if showAdminInfo
        <dt .deflist__dt>
          _{MsgUserCreated}
@ -197,67 +185,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
                  $nothing
                    ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
 <section>
-  <div .container>
-    $if hasRowsOwnedCourses
-      <div .container>
-        <h2>_{MsgProfileCourses}
-        <div .container>
-          ^{ownedCoursesTable}

-  <div .container>
-    <h2>_{MsgProfileCourseParticipations}
-    <div .container>
-      ^{enrolledCoursesTable}
+  ^{maybeTable' MsgProfileSupervisor (Just MsgProfileNoSupervisor) Nothing supervisorsTable}
+  
+  ^{maybeTable' MsgProfileSupervisee (Just MsgProfileNoSupervisee) (Just (msg2widget MsgProfileSuperviseeReroute <> toWgt (iconLetterOrEmail userPrefersPostal))) superviseesTable}

  <div .container>
    <h2>_{MsgProfileQualifications}
    <div .container>
      ^{qualificationsTable}

-  <div .container>
-    <h2>_{MsgProfileCourseExamResults}
-    <div .container>
-      ^{examTable}
+  ^{maybeTable MsgProfileCourses ownedCoursesTable}
  
-  <div .container>
-    <h2>_{MsgProfileTutorials}
-    <div .container>
-      ^{ownTutorialTable}
+  ^{maybeTable MsgProfileCourseParticipations enrolledCoursesTable}

-  <div .container>
-    <h2>_{MsgProfileTutorialParticipations}
-    <div .container>
-      ^{tutorialTable}
+  ^{maybeTable MsgProfileSubmissionGroups submissionGroupTable}

-  <div .container>
-    <h2>_{MsgProfileSubmissionGroups}
-    <div .container>
-      ^{submissionGroupTable}
+  ^{maybeTable' MsgProfileSubmissions Nothing (Just (msg2widget MsgProfileGroupSubmissionDates)) submissionTable}
  
-  <div .container>
-    <h2>_{MsgProfileSubmissions}
-    <div .container>
-      ^{submissionTable}
-      <em>_{MsgProfileRemark}
-      \ _{MsgProfileGroupSubmissionDates}
+  ^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable}
  
-  <div .container>
-    <h2> _{MsgTableCorrector}
-    <div .container>
-      ^{correctionsTable}
-
-    <em>_{MsgProfileRemark}
-    \ _{MsgProfileCorrectorRemark}
-    <a href=@{CorrectionsR}>_{MsgProfileCorrections}
-
-  <div .container>
-    <h2> _{MsgProfileSupervisor}
-    <div .container>
-      ^{supervisorsTable}
-
-  <div .container>
-    <h2> _{MsgProfileSupervisee}
-    <div .container>
-      ^{superviseesTable}

 ^{profileRemarks}