From 921e5df9d995f2222c5a785d4e3ad2593c73f35a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 16 Mar 2023 11:47:21 +0000 Subject: [PATCH] chore(company): show company column for lms and quals, show lms blocked reason for admins in quals --- src/Handler/Admin/Avs.hs | 2 +- src/Handler/LMS.hs | 24 +++++++++++++++++++++--- src/Handler/PrintCenter.hs | 2 +- src/Handler/Qualification.hs | 27 +++++++++++++++++++++++---- templates/lms-user.hamlet | 7 ++++--- test/Database/Fill.hs | 4 ++-- 6 files changed, 52 insertions(+), 14 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 27158c208..e4609bd0a 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -583,7 +583,7 @@ mkLicenceTable dbtIdent aLic apids = do dbtCsvDecode = Nothing dbtExtraReps = [] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - validator = def -- & defaultSorting [SortDescBy "column-label"] + validator = def & defaultSorting [SortAscBy "user-name"] postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool)) -> FormResult ( LicenceTableActionData, Set AvsPersonId) postprocess inp = do diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index e32257e53..c8cb5aaa9 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -395,7 +395,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) - + , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId + E.orderBy [E.asc (comp E.^. CompanyName)] + return (comp E.^. CompanyName) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -514,6 +519,16 @@ postLmsR sid qsh = do [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail + , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid + E.orderBy [E.asc (comp E.^. CompanyName)] + return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let companies = intersperse (text2markup ", ") $ + (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' + icnSuper = text2markup " " <> icon IconSupervisor + pure $ toWgt $ mconcat companies , 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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d @@ -608,8 +623,10 @@ postLmsR sid qsh = do -- intended to be viewed primarily in a modal, vie lmsStatusPlusCell' getLmsUserR :: CryptoUUIDUser -> Handler Html -getLmsUserR uuid = do +getLmsUserR uuid = do uid <- decrypt uuid + now <- liftIO getCurrentTime + let nowaday = utctDay now (user@User{userDisplayName}, quals) <- runDB $ do usr <- get404 uid qs <- Ex.select $ do @@ -625,7 +642,8 @@ getLmsUserR uuid = do ) Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser) - pure (qual, qualUsr, lmsUsr) + Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand] + pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr) return (usr,qs) let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index f3b89f378..9c0475259 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -279,7 +279,7 @@ mkPJTable = do (First (Just act), jobMap) <- inp let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap return (act, jobSet) - psValidator = def & defaultSorting [SortAscBy "created"] + psValidator = def & defaultSorting [SortDescBy "created"] -- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter over _1 postprocess <$> dbTable psValidator DBTable{..} diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 2aee9284a..87da7a59b 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -317,6 +317,13 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- , 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]) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId + E.orderBy [E.asc (comp E.^. CompanyName)] + return (comp E.^. CompanyName) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -340,7 +347,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true - ) + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev @@ -426,15 +433,27 @@ postQualificationR sid qsh = do , singletonMap QualificationActBlock $ QualificationActBlockData <$> apreq textField (fslI MsgQualificationBlockReason) Nothing ] isAdmin - linkLmsUser = toMaybe isAdmin LmsUserR + linkLmsUser = toMaybe isAdmin LmsUserR + linkUserName = bool ForProfileR ForProfileDataR isAdmin + blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin colChoices = mconcat [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) - , colUserNameModalHdr MsgLmsUser ForProfileR + , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail + , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid + E.orderBy [E.asc (comp E.^. CompanyName)] + return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let companies = intersperse (text2markup ", ") $ + (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' + icnSuper = text2markup " " <> icon IconSupervisor + pure $ toWgt $ mconcat companies , 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 MsgTableQualificationBlockedTooltipSimple - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCellNoReason b + ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell 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) diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index 13b3c0375..6108b47c1 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $if null quals _{MsgQualificationUserNone} $else - $forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals + $forall (Entity _ quali, mbQualUsr, mbLmsUsr, validity) <- quals

- #{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali} + #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali})   #{boolSymbol (E.unValue validity)}
$maybe (Entity _ qualUsr) <- mbQualUsr @@ -41,7 +41,8 @@ $else
#{lmsUserPin lmsUsr} - \ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)} +
+ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)} $if lmsUserResetPin lmsUsr \ #{icon IconReset} $maybe ts <- lmsUserReceived lmsUsr diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index af1cec970..ef14d37ae 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -172,7 +172,7 @@ fillDb = do , userTitle = Just "Dr." , userMaxFavourites = 14 , userMaxFavouriteTerms = 4 - , userTheme = userDefaultTheme + , userTheme = ThemeMossGreen , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat @@ -574,7 +574,7 @@ fillDb = do void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True - void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False + void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False