From cf5759bc606779548dbec9a6786764fec3b9c80e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:02:12 +0100 Subject: [PATCH 01/14] chore(firm): hide general actions --- templates/firm-users.hamlet | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 981255a1f..2346ac4dd 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -68,4 +68,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{fusrTable}
- ^{fucrForm} \ No newline at end of file +

+ Heading TODO +
+ ^{fucrForm} \ No newline at end of file From 4ae59fc1fa658e1462139ddddd6dc80308d85872 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:03:01 +0100 Subject: [PATCH 02/14] fix(cache): remove risky caching for submissions --- src/Handler/Submission/List.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 72c17f0e5..4590b9f48 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -397,7 +397,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName subCID = x ^. resultCryptoID - in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) + in anchorCell (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId)) colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return From 7fc6e431311979919d8d753a6a6d4651668d64b7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:58:03 +0100 Subject: [PATCH 03/14] chore(profile): allow editing phone numbers --- models/users.model | 2 +- src/Handler/Profile.hs | 22 ++++++++++++++++------ src/Utils.hs | 6 ++++++ 3 files changed, 23 insertions(+), 7 deletions(-) diff --git a/models/users.model b/models/users.model index 8a686feac..b29f71eb3 100644 --- a/models/users.model +++ b/models/users.model @@ -34,7 +34,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) languages Languages Maybe -- Preferred language; user-defined - notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined + notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined; missing fields in json object will be parsed to default trigger warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos csvOptions CsvOptions "default='{}'::jsonb" sex Sex Maybe -- currently ignored diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e0a12e0b1..a92c54571 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -70,6 +70,9 @@ data SettingsForm = SettingsForm , stgPrefersPostal :: Bool , stgPostAddress :: Maybe StoredMarkup + , stgTelephone :: Maybe Text + , stgMobile :: Maybe Text + , stgExamOfficeSettings :: ExamOfficeSettings , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings @@ -129,9 +132,12 @@ makeSettingForm template html = do <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template) <* aformSection MsgFormNotifications - <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) + <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) <*> apopt checkBoxField (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) - <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + + <*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template) + <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) <*> schoolsForm (stgSchools <$> template) @@ -362,14 +368,14 @@ validateSettings User{..} = do validEmail' userDisplayEmail' userPostAddress' <- use _stgPostAddress - let postalNotSet = isNothing userPostAddress' + let postalNotSet = isNothing userPostAddress' -- TODO $ canonical userPostAddress' postalIsValid = validPostAddress userPostAddress' guardValidation MsgUserPostalInvalid $ postalNotSet || postalIsValid userPrefersPostal' <- use _stgPrefersPostal guardValidation MsgUserPrefersPostalInvalid $ - not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment) + not $ userPrefersPostal' && postalNotSet && isNothing userCompanyDepartment userPinPassword' <- use _stgPinPassword let pinBad = validCmdArgument =<< userPinPassword' @@ -439,6 +445,8 @@ serveProfileR (uid, user@User{..}) = do , stgPinPassword = userPinPassword , stgPostAddress = userPostAddress , stgPrefersPostal = userPrefersPostal + , stgTelephone = userTelephone + , stgMobile = userMobile , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced , eosettingsGetLabels = userExamOfficeGetLabels @@ -467,9 +475,11 @@ serveProfileR (uid, user@User{..}) = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex - , UserPinPassword =. stgPinPassword - , UserPostAddress =. stgPostAddress + , UserPinPassword =. stgPinPassword -- TODO & canonical + , UserPostAddress =. stgPostAddress -- TODO & canonical , UserPrefersPostal =. stgPrefersPostal + , UserTelephone =. stgTelephone & canonical + , UserMobile =. stgMobile & canonical , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] diff --git a/src/Utils.hs b/src/Utils.hs index 6ec20b881..b879a2164 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1986,3 +1986,9 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca -- this instance is more of a convenient abuse of the class (expand to Foldable) instance (Ord a, Canonical a) => Canonical (Set a) where canonical = Set.map canonical + +instance Canonical (Maybe Text) where + canonical Nothing = Nothing + canonical (Just t) = + let t' = Text.strip t + in if Text.null t' then Nothing else Just t' From c5c4a62de0c92bde660f177d062c4874e232d8bc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:59:15 +0100 Subject: [PATCH 04/14] chore(firm): various - multiSelectField working - section hiding demo working - modal links access rights checking --- src/Handler/Firm.hs | 35 +++++++++++++++++++------------- src/Handler/Utils/Table/Cells.hs | 19 +++++++++-------- src/Handler/Utils/Widgets.hs | 9 ++++++++ src/Utils/Frontend/Modal.hs | 2 +- 4 files changed, 42 insertions(+), 23 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d4e9176f6..9e4c7655d 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -325,7 +325,12 @@ mkFirmAllTable isAdmin uid = do unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + )) return ( cmpy -- 1 , cmpy & firmCountUsers -- 2 , cmpy & firmHasSupervisors -- 3 @@ -598,7 +603,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -676,7 +681,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 _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (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) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -785,17 +790,19 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - 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 - 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 + formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do + -- let fucrPAddr = canonical fucrPAddr' TODO + when (isJust fucrPPref || isJust fucrPAddr) $ do + let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> + foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- 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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2dee91389..2cab48fc2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -226,7 +226,7 @@ cellHasUserModal toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt (Left $ SomeRoute $ toLink uuid) + modalAccess False nWdgt nWdgt $ toLink uuid in cell lWdgt -- | like `cellHasUserModal` but with fixed route and showing an edit icon instead @@ -234,10 +234,10 @@ cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModal user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey - nWdgt = toWidget $ icon IconUserEdit + nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + modalAccess True nWdgt mempty $ ForProfileR uuid in cell lWdgt cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer @@ -246,7 +246,7 @@ cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell cellHasMatrikelnummerLinked usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser @@ -364,7 +364,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser - let modalWgt = modal dateWgt (Left $ SomeRoute $ toLink uuid) + let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) @@ -385,7 +385,8 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess False dWgt dWgt $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -403,7 +404,8 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess False dWgt dWgt $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -463,7 +465,8 @@ avsPersonNoCell = numCell . view _userAvsNoPerson avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser - modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid) + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modalAccess False nWgt nWgt $ AdminAvsUserR uuid avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 23a4b3a37..61c3c298e 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -123,6 +123,15 @@ 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 + 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 c7c3ad8d0..304326ccc 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -38,7 +38,7 @@ customModal Modal{..} = do route <- traverse toTextUrl $ modalContent ^? _Left modalTrigger route triggerId' --- | Create a link to a modal +-- | 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 -> WidgetFor site () -- ^ result widget From 400a3449c5e68994ba0e872b590bef9c0acaf728 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 13:27:57 +0100 Subject: [PATCH 05/14] refactor(firm): fix build too --- .../uniworx/categories/firm/de-de-formal.msg | 2 ++ messages/uniworx/categories/firm/en-eu.msg | 2 ++ src/Handler/Firm.hs | 2 ++ src/Handler/Profile.hs | 8 +++---- src/Model/Types/Markup.hs | 7 ++++++ src/Utils.hs | 11 +++++---- templates/firm-contact-info.hamlet | 23 +++++++++++++++++++ templates/firm-users.hamlet | 13 +---------- .../i18n/firm-supervisors/de-de-formal.hamlet | 16 ++++--------- templates/i18n/firm-supervisors/en-eu.hamlet | 16 ++++--------- 10 files changed, 55 insertions(+), 45 deletions(-) create mode 100644 templates/firm-contact-info.hamlet diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 8c9cf7a8e..5d81a2b03 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -3,6 +3,8 @@ # SPDX-License-Identifier: AGPL-3.0-or-later FirmAssociates: Firmenangehörige +FirmContact: Firmenkontakt +FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 0d7ef77eb..250b9ca38 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -3,6 +3,8 @@ # SPDX-License-Identifier: AGPL-3.0-or-later FirmAssociates: Company associated users +FirmContact: Company Contact +FirmNoContact: No general contact information known. FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e4c7655d..9442d841a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -806,6 +806,7 @@ postFirmUsersR fsh = do siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId + let firmContactInfo = $(widgetFile "firm-contact-info") $(widgetFile "firm-users") @@ -1053,6 +1054,7 @@ postFirmSupersR fsh = do siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" + let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a92c54571..3a0103c58 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -475,11 +475,11 @@ serveProfileR (uid, user@User{..}) = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex - , UserPinPassword =. stgPinPassword -- TODO & canonical - , UserPostAddress =. stgPostAddress -- TODO & canonical + , UserPinPassword =. (stgPinPassword & canonical) + , UserPostAddress =. (stgPostAddress & canonical) , UserPrefersPostal =. stgPrefersPostal - , UserTelephone =. stgTelephone & canonical - , UserMobile =. stgMobile & canonical + , UserTelephone =. (stgTelephone & canonical) + , UserMobile =. (stgMobile & canonical) , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index c5555ceba..0715b65b5 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -50,6 +50,13 @@ data StoredMarkup = StoredMarkup deriving (Read, Show, Generic) deriving anyclass (Binary, Hashable, NFData) +instance Canonical (Maybe StoredMarkup) where + canonical Nothing = Nothing + canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if + | LT.null mi' -> Nothing + | markupInput == mi' -> r + | otherwise -> Just s{markupInput = mi'} + htmlToStoredMarkup :: Html -> StoredMarkup htmlToStoredMarkup html = StoredMarkup { markupInputFormat = MarkupHtml diff --git a/src/Utils.hs b/src/Utils.hs index b879a2164..324f71aa7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1987,8 +1987,9 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca instance (Ord a, Canonical a) => Canonical (Set a) where canonical = Set.map canonical -instance Canonical (Maybe Text) where - canonical Nothing = Nothing - canonical (Just t) = - let t' = Text.strip t - in if Text.null t' then Nothing else Just t' +instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = Text.strip t in if + | Text.null t' -> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet new file mode 100644 index 000000000..8aea13ab1 --- /dev/null +++ b/templates/firm-contact-info.hamlet @@ -0,0 +1,23 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
+

_{MsgFirmContact} +
+ $maybe fem <- companyEmail +
+ _{MsgFirmEmail} #{iconLetterOrEmail False} +
+ #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
+ _{MsgFirmAddress} #{iconLetterOrEmail True} +
+ #{addr} + $nothing + $maybe _ <- companyEmail + $nothing + _{MsgFirmNoContact} diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 2346ac4dd..19c41bb64 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -4,18 +4,7 @@ $# SPDX-FileCopyrightText: 2023 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -
-
- $maybe fem <- companyEmail -
- _{MsgFirmEmail} #{iconLetterOrEmail False} -
- #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
- _{MsgFirmAddress} #{iconLetterOrEmail True} -
- #{addr} +^{firmContactInfo}
diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index d81248e80..5e432e780 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -9,19 +9,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Daraus folgt zum Beispiel, dass wenn x ein Standard-Ansprechpartner für Firma a ist und wenn y sowohl Firma a als auch b angehört, dass dann x als firmenfremd in der Liste der Ansprechpartner von Firma b angezeigt wird. -
-
- $maybe fem <- companyEmail -
- _{MsgFirmEmail} #{iconLetterOrEmail False} -
- #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
- _{MsgFirmAddress} #{iconLetterOrEmail True} -
- #{addr} + +^{firmContactInfo} +
^{fsprTable} +
^{addSuperForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index 400fc543b..b34a75431 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -8,19 +8,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Note that supervision is company independent. For example, if x is a regular supervisor for company a and y belongs to companies a and b, then x will be listed as a foreign supervisor for company b. -
-
- $maybe fem <- companyEmail -
- _{MsgFirmEmail} #{iconLetterOrEmail False} -
- #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
- _{MsgFirmAddress} #{iconLetterOrEmail True} -
- #{addr} + +^{firmContactInfo} +
^{fsprTable} +
^{addSuperForm} From dc6079ec3b4eae32fe0e4325f958955edbcef965 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:05:16 +0100 Subject: [PATCH 06/14] chore(nix): attempt to create alias for killall-uni2work --- shell.nix | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/shell.nix b/shell.nix index 0988cc475..9acbf8a78 100644 --- a/shell.nix +++ b/shell.nix @@ -257,6 +257,10 @@ let done ''; + environment.interactiveShellInit = '' + alias killuni2work='killall-uni2work' + ''; + diffRunning = pkgs.writeScriptBin "diff-running" '' #!${pkgs.zsh}/bin/zsh From 8973ea5849a69b72b559bae20f3c6f9564f8030f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:06:00 +0100 Subject: [PATCH 07/14] refactor(firm): WIP generalize firm actions --- .../uniworx/categories/firm/de-de-formal.msg | 6 + messages/uniworx/categories/firm/en-eu.msg | 8 +- src/Handler/Firm.hs | 183 ++++++++++++++---- src/Handler/Utils.hs | 4 +- src/Utils/Form.hs | 1 + .../i18n/firm-supervisors/de-de-formal.hamlet | 2 + templates/i18n/firm-supervisors/en-eu.hamlet | 4 +- 7 files changed, 161 insertions(+), 47 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 5d81a2b03..d5cda6037 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -8,6 +8,12 @@ FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige +FirmAction: Firmenweite Aktion +FirmActNotify: Mitteilung versenden +FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? +FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig +FirmActAddSupervisors: Ansprechpartner hinzufügen FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 250b9ca38..953055b25 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -8,11 +8,17 @@ FirmNoContact: No general contact information known. FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only +FirmAction: Companywide action +FirmActNotify: Send message +FirmActResetSupervision: Reset supervisors for all company associates +FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? +FirmActResetMutualSupervision: Supervisors supervise each other +FirmActAddSupervisors: Add supervisors FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates -FirmUserActNotify: Send message FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActMkSuper: Mark as company supervisor diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9442d841a..12efe6594 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -48,12 +48,134 @@ decryptUser = decrypt encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser encryptUser = encrypt +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + +--------------------------------- +-- General firm affecting actions + +data FirmAction = FirmActNotify + | FirmActResetSupervision + -- | FirmActAddSupervisors + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmAction id + +data FirmActionData = FirmActNotifyData + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool + } + -- | FirmActAddSupervisorsData + -- { firmActAddSupervisorIds :: Set Text + -- , firmActAddSupervisorReroute :: Bool + -- , firmActAddSupervisorPostal :: Maybe Bool + -- } + deriving (Eq, Ord, Read, Show, Generic) + +firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap acts = mconcat (mkAct <$> acts) + where + mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData + mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + -- mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData + -- <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty) + -- <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + -- <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (Just Nothing) + +firmActionForm :: [FirmAction] -> AForm Handler FirmActionData +firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing + + +makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts + +-- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ()) +-- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts + +firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () +firmActionHandler route = 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 Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams route -- reload to reflect changes + + faHandler (FirmActNotifyData, Set.toList -> fids) = do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + + -- faHandler (FirmActAddSupervisorsData{..}, 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 + -- usersFound = mapMaybe snd usersFound' + -- unless (null usersNotFound) $ + -- let msgContent = [whamlet| + -- $newline never + --
    + -- $forall (usr,_) <- usersNotFound + --
  • #{usr} + -- |] + -- in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + -- when (null usersFound) $ do + -- addMessageI Warning MsgASReqEmpty + -- reloadKeepGetParams route + -- runDB $ do + -- putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + -- whenIsJust firmActAddSupervisorPostal $ \prefPostal -> + -- updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + -- addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + -- redirect route + -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction + + +runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget +runFirmActionFormPost cid route acts = do + -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts + ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts + let faAnchor = "firm-action-form" :: Text + faRoute = route :#: faAnchor + faForm = wrapForm faWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ faRoute + , formEncoding = faEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just faAnchor + } + firmActionHandler route faRes + return [whamlet| +
    +

    + _{MsgFirmAction} +
    + ^{faForm} + |] + + --------------------------- -- Firm specific utilities -- 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 @@ -315,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -432,21 +554,14 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAllAction (AForm Handler FirmAllActionData) - acts = mconcat - [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) - ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional - = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -457,14 +572,14 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap return (act, cmpSet) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -475,32 +590,8 @@ getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR - (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - formResult firmRes $ \case - (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - - (FirmAllActResetSupervisionData{..}, fids) -> do - runDB $ do - delSupers <- if firmAllActResetKeepOldSupers == 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 (firmAllActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams FirmAllR -- reload to reflect changes - - (FirmAllActNotifyData , Set.toList -> fids) -> do - usrs <- runDB $ E.select $ E.distinct $ do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids - return $ usr E.^. UserId - cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - + (_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + -- firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -1019,6 +1110,8 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors] + ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) let addSuperAnchor = "add-supervisors-form" :: Text routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor @@ -1056,7 +1149,11 @@ postFirmSupersR fsh = do setTitle $ citext2Html $ fsh <> " Supers" let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") - + + +------------------------ +-- Firm Communications + getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 2460eb65d..715c910a5 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -146,7 +146,7 @@ redirectAlternatives = go reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reload r = getCurrentRoute >>= redirect . fromMaybe r --- | like `reload`, preserving all GET parameters +-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reloadKeepGetParams r = liftHandler $ do getps <- reqGetParams <$> getRequest @@ -155,7 +155,7 @@ reloadKeepGetParams r = liftHandler $ do -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) redirect (route, getps) --- | redirect preserving all GET parameters +-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams route = liftHandler $ do getps <- reqGetParams <$> getRequest diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 43b1ad82d..39107331e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -318,6 +318,7 @@ data FormIdentifier | FIDHijackUser | FIDAddSupervisor | FIDFirmUserChangeRequest + | FIDFirmAction deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index 5e432e780..bd9fdf4db 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -12,6 +12,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
    ^{fsprTable} diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index b34a75431..8edcdeeec 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -11,8 +11,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
    ^{fsprTable} - +
    ^{addSuperForm} From b10cbc39cca0d4e23c0d2a3f8b65d9f3343e6bd4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:22:00 +0100 Subject: [PATCH 08/14] refactor(firm): FirmAllR messaging working old way --- src/Handler/Firm.hs | 48 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 42 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 12efe6594..5014bec27 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -437,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -554,14 +554,25 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmAllAction (AForm Handler FirmAllActionData) + acts = mconcat + [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData + , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + ] + dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + -- <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + , dbParamsFormAdditional + = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -572,8 +583,8 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmActionData, Set CompanyId) + postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmAllActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap @@ -590,8 +601,33 @@ getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR - (_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins -- firmActionHandler FirmAllR firmRes + formResult firmRes $ \case + (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected + + (FirmAllActResetSupervisionData{..}, fids) -> do + runDB $ do + delSupers <- if firmAllActResetKeepOldSupers == 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 (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams FirmAllR -- reload to reflect changes + + (FirmAllActNotifyData , Set.toList -> fids) -> do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") From 577a2fb45d8274f26677275f9fc892ac64afa3e6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:29:12 +0100 Subject: [PATCH 09/14] refactor(firm): FirmAllR messaging no longer works now What did change? Nothing here is essential?! --- src/Handler/Firm.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5014bec27..bbb69ad23 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -437,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -554,12 +554,12 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAllAction (AForm Handler FirmAllActionData) + acts :: Map FirmAction (AForm Handler FirmActionData) acts = mconcat - [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + [ singletonMap FirmActNotify $ pure FirmActNotifyData + , singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) ] dbtParams = DBParamsForm @@ -583,8 +583,8 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap @@ -606,9 +606,9 @@ postFirmAllR = do formResult firmRes $ \case (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - (FirmAllActResetSupervisionData{..}, fids) -> do + (FirmActResetSupervisionData{..}, fids) -> do runDB $ do - delSupers <- if firmAllActResetKeepOldSupers == Just False + delSupers <- if firmActResetKeepOldSupers == Just False then E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor E.where_ $ E.exists $ do @@ -616,11 +616,11 @@ postFirmAllR = do E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser else return 0 - newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams FirmAllR -- reload to reflect changes - (FirmAllActNotifyData , Set.toList -> fids) -> do + (FirmActNotifyData , Set.toList -> fids) -> do usrs <- runDB $ E.select $ E.distinct $ do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids @@ -818,8 +818,8 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) ] @@ -848,7 +848,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable From e645517d327734ebd0e2b5a4e877bb440c9b0af0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:36:02 +0100 Subject: [PATCH 10/14] refactor(firm): FirmAllR messaging no works again! --- 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 bbb69ad23..73302520b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -60,7 +60,7 @@ data FirmAction = FirmActNotify deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) -nullaryPathPiece ''FirmAction $ camelToPathPiece' 3 +nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData From 076dff2a60de1c066148131a93ba541f7777079e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 11:44:16 +0100 Subject: [PATCH 11/14] Revert "chore(nix): attempt to create alias for killall-uni0work" This reverts commit dc6079ec3b4eae32fe0e4325f958955edbcef965. --- src/Handler/Firm.hs | 117 +++++++++++++++----------------------------- 1 file changed, 40 insertions(+), 77 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 73302520b..384db461f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -56,7 +56,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - -- | FirmActAddSupervisors + | FirmActAddSupervisors deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -68,11 +68,11 @@ data FirmActionData = FirmActNotifyData { firmActResetKeepOldSupers :: Maybe Bool , firmActResetMutualSupervision :: Maybe Bool } - -- | FirmActAddSupervisorsData - -- { firmActAddSupervisorIds :: Set Text - -- , firmActAddSupervisorReroute :: Bool - -- , firmActAddSupervisorPostal :: Maybe Bool - -- } + | FirmActAddSupervisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } deriving (Eq, Ord, Read, Show, Generic) firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) @@ -82,10 +82,10 @@ firmActionMap acts = mconcat (mkAct <$> acts) mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - -- mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - -- <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty) - -- <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - -- <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (Just Nothing) + mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing firmActionForm :: [FirmAction] -> AForm Handler FirmActionData firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing @@ -123,28 +123,28 @@ 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 (FirmActAddSupervisorsData{..}, 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 - -- usersFound = mapMaybe snd usersFound' - -- unless (null usersNotFound) $ - -- let msgContent = [whamlet| - -- $newline never - --
      - -- $forall (usr,_) <- usersNotFound - --
    • #{usr} - -- |] - -- in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) - -- when (null usersFound) $ do - -- addMessageI Warning MsgASReqEmpty - -- reloadKeepGetParams route - -- runDB $ do - -- putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] - -- whenIsJust firmActAddSupervisorPostal $ \prefPostal -> - -- updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - -- addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal - -- redirect route - -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction + faHandler (FirmActAddSupervisorsData{..}, 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 + usersFound = mapMaybe snd usersFound' + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +
        + $forall (usr,_) <- usersNotFound +
      • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + when (null usersFound) $ do + addMessageI Warning MsgASReqEmpty + reloadKeepGetParams route + runDB $ do + putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + whenIsJust firmActAddSupervisorPostal $ \prefPostal -> + updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + redirect route + faHandler _ = addMessageI Error MsgErrorUnknownFormAction runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget @@ -554,25 +554,14 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAction (AForm Handler FirmActionData) - acts = mconcat - [ singletonMap FirmActNotify $ pure FirmActNotifyData - , singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - ] - dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - -- <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing - , dbParamsFormAdditional - = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -602,32 +591,7 @@ postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - -- firmActionHandler FirmAllR firmRes - formResult firmRes $ \case - (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - - (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 Info $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams FirmAllR -- reload to reflect changes - - (FirmActNotifyData , Set.toList -> fids) -> do - usrs <- runDB $ E.select $ E.distinct $ do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids - return $ usr E.^. UserId - cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - + firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -818,8 +782,8 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) ] @@ -848,7 +812,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -917,8 +881,7 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do - -- let fucrPAddr = canonical fucrPAddr' TODO + formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do when (isJust fucrPPref || isJust fucrPAddr) $ do let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! @@ -1146,7 +1109,7 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors] + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision] ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) let addSuperAnchor = "add-supervisors-form" :: Text From 0b00fffd2715a3908b5cc0055aada7c0fd2c1673 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 11:45:07 +0100 Subject: [PATCH 12/14] chore(nix): change killall-uni2work to killuni2work for ease of use --- shell.nix | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/shell.nix b/shell.nix index 9acbf8a78..42c65ae1f 100644 --- a/shell.nix +++ b/shell.nix @@ -223,7 +223,7 @@ let fi ''; - killallUni2work = pkgs.writeScriptBin "killall-uni2work" '' + killallUni2work = pkgs.writeScriptBin "killuni2work" '' #!${pkgs.zsh}/bin/zsh set -o pipefail @@ -257,10 +257,6 @@ let done ''; - environment.interactiveShellInit = '' - alias killuni2work='killall-uni2work' - ''; - diffRunning = pkgs.writeScriptBin "diff-running" '' #!${pkgs.zsh}/bin/zsh From 2636c9d41aa50726f05c6952f45ed7b08a3b3507 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 17:31:34 +0100 Subject: [PATCH 13/14] refactor(firm): clean firm interface - multiactions working - several code redundancies removed --- .../uniworx/categories/firm/de-de-formal.msg | 24 +- messages/uniworx/categories/firm/en-eu.msg | 22 +- src/Handler/Firm.hs | 422 ++++++++---------- src/Utils.hs | 7 + templates/firm-contact-info.hamlet | 8 +- templates/firm-users.hamlet | 8 +- .../i18n/firm-supervisors/de-de-formal.hamlet | 8 +- templates/i18n/firm-supervisors/en-eu.hamlet | 7 +- 8 files changed, 234 insertions(+), 272 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index d5cda6037..3158130c1 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -9,18 +9,23 @@ FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAction: Firmenweite Aktion +FirmActionInfo: Betrifft alle Firmenangehörigen. FirmActNotify: Mitteilung versenden FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig -FirmActAddSupervisors: Ansprechpartner hinzufügen -FirmAllActNotify: Mitteilung versenden -FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen -FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? -FirmAllActResetMutualSupervision: 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. +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 +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 FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen 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 @@ -37,12 +42,9 @@ FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} -NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. +NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus. TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung -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. -RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +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 diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 953055b25..b73afc808 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,18 +9,23 @@ FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAction: Companywide action +FirmActionInfo: Affects alle company associates. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmActResetMutualSupervision: Supervisors supervise each other -FirmActAddSupervisors: Add supervisors -FirmAllActNotify: Send message -FirmAllActResetSupervision: Reset supervisors for all company associates -FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? -FirmAllActResetMutualSupervision: 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 +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 FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default 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 FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor @@ -40,9 +45,6 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute -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. -RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 384db461f..9ed737280 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -32,7 +32,7 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as EL (from, on) +import qualified Database.Esqueleto.Legacy as EL (on) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,11 +42,11 @@ import Database.Esqueleto.Utils.TH single :: (k,a) -> Map k a single = uncurry Map.singleton -decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId -decryptUser = decrypt +-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +-- decryptUser = decrypt encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser -encryptUser = encrypt +encryptUser = encrypt postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged @@ -56,7 +56,9 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - | FirmActAddSupervisors + | FirmActAddSupersvisors + | FirmActChangeContactFirm + | FirmActChangeContactUser deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -64,41 +66,54 @@ nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData - | FirmActResetSupervisionData - { firmActResetKeepOldSupers :: Maybe Bool - , firmActResetMutualSupervision :: Maybe Bool + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool } - | FirmActAddSupervisorsData - { firmActAddSupervisorIds :: Set Text - , firmActAddSupervisorReroute :: Bool - , firmActAddSupervisorPostal :: Maybe Bool + | FirmActAddSupersvisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } + | FirmActChangeContactFirmData + { firmActCCFPostalAddr :: Maybe StoredMarkup + , firmActCCFEmail :: Maybe UserEmail + , firmActCCFPostalPref :: Maybe Bool + } + | FirmActChangeContactUserData + { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUPostalPref :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) -firmActionMap acts = mconcat (mkAct <$> acts) +firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr acts = mconcat (mkAct <$> acts) where mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> 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 + <* 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 -firmActionForm :: [FirmAction] -> AForm Handler FirmActionData -firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing +firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing - -makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId) -makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts - --- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ()) --- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts +makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () -firmActionHandler route = flip formResult faHandler +firmActionHandler route = flip formResult faHandler where faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected faHandler (FirmActResetSupervisionData{..}, fids) = do @@ -109,10 +124,10 @@ firmActionHandler route = flip formResult faHandler 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 Info $ MsgFirmResetSupervision delSupers newSupers + 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 @@ -123,7 +138,7 @@ 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 (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + 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 usersFound = mapMaybe snd usersFound' @@ -136,24 +151,51 @@ firmActionHandler route = flip formResult faHandler |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) when (null usersFound) $ do - addMessageI Warning MsgASReqEmpty + addMessageI Warning MsgFirmActAddSupersEmpty reloadKeepGetParams route runDB $ do putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal redirect route + + faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr + , (CompanyEmail =.) . Just <$> canonical firmActCCFEmail + , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref + ] + in unless (null changes) $ do + runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes + addMessageI Success MsgFirmActChangeContactFirmResult + reloadKeepGetParams route + + faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref + ] + in unless (null changes) $ do + 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 Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams route -- reload to reflect changes + faHandler _ = addMessageI Error MsgErrorUnknownFormAction runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget -runFirmActionFormPost cid route acts = do - -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts - ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts +runFirmActionFormPost cid route acts = do + mr <- getMessageRender + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts let faAnchor = "firm-action-form" :: Text faRoute = route :#: faAnchor - faForm = wrapForm faWgt FormSettings + faForm = wrapForm faWgt FormSettings { formMethod = POST , formAction = Just . SomeRoute $ faRoute , formEncoding = faEnctype @@ -162,14 +204,17 @@ runFirmActionFormPost cid route acts = do , formAnchor = Just faAnchor } firmActionHandler route faRes - return [whamlet| + return [whamlet|

        _{MsgFirmAction} -
        - ^{faForm} +
        +

        + _{MsgFirmActionInfo} +

        + ^{faForm} |] - + --------------------------- -- Firm specific utilities @@ -190,9 +235,9 @@ resetSupervisors cid employees = do -- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 -addDefaultSupervisors cid employees = do +addDefaultSupervisors cid employees = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (do (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid E.&&. spr E.^. UserCompanySupervisor @@ -205,12 +250,12 @@ addDefaultSupervisors cid employees = do -- 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 +addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (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 ] + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] <> [ spr E.^. UserCompanySupervisor , spr E.^. UserCompanyCompany `E.in_` E.vals cids , usr E.^. UserCompanyCompany `E.in_` E.vals cids @@ -264,7 +309,7 @@ firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser @@ -272,7 +317,7 @@ firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do (usrSuper :& usr) <- E.from $ E.table @UserSupervisor @@ -330,7 +375,7 @@ firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value firmCountUserSupervisors usrCmp = E.subSelectCount $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - + firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do usrSpr <- E.from $ E.table @UserSupervisor @@ -367,7 +412,7 @@ postFirmR fsh = do siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh [whamlet| -

        PROVISORISCHE DEBUG SEITE +

        PROVISORISCHE DEBUG SEITE

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

        #{length csuper} Company Default Supervisors (non-foreign only) @@ -400,21 +445,6 @@ postFirmR fsh = do ----------------------- -- All Firms Table -data FirmAllAction = FirmAllActNotify - | FirmAllActResetSupervision - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - deriving anyclass (Universe, Finite) - -nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 -embedRenderMessage ''UniWorX ''FirmAllAction id - -data FirmAllActionData = FirmAllActNotifyData - | FirmAllActResetSupervisionData - { firmAllActResetKeepOldSupers :: Maybe Bool - , firmAllActResetMutualSupervision :: Maybe Bool - } - deriving (Eq, Ord, Read, Show, Generic) - -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) @@ -440,6 +470,7 @@ resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime + mr <- getMessageRender let resultDBTable = DBTable{..} where @@ -448,7 +479,7 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor) - E.||. E.exists (do + E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid @@ -476,12 +507,12 @@ mkFirmAllTable isAdmin uid = do , 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 - , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok -- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr - -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr @@ -508,14 +539,14 @@ mkFirmAllTable isAdmin uid = do , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) - , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do @@ -546,7 +577,7 @@ mkFirmAllTable isAdmin uid = do ) , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) ] - dbtFilterUI mPrev = mconcat + dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) @@ -559,9 +590,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -600,28 +629,11 @@ 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 +data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActMkSuper + | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -630,12 +642,15 @@ embedRenderMessage ''UniWorX ''FirmUserAction id data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData - { firmUserActResetKeepOldSupers :: Maybe Bool + { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } - + | FirmUserActChangeContactData + { firmUserActPostalAddr :: Maybe StoredMarkup + , firmUserActPostalPref :: Maybe Bool + } deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -649,7 +664,7 @@ queryUserUserCompany = $(sqlIJproj 2 2) type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) resultUserUser :: Lens' UserCompanyTableData (Entity User) -resultUserUser = _dbrOutput . _1 +resultUserUser = _dbrOutput . _1 resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) resultUserUserCompany = _dbrOutput . _2 @@ -660,10 +675,10 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue -instance HasEntity UserCompanyTableData User where +instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser -instance HasUser UserCompanyTableData where +instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal @@ -675,7 +690,7 @@ mkFirmUserTable isAdmin cid = do return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } procOptions = fmap mkOptionList . traverse mkSprOption - rawSupers <- E.select $ do + rawSupers <- E.select $ do usr <- E.from $ E.table @User E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr return (usr E.^. UserId, usr E.^. UserDisplayName) @@ -694,7 +709,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -715,16 +730,16 @@ mkFirmUserTable isAdmin cid = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUserUser - , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId in case criterion of Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.exists (do @@ -736,8 +751,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.notExists (do @@ -750,20 +765,20 @@ mkFirmUserTable isAdmin cid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> - case criterion of - Just uid -> do + case criterion of + Just uid -> do -- uid <- decryptUser uuid - E.exists $ do + E.exists $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid _otherwise -> E.true , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> - case criteria of + case criteria of _ | Set.null criteria -> E.true | otherwise -> do -- uids <- traverse decryptUser criteria - E.exists $ do + E.exists $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria @@ -771,7 +786,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) @@ -782,10 +797,13 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , 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 ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -812,7 +830,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -832,7 +850,7 @@ postFirmUsersR fsh = do , E.Value nrCompanyEmployeeRerPost , E.Value nrCompanyDefaultReroutes , E.Value nrCompanyActiveReroutes - ) , (fusrRes, fusrTable)) <- runDB $ (,) + ) , (fusrRes, fusrTable)) <- runDB $ (,) <$> fromMaybeM notFound (E.selectOne $ do cmpy <- E.from $ E.table @Company E.where_ $ cmpy E.^. CompanyId E.==. E.val cid @@ -846,17 +864,17 @@ postFirmUsersR fsh = do , cmpy & firmCountDefaultReroutes , cmpy & firmCountActiveReroutes )) - -- superVs <- E.select $ do + -- superVs <- E.select $ do -- usr <- E.from $ E.table @User -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr -- return usr - <*> mkFirmUserTable isAdmin cid + <*> mkFirmUserTable isAdmin cid - formResult fusrRes $ \case + formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] @@ -865,34 +883,21 @@ postFirmUsersR fsh = do runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False then deleteSupervisors uids - else return 0 + else return 0 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{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do - when (isJust fucrPPref || isJust fucrPAddr) $ do - let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> - foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- 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 + (FirmUserActChangeContactData{..}, Set.toList -> uids) -> + let changes = catMaybes + [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal =.) <$> firmUserActPostalPref + ] + in unless (null changes) $ do + nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes + addMessageI Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -903,9 +908,9 @@ postFirmUsersR fsh = do ----------------------------- -- Firm Supervisors Table -data FirmSuperAction = FirmSuperActNotify +data FirmSuperAction = FirmSuperActNotify | FirmSuperActRMSuperDef - + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -915,32 +920,10 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData { firmSuperActRMSuperActive :: Maybe Bool } - + deriving (Eq, Ord, Show, Generic) -data AddSupervisorRequest = AddSupervisorRequest - { asReqSupers :: Set Text - , asReqReroute :: Bool - , asReqPostal :: Maybe Bool - } deriving (Eq, Ord, Show, Generic) - -instance Default AddSupervisorRequest where - def = AddSupervisorRequest - { asReqSupers = mempty - , asReqReroute = True - , asReqPostal = Nothing - } - -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 MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template) - - type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) @@ -955,7 +938,7 @@ type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 ) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) -resultSuperUser = _dbrOutput . _1 +resultSuperUser = _dbrOutput . _1 resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64 resultSuperCompanySupervised = _dbrOutput . _2 . _unValue @@ -972,10 +955,10 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue -instance HasEntity SuperCompanyTableData User where +instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser -instance HasUser SuperCompanyTableData where +instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal @@ -997,7 +980,7 @@ mkFirmSuperTable isAdmin cid = do ) dbtRowKey = querySuperUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do - cmps <- E.select $ do + cmps <- E.select $ do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) E.orderBy [E.asc $ cmp E.^. CompanyName] @@ -1020,7 +1003,7 @@ mkFirmSuperTable isAdmin cid = do ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser - , single $ sortUserEmail querySuperUser + , single $ sortUserEmail querySuperUser , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) @@ -1045,7 +1028,7 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm @@ -1072,7 +1055,7 @@ mkFirmSuperTable isAdmin cid = do (First (Just act), m) <- inp let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - + resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -1089,7 +1072,7 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] <*> if firmSuperActRMSuperActive /= Just True @@ -1100,49 +1083,16 @@ postFirmSupersR fsh = do 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 - ) + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - - (FirmSuperActNotifyData , uids) -> do + + (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision] - - ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) - let addSuperAnchor = "add-supervisors-form" :: Text - routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor - addSuperForm = wrapForm asReqWgt FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ routeAddSuperForm - , formEncoding = asReqEnctype - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Just addSuperAnchor - } - formResult asReqRes $ \AddSupervisorRequest{..} -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers - let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers - usersFound = mapMaybe snd usersFound' - unless (null usersNotFound) $ - let msgContent = [whamlet| - $newline never -
          - $forall (usr,_) <- usersNotFound -
        • #{usr} - |] - in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) - when (null usersFound) $ do - addMessageI Warning MsgASReqEmpty - redirect routeAddSuperForm - runDB $ do - putMany [UserCompany uid cid True asReqReroute | uid <- usersFound] - whenIsJust asReqPostal $ \prefPostal -> - updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal - redirect $ FirmSupersR fsh + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" @@ -1167,9 +1117,9 @@ 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 + let queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds - queryGiven usrs = do + queryGiven usrs = do usr <- E.from $ E.table @User E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr @@ -1179,14 +1129,14 @@ handleFirmCommR ultDest cs = do csKeys = CompanyKey <$> cs mbUser <- maybeAuthId -- get employees of chosen companies - empys <- mkCompanyUsrList <$> runDB (E.select $ do + 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.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 + -- get supervisors of employees + 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) @@ -1197,24 +1147,24 @@ handleFirmCommR ultDest cs = do ) E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] return (cmp E.?. UserCompanyCompany, spr E.^. UserId) - ) - + ) + commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } , crUltDest = ultDest - , 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)))] + , 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)))] [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: Wenn Firma gewählt, dann zeige: - Alle Supervisor von Leuten in X, gruppiert nach deren Firma - Alle Teilnehmer von X + Alle Supervisor von Leuten in X, gruppiert nach deren Firma + Alle Teilnehmer von X Wenn keine Firma gewählt, dann zeige: Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma Alle gewählten Personen, gruppiert nach deren Firma diff --git a/src/Utils.hs b/src/Utils.hs index 324f71aa7..a2b35c37a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1993,3 +1993,10 @@ instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonic | Text.null t' -> Nothing | t == t' -> r | otherwise -> Just t' + +instance Canonical (Maybe (CI Text)) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = CI.map Text.strip t in if + | mempty == t'-> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet index 8aea13ab1..a251650db 100644 --- a/templates/firm-contact-info.hamlet +++ b/templates/firm-contact-info.hamlet @@ -9,12 +9,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
          $maybe fem <- companyEmail
          - _{MsgFirmEmail} #{iconLetterOrEmail False} + _{MsgFirmEmail} + $if not companyPrefersPostal +   #{iconLetterOrEmail False}
          #{mailtoHtml fem} $maybe addr <- companyPostAddress
          - _{MsgFirmAddress} #{iconLetterOrEmail True} + _{MsgFirmAddress} + $if companyPrefersPostal +   #{iconLetterOrEmail True}
          #{addr} $nothing diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 19c41bb64..c10c06e13 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -6,6 +6,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
          @@ -55,9 +57,3 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgFirmAssociates}

          ^{fusrTable} - -

          -

          - Heading TODO -
          - ^{fucrForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index bd9fdf4db..ddd921f87 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -15,7 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
          - ^{fsprTable} - -
          - ^{addSuperForm} \ No newline at end of file +

          + _{MsgTableSupervisor} +
          + ^{fsprTable} diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index 8edcdeeec..09a6a37c5 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -14,7 +14,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
          - ^{fsprTable} +

          + _{MsgTableSupervisor} +
          + ^{fsprTable} -
          - ^{addSuperForm} From 212cb7180764109924fb09ce3ed748695f0f2cd2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 17:44:27 +0100 Subject: [PATCH 14/14] chore(firm): limit firm action access to admins --- routes | 4 +-- src/Handler/Firm.hs | 61 +++++++++++++++++++++++---------------------- 2 files changed, 33 insertions(+), 32 deletions(-) diff --git a/routes b/routes index d341734ac..df8c32fa2 100644 --- a/routes +++ b/routes @@ -115,9 +115,9 @@ /firms FirmAllR GET POST !supervisor /firms/comm/+Companies FirmsCommR GET POST -/firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST -/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor +/firm/#CompanyShorthand FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9ed737280..429f7db72 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -62,7 +62,7 @@ data FirmAction = FirmActNotify deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) -nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 +nullaryPathPiece ''FirmAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData @@ -86,28 +86,29 @@ data FirmActionData = FirmActNotifyData } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) -firmActionMap mr acts = mconcat (mkAct <$> acts) +firmActionMap :: _ -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) where - mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData - mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> 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 - <* 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 + mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData + mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> 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 + <* 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 + mkAct _ _ = mempty -firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData -firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing +firmActionForm :: () -> Bool -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts @@ -189,10 +190,10 @@ firmActionHandler route = flip formResult faHandler faHandler _ = addMessageI Error MsgErrorUnknownFormAction -runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget -runFirmActionFormPost cid route acts = do +runFirmActionFormPost :: CompanyId -> Route UniWorX -> Bool -> [FirmAction] -> Handler Widget +runFirmActionFormPost cid route isAdmin acts = do mr <- getMessageRender - ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr isAdmin acts let faAnchor = "firm-action-form" :: Text faRoute = route :#: faAnchor faForm = wrapForm faWgt FormSettings @@ -590,7 +591,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -618,7 +619,7 @@ getFirmAllR, postFirmAllR :: Handler Html getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do @@ -839,7 +840,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -897,7 +898,7 @@ postFirmUsersR fsh = do addMessageI Success $ MsgFirmUserChanges nrChanged reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -1064,7 +1065,7 @@ mkFirmSuperTable isAdmin cid = do getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin let cid = CompanyKey fsh (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) <$> get404 cid @@ -1092,7 +1093,7 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers"