From 0f9a7a8c53d216ca7a6d0a25462b19ab1fa00bb4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 20 Nov 2023 15:02:44 +0100 Subject: [PATCH 1/5] fix(firm): show default supervisors with no employees too --- src/Handler/Firm.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index a37f59caa..479b2009f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -845,7 +845,8 @@ mkFirmSuperTable isAdmin cid = do where dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid - E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) -- 2.39.2 From b7d6474acefbafb700241ec4cf60166965c1ac1c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 13:33:12 +0100 Subject: [PATCH 2/5] refactor(firm): messaging performance --- src/Handler/Firm.hs | 89 +++++++++++++++++++-------------------------- src/Utils.hs | 3 ++ 2 files changed, 40 insertions(+), 52 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 479b2009f..1c2a8943a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1006,56 +1006,42 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] handleFirmCommR ultDest cs = do - let csKey = CompanyKey <$> cs - -- get employees of chosen companies - empys <- E.unValue <<$>> runDB (E.select $ do - (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey - return $ emp E.^. UserId - ) - -- get supervisors of employees - sprs <- E.unValue <<$>> runDB (E.select $ do - spr <- E.from $ E.table @User - E.where_ $ E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - return $ spr E.^. UserId - ) - -- get companies of all supervisors - sprCmpys <- E.unValue <<$>> runDB (E.select $ do - cmpy <- E.from $ E.table @Company - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs - return $ cmpy E.^.CompanyId - ) let - queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation - queryLoners = do - spr <- E.from $ E.table @User - E.where_ $ spr E.^. UserId `E.in_` E.valList empys - E.&&. E.notExists (do - sprCmp <- E.from $ E.table @UserCompany - E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId - ) - return spr - - queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) - queryCmpy sORe acid = do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid - E.&&. (if sORe - then -- supervisors only - E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - else E.true - ) + queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds + queryGiven usrs = do + usr <- E.from $ E.table @User + E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr - + mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId] + mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l] + toGrp = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey) + csKeys = CompanyKey <$> cs + mbUser <- maybeAuthId + -- get employees of chosen companies + empys <- mkCompanyUsrList <$> runDB (E.select $ do + (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] + return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) + ) + -- get supervisors of employees + --sprs <- mkCompanyUsrList <$> runDB (E.select $ do + sprs' <- runDB (E.select $ do + (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) + E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) + E.||. (spr E.^. UserId E.=?. E.val mbUser) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList (concat $ Map.elems empys) + ) + E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] + return (cmp E.?. UserCompanyCompany, spr E.^. UserId) + ) + $logInfoS "Firm" "!!!Messaging here!!!" + unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!! + let sprs = mkCompanyUsrList sprs' + commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } @@ -1063,10 +1049,9 @@ handleFirmCommR ultDest cs = do , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult - , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] - [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++ - (RGFirmIndependent, queryLoners) : - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ] + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ + [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: diff --git a/src/Utils.hs b/src/Utils.hs index 44b863ae9..6ec20b881 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -771,6 +771,9 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a pattern NonEmpty x xs = x :| xs {-# COMPLETE NonEmpty #-} +checkAsc :: Ord a => [a] -> Bool +checkAsc (x:r@(y:_)) = x<=y && checkAsc r +checkAsc _ = True ---------- -- Sets -- -- 2.39.2 From b9f2d3bda4fe80017c40438583e6e139a022fd0a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 16:53:06 +0100 Subject: [PATCH 3/5] chore(firm): add setting for global communications cc --- src/Handler/Firm.hs | 8 ++------ src/Handler/Utils/Communication.hs | 14 +++++++++----- src/Settings.hs | 2 ++ 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1c2a8943a..f8cf257dc 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1025,8 +1025,7 @@ handleFirmCommR ultDest cs = do return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) ) -- get supervisors of employees - --sprs <- mkCompanyUsrList <$> runDB (E.select $ do - sprs' <- runDB (E.select $ do + sprs <- mkCompanyUsrList <$> runDB (E.select $ do (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) E.||. (spr E.^. UserId E.=?. E.val mbUser) @@ -1037,10 +1036,7 @@ handleFirmCommR ultDest cs = do ) E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] return (cmp E.?. UserCompanyCompany, spr E.^. UserId) - ) - $logInfoS "Firm" "!!!Messaging here!!!" - unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!! - let sprs = mkCompanyUsrList sprs' + ) commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index d94f79706..70c8e45e2 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -139,7 +139,7 @@ commR CommunicationRoute{..} = do decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) - getEntity uid + getEntity uid cUser <- maybeAuth (chosenRecipients, suggestedRecipients) <- runDB $ (,) <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) @@ -148,7 +148,8 @@ commR CommunicationRoute{..} = do MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute - + globalCC <- getsYesod $ view _appCommunicationGlobalCC + let lookupUser :: UserId -> (UserDisplayName,UserSurname) lookupUser = @@ -156,7 +157,7 @@ commR CommunicationRoute{..} = do usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) in usrNames . flip Map.lookup usrMap - + chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) , (Right recp, recp `elem` map entityKey chosenRecipients) @@ -165,9 +166,12 @@ commR CommunicationRoute{..} = do , (pos, recp) <- zip [0..] $ map entityKey recps ] ++ [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) + , (recp, True) ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) + | (pos, recp) <- zip [0..] + ( mcons (Left <$> globalCC) + (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients))) + ) ] activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom diff --git a/src/Settings.hs b/src/Settings.hs index 5b6c139cb..0916f439f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -245,6 +245,7 @@ data AppSettings = AppSettings , appJobMaxFlush :: Maybe Natural , appCommunicationAttachmentsMaxSize :: Maybe Natural + , appCommunicationGlobalCC :: Maybe UserEmail , appFileChunkingParams :: FastCDCParameters @@ -804,6 +805,7 @@ instance FromJSON AppSettings where appJobMaxFlush <- o .:? "job-max-flush" appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size" + appCommunicationGlobalCC <- o .:? "communication-global-cc" appLegalExternal <- o .: "legal-external" -- 2.39.2 From 83bab6b86bd4743114c733ac952dee9539e97938 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 18:45:51 +0100 Subject: [PATCH 4/5] chore(firm): implement fix #67 Maske Firmen --- .../uniworx/categories/firm/de-de-formal.msg | 9 +- messages/uniworx/categories/firm/en-eu.msg | 9 +- .../utils/table_column/de-de-formal.msg | 3 +- messages/uniworx/utils/table_column/en-eu.msg | 3 +- src/Handler/Firm.hs | 86 +++++++++++++++---- src/Handler/Utils/Table/Cells.hs | 10 +++ src/Utils/Form.hs | 1 + src/Utils/Icon.hs | 4 +- templates/firm-users.hamlet | 5 +- 9 files changed, 103 insertions(+), 27 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 49fc0d066..8c9cf7a8e 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,7 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen 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 -FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen +FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen Benachrichtigung versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FirmsNotificationTitle: Firmen benachrichtigen @@ -32,8 +32,9 @@ FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung -ASReqPostal: Benachrichtigungseinstellung -ASReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +FormReqPostal: Benachrichtigungseinstellung +FormReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. -RemoveDefaultSupervisors n@Int64: #{n} Standard Ansprechpartner entfernt, aber noch nicht deaktiviert. \ No newline at end of file +RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ 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 39e46d552..0d7ef77eb 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -16,7 +16,7 @@ FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor -FirmSuperActRMSuperAll: Remove all active supervisions for this company +FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification FirmNotification fsh: Send notification to company #{fsh} FirmsNotificationTitle: Company notification @@ -32,8 +32,9 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute -ASReqPostal: Notification type -ASReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +FormReqPostal: Notification type +FormReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor ASReqEmpty: No supervisors added ASReqSetSupers n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. -RemoveDefaultSupervisors n: #{n} default supervisors removed, but not yet deactivated. \ No newline at end of file +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 295648b7e..71e251d18 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -104,4 +104,5 @@ TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. TableFilterCommaName: Mehrere Namen mit Komma trennen. -TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. \ No newline at end of file +TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. +TableUserEdit: Benutzer bearbeiten \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 3b7962522..b000a6d7d 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -104,4 +104,5 @@ TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. TableFilterCommaName: Separate names by comma. -TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. \ No newline at end of file +TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. +TableUserEdit: Edit user \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f8cf257dc..f102c1734 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -50,7 +50,10 @@ encryptUser = encrypt --------------------------- -- Firm specific utilities --- for filters and counts see before FirmAllR Handlers +-- for filters and counts also see before FirmAllR Handlers + +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged -- remove supervisors: deleteSupervisors :: NonEmpty UserId -> DB Int64 @@ -501,6 +504,25 @@ postFirmAllR = do ----------------------- -- Firm Users Table +data FirmUserChangeRequest = FirmUserChangeRequest + { fucrPostalPref :: Maybe Bool + , fucrPostalAddr :: Maybe StoredMarkup + } + deriving (Eq, Ord, Show, Generic) + +instance Default FirmUserChangeRequest where + def = FirmUserChangeRequest + { fucrPostalPref = Nothing + , fucrPostalAddr = Nothing + } + +makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest +makeFirmUserChangeRequestForm template html = do + flip (renderAForm FormStandard) html $ FirmUserChangeRequest + <$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template) + <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template) + + data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActMkSuper @@ -518,7 +540,7 @@ data FirmUserActionData = FirmUserActNotifyData | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -584,6 +606,7 @@ mkFirmUserTable isAdmin cid = do , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink queryUserUser @@ -750,6 +773,29 @@ postFirmUsersR fsh = do newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + ((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def) + let addFormAnchor = "firm-user-change-form" :: Text + routeForm = FirmUsersR fsh :#: addFormAnchor + fucrForm = wrapForm fucrWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ routeForm + , formEncoding = fucrEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just addFormAnchor + } + formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalAddr || isJust fucrPostalAddr) $ do + let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> + foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Info $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -761,7 +807,7 @@ postFirmUsersR fsh = do data FirmSuperAction = FirmSuperActNotify | FirmSuperActRMSuperDef - | FirmSuperActRMSuperAll + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -770,8 +816,9 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData - | FirmSuperActRMSuperAllData - deriving (Eq, Ord, Read, Show, Generic) + { firmSuperActRMSuperActive :: Maybe Bool } + + deriving (Eq, Ord, Show, Generic) data AddSupervisorRequest = AddSupervisorRequest @@ -787,16 +834,13 @@ instance Default AddSupervisorRequest where , asReqPostal = Nothing } -postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool -postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged - makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest makeAddSupervisorForm template html = do flip (renderAForm FormStandard) html $ AddSupervisorRequest <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template) <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template) - <*> aopt postalEmailField (fslI MsgASReqPostal & setTooltip MsgASReqPostalTip) (asReqPostal <$> template) + <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template) type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) @@ -874,6 +918,7 @@ mkFirmSuperTable isAdmin cid = do , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser @@ -902,8 +947,8 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ pure FirmSuperActRMSuperDefData - , singletonMap FirmSuperActRMSuperAll $ pure FirmSuperActRMSuperAllData + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -946,11 +991,22 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData, Set.toList -> uids) -> do - nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] - addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (nrRmSuper,nrRmActual) <- runDB $ (,) + <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] + <*> if firmSuperActRMSuperActive /= Just True + then return 0 + else E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids + E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) + addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (FirmSuperActRMSuperAllData, uids) -> addMessage Warning $ text2Html $ "TODO Make " <> tshow (length uids) <> " default and active supervisors. TODO" + (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index cf5051ef5..2dee91389 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -229,6 +229,16 @@ cellHasUserModal toLink user = modal nWdgt (Left $ SomeRoute $ toLink uuid) in cell lWdgt +-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead +cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModal 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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 69ec53464..43b1ad82d 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -317,6 +317,7 @@ data FormIdentifier | FIDBtnAvsRevokeUnknown | FIDHijackUser | FIDAddSupervisor + | FIDFirmUserChangeRequest deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 0018e74e0..fb2771e85 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -116,6 +116,7 @@ data Icon | IconUnlocked | IconResetTries -- also see IconReset | IconCompany + | IconUserEdit deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -209,7 +210,8 @@ iconText = \case IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" - IconCompany -> "building" + IconCompany -> "building" + IconUserEdit -> "user-edit" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 9acaf1c2f..981255a1f 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -65,4 +65,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

_{MsgFirmAssociates}

- ^{fusrTable} \ No newline at end of file + ^{fusrTable} + +

+ ^{fucrForm} \ No newline at end of file -- 2.39.2 From 5163ed06c6b6e0652ba2f137f7350483470e1078 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 18:49:33 +0100 Subject: [PATCH 5/5] fix(build) --- src/Handler/Firm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f102c1734..d4e9176f6 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -785,7 +785,7 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalAddr || isJust fucrPostalAddr) $ do + formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalPref || isJust fucrPostalAddr) $ do let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! nrChanged <- runDB $ E.updateCount $ \usr -> do -- 2.39.2