diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 39f4286d6..3e85955f0 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -32,6 +32,7 @@ TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versende QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte? QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. +QualificationGrantReason: Erteilungsbegründung QualificationBlockReason: Entzugsbegründung QualificationBlockNotify: Benachrichtigung verschicken QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 587f18d11..4f46638db 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -32,6 +32,7 @@ TableQualificationNoRenewalTooltip: No renewal notifications will be send for th QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon? QualificationUserNoRenewal: Expires without further notification QualificationUserNone: No registered qualifications for this person. +QualificationGrantReason: Reason for granting QualificationBlockReason: Reason for revoking QualificationBlockNotify: Send notification QualificationBlockRemoveSupervisor: Remove all supervisors diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 196b16786..c97fea7df 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -118,6 +118,7 @@ MenuQualifications: Qualifikationen MenuLms !ident-ok: E‑Learning MenuLmsEdit: Bearbeiten E‑Learning MenuLmsUser: Benutzer Qualifikationen +MenuLmsUserAll: Alle Benutzer Qualifikationen MenuLmsUsers: Export E‑Learning Benutzer MenuLmsUserlist: Melden E‑Learning Benutzer MenuLmsResult: Melden Ergebnisse E‑Learning diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 85130a2e9..987fff8a5 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -119,6 +119,7 @@ MenuQualifications: Qualifications MenuLms: E‑Learning MenuLmsEdit: Edit E‑Learning MenuLmsUser: User Qualifications +MenuLmsUserAll: All User Qualifications MenuLmsUsers: Download E‑Learning Users MenuLmsUserlist: Upload E‑Learning Users MenuLmsResult: Upload E‑Learning Results diff --git a/routes b/routes index 32721396e..7259c468a 100644 --- a/routes +++ b/routes @@ -260,29 +260,29 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -/qualification QualificationAllR GET !free -/qualification/#SchoolId QualificationSchoolR GET !free -/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free -/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement --- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL +/qualification QualificationAllR GET !free +/qualification/#SchoolId QualificationSchoolR GET !free +/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free +-- /qualification/#SchoolId/#QualificationShorthand/#CryptoUUIDUser QualificationUserR GET -- see LmsUserR +/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement + -- LMS -/lms LmsAllR GET POST -/lms/#SchoolId LmsSchoolR GET -/lms/#SchoolId/#QualificationShorthand LmsR GET POST -/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST -/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS -/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS -/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter -/lmsuser/#CryptoUUIDUser LmsUserR GET - - +/lms LmsAllR GET POST +/lms/#SchoolId LmsSchoolR GET +/lms/#SchoolId/#QualificationShorthand LmsR GET POST +/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST +/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST +/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS +/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS +/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter +/lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET +/lmsuser/#CryptoUUIDUser LmsUserAllR GET /api ApiDocsR GET !free /swagger SwaggerR GET !free diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b889d5436..5e6fe6463 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -186,7 +186,8 @@ breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Jus breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect -breadcrumb (LmsUserR _) = i18nCrumb MsgMenuLmsUser $ Just LmsAllR +breadcrumb (LmsUserR _ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserAllR u +breadcrumb (LmsUserAllR _ ) = i18nCrumb MsgMenuLmsUserAll $ Just LmsAllR -- breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a434ace81..227df595f 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -41,15 +41,14 @@ getAdminR = redirect AdminProblemsR getAdminProblemsR :: Handler Html getAdminProblemsR = do now <- liftIO getCurrentTime - let nowaday = utctDay now - cutOffPrintDays = 7 + let cutOffPrintDays = 7 cutOffPrintJob = addLocalDays (-cutOffPrintDays) now cutOffAvsSynch = Just $ addUTCTime (-nominalHour) now -- update at most once per hour (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,) <$> areAllUsersReachable - <*> allDriversHaveAvsId nowaday - <*> allRDriversHaveFs nowaday + <*> allDriversHaveAvsId now + <*> allRDriversHaveFs now <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" @@ -107,9 +106,8 @@ getProblemUnreachableR = do getProblemFbutNoR :: Handler Html getProblemFbutNoR = do - now <- liftIO getCurrentTime - let nowaday = utctDay now - rnofs <- runDB $ E.select $ retrieveDriversRWithoutF nowaday + now <- liftIO getCurrentTime + rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now siteLayoutMsg MsgProblemsRWithoutFHeading $ do setTitleI MsgProblemsRWithoutFHeading [whamlet| @@ -123,9 +121,8 @@ getProblemFbutNoR = do getProblemWithoutAvsId :: Handler Html getProblemWithoutAvsId = do - now <- liftIO getCurrentTime - let nowaday = utctDay now - rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId nowaday + now <- liftIO getCurrentTime + rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now siteLayoutMsg MsgProblemsNoAvsIdHeading $ do setTitleI MsgProblemsNoAvsIdHeading [whamlet| @@ -174,7 +171,7 @@ retrieveUnreachableUsers = do hasInvalidEmail = isNothing . getEmailAddress . entityVal -allDriversHaveAvsId :: Day -> DB Bool +allDriversHaveAvsId :: UTCTime -> DB Bool -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId @@ -199,8 +196,8 @@ retrieveDriversWithoutAvsId' nowaday = do -} -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known -retrieveDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) -retrieveDriversWithoutAvsId nowaday = do +retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User)) +retrieveDriversWithoutAvsId now = do usr <- E.from $ E.table @User E.where_ $ E.exists (do -- a valid avs licence @@ -209,7 +206,7 @@ retrieveDriversWithoutAvsId nowaday = do `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) E.where_ $ -- is avs licence E.isJust (qual E.^. QualificationAvsLicence) - E.&&. (qualUsr & validQualification nowaday) -- currently valid + E.&&. (qualUsr & validQualification now) -- currently valid E.&&. -- matches user (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) ) @@ -221,13 +218,13 @@ retrieveDriversWithoutAvsId nowaday = do return usr -allRDriversHaveFs :: Day -> DB Bool +allRDriversHaveFs :: UTCTime -> DB Bool -- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known -retrieveDriversRWithoutF :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) -retrieveDriversRWithoutF nowaday = do +retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User)) +retrieveDriversRWithoutF now = do usr <- E.from $ E.table @User let hasValidQual lic = do (qual :& qualUsr) <- E.from (E.table @Qualification @@ -235,7 +232,7 @@ retrieveDriversRWithoutF nowaday = do `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user - E.&&. (qualUsr & validQualification nowaday) -- currently valid + E.&&. (qualUsr & validQualification now) -- currently valid E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 99751e95c..cda7bf9f0 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -356,6 +356,7 @@ data LicenceTableActionData = LicenceTableChangeAvsData } | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId + , licenceTableChangeFDriveReason :: Text , licenceTableChangeFDriveEnd :: Day , licenceTableChangeFDriveRenew :: Maybe Bool } @@ -445,11 +446,7 @@ getProblemAvsSynchR = do then return (-1) else do uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] - qualificationUserBlocking licenceTableChangeFDriveQId uids licenceTableChangeFDriveNotify $ - Just $ QualificationBlocked - { qualificationBlockedDay = nowaday - , qualificationBlockedReason = licenceTableChangeFDriveReason - } + qualificationUserBlocking licenceTableChangeFDriveQId uids False (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks | otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks @@ -459,6 +456,7 @@ getProblemAvsSynchR = do (n, Qualification{qualificationShorthand}) <- runDB $ do uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG + void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True (Left licenceTableChangeFDriveReason) False forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew (length uids,) <$> get404 licenceTableChangeFDriveQId addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n @@ -477,21 +475,25 @@ type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) ) queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs) -queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 3 1) +queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1) queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User) -queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 3 1) +queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1) queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser)) -queryQualUser = $(E.sqlLOJproj 3 2) +queryQualUser = $(E.sqlLOJproj 4 2) queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) -queryQualification = $(E.sqlLOJproj 3 3) +queryQualification = $(E.sqlLOJproj 4 3) -type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification)) +queryQualBlock :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +queryQualBlock = $(E.sqlLOJproj 4 4) + +type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification), Maybe (Entity QualificationUserBlock)) resultUserAvs :: Lens' LicenceTableData (Entity UserAvs) resultUserAvs = _dbrOutput . _1 @@ -505,30 +507,40 @@ resultQualUser = _dbrOutput . _3 . _Just resultQualification :: Traversal' LicenceTableData (Entity Qualification) resultQualification = _dbrOutput . _4 . _Just +resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock) +resultQualBlock = _dbrOutput . _5 . _Just + instance HasEntity LicenceTableData User where hasEntity = resultUser instance HasUser LicenceTableData where - hasUser = resultUser . _entityVal + hasUser = resultUser . _entityVal +-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser +-- hasQualificationUser = resultQualUser . _entityVal mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) mkLicenceTable apidStatus dbtIdent aLic apids = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] now <- liftIO getCurrentTime + let nowaday = utctDay now + avsQids = entityKey <$> avsQualifications -- fltrLic qual = if -- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS -- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution: - dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual) -> do + dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual `E.LeftOuterJoin` qblock) -> do + E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser - E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) - return (usrAvs, user, qualUser, qual) + E.where_ $ fltrLic qual + E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) + E.&&. qblock `isLatestBlockBefore` E.val now + return (usrAvs, user, qualUser, qual, qblock) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) @@ -536,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal , colUserNameLink AdminUserR - , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a + , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a -- , colUserCompany , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(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 @@ -549,12 +561,13 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (cellMaybe (qualificationValidIconCell nowaday) . preview resultQualUser) + , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) $ \row -> + cellMaybe (qualificationValidIconCell nowaday (row ^? resultQualBlock)) (row ^? resultQualUser) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip - ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b + , sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> + cellMaybe (qualificationValidReasonCell True nowaday (row ^? resultQualBlock)) (row ^? resultQualUser) , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus @@ -567,14 +580,14 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) - , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue)) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) - , single ("validity" , SortColumn $ queryQualUser >>> validQualification' nowaday) + , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) + , single ("validity" , SortColumn $ queryQualUser >>> validQualification' now) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work? + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` @@ -600,17 +613,37 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , optionExternalValue = tshow cQualId } aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications + + -- Block identical to Handler/Qualifications TODO: refactor + getBlockReasons unblk = E.select $ do + (quser :& qblock) <- X.from $ E.table @QualificationUser + `E.innerJoin` E.table @QualificationUserBlock + `X.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) + E.where_ $ ((quser E.^. QualificationUserQualification) `E.in_` E.valList avsQids) + E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) + E.groupBy (qblock E.^. QualificationUserBlockReason) + let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows + E.orderBy [E.desc countRows'] + E.limit 7 + pure (qblock E.^. QualificationUserBlockReason) + mkOption :: E.Value Text -> Option Text + mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + suggestionsBlock :: HandlerFor UniWorX (OptionList Text) + suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) + suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) + acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData) acts = mconcat [ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData , if aLic == AvsNoLicence then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid - <*> apreq textField (fslI MsgQualificationBlockReason) Nothing - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) + <*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid + <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing ] diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index f6c63d741..513e63f87 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -105,7 +105,7 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolSh in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell +colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered ((spacerCell <>) . tickmarkCell) makeCourseTable :: (ToSortable h, Functor h) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 250bc640f..ef4ff823b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -18,7 +18,8 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.Course -import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.PostgreSQL as E import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) @@ -87,7 +88,7 @@ userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.L E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return (user, participant, note E.?. CourseUserNoteId, subGroup) -type UserTableQualifications = [(Entity Qualification, Entity QualificationUser)] +type UserTableQualifications = [(Entity Qualification, Entity QualificationUser, Maybe (Entity QualificationUserBlock))] type UserTableData = DBRow ( Entity User , Entity CourseParticipant @@ -131,7 +132,9 @@ _userSheets = _dbrOutput . _7 -- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications _userQualifications :: Getter UserTableData [Entity Qualification] -_userQualifications = _dbrOutput . _8 . to (fmap fst) +_userQualifications = _dbrOutput . _8 . to (fmap fst3) +-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work + _userCourseQualifications :: Lens' UserTableData UserTableQualifications _userCourseQualifications = _dbrOutput . _8 @@ -182,18 +185,17 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points _other -> mempty -colUserQualifications :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -colUserQualifications = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ - \(view _userCourseQualifications -> qualis) -> - (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationValidUntilCell - -colUserQualificationBlocked :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -colUserQualificationBlocked = sortable (Just "qualification-block") (i18nCell MsgTableQualificationBlockedDue) $ - \(view _userCourseQualifications -> qualis) -> - let blocks = qualificationUserBlockedDue . entityVal . snd <$> qualis - --blocks = qaulis <$> view (_2 . _entityVal . _qualificationUserBlockedDue) - in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell blocks $ qualificationBlockedCell +colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c) +colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ + let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidIconCell cutoff qb qu <> spacerCell <> dayCell (qu ^. _qualificationUserValidUntil) + in \(view _userCourseQualifications -> qualis) -> + (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell +colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c) +colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgTableQualificationBlockedDue) $ + let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell isAdmin cutoff qb qu + in \(view _userCourseQualifications -> qualis) -> + (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell data UserTableCsv = UserTableCsv { csvUserSurname :: UserSurname @@ -417,13 +419,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , submission ) ) - qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser) -> do - E.on $ qualification E.^. QualificationId E.==. qualificationUser E.^. QualificationUserQualification + qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do + E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser + E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user) E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids - + E.&&. qualificationBlock `isLatestBlockBefore` E.now_ E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here - return (qualification, qualificationUser) + return (qualification, qualificationUser, qualificationBlock) let regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials @@ -624,6 +627,8 @@ courseUserDeregisterForm _cid = wFormToAForm . pure . pure $ CourseUserDeregiste getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do + now <- liftIO getCurrentTime + let nowaday = utctDay now showSex <- getShowSex (course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR @@ -656,7 +661,7 @@ postCUsersR tid ssh csh = do , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail , pure . cap' $ colUserMatriclenr - , pure . cap' $ colUserQualifications + , pure . cap' $ colUserQualifications nowaday , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh @@ -734,8 +739,7 @@ postCUsersR tid ssh csh = do redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterExamData{..}, selectedUsers) -> do Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do - guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - now <- liftIO getCurrentTime + guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] let (exam, mOccurrence) = registerExam mExamReg <- lift $ insertUnique ExamRegistration { examRegistrationExam = exam @@ -759,8 +763,7 @@ postCUsersR tid ssh csh = do Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet redirect $ CourseR tid ssh csh CUsersR - (CourseUserReRegisterData, selectedUsers) -> do - now <- liftIO getCurrentTime + (CourseUserReRegisterData, selectedUsers) -> do Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do didUpdate <- lift $ updateWhereCount [ CourseParticipantUser ==. uid diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 49bd849a1..749fd669a 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -19,6 +19,7 @@ module Handler.LMS , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR , getLmsFakeR , postLmsFakeR , getLmsUserR + , getLmsUserAllR ) where @@ -582,8 +583,7 @@ postLmsR sid qsh = do <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing <* aformMessage msgRestartWarning - ] - -- lmsStatusLink = toMaybe isAdmin LmsUserR + ] colChoices cmpMap = mconcat [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser AdminUserR @@ -603,7 +603,7 @@ postLmsR sid qsh = do , 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 , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> - qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock) + qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid @@ -721,8 +721,14 @@ getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)]) -- intended to be viewed primarily in a modal, wie lmsStatusCell -getLmsUserR :: CryptoUUIDUser -> Handler Html -getLmsUserR uuid = do +getLmsUserAllR :: CryptoUUIDUser -> Handler Html +getLmsUserAllR = viewLmsUserR Nothing Nothing + +getLmsUserR :: SchoolId -> QualificationShorthand -> CryptoUUIDUser -> Handler Html +getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh) + +viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html +viewLmsUserR msid mqsh uuid = do uid <- decrypt uuid now <- liftIO getCurrentTime (user@User{userDisplayName}, quals, qblocks) <- runDB $ do @@ -738,8 +744,11 @@ getLmsUserR uuid = do `Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId ) - Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) - E.||. E.isJust ( lmsUsr E.?. LmsUserUser) + Ex.where_ $ E.and $ + (E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes + [ (qual E.^. QualificationSchool E.==.) . E.val <$> msid + , (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh + ] Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand] pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr) bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName))] diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 0e19a441c..7ca925076 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -527,6 +527,7 @@ postQualificationR sid qsh = do , qualificationValidDuration=validMonths }} <- getBy404 $ SchoolQualificationShort sid qsh + -- Block copied to Handler/Qualifications TODO: refactor let getBlockReasons unblk = Ex.select $ do (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser `Ex.innerJoin` Ex.table @QualificationUserBlock @@ -565,7 +566,7 @@ postQualificationR sid qsh = do <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning ] isAdmin - linkLmsUser = toMaybe isAdmin LmsUserR + linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) linkUserName = bool ForProfileR ForProfileDataR isAdmin colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) @@ -585,7 +586,7 @@ postQualificationR sid qsh = do , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> - qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock) + qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 207bc1731..79eca5079 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -60,21 +60,23 @@ data TutorialUserActionData getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent getTUsersR = postTUsersR -postTUsersR tid ssh csh tutn = do +postTUsersR tid ssh csh tutn = do + isAdmin <- hasReadAccessTo AdminR (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime - let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays - dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur + let nowaday = utctDay now + minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays + dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , pure colUserEmail , pure colUserMatriclenr - , pure colUserQualifications - , pure colUserQualificationBlocked + , pure $ colUserQualifications nowaday + , pure $ colUserQualificationBlocked isAdmin nowaday ] psValidator = def & defaultSortingByName diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 5b3da66ed..ef9cd3d17 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -326,19 +326,21 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific Nothing -> mempty (Just descr) -> spacerCell <> markupCellLargeModal descr -qualificationValidUntilCell :: (IsDBTable m c, HasQualification a, HasQualificationUser a) => a -> DBCell m c -qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd - where - qsh = q ^. hasQualification . _qualificationShorthand . _CI - vtd = q ^. hasQualificationUser . _qualificationUserValidUntil +-- DEPRECATED +-- qualificationValidUntilCell :: (IsDBTable m c, HasQualification a, HasQualificationUser a) => a -> DBCell m c +-- qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd +-- where +-- qsh = q ^. hasQualification . _qualificationShorthand . _CI +-- vtd = q ^. hasQualificationUser . _qualificationUserValidUntil -qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c -qualificationValidIconCell d qu qb = blockIcon $ isValidQualification d qu qb +qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c +qualificationValidIconCell d qb qu = do + blockIcon $ isValidQualification d qu qb where blockIcon = cell . toWidget . iconQualificationBlock -qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> a -> Maybe b -> DBCell m c -qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb +qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> Maybe b -> a -> DBCell m c +qualificationValidReasonCell showReason d qb qu = ic <> foldMap blc qb where ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb blc (view hasQualificationUserBlock -> QualificationUserBlock{..})