From 640a2e61d146f16c32b1cdfa7f13d277860cde21 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 27 Nov 2023 12:07:17 +0100 Subject: [PATCH 01/11] chore(messages): Add SomeMessages newtype SomeMessages provides a RenderMessage instance for a list of messages. --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Foundation/I18n.hs | 14 ++++++++++++++ src/Handler/Firm.hs | 14 +++++++------- src/Handler/Utils/Table/Pagination.hs | 1 + 5 files changed, 24 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index f25770b33..067b7ba11 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder !ident-ok: URL RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen UtilEmptyChoice: Auswahl war leer +UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 97f5daa22..cafb5fac8 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder: URL RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions UtilEmptyChoice: Empty selection +UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. #invitation.hs InvitationAction: Action diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 8c8a0137b..571fd0249 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -43,6 +43,8 @@ module Foundation.I18n , UniWorXMessages(..) , uniworxMessages , unRenderMessage, unRenderMessage', unRenderMessageLenient + , SomeMessages(..) + , someMessages , module Foundation.I18n.TH ) where @@ -266,6 +268,18 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) + +newtype SomeMessages master = SomeMessages [SomeMessage master] + deriving newtype (Semigroup, Monoid) + +instance master ~ master' => RenderMessage master (SomeMessages master') where + renderMessage a b (SomeMessages msgs) = Text.intercalate " " $ renderMessage a b <$> msgs + +-- | convenienience function if all messages happen to belong to the exact same type +someMessages :: RenderMessage master msg => [msg] -> SomeMessages master +someMessages msgs = SomeMessages $ SomeMessage <$> msgs + + instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite renderMessage f ls (Just s) = renderMessage f ls s renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 0eeaa5edd..d5cd1da0b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -98,13 +98,13 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData @@ -803,8 +803,8 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 415fb255b..0d5182704 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1723,6 +1723,7 @@ i18nCell msg = cell $ do cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a cellTooltip = cellTooltipIcon Nothing +-- note that you can also use `cellTooltip` with `SomeMessages`, which uses ' ' for separation only cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a cellTooltips msgs = cellTooltipWgt Nothing [whamlet| $forall msg <- msgs From 0a06efd76c63180c996657c2c7d78efc5bddd83d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 27 Nov 2023 17:49:06 +0100 Subject: [PATCH 02/11] fix(firm): restrict firm access to company supervisors only --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 6 +- src/Foundation/Authorization.hs | 3 +- src/Foundation/I18n.hs | 2 +- src/Handler/Firm.hs | 66 ++++++++++++++----- 5 files changed, 57 insertions(+), 24 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 3158130c1..0d872dba0 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -9,7 +9,7 @@ FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAction: Firmenweite Aktion -FirmActionInfo: Betrifft alle Firmenangehörigen. +FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht. FirmActNotify: Mitteilung versenden FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? @@ -18,7 +18,7 @@ FirmActAddSupersvisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} -FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern +FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern FirmActChangeContactFirm: Kontaktinformationen der Firma ändern FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen. FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index b73afc808..0554ce6e9 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,7 +9,7 @@ FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAction: Companywide action -FirmActionInfo: Affects alle company associates. +FirmActionInfo: Affects alle company associates under your supervision. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? @@ -17,8 +17,8 @@ FirmActResetMutualSupervision: Supervisors supervise each other FirmActAddSupersvisors: Add supervisors FirmActAddSupersEmpty: No supervisors added FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. -RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} -FirmActChangeContactUser: Change contact data for company associates +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} +FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactFirm: Change company contact data FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise. FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 7ca298622..0243b0609 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -554,7 +554,8 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of return Authorized checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) return Authorized checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 571fd0249..fd2bb9479 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -273,7 +273,7 @@ newtype SomeMessages master = SomeMessages [SomeMessage master] deriving newtype (Semigroup, Monoid) instance master ~ master' => RenderMessage master (SomeMessages master') where - renderMessage a b (SomeMessages msgs) = Text.intercalate " " $ renderMessage a b <$> msgs + renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs -- | convenienience function if all messages happen to belong to the exact same type someMessages :: RenderMessage master msg => [msg] -> SomeMessages master diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d5cd1da0b..6030a9052 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -113,23 +113,10 @@ firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (f makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId) makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts -firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () -firmActionHandler route = flip formResult faHandler +firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler () +firmActionHandler route isAdmin = flip formResult faHandler where faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected - faHandler (FirmActResetSupervisionData{..}, fids) = do - runDB $ do - delSupers <- if firmActResetKeepOldSupers == Just False - then E.deleteCount $ do - spr <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists $ do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids - addMessageI Success $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams route -- reload to reflect changes faHandler (FirmActNotifyData, Set.toList -> fids) = do usrs <- runDB $ E.select $ E.distinct $ do @@ -139,6 +126,26 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + faHandler (FirmActResetSupervisionData{..}, fids) = do + madId <- bool maybeAuthId (return Nothing) isAdmin + let suprFltr = if + | isAdmin -> const E.true + | (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId + | otherwise -> const E.false + runDB $ do + delSupers <- if firmActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ suprFltr spr E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) + else return 0 + newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids + addMessageI Success $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams route -- reload to reflect changes + faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers @@ -204,11 +211,12 @@ runFirmActionFormPost cid route isAdmin acts = do , formSubmit = FormSubmit , formAnchor = Just faAnchor } - firmActionHandler route faRes + firmActionHandler route isAdmin faRes return [whamlet|

_{MsgFirmAction} + $

_{MsgFirmActionInfo} @@ -249,6 +257,30 @@ addDefaultSupervisors cid employees = do ) (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) +-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual +addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 +addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do + superv <- E.from $ E.table @UserSupervisor + E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId + E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + ]) + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + -- like `addDefaultSupervisors`, but selects all employees of given companies from database addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 addDefaultSupervisorsAll mutualSupervision cids = do @@ -621,7 +653,7 @@ postFirmAllR = do uid <- requireAuthId isAdmin <- checkAdmin (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - firmActionHandler FirmAllR firmRes + firmActionHandler FirmAllR isAdmin firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") From 92aca1b830f3bac78543e26956ec2707eb194187 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Nov 2023 15:32:33 +0100 Subject: [PATCH 03/11] refactor(performance): disable modalAccess use for known admins modalAccess displays a link to modal only if the user has the rights to follow that link. However, for large dbTables this checking takes too long. So we use a conventional modal instead again. Worst-case: some non-admins are shown links that they cannot follow --- src/Handler/Admin/Avs.hs | 4 +- src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/Users.hs | 2 +- src/Handler/Firm.hs | 7 ++-- src/Handler/LMS.hs | 4 +- src/Handler/Qualification.hs | 2 +- src/Handler/Tutorial/Users.hs | 4 +- src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 62 ++++++++++++++++++++++++------ src/Handler/Utils/Table/Columns.hs | 8 +++- src/Handler/Utils/Widgets.hs | 7 ++-- src/Utils/Frontend/Modal.hs | 2 +- 12 files changed, 74 insertions(+), 32 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 3773a9c85..f65f44f50 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -548,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal , colUserNameLink AdminUserR - , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a + , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a -- , colUserCompany , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do @@ -752,7 +752,7 @@ getProblemAvsErrorR = do dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ colUserNameModalHdr MsgLmsUser AdminUserR + [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR , sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo) $ avsPersonNoLinkedCell . view reserrUsrAvs , sortable Nothing (i18nCell MsgAvsPersonId) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index c2056d6c8..4a4e11e9d 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR) , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail - , pure . cap' $ colUserMatriclenr + , pure . cap' $ colUserMatriclenr False , pure . cap' $ colUserQualifications nowaday , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 89d0bf40f..cd06ea982 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) - , pure colUserMatriclenr + , pure $ colUserMatriclenr False , pure $ colStudyFeatures resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 6030a9052..eb95a1e40 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -215,8 +215,7 @@ runFirmActionFormPost cid route isAdmin acts = do return [whamlet|

- _{MsgFirmAction} - $ + _{MsgFirmAction}

_{MsgFirmActionInfo} @@ -744,7 +743,7 @@ mkFirmUserTable isAdmin cid = do dbtColonnade = formColonnade $ mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr @@ -1022,7 +1021,7 @@ mkFirmSuperTable isAdmin cid = do 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 + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin 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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 682e0c7f4..9d363f449 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -632,7 +632,7 @@ postLmsR sid qsh = do ] colChoices cmpMap = mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) - , colUserNameModalHdr MsgLmsUser AdminUserR + , colUserNameModalHdrAdmin MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr @@ -640,7 +640,7 @@ postLmsR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , colUserMatriclenr + , colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 65710b884..5b2c315af 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -591,7 +591,7 @@ postQualificationR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , guardMonoid isAdmin colUserMatriclenr + , guardMonoid isAdmin $ colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 46d15e16b..973366f0a 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR - , pure colUserEmail - , pure colUserMatriclenr + , pure colUserEmail + , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday ] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 1133c56d8..0cbbbde66 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -100,7 +100,7 @@ postUsersR = do , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2cab48fc2..6b776cd41 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -218,7 +218,7 @@ cellHasUserLink toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) in anchorCellM (toLink <$> encrypt uid) nWdgt --- | like `cellHasUserLink` but opens the user in a modal instead +-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c cellHasUserModal toLink user = let userEntity = user ^. hasEntityUser @@ -226,10 +226,21 @@ cellHasUserModal toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid - modalAccess False nWdgt nWdgt $ toLink uuid + modalAccess nWdgt nWdgt False $ toLink uuid in cell lWdgt --- | like `cellHasUserModal` but with fixed route and showing an edit icon instead +-- | like `cellHasUserModal` but but always display link without prior access rights checks +cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c +cellHasUserModalAdmin toLink user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt $ Left $ SomeRoute $ toLink uuid + in cell lWdgt + +-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModal user = let userEntity = user ^. hasEntityUser @@ -237,16 +248,39 @@ cellEditUserModal user = nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid - modalAccess True nWdgt mempty $ ForProfileR uuid + modalAccess mempty nWdgt True $ ForProfileR uuid in cell lWdgt + +-- | like `cellEditUserModal` but always displays the link without prior access rights checks +cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModalAdmin user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + in cell lWdgt + cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer -cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a -cellHasMatrikelnummerLinked usr +cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a +cellHasMatrikelnummerLinked isAdmin usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid) + if isAdmin + then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid) + | otherwise = mempty + where + usrEntity = usr ^. hasEntityUser + +cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a +cellHasMatrikelnummerLinkedAdmin usr + | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do + uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey + modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser @@ -364,7 +398,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser - let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid + let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) @@ -386,7 +420,7 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp - modalAccess False dWgt dWgt $ toLink uuid + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -405,7 +439,7 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp - modalAccess False dWgt dWgt $ toLink uuid + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -466,7 +500,13 @@ avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson - modalAccess False nWgt nWgt $ AdminAvsUserR uuid + modalAccess nWgt nWgt False $ AdminAvsUserR uuid + +avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c +avsPersonNoLinkedCellAdmin a = cell $ do + uuid <- liftHandler $ encrypt $ a ^. _userAvsUser + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid) avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 6184d1314..c0f768e99 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -336,6 +336,10 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink) +-- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them) +colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) +colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink) + -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') sortUserName = ("user-name",) . sortUserNameBare @@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) -colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked +colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c) +colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 61c3c298e..1e5f6bdc2 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -123,15 +123,14 @@ editedByW fmt tm usr = do [whamlet|_{MsgUtilEditedBy usr ft}|] --- | like `modal`, but checks access rights to the link -modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget -modalAccess writeAccess wdgtYes wdgtNo route = do +-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead +modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget +modalAccess wdgtNo wdgtYes writeAccess route = do authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route if authOk then modal wdgtYes (Left $ SomeRoute route) else wdgtNo - ---------- -- HEAT -- ---------- diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index 304326ccc..d8180f58d 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -40,7 +40,7 @@ customModal Modal{..} = do -- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant modal :: WidgetFor site () -- ^ Widget that represents the link - -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget + -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal content: either dynamic link or static widget -> WidgetFor site () -- ^ result widget modal modalTrigger' modalContent = customModal Modal{..} where From eb541b4e91ecf86f7cba1c3b080675543a1f1dbd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Nov 2023 18:54:16 +0100 Subject: [PATCH 04/11] chore(firm): add action to change individual supervisors --- .../uniworx/categories/firm/de-de-formal.msg | 4 ++ messages/uniworx/categories/firm/en-eu.msg | 4 ++ .../send/send_notifications/de-de-formal.msg | 2 +- .../send/send_notifications/en-eu.msg | 2 +- src/Handler/Firm.hs | 43 ++++++++++++++++--- 5 files changed, 48 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 0d872dba0..2772c864a 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -24,6 +24,10 @@ FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Fi FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen +FirmUserActSetSupervisor: Ansprechpartner ändern +FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen +FirmSetSupervisor: Existierende Ansprechpartner hinzufügen +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)} FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 0554ce6e9..a91186f6e 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -24,6 +24,10 @@ FirmActChangeContactFirmInfo: The company contact data is only used for new comp FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default +FirmUserActSetSupervisor: Change supervision +FirmNewSupervisor: Appoint new individual supervisors +FirmSetSupervisor: Add existing supervisors +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index b2a350b3e..cba2c8110 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen E MailSupervisedNote: Hinweis MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet: MailSupervisorReroute: Benachrichtigungsumleitung -MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file +MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index b06a1c2eb..04fe30088 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warning: This message was not sent to the original recipie MailSupervisedNote: Please note MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely: MailSupervisorReroute: Reroute notifications -MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead \ No newline at end of file +MailSupervisorRerouteTooltip: All notification will be rerouted to these supervisors instead \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index eb95a1e40..547c4e07c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -664,6 +664,7 @@ postFirmAllR = do data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision + | FirmUserActSetSupervisor | FirmUserActMkSuper | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -672,11 +673,17 @@ data FirmUserAction = FirmUserActNotify nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmUserAction id -data FirmUserActionData = FirmUserActNotifyData +data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool } + | FirmUserActSetSupervisorData + { firmUserActSetSuperNames :: Set Text + , firmUserActSetSuperIds :: [UserId] + , firmUserActSetSuperReroute :: Bool + , firmUserActSetSuperKeep :: Bool + } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } | FirmUserActChangeContactData @@ -831,6 +838,11 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData + <$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData @@ -904,10 +916,6 @@ postFirmUsersR fsh = do formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do - nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing - reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) @@ -919,6 +927,31 @@ postFirmUsersR fsh = do newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound + nrSupers = fromIntegral $ length newSupers + nrUsers = fromIntegral $ length uids + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +

    + $forall (usr,_) <- usersNotFound +
  • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + delSupers <- runDB + $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep + <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] + addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActChangeContactData{..}, Set.toList -> uids) -> let changes = catMaybes [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! From 57d9447b4f94b68e356461f6e25f6289ff03e430 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 13:18:30 +0100 Subject: [PATCH 05/11] chore(firm): update table action access rights --- src/Handler/Firm.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 547c4e07c..79236d154 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -530,7 +530,7 @@ mkFirmAllTable isAdmin uid = do dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> @@ -748,7 +748,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -834,7 +834,7 @@ mkFirmUserTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) acts = mconcat - [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) @@ -883,7 +883,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- checkAdmin + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -1052,7 +1052,7 @@ mkFirmSuperTable isAdmin cid = do return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) return (usr, supervised, rerouted, cmps, supervisor, reroute) dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> @@ -1092,7 +1092,7 @@ mkFirmSuperTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat - [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] From 929eb1b1755c1df294fb789928fb15665bce3628 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 13:22:34 +0100 Subject: [PATCH 06/11] chore(firm): hide supervision key data by default --- messages/uniworx/categories/firm/de-de-formal.msg | 3 ++- messages/uniworx/categories/firm/en-eu.msg | 3 ++- templates/firm-users.hamlet | 4 +++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 2772c864a..2f5a807ef 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -51,4 +51,5 @@ TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung FormFieldPostal: Benachrichtigungseinstellung FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner -FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ No newline at end of file +FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert +FirmSupervisionKeyData: Kennzahlen Ansprechpartner \ 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 a91186f6e..b14df5fba 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -51,4 +51,5 @@ TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute FormFieldPostal: Notification type FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor -FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file +FirmUserChanges n: Notification settings changed for #{n} company associates +FirmSupervisionKeyData: Supervision key data \ No newline at end of file diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index c10c06e13..05e90f8ed 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -8,7 +8,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction} -
    +
    +

    + _{MsgFirmSupervisionKeyData}
    From ef9a5dc5a9bd729e4a8c5a8af2193fead366726e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 16:22:09 +0100 Subject: [PATCH 07/11] chore(firm): disallow supervisors on firm routes for now --- routes | 6 +++--- src/Handler/Firm.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/routes b/routes index df8c32fa2..b024c577f 100644 --- a/routes +++ b/routes @@ -113,12 +113,12 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firms FirmAllR GET POST !supervisor +/firms FirmAllR GET POST -- not yet !supervisor /firms/comm/+Companies FirmsCommR GET POST /firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST -/firm/#CompanyShorthand FirmUsersR GET POST !supervisor -/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor +/firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor +/firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 79236d154..6e88accfa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -735,7 +735,7 @@ mkFirmUserTable isAdmin cid = do return (usr E.^. UserId, usr E.^. UserDisplayName) let -- supervisorField :: Field Handler UserId - supervisorField = selectField $ procOptions rawSupers + -- supervisorField = selectField $ procOptions rawSupers supervisorsField = multiSelectField $ procOptions rawSupers fsh = unCompanyKey cid @@ -825,7 +825,7 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) , 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) From 75e4975c52e0ab1beff0251d9b654cdaab1d1af8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 30 Nov 2023 18:32:25 +0100 Subject: [PATCH 08/11] refactor(mail): course and firm message are sent only once to each supervisor --- .../uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- src/Handler/Firm.hs | 2 +- src/Handler/Utils/Communication.hs | 40 +++--- src/Handler/Utils/Mail.hs | 8 +- src/Handler/Utils/Users.hs | 118 ++++++++++-------- src/Jobs/Handler/SendCourseCommunication.hs | 4 +- src/Mail.hs | 13 +- src/Utils/Set.hs | 13 +- 9 files changed, 121 insertions(+), 81 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 2f5a807ef..e53e55b50 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -34,7 +34,7 @@ FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{ FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden -FirmsNotification: Firmen Benachrichtigung versenden +FirmsNotification: Firmen E-Mail versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FirmsNotificationTitle: Firmen benachrichtigen FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index b14df5fba..be6d003ad 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -34,7 +34,7 @@ FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company -FirmsNotification: Send company notification +FirmsNotification: Send company notification e-mail FirmNotification fsh: Send notification to company #{fsh} FirmsNotificationTitle: Company notification FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 6e88accfa..fcf60c8a6 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -535,7 +535,7 @@ mkFirmAllTable isAdmin uid = do anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm - in anchorCell (FirmUsersR fsh) $ toWgt fsh + in anchorCell (FirmSupersR fsh) $ toWgt fsh , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 70c8e45e2..3783ba0aa 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -15,6 +15,7 @@ module Handler.Utils.Communication import Import import Handler.Utils +import Handler.Utils.Users import Jobs.Queue @@ -95,35 +96,40 @@ makeLenses_ ''Communication crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsCourseCommunication jCourse 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 JobSendCourseCommunication{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendCourseCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email + crTestJobsCourseCommunication jCourse comm = do jSender <- requireAuthId - MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) -crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication, crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsFirmCommunication jCompanies 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{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendFirmCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email -crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () crTestFirmCommunication jCompanies comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 6a5e7be61..851928033 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -4,7 +4,8 @@ module Handler.Utils.Mail ( addRecipientsDB - , userAddress, userAddressFrom + , userAddress, userAddress' + , userAddressFrom , userMailT, userMailTdirect , addFileDB , addHtmlMarkdownAlternatives @@ -52,6 +53,11 @@ userAddress :: User -> Address userAddress User{userEmail, userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail +userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address +-- Like userAddress', but does not require a complete entity +userAddress' userEmail userDisplayEmail userDisplayName + = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) userAddressError User{userEmail, userDisplayEmail, userDisplayName} | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index fb19f07a7..1e4a28487 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + -- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users ( computeUserAuthenticationDigest @@ -17,7 +19,7 @@ module Handler.Utils.Users , getEmailAddress , getPostalAddress, getPostalPreferenceAndAddress , abbrvName - , getReceivers + , getReceivers, getReceiversFor , getSupervisees ) where @@ -38,7 +40,9 @@ import qualified Data.Set as Set -- import qualified Data.List as List import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -111,6 +115,14 @@ getReceivers uid = do then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) +-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates +getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId] +getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do + usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor + `E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications)) + E.where_ $ usr E.^. UserId `E.in_` E.vals uids + return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId + -- | return underlings for currently logged in user getSupervisees :: DB (Set UserId) getSupervisees = do @@ -185,7 +197,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' go didLdap = do - let retrieveUsers = E.select . E.from $ \user -> do + let retrieveUsers = E.select . EL.from $ \user -> do E.where_ . E.or $ map (E.and . map (toSql user)) criteria when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit return user @@ -307,7 +319,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseFavourite - (E.from $ \courseFavourite -> do + (EL.from $ \courseFavourite -> do E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId return $ CourseFavourite E.<# E.val newUserId @@ -320,7 +332,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseNoFavourite - (E.from $ \courseNoFavourite -> do + (EL.from $ \courseNoFavourite -> do E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId return $ CourseNoFavourite E.<# E.val newUserId @@ -331,7 +343,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeField - (E.from $ \examOfficeField -> do + (EL.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId return $ ExamOfficeField E.<# E.val newUserId @@ -343,7 +355,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId return $ ExamOfficeUser E.<# E.val newUserId @@ -353,7 +365,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamOfficeUserOffice ==. oldUserId ] E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId return $ ExamOfficeUser E.<# (examOfficeUser E.^. ExamOfficeUserOffice) @@ -362,7 +374,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) deleteWhere [ ExamOfficeUserUser ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeResultSynced -> do + E.insertSelect . EL.from $ \examOfficeResultSynced -> do E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeResultSynced E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool) @@ -371,7 +383,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime) deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do + E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeExternalResultSynced E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool) @@ -400,7 +412,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExternalExamStaff - (E.from $ \externalExamStaff -> do + (EL.from $ \externalExamStaff -> do E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId return $ ExternalExamStaff E.<# E.val newUserId @@ -415,7 +427,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSubmissionUser - (E.from $ \submissionUser -> do + (EL.from $ \submissionUser -> do E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId return $ SubmissionUser E.<# E.val newUserId @@ -425,19 +437,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ SubmissionUserUser ==. oldUserId ] do - collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do - E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup - E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do + EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId - E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse return (submissionGroupUserA, submissionGroupUserB) forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) -> tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB E.insertSelectWithConflict UniqueSubmissionGroupUser - (E.from $ \submissionGroupUser -> do + (EL.from $ \submissionGroupUser -> do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId return $ SubmissionGroupUser E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup) @@ -454,7 +466,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueLecturer - (E.from $ \lecturer -> do + (EL.from $ \lecturer -> do E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId return $ Lecturer E.<# E.val newUserId @@ -466,7 +478,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueParticipant - (E.from $ \courseParticipant -> do + (EL.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId return $ CourseParticipant E.<# (courseParticipant E.^. CourseParticipantCourse) @@ -496,7 +508,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseUserExamOfficeOptOut - (E.from $ \examOfficeOptOut -> do + (EL.from $ \examOfficeOptOut -> do E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId return $ CourseUserExamOfficeOptOut E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse) @@ -508,7 +520,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserFunction - (E.from $ \userFunction -> do + (EL.from $ \userFunction -> do E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId return $ UserFunction E.<# E.val newUserId @@ -520,7 +532,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSystemFunction - (E.from $ \userSystemFunction -> do + (EL.from $ \userSystemFunction -> do E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId return $ UserSystemFunction E.<# E.val newUserId @@ -533,7 +545,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserExamOffice - (E.from $ \userExamOffice -> do + (EL.from $ \userExamOffice -> do E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId return $ UserExamOffice E.<# E.val newUserId @@ -544,7 +556,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSchool - (E.from $ \userSchool -> do + (EL.from $ \userSchool -> do E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId return $ UserSchool E.<# E.val newUserId @@ -557,7 +569,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ] E.insertSelectWithConflict UniqueUserGroupMember - (E.from $ \userGroupMember -> do + (EL.from $ \userGroupMember -> do E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId return $ UserGroupMember E.<# (userGroupMember E.^. UserGroupMemberGroup) @@ -568,8 +580,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ UserGroupMemberUser ==. oldUserId ] do - collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do - E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam + collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do + EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence @@ -580,7 +592,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration E.insertSelectWithConflict UniqueExamRegistration - (E.from $ \examRegistration -> do + (EL.from $ \examRegistration -> do E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId return $ ExamRegistration E.<# (examRegistration E.^. ExamRegistrationExam) @@ -592,8 +604,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamRegistrationUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do - E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart + collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do + EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult @@ -602,7 +614,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult E.insertSelectWithConflict UniqueExamPartResult - (E.from $ \examPartResult -> do + (EL.from $ \examPartResult -> do E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId return $ ExamPartResult E.<# (examPartResult E.^. ExamPartResultExamPart) @@ -614,8 +626,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamPartResultUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do - E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam + collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do + EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus @@ -624,7 +636,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus E.insertSelectWithConflict UniqueExamBonus - (E.from $ \examBonus -> do + (EL.from $ \examBonus -> do E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId return $ ExamBonus E.<# (examBonus E.^. ExamBonusExam) @@ -657,8 +669,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } [] E.insertSelectWithConflict UniqueExamPartCorrector - (E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do - E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector + (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do + EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector) return $ ExamPartCorrector @@ -704,8 +716,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector do - collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do - E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet + collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do + EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId @@ -716,7 +728,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile E.insertSelectWithConflict UniquePersonalisedSheetFile - (E.from $ \personalisedSheetFile -> do + (EL.from $ \personalisedSheetFile -> do E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId return $ PersonalisedSheetFile E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet) @@ -731,7 +743,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueTutor - (E.from $ \tutor -> do + (EL.from $ \tutor -> do E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId return $ Tutor E.<# (tutor E.^. TutorTutorial) @@ -740,12 +752,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) do - collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do - E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId - E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse + collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do + EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId + EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId - E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId + EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup return (tutorialParticipantA, tutorialParticipantB) @@ -753,7 +765,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB E.insertSelectWithConflict UniqueTutorialParticipant - (E.from $ \tutorialParticipant -> do + (EL.from $ \tutorialParticipant -> do E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId return $ TutorialParticipant E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) @@ -764,7 +776,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSystemMessageHidden - (E.from $ \systemMessageHidden -> do + (EL.from $ \systemMessageHidden -> do E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId return $ SystemMessageHidden E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage) @@ -789,7 +801,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do ] E.insertSelectWithConflict UniqueRelevantStudyFeatures - (E.from $ \relevantStudyFeatures -> do + (EL.from $ \relevantStudyFeatures -> do E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId return $ RelevantStudyFeatures E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm) @@ -815,8 +827,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ] - usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do - E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification + usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do + EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId ) E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId @@ -838,7 +850,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId return $ UserSupervisor E.<# E.val newUserId @@ -850,7 +862,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId return $ UserSupervisor E.<# (userSupervisor E.^. UserSupervisorSupervisor) @@ -863,7 +875,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Companies, in conflict, keep the newUser-Company as is E.insertSelectWithConflict UniqueUserCompany - (E.from $ \userCompany -> do + (EL.from $ \userCompany -> do E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId return $ UserCompany E.<# E.val newUserId diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 4edaa2d4d..1a065726c 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours (sender, Course{..}) <- runDB $ (,) <$> getJust jSender <*> getJust jCourse - either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID @@ -59,7 +59,7 @@ dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompan -- <$> 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 + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID diff --git a/src/Mail.hs b/src/Mail.hs index 6f8879b71..4f9ab00d6 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -10,6 +10,7 @@ module Mail ( -- * Structured MIME emails module Network.Mail.Mime + , AddressEqIgnoreName(..) -- * MailT , MailT, defMailT , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients @@ -137,6 +138,14 @@ import Network.HTTP.Types.Header (hETag) import Web.HttpApiData (ToHttpApiData(toHeader)) +newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address } + deriving (Show, Generic) +instance Eq AddressEqIgnoreName where + (==) = (==) `on` (addressEmail . getAddress) +instance Ord AddressEqIgnoreName where + compare = compare `on` (addressEmail . getAddress) + + makeLenses_ ''Address makeLenses_ ''Mail makeLenses_ ''Part @@ -339,8 +348,8 @@ defMailT ls (MailT mailC) = do return $ mail0 & _mailFrom .~ fromAddress & _mailReplyTo .~ sender - mailRerouteTo' <- mailRerouteTo - let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on enveloper, if rerouting is active + mailRerouteTo' <- mailRerouteTo -- this is the general reroute, e.g. for test instances, not for supervisors + let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on envelope, if rerouting is active switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } ) switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)] mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2 diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index 7ef167280..79e11c662 100644 --- a/src/Utils/Set.hs +++ b/src/Utils/Set.hs @@ -5,7 +5,7 @@ module Utils.Set ( setIntersectNotOne , setIntersections -, setMapMaybe +, setMapMaybe, setMapMaybeMonotonic , concatMapSet , setSymmDiff , setProduct @@ -56,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b setMapMaybe f = Set.fromList . mapMaybe f . Set.toList +-- | like `setMapMaybe`, but only when f is strictly increasing +setMapMaybeMonotonic :: (a -> Maybe b) -> Set a -> Set b +setMapMaybeMonotonic f = Set.fromDistinctAscList . mapMaybe f . Set.toAscList + concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b concatMapSet f = Set.foldl ((. f) . (<>)) mempty -- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway @@ -68,8 +72,11 @@ setProduct :: Set a -> Set b -> Set (a, b) -- ^ Depends on the valid internal structure of the given sets setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs -setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) -setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) +-- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) +-- setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) +-- +setPartitionEithers :: Set (Either a b) -> (Set a, Set b) +setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMaybeMonotonic (preview _Right) setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k setFromFunc = Set.fromList . flip filter universeF From b1ce55597ec44774f5e293d176236bb35144b0ac Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 13:29:38 +0100 Subject: [PATCH 09/11] chore(lms): remove debug code --- .../uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- messages/uniworx/misc/de-de-formal.msg | 1 + messages/uniworx/misc/en-eu.msg | 1 + models/users.model | 2 +- routes | 1 - src/Foundation/Navigation.hs | 11 --- src/Handler/Admin/Avs.hs | 2 +- src/Handler/Firm.hs | 67 +------------------ src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 2 +- 11 files changed, 11 insertions(+), 82 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index e53e55b50..1668a06c3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -35,7 +35,7 @@ FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen E-Mail versenden -FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden +FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden FirmsNotificationTitle: Firmen benachrichtigen FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen FilterSupervisor: Hat aktiven Ansprechpartner diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index be6d003ad..7539257d1 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -35,7 +35,7 @@ FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail -FirmNotification fsh: Send notification to company #{fsh} +FirmNotification fsh: Send e-mail to #{fsh} FirmsNotificationTitle: Company notification FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification FilterSupervisor: Has active supervisor diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index ef68eb735..eaa02c0fa 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,6 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich +MultiSelectTip: Mehrfachauswahl mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 97423bdda..5b6b15f5b 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,6 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) +MultiSelectTip: Multiple selection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/models/users.model b/models/users.model index b29f71eb3..b23fe85b2 100644 --- a/models/users.model +++ b/models/users.model @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later --- The files in /models determine the database scheme. +-- The files in /models determine t he database scheme. -- The organisational split into several files has no operational effects. -- White-space and case matters: Each SQL table is named in 1st column of this file -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options diff --git a/routes b/routes index b024c577f..0ea40300c 100644 --- a/routes +++ b/routes @@ -115,7 +115,6 @@ /firms FirmAllR GET POST -- not yet !supervisor /firms/comm/+Companies FirmsCommR GET POST -/firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b029cc0ee..1d0258e31 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -125,7 +125,6 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just 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 @@ -2417,16 +2416,6 @@ pageActions ApiDocsR = return , navChildren = [] } ] -pageActions (FirmR fsh) = return - [ NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh - , navChildren = [] - } - , NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh - , navChildren = [] - } - ] pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index f65f44f50..9521912c9 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -558,7 +558,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor companies = - (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fcf60c8a6..881be6223 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -7,8 +7,7 @@ {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR , postFirmAllR - , getFirmR , postFirmR + ( getFirmAllR , postFirmAllR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR , getFirmCommR , postFirmCommR @@ -415,65 +414,6 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do E.&&. usrSpr E.^. UserSupervisorRerouteNotifications ------------------- --- Debug Handler - -getFirmR, postFirmR :: CompanyShorthand -> Handler Html -getFirmR = postFirmR -postFirmR fsh = do - let cid = CompanyKey fsh - cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. cid] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] - csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] - cactSuper <- runDB $ E.select $ do - (usr :& spr :& scmpy) <- E.from $ - E.table @User - `E.innerJoin` E.table @UserSupervisor - `E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) - `E.leftJoin` E.table @UserCompany - `E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser) - E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers) - E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany) - E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany] - let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows - return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows', usr E.^. UserPrefersPostal) - - siteLayoutMsg (SomeMessage fsh) $ do - setTitle $ citext2Html fsh - [whamlet| -

    PROVISORISCHE DEBUG SEITE -

    Diese Seite wird in der finalen Version nicht mehr enthalten sein. - -

    #{length csuper} Company Default Supervisors (non-foreign only) -
      - $forall u <- csuper -
    • ^{linkUserWidget ForProfileDataR u} - -

      #{length cactSuper} Active Supervisors for Employees -
        - $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper -
      • #{nr} Employees supervised by ^{nameWidget dn sn} # - #{iconLetterOrEmail prefPost} # - $maybe csh <- mbCsh - $if csh /= cid - from foreign company #{unCompanyKey csh} - $else - from this company - $nothing - having no associated company - -

        #{length cusers} Employees -
          - $forall u <- cusers -
        • ^{linkUserWidget ForProfileDataR u} - - In the end, this needs to be a dbTable, of course! - |] - - ----------------------- -- All Firms Table @@ -536,8 +476,7 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm in anchorCell (FirmSupersR fsh) $ toWgt fsh - , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> - anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors @@ -826,7 +765,7 @@ mkFirmUserTable isAdmin cid = do dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) , 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) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0cbbbde66..b2c8d3073 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -109,7 +109,7 @@ postUsersR = do return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor companies = - (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 6b776cd41..a1ca0a18a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -358,7 +358,7 @@ courseCell Course{..} = anchorCell link name `mappend` desc companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a companyCell cid cname isSupervisor = anchorCell link name where - link = FirmR cid + link = FirmUsersR cid corg = ciOriginal cname name | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor From 34c0928718a0dcac57a0ba97f7b9f0e24383c9ed Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 16:12:10 +0100 Subject: [PATCH 10/11] chore(firm): add switch supervisor status --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++++-- messages/uniworx/categories/firm/en-eu.msg | 6 ++++-- src/Handler/Firm.hs | 21 +++++++++++++++++-- 3 files changed, 27 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 1668a06c3..f938dbaa9 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,7 @@ FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzl FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmActAddSupersvisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden -FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern FirmActChangeContactFirm: Kontaktinformationen der Firma ändern @@ -32,7 +32,9 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden -FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen +FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern +FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen. +FirmSuperActRMSuperDef: Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen E-Mail versenden FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 7539257d1..747900397 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -16,7 +16,7 @@ FirmActResetSuperKeep: Additionally keep existing supervisors of company associa FirmActResetMutualSupervision: Supervisors supervise each other FirmActAddSupersvisors: Add supervisors FirmActAddSupersEmpty: No supervisors added -FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactFirm: Change company contact data @@ -32,7 +32,9 @@ FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message -FirmSuperActRMSuperDef: Remove as default supervisor +FirmSuperActSwitchSuper: Change default company supervisor +FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired. +FirmSuperActRMSuperDef: Remove default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail FirmNotification fsh: Send e-mail to #{fsh} diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 881be6223..11ff2e4fa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -913,6 +913,7 @@ postFirmUsersR fsh = do -- Firm Supervisors Table data FirmSuperAction = FirmSuperActNotify + | FirmSuperActSwitchSuper | FirmSuperActRMSuperDef deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -922,6 +923,10 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData + | FirmSuperActSwitchSuperData + { firmSuperActSwitchSuper :: Maybe Bool + , firmSuperActSwitchReroute :: Maybe Bool + } | FirmSuperActRMSuperDefData { firmSuperActRMSuperActive :: Maybe Bool } @@ -968,6 +973,7 @@ instance HasUser SuperCompanyTableData where mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do + msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo let -- fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -1032,6 +1038,10 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True) + <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) (Nothing) + <* aformMessage msgSupervisorUnchanged , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] @@ -1079,7 +1089,7 @@ postFirmSupersR fsh = do (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] - <*> if firmSuperActRMSuperActive /= Just True + <*> if firmSuperActRMSuperActive /= Just True then return 0 else E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor @@ -1091,7 +1101,14 @@ postFirmSupersR fsh = do ) addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - + (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do + let fltrSpr = guardMonoid (isNothing firmSuperActSwitchSuper) [UserCompanySupervisor ==. True] + changes = maybeEmpty firmSuperActSwitchSuper (pure . (UserCompanySupervisor =.)) + <> guardMonoid (firmSuperActSwitchSuper /= Just False || firmSuperActSwitchReroute == Just False) ( + maybeEmpty firmSuperActSwitchReroute (pure . (UserCompanySupervisorReroute =.))) + nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes + addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) From 1d3345cbba1cb65ee49c6f62e145750545439642 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 16:55:51 +0100 Subject: [PATCH 11/11] fix(firm): supervisor changes led to inconsistent DB --- src/Handler/Firm.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 11ff2e4fa..f86048434 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1102,10 +1102,14 @@ postFirmSupersR fsh = do addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do - let fltrSpr = guardMonoid (isNothing firmSuperActSwitchSuper) [UserCompanySupervisor ==. True] - changes = maybeEmpty firmSuperActSwitchSuper (pure . (UserCompanySupervisor =.)) - <> guardMonoid (firmSuperActSwitchSuper /= Just False || firmSuperActSwitchReroute == Just False) ( - maybeEmpty firmSuperActSwitchReroute (pure . (UserCompanySupervisorReroute =.))) + let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of + (Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ]) + (Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer] + , [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ]) + (Just False, _) -> ([UserCompanySupervisor ==. True ], [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]) + (Nothing, Just True) -> ([UserCompanySupervisor ==. True, UserCompanySupervisorReroute ==. False], [UserCompanySupervisorReroute =. True ]) + (Nothing, Just False) -> ([ UserCompanySupervisorReroute ==. True ], [UserCompanySupervisorReroute =. False]) + (Nothing, Nothing ) -> ([],[]) nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes