From 6098d4554d1b1737185d7ec8caa903afad9600c9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Feb 2023 15:32:41 +0100 Subject: [PATCH] chore(qualifications): supervisor page finished with sorting and infos --- .../categories/qualification/de-de-formal.msg | 3 + .../categories/qualification/en-eu.msg | 3 + src/Foundation/I18n.hs | 16 +++++ src/Handler/Qualification.hs | 70 +++++++++++-------- src/Handler/Utils/Table/Cells.hs | 5 ++ test/Database/Fill.hs | 4 +- 6 files changed, 70 insertions(+), 31 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 7be390ddd..6901a104d 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -22,6 +22,7 @@ TableQualificationLastRefresh: Zuletzt erneuert TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Suspendiert TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? +TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? TableQualificationNoRenewal: Storniert TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus @@ -40,6 +41,8 @@ TableLmsNotified: Versand Benachrichtigung TableLmsNotifiedTooltip: Benachrichtigungen werden erst versendet wenn das LMS bestätigt die Eröffnung des E-Learning für den Benutzer bestätigt hat, was ein paar Stunden dauern kann! TableLmsEnded: Beended TableLmsStatus: Status E-Learning +TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt an, seit wann ein E-Learning offen ist oder wann es mit Bestanden oder Durchgefalen abgeschlossen wurde. #{maybeToMessage "Anzeige erlischt " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss."} +TableLmsStatusDay: Datum letzte Statusänderung E-Learning TableLmsSuccess: Bestanden TableLmsFailed: Gesperrt FilterLmsValid: Aktuell gültig diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 6ca8734a7..83acfaf45 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -22,6 +22,7 @@ TableQualificationLastRefresh: Last renewed TableQualificationFirstHeld: First held TableQualificationBlockedDue: Suspended TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? +TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? TableQualificationNoRenewal: Canceled TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. QualificationUserNoRenewal: Expires without further notification @@ -40,6 +41,8 @@ TableLmsNotified: Notification sent TableLmsNotifiedTooltip: Notfications are not sent before the LMS acknowledges the opening of the e-learning course for the user, which may take several hours! TableLmsEnded: Ended TableLmsStatus: Status e-learning +TableLmsStatusTooltip mbMonth: Shows since when an e-learning is open or when it was closed, including the result. #{maybeToMessage "Shown for " (fmap (flip pluralENsN "month") mbMonth) " after closure."} +TableLmsStatusDay: Date of last e-learning status change TableLmsSuccess: Completed TableLmsFailed: Blocked FilterLmsValid: Currently valid diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index bca3c6b87..bab0c1d3a 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -79,6 +79,22 @@ pluralDE num singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm +-- pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text +-- -- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ +-- pluralDEx c n t = pluralDE n t $ t `snoc` c + +-- -- | like `pluralDEe` but also prefixes with the number +-- pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text +-- pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t) + +pluralDEe :: (Eq a, Num a) => a -> Text -> Text +-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ +pluralDEe n t = pluralDE n t $ t `snoc` 'e' + +-- | like `pluralDEe` but also prefixes with the number +pluralDEeN :: (Eq a, Num a, Show a) => a -> Text -> Text +pluralDEeN n t = tshow n <> cons ' ' (pluralDEe n t) + noneOneMoreDE :: (Eq a, Num a) => a -- ^ Count -> Text -- ^ None diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index d700aff73..0f274f3f2 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -151,26 +151,26 @@ mkQualificationAllTable = do -- postQualificationEditR = error "TODO" data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. - { qtcDisplayName :: UserDisplayName - , qtcEmail :: UserEmail - , qtcValidUntil :: Day - , qtcLastRefresh :: Day - , qtcBlocked :: Maybe Day - , qtcLmsStarted :: Maybe UTCTime - , qtcLmsStatus :: Maybe LmsStatus + { qtcDisplayName :: UserDisplayName + , qtcEmail :: UserEmail + , qtcValidUntil :: Day + , qtcLastRefresh :: Day + , qtcBlocked :: Maybe Day + , qtcLmsStatusTxt :: Maybe Text + , qtcLmsStatusDay :: Maybe Day } deriving Generic makeLenses_ ''QualificationTableCsv qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv - { qtcDisplayName = "Max Mustermann" - , qtcEmail = "m.mustermann@example.com" - , qtcValidUntil = compDay - , qtcLastRefresh = compDay - , qtcBlocked = Nothing - , qtcLmsStarted = Just compTime - , qtcLmsStatus = Nothing + { qtcDisplayName = "Max Mustermann" + , qtcEmail = "m.mustermann@example.com" + , qtcValidUntil = compDay + , qtcLastRefresh = compDay + , qtcBlocked = Nothing + , qtcLmsStatusTxt = Just "Success" + , qtcLmsStatusDay = Just compDay } where compTime :: UTCTime @@ -199,8 +199,8 @@ instance CsvColumnsExplained QualificationTableCsv where , ('qtcEmail , MsgTableLmsEmail) , ('qtcValidUntil , MsgLmsQualificationValidUntil) , ('qtcLastRefresh, MsgTableQualificationLastRefresh) - , ('qtcLmsStarted , MsgLmsStarted) - , ('qtcLmsStatus , MsgTableLmsStatus) + , ('qtcLmsStatusTxt, MsgTableLmsStatus) + , ('qtcLmsStatusDay, MsgTableLmsStatusDay) ] @@ -295,8 +295,10 @@ mkQualificationTable (Entity qid quali) acts cols psValidator = do , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) - , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) - , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) + -- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) + -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) + , single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" + , queryLmsUser row E.?. LmsUserStarted]) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -330,11 +332,20 @@ mkQualificationTable (Entity qid quali) acts cols psValidator = do <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userEmail) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) - <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) - -- <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue . _qualificationBlockedDay) + <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) - <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) + <*> getStatusPlusTxt + <*> getStatusPlusDay + getStatusPlusTxt = + (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case + Just LmsBlocked{} -> return $ Just "Failed" + Just LmsSuccess{} -> return $ Just "Success" + Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ + preview (resultLmsUser . _entityVal . _lmsUserStarted) + getStatusPlusDay = + (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case + Just ls -> return $ Just $ lmsStatusDay ls + Nothing -> utctDay <<$>> preview (resultLmsUser . _entityVal . _lmsUserStarted) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -369,7 +380,7 @@ getQualificationR = postQualificationR postQualificationR sid qsh = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do - qent <- getBy404 $ SchoolQualificationShort sid qsh + qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat [ singletonMap QualificationActExpire $ pure QualificationActExpireData @@ -381,14 +392,15 @@ postQualificationR sid qsh = do , colUserEmail , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue -- & cellTooltip MsgTableQualificationBlockedTooltip - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> d) -> foldMap (dayCell . qualificationBlockedDay) d + , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple + ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCellNoReason b , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) - $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d - , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status - , sortable Nothing (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu + -- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) + -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d + -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status + , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltip (MsgTableLmsStatusTooltip auditMonths)) + $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu ] psValidator = def tbl <- mkQualificationTable qent acts colChoices psValidator diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index ce1402b62..835a69652 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -345,6 +345,11 @@ lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted +qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a +qualificationBlockedCellNoReason Nothing = mempty +qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) = + iconCell IconBlocked <> spacerCell <> dayCell d + qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCell Nothing = mempty qualificationBlockedCell (Just QualificationBlocked{..}) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index c7b43e5cc..b129d721c 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -525,13 +525,13 @@ fillDb = do void . insert' $ UserFunction jost avn SchoolAdmin void . insert' $ UserFunction gkleen ifi SchoolAdmin void . insert' $ UserFunction gkleen mi SchoolAdmin - void . insert' $ UserFunction fhamann ifi SchoolAdmin + -- void . insert' $ UserFunction fhamann ifi SchoolAdmin -- goto-example for non-admin supervisor void . insert' $ UserFunction jost ifi SchoolAdmin void . insert' $ UserFunction jost mi SchoolAdmin void . insert' $ UserFunction svaupel ifi SchoolAdmin void . insert' $ UserFunction svaupel mi SchoolAdmin void . insert' $ UserFunction gkleen ifi SchoolLecturer - void . insert' $ UserFunction fhamann ifi SchoolLecturer + -- void . insert' $ UserFunction fhamann ifi SchoolLecturer -- goto-example for non-admin supervisor void . insert' $ UserFunction jost ifi SchoolLecturer void . insert' $ UserFunction svaupel ifi SchoolLecturer void . insert' $ UserFunction sbarth ifi SchoolLecturer