chore(firm): wip all firm table query
This commit is contained in:
parent
bc0b449689
commit
8fcfc9586e
2
routes
2
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:
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user