From 2c12477c57fc455ba2a5f0186ea33eaac7363490 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 18:05:18 +0100 Subject: [PATCH 01/12] fix minor typo --- messages/uniworx/utils/table_column/en-eu.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5839e332c..3b7962522 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -83,7 +83,7 @@ TableCompanyNos: Company numbers TableCompanyUser: Associate TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors -TableCompanyNrEmpSupervised: Supervsied employees +TableCompanyNrEmpSupervised: Supervised employees TableCompanyNrEmpRerouted: Employees having reroute TableCompanyNrEmpRerPost: Employees having postal reroute TableCompanyNrSupersActive: Associates having supervisors From 069561763cb0f705f1ff7358f8cb7d43017b45a8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 6 Nov 2023 12:17:11 +0100 Subject: [PATCH 02/12] refactor(firm); supervisor table sorting and company column --- src/Handler/Firm.hs | 62 +++++++++++++++++++++----------- src/Handler/Utils/Table/Cells.hs | 3 ++ templates/firm-users.hamlet | 3 +- 3 files changed, 45 insertions(+), 23 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 3f6d46207..de7a86d06 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -597,7 +597,7 @@ type SuperCompanyTableExpr = E.SqlExpr (Entity User) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) querySuperUser = id -type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64) +type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) resultSuperUser = _dbrOutput . _1 @@ -608,12 +608,27 @@ resultSuperCompanySupervised = _dbrOutput . _2 . _unValue resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64 resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue +resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] +resultSuperCompanies = _dbrOutput . _4 + + instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal +firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () +firmQuerySupervisedBy cid mbFltr usr = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr + +firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) +firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do @@ -621,34 +636,31 @@ mkFirmSuperTable isAdmin cid = do -- fsh = unCompanyKey cid resultDBTable = DBTable{..} where - dbtSQLQuery = \usr -> do - -- refactor this - let subs = do - (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @UserCompany - `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid - subs' = do - (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @UserCompany - `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid - E.&&. usrSpr E.^. UserSupervisorRerouteNotifications - E.where_ $ E.exists subs - return (usr, E.subSelectCount subs, E.subSelectCount subs') + dbtSQLQuery = \usr -> do + E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + return ( usr + , usr & firmCountForSupervisor cid Nothing + , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + ) dbtRowKey = querySuperUser >>> (E.^. UserId) - dbtProj = dbtProjId + dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do + cmps <- E.select $ do + (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) + E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) + E.orderBy [E.asc $ cmp E.^. CompanyName] + return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) + return (usr, supervised, rerouted, cmps) dbtColonnade = formColonnade $ mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> + intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps] , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail - , sortable Nothing (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr - , sortable Nothing (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr + , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser @@ -656,6 +668,14 @@ mkFirmSuperTable isAdmin cid = do , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) + , singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing + , singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + , singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do + (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) + E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId + E.orderBy [E.asc $ cmp E.^. CompanyName] + return (cmp E.^. CompanyName) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail querySuperUser diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index bdc1cc611..cf5051ef5 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -29,6 +29,9 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit spacerCell :: IsDBTable m a => DBCell m a spacerCell = cell [whamlet| |] +semicolonCell :: IsDBTable m a => DBCell m a +semicolonCell = cell [whamlet|; |] + tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a tellCell = flip mappend . writerCell . tell diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 0da59383f..9acaf1c2f 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -23,8 +23,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgTableCompanyNrSupersDefault} _{MsgTableCompanyNrRerouteDefault} - _{MsgPrefersPostal} - + _{MsgPrefersPostal} #{nrCompanySupervisors} #{nrCompanyDefaultReroutes} From 8165892b2e4f945780bb8420cfc4eed50fdd294d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 11:35:12 +0000 Subject: [PATCH 03/12] fix(lms): mark as ended only if not seen for at least one day --- src/Jobs/Handler/LMS.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 586b2404e..5ff83df0d 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -347,6 +347,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. E.isNothing (luser E.^. LmsUserEnded ) E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. luser E.^. LmsUserReceived E.<= E.justVal (addUTCTime (-nominalDay) now) E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent From 5936435c54f15a45941836deb43d7574f62bbc96 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 11:50:01 +0000 Subject: [PATCH 04/12] Revert "fix(lms): mark as ended only if not seen for at least one day" This reverts commit 8165892b2e4f945780bb8420cfc4eed50fdd294d --- src/Jobs/Handler/LMS.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 5ff83df0d..586b2404e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -347,7 +347,6 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. E.isNothing (luser E.^. LmsUserEnded ) E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet - E.&&. luser E.^. LmsUserReceived E.<= E.justVal (addUTCTime (-nominalDay) now) E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent From 2d37315d18e97e18ea1441dd595a4dc39c7e9d3f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 17:06:46 +0100 Subject: [PATCH 05/12] chore(lms): log newly unreported idents --- models/lms.model | 1 + src/Jobs/Handler/LMS.hs | 30 +++++++++++++++++++++++++++--- src/Model/Migration/Definitions.hs | 3 ++- 3 files changed, 30 insertions(+), 4 deletions(-) diff --git a/models/lms.model b/models/lms.model index e72c7fc82..4ba0f3927 100644 --- a/models/lms.model +++ b/models/lms.model @@ -182,4 +182,5 @@ LmsReportLog result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success] lock Bool -- (0|1) timestamp UTCTime default=now() + missing Bool default=false deriving Generic \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 586b2404e..0f510f64c 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -389,16 +389,40 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult - E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.&&. E.not_ (lrl E.^. LmsReportLogMissing) E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.not_ (E.isTrue samelog) return (LmsReportLog E.<# (lreport E.^. LmsReportQualification) E.<&> (lreport E.^. LmsReportIdent ) - E.<&> (lreport E.^. LmsReportDate ) + E.<&> E.nothing E.<&> (lreport E.^. LmsReportResult ) E.<&> (lreport E.^. LmsReportLock ) - E.<&> (lreport E.^. LmsReportTimestamp )) + E.<&> (lreport E.^. LmsReportTimestamp ) + E.<&> E.false) + E.insertSelect $ do + lrl <- E.from $ E.table @LmsReportLog + E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing) + E.&&. E.notExists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent + ) + E.&&. E.notExists (do + lrl_old <- E.from $ E.table @LmsReportLog + E.where_ $ lrl_old E.^. LmsReportLogQualification E.==. E.val qid + E.&&. lrl_old E.^. LmsReportLogIdent E.==. lrl E.^. LmsReportLogIdent + E.&&. lrl_old E.^. LmsReportLogTimestamp E.>. lrl E.^. LmsReportLogTimestamp + ) + return (LmsReportLog + E.<# (lrl E.^. LmsReportLogQualification) + E.<&> (lrl E.^. LmsReportLogIdent ) + E.<&> (lrl E.^. LmsReportLogDate ) + E.<&> (lrl E.^. LmsReportLogResult ) + E.<&> (lrl E.^. LmsReportLogLock ) + E.<&> E.val now + E.<&> E.true) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 4224ab7b7..5f9940449 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -139,7 +139,8 @@ migrateManual = do , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")") , ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")") , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") - , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") + , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") + , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") ] where addIndex :: Text -> Sql -> Migration From 3865bda64d488c161b55e1f6eb48ca1b742dff98 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 17:29:57 +0100 Subject: [PATCH 06/12] fix(lms): improve sorting for firm all --- src/Handler/Firm.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index de7a86d06..1b27ad612 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -272,11 +272,11 @@ mkFirmAllTable isAdmin uid = do , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) , singletonMap "users" $ SortColumn firmCountUsers - , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "supervisors" $ SortColumn firmHasSupervisors -- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised -- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted -- , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost - , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes + , singletonMap "reroute-def" $ SortColumn firmHasDefaultReroutes -- , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors -- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes -- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' From 631d157688b79dd80916ee27ef08f209ccfb1f3b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 18:38:21 +0100 Subject: [PATCH 07/12] chore(firm): add messaging action (WIP) --- .../uniworx/categories/firm/de-de-formal.msg | 2 + messages/uniworx/categories/firm/en-eu.msg | 2 + routes | 5 +- src/Handler/Firm.hs | 100 ++++++++++++++++-- src/Handler/Utils/Communication.hs | 1 + 5 files changed, 103 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 4fb1d392d..65e8291f1 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -13,6 +13,8 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen +FirmsNotification: Firmen Benachrichtigung versenden +FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index a4df65482..68e4add9b 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -13,6 +13,8 @@ FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperAll: Remove all active supervisions for this company +FirmsNotification: Send company notification +FirmNotification fsh: Send notification to company #{fsh} FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} diff --git a/routes b/routes index 6b89c13f6..694386474 100644 --- a/routes +++ b/routes @@ -113,10 +113,13 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET POST !supervisor +/firms FirmAllR GET POST !supervisor +/firms/comm FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor +/firm/#CompanyShorthand/comm FirmCommR GET POST + /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1b27ad612..b6eb43e95 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -11,6 +11,8 @@ module Handler.Firm , getFirmR , postFirmR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR + , getFirmCommR , postFirmCommR + , getFirmsCommR, postFirmsCommR ) where @@ -18,6 +20,7 @@ import Import -- import Jobs import Handler.Utils +import Handler.Utils.Communication import qualified Data.Set as Set import qualified Data.Map as Map @@ -494,8 +497,10 @@ mkFirmUserTable isAdmin cid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper ] + -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -541,7 +546,7 @@ getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do isAdmin <- hasReadAccessTo AdminR - let fshId = CompanyKey fsh + let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers , E.Value nrCompanySupervisors @@ -551,10 +556,10 @@ postFirmUsersR fsh = do , E.Value nrCompanyEmployeeRerPost , E.Value nrCompanyDefaultReroutes , E.Value nrCompanyActiveReroutes - ) , (fusrRes, fusrTable)) <- runDB $ (,) + ) , (fusrRes, fusrTable)) <- runDB $ (,) <$> fromMaybeM notFound (E.selectOne $ do cmpy <- E.from $ E.table @Company - E.where_ $ cmpy E.^. CompanyId E.==. E.val fshId + E.where_ $ cmpy E.^. CompanyId E.==. E.val cid return ( cmpy , cmpy & firmCountUsers , cmpy & firmCountSupervisors @@ -565,11 +570,18 @@ postFirmUsersR fsh = do , cmpy & firmCountDefaultReroutes , cmpy & firmCountActiveReroutes )) - <*> mkFirmUserTable isAdmin fshId + -- superVs <- E.select $ do + -- usr <- E.from $ E.table @User + -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr + -- return usr + <*> mkFirmUserTable isAdmin cid - formResult fusrRes $ \case - (FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO" + formResult fusrRes $ \case (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" + (FirmUserActNotifyData , fids) -> do + cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" $(widgetFile "firm-users") @@ -755,3 +767,79 @@ postFirmSupersR fsh = do
^{fsprTable} |] + + +getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html +getFirmCommR = postFirmCommR +postFirmCommR fsh = handleFirmCommR (SomeRoute FirmUsersR) (Just fsh) + + +getFirmsCommR, postFirmsCommR :: Handler Html +getFirmsCommR = postFirmsCommR +postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing + + +handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html +handleFirmCommR ultDest mbFsh = do + let decrypt' :: CryptoUUIDUser -> Handler UserId + decrypt' = decrypt + + mbCid = CompanyKey <$> mbFsh + + -- queryEmpys :: CompanyId -> Handler [UserId] + queryEmpys cid = E.unValue <<$>> runDB (E.select $ do + (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid + return $ emp E.^. UserId + ) + + chosen <- mapM decrypt =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + empys <- maybe (return chosen) queryEmpys mbCid -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) + + cmpys <- runDB $ E.select $ do + cmpy <- E.from $ E.table @Company + E.where_ $ E.exists $ do + usrCmpy <- E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList chosen + E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + return $ cmpy E.^.CompanyId + + let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) + queryCmpy sORe acid = do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid + E.&&. (if sORe + then -- supervisors only + E.exists $ do + usrSpr <- E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser E.in_ E.valList empys + else -- chosen employees for this company only + usr E.^. UserId E.in_ E.valList empys + ) + + commR CommunicationRoute + { crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh + , crUltDest = ultDest + , crJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> + [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys ] + } + +{- + ??? x + + Alle Supervisor von Leuten in X, gruppiert nach Firma + Alle Teilnehmer von X + + Ansprechpartner aus X + - Fred + Ansprechpartner aus Y + - Otto + Angestellte aus X + - Fred + - Meier + -} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 93577f8ed..3ec2dd854 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -30,6 +30,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet + | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientGroup where From 8500e72dee66ae3bbb88d7450a4307b284b58c85 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 21:03:15 +0000 Subject: [PATCH 08/12] chore(release): 27.4.48 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 231e3501f..bc81a5744 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07) + + +### Bug Fixes + +* **lms:** mark as ended only if not seen for at least one day ([8165892](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8165892b2e4f945780bb8420cfc4eed50fdd294d)) + ## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03) ## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03) diff --git a/nix/docker/version.json b/nix/docker/version.json index ab8350d96..128f6e4a8 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.47" + "version": "27.4.48" } diff --git a/package-lock.json b/package-lock.json index db2b94dbc..67f032ee5 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.47", + "version": "27.4.48", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 24ecd1bcc..04e02d31c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.47", + "version": "27.4.48", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index edd6f7dcc..de481c5b4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.47 +version: 27.4.48 dependencies: - base - yesod From a98c3190e0837fbf42222476139f199d89fd776e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 13:00:31 +0100 Subject: [PATCH 09/12] chore(firm): messaging almost complete - illegal variable name splicing dispatch --- .../categories/jobs_handler/de-de-formal.msg | 1 - .../uniworx/categories/jobs_handler/en-eu.msg | 1 - .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Foundation/Navigation.hs | 2 + src/Handler/Firm.hs | 62 ++++++++++--------- src/Handler/Utils/Communication.hs | 25 +++++++- src/Jobs/Handler/SendCourseCommunication.hs | 31 +++++++++- src/Jobs/Types.hs | 7 +++ 11 files changed, 99 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/categories/jobs_handler/de-de-formal.msg b/messages/uniworx/categories/jobs_handler/de-de-formal.msg index 94fae99d1..dcb48a3fa 100644 --- a/messages/uniworx/categories/jobs_handler/de-de-formal.msg +++ b/messages/uniworx/categories/jobs_handler/de-de-formal.msg @@ -15,7 +15,6 @@ ResetPassword: FRADrive-Passwort ändern bzw. setzen MailSubjectChangeUserDisplayEmail: E-Mail-Adresse in FRADrive verwenden MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer/Die oben genannte Benutzerin möchte „#{displayEmail}“ als E-Mail-Adresse in FRADrive verwenden. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte! MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in FRADrive verwenden -CommCourseSubject: Kursartmitteilung InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat. InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat. diff --git a/messages/uniworx/categories/jobs_handler/en-eu.msg b/messages/uniworx/categories/jobs_handler/en-eu.msg index 3367e7a7a..e18244502 100644 --- a/messages/uniworx/categories/jobs_handler/en-eu.msg +++ b/messages/uniworx/categories/jobs_handler/en-eu.msg @@ -15,7 +15,6 @@ ResetPassword: Reselt FRADrive password MailSubjectChangeUserDisplayEmail: Set email address in FRADrive MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to set “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it! MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to set this email address as their own in FRADrive -CommCourseSubject: Course type message InvitationAcceptDecline: Accept/Decline invitation InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive. InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive. diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 373cfc0e6..b306bfdfc 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -136,6 +136,7 @@ MenuLmsReport: Ergebnisse E‑Learning MenuFirms: Firmen MenuFirmUsers: Angehörige MenuFirmSupervisors: Ansprechpartner +MenuFirmsComm: Mitteilung MenuSap: SAP Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c46f047da..c8c18365f 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -137,6 +137,7 @@ MenuLmsReport: E‑learning Results MenuFirms: Companies MenuFirmUsers: Associates MenuFirmSupervisors: Supervisors +MenuFirmsComm: Messaging MenuSap: SAP Interface diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 13bae27f0..c02cbe1fb 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -13,6 +13,7 @@ RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber:innen RecipientToggleAll: Alle/Keine CommCourseTestSubject customSubject@Text !ident-ok: [TEST] #{customSubject} UtilCommCourseSubject: Kursartmitteilung +UtilCommFirmSubject: Firmenmitteilung CommRecipients: Empfänger:innen CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 27a7eecad..1135dbade 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -13,6 +13,7 @@ RGCourseUnacceptedApplicants: Applicants not accepted RecipientToggleAll: All/None CommCourseTestSubject customSubject: [TEST] #{customSubject} UtilCommCourseSubject: Course type message +UtilCommFirmSubject: Company message CommRecipients: Recipients CommRecipientsTip: You always receive a copy of the message CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties. diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index e53e6b3ae..0c8cbd1a2 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -124,9 +124,11 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing +breadcrumb FirmsCommR = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh +breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index b6eb43e95..5087e68c1 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -771,7 +771,7 @@ postFirmSupersR fsh = do getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR -postFirmCommR fsh = handleFirmCommR (SomeRoute FirmUsersR) (Just fsh) +postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh) getFirmsCommR, postFirmsCommR :: Handler Html @@ -781,29 +781,36 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html handleFirmCommR ultDest mbFsh = do - let decrypt' :: CryptoUUIDUser -> Handler UserId - decrypt' = decrypt + let decryptUserId :: CryptoUUIDUser -> Handler UserId + decryptUserId = decrypt mbCid = CompanyKey <$> mbFsh - -- queryEmpys :: CompanyId -> Handler [UserId] + {- + queryEmpys :: CompanyId -> Handler [UserId] queryEmpys cid = E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid return $ emp E.^. UserId ) + -} - chosen <- mapM decrypt =<< lookupGlobalGetParams GetRecipient -- retrieve selected users - empys <- maybe (return chosen) queryEmpys mbCid -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) + selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) + E.unValue <<$>> runDB (E.select $ do + (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid + return $ emp E.^. UserId + )) - cmpys <- runDB $ E.select $ do + cmpys <- E.unValue <<$>> runDB (E.select $ do cmpy <- E.from $ E.table @Company E.where_ $ E.exists $ do - usrCmpy <- E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList chosen + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId return $ cmpy E.^.CompanyId - + ) let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) queryCmpy sORe acid = do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) @@ -811,35 +818,30 @@ handleFirmCommR ultDest mbFsh = do E.&&. (if sORe then -- supervisors only E.exists $ do - usrSpr <- E.table @UserSupervisor + usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser E.in_ E.valList empys - else -- chosen employees for this company only - usr E.^. UserId E.in_ E.valList empys - ) + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + else -- selected employees for this company only + usr E.^. UserId `E.in_` E.valList empys + ) + return usr commR CommunicationRoute { crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh , crUltDest = ultDest - , crJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crTestJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys ] } -{- - ??? x - - Alle Supervisor von Leuten in X, gruppiert nach Firma - Alle Teilnehmer von X - - Ansprechpartner aus X - - Fred - Ansprechpartner aus Y - - Otto - Angestellte aus X - - Fred - - Meier + {- Auswahlbox für Mitteilung: + Wenn Firma gewählt, dann zeige: + Alle Supervisor von Leuten in X, gruppiert nach deren Firma + Alle Teilnehmer von X + Wenn keine Firma gewählt, dann zeige: + Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma + Alle gewählten Personen, gruppiert nach deren Firma -} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 3ec2dd854..91e66d4b8 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -8,6 +8,7 @@ module Handler.Utils.Communication , Communication(..) , commR , crJobsCourseCommunication, crTestJobsCourseCommunication + , crJobsFirmCommunication, crTestFirmCommunication -- * Re-Exports , Job(..) ) where @@ -108,6 +109,28 @@ crTestJobsCourseCommunication jCourse comm = do crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) +crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication jCompany Communication{..} = do + jSender <- requireAuthId + let jMailContent = cContent + allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients + jMailObjectUUID <- liftIO getRandom + jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case + Left email -> return . Address Nothing $ CI.original email + Right rid -> userAddress <$> getJust rid + forM_ allRecipients $ \jRecipientEmail -> + yield JobSendFirmCommunication{..} + +crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crTestFirmCommunication jCompany comm = do + jSender <- requireAuthId + MsgRenderer mr <- getMsgRenderer + let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) + crJobsFirmCommunication jCompany comm' .| C.filter ((== Right jSender) . jRecipientEmail) + + + + commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do cUser <- maybeAuth @@ -133,7 +156,7 @@ commR CommunicationRoute{..} = do let lookupUser :: UserId -> User lookupUser lId - = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (view _2 <$> suggestedRecipients) ++ chosenRecipients + = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients let chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index a8a629f60..fa4fbcb69 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -4,6 +4,7 @@ module Jobs.Handler.SendCourseCommunication ( dispatchJobSendCourseCommunication + , dispatchJobSendFirmCommunication ) where import Import @@ -37,7 +38,35 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours _mailFrom .= userAddressFrom sender addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Auto-Submitted" "no" - setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage ccSubject + setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgUtilCommCourseSubject) SomeMessage ccSubject + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + forM_ ccAttachments $ addPart' . toMailPart + when (jRecipientEmail == Right jSender) $ + addPart' $ do + partIsAttachmentCsv MsgCommAllRecipients + toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses) + + +dispatchJobSendFirmCommunication :: Either UserEmail UserId + -> Set Address + -> Maybe CompanyShorthand + -> UserId + -> UUID + -> CommunicationContent + -> JobHandler UniWorX +dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do + -- (sender,mbComp) <- runDB $ (,) + -- <$> getJust jSender + -- <*> ifMaybeM jCompany Nothing get + sender <- runDB $ getJust jSender + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + MsgRenderer mr <- getMailMsgRenderer + + void $ setMailObjectUUID jMailObjectUUID + _mailFrom .= userAddressFrom sender + addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] + addMailHeader "Auto-Submitted" "no" + setSubjectI $ maybe (SomeMessage MsgUtilCommFirmSubject) SomeMessage ccSubject addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) forM_ ccAttachments $ addPart' . toMailPart when (jRecipientEmail == Right jSender) $ diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index a0717099a..6c665adb4 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -74,6 +74,13 @@ data Job , jMailObjectUUID :: UUID , jMailContent :: CommunicationContent } + | JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId + , jAllRecipientAddresses :: Set Address + , jCompany :: Maybe CompanyShorthand + , jSender :: UserId + , jMailObjectUUID :: UUID + , jMailContent :: CommunicationContent + } | JobInvitation { jInviter :: Maybe UserId , jInvitee :: UserEmail , jInvitationUrl :: Text From a24e44efc9a20d3934d96640bb9e21b3b6d55b96 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 13:16:09 +0100 Subject: [PATCH 10/12] fix(build): fix whitespace in routes --- routes | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/routes b/routes index 694386474..9c895eae7 100644 --- a/routes +++ b/routes @@ -116,10 +116,9 @@ /firms FirmAllR GET POST !supervisor /firms/comm FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor -/firm/#CompanyShorthand/comm FirmCommR GET POST - /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office From 390ff317ea3bb4ef8918c9cda858f5f228e4a882 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 15:56:35 +0000 Subject: [PATCH 11/12] fix(lms): report log did not match qualification --- src/Jobs/Handler/LMS.hs | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 0f510f64c..06451d5a6 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -164,7 +164,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse - -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid + -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of Nothing -> do @@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime -- end users that expired by doing nothing expiredUsers <- E.select $ do (quser :& luser) <- E.from $ @@ -201,7 +201,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) - pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) + pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers) @@ -214,7 +214,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do - (quser :& qblock) <- E.from $ + (quser :& qblock) <- E.from $ E.table @QualificationUser `E.leftJoin` E.table @QualificationUserBlock `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId @@ -267,7 +267,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise) now <- liftIO getCurrentTime -- DEBUG 2rows; remove later - totalrows <- count [LmsReportQualification ==. qid] + totalrows <- count [LmsReportQualification ==. qid] $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid when (totalrows > 0) $ do let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only @@ -293,7 +293,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners E.&&. lrFltr luser lreport - return (luser, lreport) + return (luser, lreport) -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen E.update $ \luser -> do E.set luser [ LmsUserStatus E.=. E.nothing @@ -316,13 +316,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed - procBlock (Entity luid luser, Entity _ lreport) = do + procBlock (Entity luid luser, Entity _ lreport) = do let repDay = lmsReportDate lreport <|> Just now ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] return $ Sum ok_block - in lrepQry lrFltrBlock - >>= foldMapM procBlock + in lrepQry lrFltrBlock + >>= foldMapM procBlock >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later -- D) renew qualifications for all successfull learners let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed @@ -330,14 +330,14 @@ dispatchJobLmsReports qid = JobHandlerAtomic act let repDay = lmsReportDate lreport <|> Just now reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning + -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) - -- END LMS WORKAROUND 2 + -- END LMS WORKAROUND 2 ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] return $ Sum ok_renew - in lrepQry lrFltrSuccess + in lrepQry lrFltrSuccess >>= foldMapM procRenew >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) @@ -380,8 +380,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later updateReceivedLocked True >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later - -- G) Truncate LmsReport for qid, after updating log - E.insertSelect $ do + -- G) Truncate LmsReport for qid, after updating log + E.insertSelect $ do lreport <- E.from $ E.table @LmsReport let samelog = E.subSelect $ do lrl <- E.from $ E.table @LmsReportLog @@ -389,22 +389,23 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult - E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock E.&&. E.not_ (lrl E.^. LmsReportLogMissing) E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.not_ (E.isTrue samelog) return (LmsReportLog E.<# (lreport E.^. LmsReportQualification) E.<&> (lreport E.^. LmsReportIdent ) - E.<&> E.nothing + E.<&> (lreport E.^. LmsReportDate ) E.<&> (lreport E.^. LmsReportResult ) E.<&> (lreport E.^. LmsReportLock ) E.<&> (lreport E.^. LmsReportTimestamp ) E.<&> E.false) - E.insertSelect $ do + E.insertSelect $ do lrl <- E.from $ E.table @LmsReportLog E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing) - E.&&. E.notExists (do + E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid + E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent @@ -418,7 +419,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act return (LmsReportLog E.<# (lrl E.^. LmsReportLogQualification) E.<&> (lrl E.^. LmsReportLogIdent ) - E.<&> (lrl E.^. LmsReportLogDate ) + E.<&> E.nothing E.<&> (lrl E.^. LmsReportLogResult ) E.<&> (lrl E.^. LmsReportLogLock ) E.<&> E.val now @@ -514,7 +515,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act | otherwise -> return () -- users likely not yet started (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist + let lReceived = lmsUserlistTimestamp lulist update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available From 9ee80f8f7f8b7c65de8bb3540e5b6c4581978bff Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 17:41:59 +0100 Subject: [PATCH 12/12] chore(lms): message action done for firm views --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++++-- messages/uniworx/categories/firm/en-eu.msg | 4 +++- routes | 2 +- src/Handler/Firm.hs | 19 ++++++++++++++----- src/Handler/Utils/Communication.hs | 1 + .../communication/recipientLayout.hamlet | 4 ++++ 6 files changed, 27 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 65e8291f1..c50120e92 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,9 @@ FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen FirmsNotification: Firmen Benachrichtigung versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FilterSupervisor: Hat aktiven Ansprechpartner -FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört +FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner -FilterFirmPostalAddress: Postalische Firmenadresse vorhanden \ No newline at end of file +FilterFirmPostalAddress: Postalische Firmenadresse vorhanden +FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig +FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 68e4add9b..3e24de5c5 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -19,4 +19,6 @@ FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors -FilterFirmPostalAddress: Postal company addresse known \ No newline at end of file +FilterFirmPostalAddress: Postal company addresse known +FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} +FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file diff --git a/routes b/routes index 9c895eae7..931c52909 100644 --- a/routes +++ b/routes @@ -116,7 +116,7 @@ /firms FirmAllR GET POST !supervisor /firms/comm FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST -/firm/#CompanyShorthand/comm FirmCommR GET POST +/firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5087e68c1..9e6cdd55e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -366,9 +366,15 @@ postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - formResult firmRes $ \case - (FirmAllActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " companies. TODO" - (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" + formResult firmRes $ \case + (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" + (FirmAllActNotifyData , fids) -> do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList (Set.toList fids) + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -742,9 +748,12 @@ postFirmSupersR fsh = do <*> mkFirmSuperTable isAdmin fshId formResult fsprRes $ \case - (FirmSuperActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " supervisors. TODO" (FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove " <> tshow (length fids) <> " default supervisors. TODO" (FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " default and active supervisors. TODO" + (FirmSuperActNotifyData , fids) -> do + cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh @@ -834,7 +843,7 @@ handleFirmCommR ultDest mbFsh = do , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys ] + [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid] } {- Auswahlbox für Mitteilung: diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 91e66d4b8..893b22d14 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -28,6 +28,7 @@ import qualified Data.Conduit.Combinators as C data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants + -- WARNING: no RenderMessage instance, but a pattern match in templates/widgets/communication/recipientLayout.hamlet that needs to be extended | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index 7b7f188d1..9dc2beea0 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -31,6 +31,10 @@ $if not (null activeCategories) ^{rgSheetSubmittorCaption sid} $of RecipientGroup RGCourseUnacceptedApplicants _{MsgRGCourseUnacceptedApplicants} + $of RecipientGroup (RGFirmSupervisor fsh) + _{MsgFirmSupervisorOf fsh} + $of RecipientGroup (RGFirmEmployees fsh) + _{MsgFirmEmployeeOf fsh} $if hasContent category