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 ForProfileR GET POST !supervisor !self
|
||||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
||||||
|
|
||||||
/firm FirmAllR GET
|
/firm FirmAllR GET !free
|
||||||
/firm/#CompanyShorthand FirmR GET POST
|
/firm/#CompanyShorthand FirmR GET POST
|
||||||
|
|
||||||
/exam-office ExamOfficeR !exam-office:
|
/exam-office ExamOfficeR !exam-office:
|
||||||
|
|||||||
@ -36,13 +36,6 @@ import Import
|
|||||||
-- single = uncurry Map.singleton
|
-- 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 :: CompanyShorthand -> Handler Html
|
||||||
getFirmR = postFirmR
|
getFirmR = postFirmR
|
||||||
postFirmR _ = do
|
postFirmR _ = do
|
||||||
@ -51,101 +44,125 @@ postFirmR _ = do
|
|||||||
[whamlet|STUB TO DO|]
|
[whamlet|STUB TO DO|]
|
||||||
|
|
||||||
|
|
||||||
-- isAdmin <- hasReadAccessTo AdminR
|
getFirmAllR :: Handler Html
|
||||||
-- firmTable <- runDB $ do
|
getFirmAllR = do
|
||||||
-- view _2 <$> mkFirmAllTable isAdmin
|
uid <- requireAuthId
|
||||||
-- siteLayoutMsg MsgMenuFirms $ do
|
isAdmin <- hasReadAccessTo AdminR
|
||||||
-- setTitleI MsgMenuFirms
|
firmTable <- runDB $ do
|
||||||
-- $(widgetFile "firm-all")
|
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)
|
^{firmTable}
|
||||||
-- resultAllQualification :: Lens' AllQualificationTableData Qualification
|
|]
|
||||||
-- resultAllQualification = _dbrOutput . _1 . _entityVal
|
|
||||||
|
|
||||||
-- resultAllQualificationActive :: Lens' AllQualificationTableData Word64
|
|
||||||
-- resultAllQualificationActive = _dbrOutput . _2 . _unValue
|
|
||||||
|
|
||||||
-- resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
|
|
||||||
-- resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
|
||||||
|
|
||||||
|
|
||||||
-- mkQualificationAllTable :: Bool -> DB (Any, Widget)
|
type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64)
|
||||||
-- mkQualificationAllTable isAdmin = do
|
resultAllCompany :: Lens' AllCompanyTableData Company
|
||||||
-- svs <- getSupervisees
|
resultAllCompany = _dbrOutput . _1 . _entityVal
|
||||||
-- 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 = []
|
|
||||||
|
|
||||||
-- resultDBTableValidator = def
|
resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64
|
||||||
-- & defaultSorting [SortAscBy "school", SortAscBy "qshort"]
|
resultAllCompanySupervisors = _dbrOutput . _2 . _unValue
|
||||||
-- dbTable resultDBTableValidator resultDBTable
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user