From 8fcfc9586e3aca5f1eb0b3f1019127c7690328e8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 10 Oct 2023 15:11:56 +0000 Subject: [PATCH] chore(firm): wip all firm table query --- routes | 2 +- src/Handler/Firm.hs | 213 ++++++++++++++++++++++++-------------------- 2 files changed, 116 insertions(+), 99 deletions(-) diff --git a/routes b/routes index e7f9fc7b9..031e7b5c2 100644 --- a/routes +++ b/routes @@ -113,7 +113,7 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET +/firm FirmAllR GET !free /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 10dcf320b..8072ef78b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -36,13 +36,6 @@ import Import -- single = uncurry Map.singleton -getFirmAllR :: Handler Html -getFirmAllR = do - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - [whamlet|STUB TO DO|] - - getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR _ = do @@ -51,101 +44,125 @@ postFirmR _ = do [whamlet|STUB TO DO|] --- isAdmin <- hasReadAccessTo AdminR --- firmTable <- runDB $ do --- view _2 <$> mkFirmAllTable isAdmin --- siteLayoutMsg MsgMenuFirms $ do --- setTitleI MsgMenuFirms --- $(widgetFile "firm-all") +getFirmAllR :: Handler Html +getFirmAllR = do + uid <- requireAuthId + isAdmin <- hasReadAccessTo AdminR + firmTable <- runDB $ do + view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + -- $(widgetFile "firm-all") + [whamlet|!!!STUB!!!TO DO!!! --- type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) --- resultAllQualification :: Lens' AllQualificationTableData Qualification --- resultAllQualification = _dbrOutput . _1 . _entityVal - --- resultAllQualificationActive :: Lens' AllQualificationTableData Word64 --- resultAllQualificationActive = _dbrOutput . _2 . _unValue - --- resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 --- resultAllQualificationTotal = _dbrOutput . _3 . _unValue + ^{firmTable} + |] --- mkQualificationAllTable :: Bool -> DB (Any, Widget) --- mkQualificationAllTable isAdmin = do --- svs <- getSupervisees --- now <- liftIO getCurrentTime --- let --- resultDBTable = DBTable{..} --- where --- dbtSQLQuery quali = do --- let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId --- Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) --- cusers = Ex.subSelectCount $ do --- quser <- Ex.from $ Ex.table @QualificationUser --- Ex.where_ $ filterSvs quser --- cactive = Ex.subSelectCount $ do --- quser <- Ex.from $ Ex.table @QualificationUser --- Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser --- return (quali, cactive, cusers) --- dbtRowKey = (Ex.^. QualificationId) --- dbtProj = dbtProjId --- dbtColonnade = dbColonnade $ mconcat --- [ colSchool $ resultAllQualification . _qualificationSchool --- , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> --- let qsh = qualificationShorthand quali in --- anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh --- , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> --- let qsh = qualificationShorthand quali --- qnm = qualificationName quali --- in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm --- , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> --- maybeCell (qualificationDescription quali) markupCellLargeModal --- , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ --- foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) --- , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ --- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) --- , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ --- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) --- , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) --- $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) --- , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) --- $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) --- , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) --- $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char --- , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) --- $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId --- , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) --- $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n --- , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal --- ] --- dbtSorting = mconcat --- [ --- sortSchool $ to (E.^. QualificationSchool) --- , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) --- , singletonMap "qname" $ SortColumn (E.^. QualificationName) --- , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) --- , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) --- ] --- dbtFilter = mconcat --- [ --- fltrSchool $ to (E.^. QualificationSchool) --- , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) --- ] --- dbtFilterUI = mconcat --- [ --- fltrSchoolUI --- , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) --- ] --- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } --- dbtParams = def --- dbtIdent :: Text --- dbtIdent = "qualification-overview" --- dbtCsvEncode = noCsvEncode --- dbtCsvDecode = Nothing --- dbtExtraReps = [] +type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64) +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = _dbrOutput . _1 . _entityVal --- resultDBTableValidator = def --- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] --- dbTable resultDBTableValidator resultDBTable +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _2 . _unValue + +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _3 . _unValue + +resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 +resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue + + +mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) +mkQualificationAllTable mbUid = do + + now <- liftIO getCurrentTime + let + resultDBTable = DBTable{..} + where + dbtSQLQuery cmpy = do + let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId + cforeign = Ex.subSelectCount $ Ex.distinct $ do + usrSuper <- Ex.from $ Ex.table @UserSupervisor + Ex.where_ (Ex.exists $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser + ) E.&&. Ex.notExists (do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor + ) + return $ usrSuper E.^. UserSupervisorSupervisor + cusers = Ex.subSelectCount $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy + csupers = Ex.subSelectCount $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor + whenIsJust mbUid $ \uid -> + Ex.where_ $ Ex.exists $ do -- only show associated companies + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val uid + return (cmpy, csupers, cusers, cforeign) + dbtRowKey = (Ex.^. CompanyShorthand) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ colSchool $ resultAllQualification . _qualificationSchool + , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali in + anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh + , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali + qnm = qualificationName quali + in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm + , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> + maybeCell (qualificationDescription quali) markupCellLargeModal + , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ + foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) + , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) + , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) + , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) + $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) + , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) + $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) + , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) + $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char + , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) + $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId + , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) + $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n + , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + ] + dbtSorting = mconcat + [ + sortSchool $ to (E.^. QualificationSchool) + , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) + , singletonMap "qname" $ SortColumn (E.^. QualificationName) + , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) + , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) + ] + dbtFilter = mconcat + [ + fltrSchool $ to (E.^. QualificationSchool) + , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) + ] + dbtFilterUI = mconcat + [ + fltrSchoolUI + , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "qualification-overview" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + resultDBTableValidator = def + & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + dbTable resultDBTableValidator resultDBTable