diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index fdf42b885..b25230af4 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanyShort: Firmenkürzel TableCompanies: Firmen +TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern +TableCompanyNrUsers: Firmenangehörige +TableCompanyNrSupers: Ansprechpartner +TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index b4fe83d34..e3d095d4f 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanyShort: Company shorthand TableCompanies: Companies +TableCompanyNo: Company number TableCompanyNos: Company numbers +TableCompanyNrUsers: Associates +TableCompanyNrSupers: Supervisors +TableCompanyNrForeignSupers: External Supervisors TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job diff --git a/routes b/routes index 031e7b5c2..0af78745f 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 !free +/firm FirmAllR GET /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e7fc5fe85..9e7a56a29 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -24,7 +24,7 @@ import Handler.Utils -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) -- 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.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E @@ -49,7 +49,7 @@ getFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR 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 setTitleI MsgMenuFirms -- $(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 = _dbrOutput . _1 . _entityVal @@ -73,95 +73,72 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue -mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) -mkQualificationAllTable mbUid = do - +mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget) +mkQualificationAllTable isAdmin uid = do now <- liftIO getCurrentTime - let + 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 + let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + cforeign = E.subSelectCount $ E.distinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ (E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser + ) E.&&. E.notExists (do + usrCmpy <- E.from $ E.table @UserCompany + E.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 + cusers = E.subSelectCount $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy + csupers = E.subSelectCount $ do + usrCmpy <- E.from $ E.table @UserCompany + E.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 + E.where_ $ E.exists $ do -- only show associated companies + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return (cmpy, csupers, cusers, cforeign) - dbtRowKey = (Ex.^. CompanyShorthand) + dbtRowKey = (E.^. 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 + [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm + anchorCell (FirmR fsh) $ toWgt fsh + , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm + anchorCell (FirmR fsh) $ toWgt $ companyAvsId firm + , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr ] 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) + [ singletonMap "name" $ SortColumn (E.^. CompanyName) + , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) + , singletonMap "nr" $ SortColumn (E.^. CompanyAvsId) ] 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 } + dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "qualification-overview" + dbtIdent = "firm" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] resultDBTableValidator = def - & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] dbTable resultDBTableValidator resultDBTable @@ -391,7 +368,7 @@ mkQualificationAllTable mbUid = do -- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) -- dbtIdent :: Text -- 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 -- dbtRowKey = queryUser >>> (E.^. UserId) -- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do @@ -562,21 +539,21 @@ mkQualificationAllTable mbUid = do -- }} <- 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 --- `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) --- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid --- Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) --- Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) --- let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows --- Ex.orderBy [Ex.desc countRows'] --- Ex.limit 7 --- pure (qblock Ex.^. QualificationUserBlockReason) --- mkOption :: Ex.Value Text -> Option Text --- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } +-- let getBlockReasons unblk = E.select $ do +-- (quser :& qblock) <- E.from $ E.table @QualificationUser +-- `E.innerJoin` E.table @QualificationUserBlock +-- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) +-- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid +-- 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 Ex.not_) +-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) -- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) -- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths -- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)