fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(firm): WIP company overview

Browse Source
This commit is contained in:
Steffen Jost 2023-10-17 16:09:48 +00:00
parent db4b1d8730
commit d81e6e15dc
4 changed files with 71 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen TableQualifications: Qualifikationen
TableCompany: Firma TableCompany: Firma
TableCompanyShort: Firmenkürzel
TableCompanies: Firmen TableCompanies: Firmen
TableCompanyNo: Firmennummer
TableCompanyNos: Firmennummern TableCompanyNos: Firmennummern
TableCompanyNrUsers: Firmenangehörige
TableCompanyNrSupers: Ansprechpartner
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
TableSupervisor: Ansprechpartner TableSupervisor: Ansprechpartner
TableCreationTime: Erstellungszeit TableCreationTime: Erstellungszeit
TableJob !ident-ok: Job TableJob !ident-ok: Job

5
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority TableExamOfficeLabelPriority: Label priority
TableQualifications: Qualifications TableQualifications: Qualifications
TableCompany: Company TableCompany: Company
TableCompanyShort: Company shorthand
TableCompanies: Companies TableCompanies: Companies
TableCompanyNo: Company number
TableCompanyNos: Company numbers TableCompanyNos: Company numbers
TableCompanyNrUsers: Associates
TableCompanyNrSupers: Supervisors
TableCompanyNrForeignSupers: External Supervisors
TableSupervisor: Supervisor TableSupervisor: Supervisor
TableCreationTime: Creation TableCreationTime: Creation
TableJob !ident-ok: Job TableJob !ident-ok: Job

2
routes
View File

@ -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 !free /firm FirmAllR GET
/firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand FirmR GET POST
/exam-office ExamOfficeR !exam-office: /exam-office ExamOfficeR !exam-office:

143
src/Handler/Firm.hs
View File

@ -24,7 +24,7 @@ import Handler.Utils
-- import qualified Data.Conduit.List as C -- import qualified Data.Conduit.List as C
-- import Database.Persist.Sql (updateWhereCount) -- import Database.Persist.Sql (updateWhereCount)
-- import Database.Esqueleto.Experimental ((:&)(..)) -- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.Legacy as E
-- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.PostgreSQL as E
-- import qualified Database.Esqueleto.Utils as E -- import qualified Database.Esqueleto.Utils as E
@ -49,7 +49,7 @@ getFirmAllR = do
uid <- requireAuthId uid <- requireAuthId
isAdmin <- hasReadAccessTo AdminR isAdmin <- hasReadAccessTo AdminR
firmTable <- runDB $ do firmTable <- runDB $ do
view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins
siteLayoutMsg MsgMenuFirms $ do siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms setTitleI MsgMenuFirms
-- $(widgetFile "firm-all") -- $(widgetFile "firm-all")
@ -59,7 +59,7 @@ getFirmAllR = do
|] |]
type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64) type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64)
resultAllCompany :: Lens' AllCompanyTableData Company resultAllCompany :: Lens' AllCompanyTableData Company
resultAllCompany = _dbrOutput . _1 . _entityVal resultAllCompany = _dbrOutput . _1 . _entityVal
@ -73,95 +73,72 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64
resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue
mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget)
mkQualificationAllTable mbUid = do mkQualificationAllTable isAdmin uid = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery cmpy = do dbtSQLQuery cmpy = do
let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
cforeign = Ex.subSelectCount $ Ex.distinct $ do cforeign = E.subSelectCount $ E.distinct $ do
usrSuper <- Ex.from $ Ex.table @UserSupervisor usrSuper <- E.from $ E.table @UserSupervisor
Ex.where_ (Ex.exists $ do E.where_ (E.exists $ do
usrCmpy <- Ex.from $ Ex.table @UserCompany usrCmpy <- E.from $ E.table @UserCompany
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser
) E.&&. Ex.notExists (do ) E.&&. E.notExists (do
usrCmpy <- Ex.from $ Ex.table @UserCompany usrCmpy <- E.from $ E.table @UserCompany
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor
) )
return $ usrSuper E.^. UserSupervisorSupervisor return $ usrSuper E.^. UserSupervisorSupervisor
cusers = Ex.subSelectCount $ do cusers = E.subSelectCount $ do
usrCmpy <- Ex.from $ Ex.table @UserCompany usrCmpy <- E.from $ E.table @UserCompany
Ex.where_ $ filterCmpy usrCmpy E.where_ $ filterCmpy usrCmpy
csupers = Ex.subSelectCount $ do csupers = E.subSelectCount $ do
usrCmpy <- Ex.from $ Ex.table @UserCompany usrCmpy <- E.from $ E.table @UserCompany
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor
whenIsJust mbUid $ \uid -> whenIsJust mbUid $ \uid ->
Ex.where_ $ Ex.exists $ do -- only show associated companies E.where_ $ E.exists $ do -- only show associated companies
usrCmpy <- Ex.from $ Ex.table @UserCompany usrCmpy <- E.from $ E.table @UserCompany
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val uid E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid
return (cmpy, csupers, cusers, cforeign) return (cmpy, csupers, cusers, cforeign)
dbtRowKey = (Ex.^. CompanyShorthand) dbtRowKey = (E.^. CompanyShorthand)
dbtProj = dbtProjId dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand))
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
let qsh = qualificationShorthand quali in anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm
anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> let fsh = companyShorthand firm
let qsh = qualificationShorthand quali anchorCell (FirmR fsh) $ toWgt fsh
qnm = qualificationName quali , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm let fsh = companyShorthand firm
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> anchorCell (FirmR fsh) $ toWgt $ companyAvsId firm
maybeCell (qualificationDescription quali) markupCellLargeModal , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
, 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 dbtSorting = mconcat
[ [ singletonMap "name" $ SortColumn (E.^. CompanyName)
sortSchool $ to (E.^. QualificationSchool) , singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
, singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) , singletonMap "nr" $ SortColumn (E.^. CompanyAvsId)
, singletonMap "qname" $ SortColumn (E.^. QualificationName)
, singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart)
, singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ [
fltrSchool $ to (E.^. QualificationSchool)
, singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
] ]
dbtFilterUI = mconcat dbtFilterUI = mconcat
[ [
fltrSchoolUI
, \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification-overview" dbtIdent = "firm"
dbtCsvEncode = noCsvEncode dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
resultDBTableValidator = def resultDBTableValidator = def
& defaultSorting [SortAscBy "school", SortAscBy "qshort"] -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"]
dbTable resultDBTableValidator resultDBTable dbTable resultDBTableValidator resultDBTable
@ -391,7 +368,7 @@ mkQualificationAllTable mbUid = do
-- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) -- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
-- dbtIdent :: Text -- dbtIdent :: Text
-- dbtIdent = "qualification" -- dbtIdent = "qualification"
-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs -- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs
-- dbtSQLQuery = qualificationTableQuery now qid fltrSvs -- dbtSQLQuery = qualificationTableQuery now qid fltrSvs
-- dbtRowKey = queryUser >>> (E.^. UserId) -- dbtRowKey = queryUser >>> (E.^. UserId)
-- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do -- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
@ -562,21 +539,21 @@ mkQualificationAllTable mbUid = do
-- }} <- getBy404 $ SchoolQualificationShort sid qsh -- }} <- getBy404 $ SchoolQualificationShort sid qsh
-- -- Block copied to Handler/Qualifications TODO: refactor -- -- Block copied to Handler/Qualifications TODO: refactor
-- let getBlockReasons unblk = Ex.select $ do -- let getBlockReasons unblk = E.select $ do
-- (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser -- (quser :& qblock) <- E.from $ E.table @QualificationUser
-- `Ex.innerJoin` Ex.table @QualificationUserBlock -- `E.innerJoin` E.table @QualificationUserBlock
-- `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) -- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
-- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid -- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
-- Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) -- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
-- Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) -- E.groupBy (qblock E.^. QualificationUserBlockReason)
-- let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows -- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
-- Ex.orderBy [Ex.desc countRows'] -- E.orderBy [E.desc countRows']
-- Ex.limit 7 -- E.limit 7
-- pure (qblock Ex.^. QualificationUserBlockReason) -- pure (qblock E.^. QualificationUserBlockReason)
-- mkOption :: Ex.Value Text -> Option Text -- mkOption :: E.Value Text -> Option Text
-- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } -- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
-- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) -- suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) -- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
-- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) -- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
-- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths -- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) -- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)