diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 53ba2d4fc..bf76f6e0e 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,7 @@ 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 -FirmActAddSupersvisors: Ansprechpartner hinzufügen +FirmActAddSupervisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} @@ -27,11 +27,16 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen FirmUserActSetSupervisor: Ansprechpartner ändern +FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern +FirmUserActChangeDetails: Firmenassoziation bearbeiten +FirmUserActRemove: Firmenassoziation entfernen +FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert +FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert +FirmuserActRemoveResult uc@Int64 sup@Int64 sub@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. #{noneMoreDE sup "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöschtt. ")} #{noneMoreDE sub "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entfernten Angesprochenen gelöscht.")} FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen FirmSetSupervisor: Existierende Ansprechpartner hinzufügen FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)} -FirmUserActMkSuper: Zum Firmenansprechpartner ernennen -FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern @@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung FormFieldPostal: Benachrichtigungseinstellung FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner -FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert -FirmSupervisionKeyData: Kennzahlen Ansprechpartner \ No newline at end of file +FirmSupervisionKeyData: Kennzahlen Ansprechpartner +CompanyUserPriority: Firmenpriorität +CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person +CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse +CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist +CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird! diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 9c26677f2..38abc7d0c 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -16,7 +16,7 @@ FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmActResetMutualSupervision: Supervisors supervise each other -FirmActAddSupersvisors: Add supervisors +FirmActAddSupervisors: Add supervisors FirmActAddSupersEmpty: No supervisors added FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} @@ -27,15 +27,20 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default FirmUserActSetSupervisor: Change supervision +FirmUserActChangeContact: Change contact data for selected company associates +FirmUserActChangeDetails: Edit company association +FirmUserActRemove: Delete company association +FirmUserActMkSuper: Mark as company supervisor +FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated +FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"} +FirmuserActRemoveResult uc sup sub: #{pluralENsN uc "Company association"} deleted. #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "" ((pluralENsN sub "supervision") <> " removed due to eliminated supervisees.")} FirmNewSupervisor: Appoint new individual supervisors FirmSetSupervisor: Add existing supervisors -FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} +FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} -FirmUserActChangeContact: Change contact data for selected company associates -FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActSwitchSuper: Change default company supervisor -FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired. +FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired. FirmSuperActRMSuperDef: Remove default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail @@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute FormFieldPostal: Notification type FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor -FirmUserChanges n: Notification settings changed for #{n} company associates -FirmSupervisionKeyData: Supervision key data \ No newline at end of file +FirmSupervisionKeyData: Supervision key data +CompanyUserPriority: Company priority +CompanyUserPriorityTip: Company priority is relative to other company associations for a user +CompanyUserUseCompanyAddress: Use company postal address +CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty +CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used! diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index fd17f8e21..110f2ad01 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde. QualificationRefreshWithin: Erneurerungszeitraum QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email. -QualificationRefreshReminder: 2. Erinnerung +QualificationRefreshReminder: Zweite Erinnerung QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde. QualificationElearningStart: Wird das E‑Learning automatisch gestartet? QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer? @@ -123,7 +123,7 @@ QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert LmsInactive: Aktuell kein E‑Learning aktiv LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. -LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. +LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. Bitte setzen Sie sich mit uns in Verbindung, wenn Sie die Qualifikation verlängern möchten und noch nicht wissen, wie Sie das tun können. Ignorieren Sie diese automatisch generierte Erinnerung, falls Sie sich bereits um die Verlängerung gekümmert haben LmsRenewalReminder: Erinnerung LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index f0436c4e4..4ac35461c 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑lea QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured. QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email. -QualificationRefreshReminder: 2. Reminder +QualificationRefreshReminder: Second reminder QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry. QualificationElearningStart: Is e‑learning automatically started? QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period? @@ -123,7 +123,7 @@ QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated LmsInactive: Currently no active e‑learning LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. -LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. +LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. Please contact us, if you do not yet know how to renew this qualification. Ignore this automatically generated reminder email, if you have made arrangements for the renewal of this qualification already. LmsRenewalReminder: Reminder LmsActNotify: Resend e‑learning notification by post or email LmsActRenewPin: Randomly replace e‑learning password diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 470e7b2db..f550dd4b2 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -111,4 +111,7 @@ UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden! UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht. UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht. -SupervisorReason: Begründung \ No newline at end of file +UserCompanyReason: Begründung der Firmenassoziation +UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern. +UserSupervisorReason: Begründung Ansprechpartner +UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern. \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 11faa5471..6e4624edc 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -111,4 +111,7 @@ UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{plur UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified! UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}. -SupervisorReason: Reason \ No newline at end of file +UserCompanyReason: Reason for company association +UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes. +UserSupervisorReason: Reason for supervision +UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes. \ No newline at end of file diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 534ed450c..7fa240fe6 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -16,6 +16,7 @@ LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"} NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch durch as AVS aktualisiert. +AddressIsLinkedTip: Verlinkte Postaddresse: Für diesen Benutzer ist keine individuelle Postadresse gespeichert, die Adresse wurde stattdessen aus der Firmenzugehörigkeit abgeleitet. ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv @@ -26,4 +27,6 @@ AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht m PaginationSize: Einträge pro Seite PaginationPage: Angzeigte Seite -PaginationError: Paginierung Parameter dürfen nicht negativ sein \ No newline at end of file +PaginationError: Paginierung Parameter dürfen nicht negativ sein + +NullDeletes: Zum Löschen NULL eingeben. \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index cd2073f00..e7142f4bc 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -16,6 +16,7 @@ LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} Days num: #{num} #{pluralEN num "Day" "Days"} NoAutomaticUpdateTip: This particular value receives no automatic AVS updates, since it has been edited manually. +AddressIsLinkedTip: Linked postal address: No individual postal address is stored for this user, instead a postal address was inferred from the user's company association. ClusterVolatileQuickActionsEnabled: Quick actions enabled @@ -26,4 +27,6 @@ AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving PaginationSize: Rows per Page PaginationPage: Page to show -PaginationError: Pagination parameter must not be negative \ No newline at end of file +PaginationError: Pagination parameter must not be negative + +NullDeletes: Enter NULL to delete. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index c35e70c20..7d44de1cf 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -84,6 +84,7 @@ TableCompanyNos: Firmennummern TableCompanyUser: Firmenangehöriger TableCompanyNrUsers: Firmenangehörige TableCompanyNrSecondaryUsers: Sekundäre Firmenangehörige +TableCompanyReason: Notiz TableCompanyNrSupers: Ansprechpartner TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung @@ -97,6 +98,7 @@ TableRerouteActive: Umleitung TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner TableSupervisee: Ansprechpartner für +TableReason: Begründung TableCreationTime: Erstellungszeit TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 45947c414..830a5c441 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -84,6 +84,7 @@ TableCompanyNos: Company numbers TableCompanyUser: Associate TableCompanyNrUsers: Associates TableCompanyNrSecondaryUsers: Secondary Associates +TableCompanyReason: Note TableCompanyNrSupers: Supervisors TableCompanyNrEmpSupervised: Supervised employees TableCompanyNrEmpRerouted: Employees having reroute @@ -97,6 +98,7 @@ TableRerouteActive: Reroute TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor TableSupervisee: Supervisor for +TableReason: Reason TableCreationTime: Creation TableJob !ident-ok: Job TableJobContent !ident-ok: Parameters diff --git a/models/users.model b/models/users.model index 6a265b02c..beb1d8e0c 100644 --- a/models/users.model +++ b/models/users.model @@ -93,6 +93,7 @@ UserCompany supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users? priority Int default=0 -- higher number, higher priority; default=1 for Haskell-Code useCompanyAddress Bool default=true -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority + reason Text Maybe -- miscellaneous note, e.g. Superior UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once deriving Generic Show UserSupervisor diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 39cc90d29..456c2d983 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -19,6 +19,7 @@ import Import -- import Jobs import Handler.Utils +import Handler.Utils.Company import Handler.Utils.Communication import Handler.Utils.Avs (guessAvsUser) @@ -32,8 +33,8 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Postgresql import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as EL (on) -import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable +-- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -56,7 +57,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - | FirmActAddSupersvisors + | FirmActAddSupervisors | FirmActChangeContactFirm | FirmActChangeContactUser deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -70,10 +71,11 @@ data FirmActionData = FirmActNotifyData { firmActResetKeepOldSupers :: Maybe Bool , firmActResetMutualSupervision :: Maybe Bool } - | FirmActAddSupersvisorsData + | FirmActAddSupervisorsData { firmActAddSupervisorIds :: Set Text , firmActAddSupervisorReroute :: Bool , firmActAddSupervisorPostal :: Maybe Bool + , firmActAddSupervisorReason :: Maybe Text } | FirmActChangeContactFirmData { firmActCCFPostalAddr :: Maybe StoredMarkup @@ -82,6 +84,7 @@ data FirmActionData = FirmActNotifyData } | FirmActChangeContactUserData { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUUseCompanyPostal :: Maybe Bool , firmActCCUPostalPref :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -91,21 +94,31 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) where 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 + <$> aopt boolField' (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 MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons) + (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty + ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text) + ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $ + fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do + usrc <- E.from $ E.table @UserCompany + E.where_ $ E.isJust $ usrc E.^. UserCompanyReason + return $ usrc E.^. UserCompanyReason + firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing @@ -136,17 +149,19 @@ firmActionHandler route isAdmin = flip formResult faHandler delSupers <- if firmActResetKeepOldSupers == Just False then E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor - E.where_ $ suprFltr spr E.&&. E.exists (do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - ) + E.where_ $ suprFltr spr + E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault) + E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) else return 0 - newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids + newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids addMessageI Success $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams route -- reload to reflect changes - faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do + 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' @@ -164,7 +179,7 @@ firmActionHandler route isAdmin = flip formResult faHandler runDB $ do -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress - upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear? + upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear? whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal @@ -181,21 +196,30 @@ firmActionHandler route isAdmin = flip formResult faHandler 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 (FirmActChangeContactUserData{..}, Set.toList -> [cid]) + | firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr = + addMessageI Error MsgCompanyUserUseCompanyPostalError + | otherwise = do + let changes = catMaybes + [ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress E.=. E.nothing) -- precondition ensures that only one update applies for UserPostAddress + , (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref + ] + (total, nrChanged) <- runDB $ do + nrUsrChange <- 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 + nrUseComp <- case firmActCCUUseCompanyPostal of + Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x] + Nothing -> return 0 + nrCid <- count [UserCompanyCompany ==. cid] + return (fromIntegral nrCid, max nrUsrChange nrUseComp) + let allok = bool Warning Success $ nrChanged == total + addMessageI allok $ MsgFirmUserActChangeResult nrChanged total + reloadKeepGetParams route -- reload to reflect changes faHandler _ = addMessageI Error MsgErrorUnknownFormAction @@ -230,99 +254,6 @@ runFirmActionFormPost cid route isAdmin acts = do -- Firm specific utilities -- for filters and counts also see before FirmAllR Handlers - - --- | remove supervisors for given users; maybe restricted to those linked to a given companies -deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64 -deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany - where - restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)] - --- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors -resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 -resetSupervisors cid employees = do - nr_del <- deleteSupervisors employees [cid] - nr_add <- addDefaultSupervisors cid employees - return $ max nr_del nr_add - --- 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 - E.insertSelectWithConflictCount UniqueUserSupervisor - (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 - E.distinct $ return $ UserSupervisor - E.<# (spr E.^. UserCompanyUser) - E.<&> usr - E.<&> (spr E.^. UserCompanySupervisorReroute) - E.<&> E.justVal cid - E.<&> E.nothing - ) - (\_old new -> - [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications - , UserSupervisorCompany E.=. E.justVal cid - -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reason - ]) - --- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual -addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 -addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do - E.insertSelectWithConflictCount UniqueUserSupervisor - (do - (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) - E.where_ $ E.and $ guardMonoid (not mutualSupervision) - [ E.not_ $ usr E.^. UserCompanySupervisor ] - <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do - superv <- E.from $ E.table @UserSupervisor - E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId - E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser - ]) - <> [ spr E.^. UserCompanySupervisor - , spr E.^. UserCompanyCompany `E.in_` E.vals cids - , usr E.^. UserCompanyCompany `E.in_` E.vals cids - ] - E.distinct $ return $ UserSupervisor - E.<# (spr E.^. UserCompanyUser) - E.<&> (usr E.^. UserCompanyUser) - E.<&> (spr E.^. UserCompanySupervisorReroute) - E.<&> E.just (spr E.^. UserCompanyCompany) - E.<&> E.nothing - ) - (\_old new -> - [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications - , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany - -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon - ] ) - --- 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 - E.insertSelectWithConflictCount UniqueUserSupervisor - (do - (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) - E.where_ $ E.and $ guardMonoid (not mutualSupervision) - [ E.not_ $ usr E.^. UserCompanySupervisor ] - <> [ spr E.^. UserCompanySupervisor - , spr E.^. UserCompanyCompany `E.in_` E.vals cids - , usr E.^. UserCompanyCompany `E.in_` E.vals cids - ] - E.distinct $ return $ UserSupervisor - E.<# (spr E.^. UserCompanyUser) - E.<&> (usr E.^. UserCompanyUser) - E.<&> (spr E.^. UserCompanySupervisorReroute) - E.<&> E.just (spr E.^. UserCompanyCompany) - E.<&> E.nothing - ) - (\_old new -> - [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications - , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany - -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon - ] ) - - ------------------------------- -- repeatedly useful queries usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery () @@ -797,7 +728,9 @@ data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActSetSupervisor | FirmUserActMkSuper + | FirmUserActChangeDetails | FirmUserActChangeContact + | FirmUserActRemove deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -812,14 +745,23 @@ data FirmUserActionData = FirmUserActNotifyData | FirmUserActSetSupervisorData { firmUserActSetSuperNames :: Maybe (Set Text) , firmUserActSetSuperIds :: Maybe [UserId] + , firmUserActSetSuperReason :: Maybe Text , firmUserActSetSuperReroute :: Bool , firmUserActSetSuperKeep :: Bool } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } + | FirmUserActChangeDetailsData + { firmUserActDetailPriority :: Maybe Int + , firmUserActDetailReason :: Maybe Text + } | FirmUserActChangeContactData - { firmUserActPostalAddr :: Maybe StoredMarkup - , firmUserActPostalPref :: Maybe Bool + { firmUserActPostalAddr :: Maybe StoredMarkup + , firmUserActUseCompanyPostal :: Maybe Bool + , firmUserActPostalPref :: Maybe Bool + } + | FirmUserActRemoveData + { firmUserActRemoveKeepSuper :: Bool } deriving (Eq, Ord, Show, Generic) @@ -831,7 +773,7 @@ queryUserUser = $(sqlIJproj 2 1) queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany) queryUserUserCompany = $(sqlIJproj 2 2) -type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) -- , E.Value Bool) +type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool) resultUserUser :: Lens' UserCompanyTableData (Entity User) resultUserUser = _dbrOutput . _1 @@ -845,8 +787,8 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue --- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool --- resultUserCompanyPrimary = _dbrOutput . _5 . _unValue +resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool +resultUserCompanyPrimary = _dbrOutput . _5 . _unValue instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser @@ -888,12 +830,12 @@ mkFirmUserTable isAdmin cid = do dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid - -- let isPrimary = E.notExists (do - -- other <- E.from $ E.table @UserCompany - -- E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser - -- E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority - -- ) - return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp) + let isPrimary = E.notExists (do + other <- E.from $ E.table @UserCompany + E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser + E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority + ) + return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary) dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat @@ -904,7 +846,16 @@ mkFirmUserTable isAdmin cid = do , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row -> + let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress + useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress + in tickmarkCell $ noUsrAddr && useCompA , colUserEmail + , sortable (Just "usr-reason") (i18nCell MsgTableCompanyReason) $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r + , sortable (Just "priority") (i18nCell MsgCompanyUserPriority) $ \row -> + let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority + isPrime = row ^. resultUserCompanyPrimary + in numCell prio <> spacerCell <> ifIconCell isPrime IconTop , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat @@ -915,6 +866,8 @@ mkFirmUserTable isAdmin cid = do , singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute + , singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) + , singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUserUser @@ -991,6 +944,20 @@ mkFirmUserTable isAdmin cid = do , prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + userReasons :: HandlerFor UniWorX (OptionList Text) + userReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $ + fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do + usrc <- E.from $ E.table @UserCompany + E.where_ $ E.isJust (usrc E.^. UserCompanyReason) + E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid + return $ usrc E.^. UserCompanyReason + superReasons :: HandlerFor UniWorX (OptionList Text) + superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $ + fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do + usrc <- E.from $ E.table @UserSupervisor + E.where_ $ E.isJust (usrc E.^. UserSupervisorReason) + E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid + return $ usrc E.^. UserSupervisorReason acts :: Map FirmUserAction (AForm Handler FirmUserActionData) acts = mconcat [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData @@ -1000,13 +967,20 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing + <*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) + , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData + <$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing + <*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + , singletonMap FirmUserActRemove $ FirmUserActRemoveData + <$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -1081,9 +1055,9 @@ postFirmUsersR fsh = do (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False - then deleteSupervisors uids [] + then deleteDefaultSupervisorsForUsers [] [] uids else return 0 - newSupers <- addDefaultSupervisors cid uids + newSupers <- addDefaultSupervisors Nothing cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do @@ -1102,26 +1076,51 @@ postFirmUsersR fsh = do |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) delSupers <- runDB - $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep - <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers] + $ bool (deleteDefaultSupervisorsForUsers [cid] [] uids) (return 0) firmUserActSetSuperKeep + <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers] addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do - nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing + nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] + addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (FirmUserActChangeContactData{..}, Set.toList -> uids) -> - let changes = catMaybes - [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! - , (UserPrefersPostal =.) <$> firmUserActPostalPref - ] - in unless (null changes) $ do - nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes - addMessageI Success $ MsgFirmUserChanges nrChanged + (FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do + let upReason = case canonical firmUserActDetailReason of + Nothing -> Nothing + Just "NULL" -> Just $ UserCompanyReason =. Nothing + other -> Just $ UserCompanyReason =. other + nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority] + let total = fromIntegral $ length uids + allok = bool Warning Success $ nrUpd == total + addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActChangeContactData{..}, Set.toList -> uids) + | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr -> + addMessageI Error MsgCompanyUserUseCompanyPostalError + | otherwise -> do + let changes = catMaybes + [ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress + , (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal =.) <$> firmUserActPostalPref + ] + nrChanged <- runDB $ do + nrUsrChange <- updateWhereCount [UserId <-. uids] changes + nrUseComp <- case firmUserActUseCompanyPostal of + Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x] + Nothing -> return 0 + return $ max nrUsrChange nrUseComp + let total = fromIntegral $ length uids + allok = bool Warning Success $ nrChanged == total + addMessageI allok $ MsgFirmUserActChangeResult nrChanged total reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActRemoveData{}, Set.toList -> uids) -> do + (nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids + let total = fromIntegral $ length uids + allok = bool Warning Success $ nrUc == total + addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -1351,7 +1350,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) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 1202e670f..d888678be 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -630,7 +630,7 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) let usrAutomatic :: CU_UserAvs_User -> Widget usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate - + addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do @@ -1096,8 +1096,8 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..} if isReroute then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter) else mempty - , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) - , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) + , sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] dbtSorting = mconcat @@ -1146,8 +1146,8 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..} , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row -> let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail - , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) - , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) + , sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] dbtSorting = mconcat diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 6e4e608dd..8c4743ea2 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -91,7 +91,7 @@ tutorialForm cid template html = do where tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $ - fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do + fmap (setOf $ folded . _Value) . E.select . E.distinct . E.from $ \tutorial -> do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid return $ tutorial E.^. TutorialType diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 156a9a6f2..3f3f6660d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -186,6 +186,12 @@ postUsersR = do let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) + superReasons :: HandlerFor UniWorX (OptionList Text) + superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $ + fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do + usrc <- Ex.from $ Ex.table @UserSupervisor + E.where_ $ E.isJust (usrc E.^. UserSupervisorReason) + return $ usrc E.^. UserSupervisorReason acts :: Map UserAction (AForm Handler UserActionData) acts = mconcat [ singletonMap UserLdapSync $ pure UserLdapSyncData @@ -193,11 +199,11 @@ postUsersR = do , singletonMap UserAddSupervisor $ UserAddSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) - <*> aopt textField (fslI MsgSupervisorReason) Nothing + <*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing , singletonMap UserSetSupervisor $ UserSetSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) - <*> aopt textField (fslI MsgSupervisorReason) Nothing + <*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData , singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData ] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2f09d0804..50b70f784 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -394,7 +394,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv -- | otherwise -- -> Nothing superReasonComDef = tshow SupervisorReasonCompanyDefault - newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done + newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done usr_up2 <- case oldAvsFirmInfo of _ | Just newCompanyId == oldCompanyId -- company unchanged entirely @@ -439,7 +439,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr - -- addCompanySupervisors newCompanyId usrId + -- addDefaultSupervisors' newCompanyId $ singleton usrId -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId -- return pst_up @@ -550,10 +550,10 @@ createAvsUserById muid api = do } runDB $ do -- any failure must rollback all DB write transactions here uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData - let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done + let userComp = UserCompany uid cid False False 1 True Nothing -- default value for new company insertion, if no update can be done void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here) -- Supervision - addCompanySupervisors cid uid + void $ addDefaultSupervisors' cid $ singleton uid -- Save AVS data for future updates insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible return uid @@ -643,71 +643,90 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do -- upsert company supervisor from AvsFirmEMailSuperior upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId)) -upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do - supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior - cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi) - supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail) - (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail) - lift $ do - let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior - oldChanges <- runMaybeT $ do -- remove old superior, if any - oldAfi <- MaybeT $ pure mbOldAfi - oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior - oldCid <- MaybeT $ getAvsCompanyId oldAfi - oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml - let supChange = oldSup /= supid - when (supChange && oldCid == cid) $ lift $ do - -- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update - -- switch supervison - -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness - E.update $ \usuper -> do - E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ] - E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup - E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid - E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior - E.&&. E.notExists (do - newSuper <- E.from $ E.table @UserSupervisor - E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid - E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser - ) - deleteWhere [UserSupervisorSupervisor ==. oldSup, UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any - return (supChange, oldSup) - let supChange = fst <$> oldChanges - oldSup = snd <$> oldChanges - unless (supChange == Just False) $ do - -- upsert new superior company supervisor - mbMaxPrio <- E.selectOne $ do - usrCmp <- E.from $ E.table @UserCompany - E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid - return . E.max_ $ usrCmp E.^. UserCompanyPriority - let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio - suprEnt <- upsertBy (UniqueUserCompany supid cid) - (UserCompany supid cid True False maxPrio True) - [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio] - E.insertSelectWithConflict UniqueUserSupervisor - (do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid - -- E.&&. E.notExists (do -- restrict to primary company only - -- othr <- E.from $ E.table @UserCompany - -- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority - -- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser - -- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving - -- ) - return $ UserSupervisor - E.<# E.val supid - E.<&> (usr E.^. UserCompanyUser) - E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute) - E.<&> E.justVal cid - E.<&> E.val reasonSuperior - ) - (\old new -> - [ UserSupervisorCompany E.=. E.coalesce [old E.^. UserSupervisorCompany, new E.^. UserSupervisorCompany] - , UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason , new E.^. UserSupervisorReason ] - ] - ) - reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup - return (cid,supid) +upsertCompanySuperior (mbCid, newAfi) mbOldAfi + | Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given + = runMaybeT $ do + cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi) + supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail) + (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail) + lift $ do + oldChanges <- runMaybeT $ do -- remove old superior, if any + oldAfi <- MaybeT $ pure mbOldAfi + oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior + oldCid <- MaybeT $ getAvsCompanyId oldAfi + oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml + let supChange = oldSup /= supid + when (supChange && oldCid == cid) $ lift $ do + -- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update + -- switch supervison + -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness + E.update $ \usuper -> do + E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ] + E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup + E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid + E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior + E.&&. E.notExists (do + newSuper <- E.from $ E.table @UserSupervisor + E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid + E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser + ) + deleteOldSuperior oldSup cid -- remove un-updateable remainders, if any + return (supChange, oldSup) + let supChange = fst <$> oldChanges + oldSup = snd <$> oldChanges + unless (supChange == Just False) $ do + -- upsert new superior company supervisor + mbMaxPrio <- E.selectOne $ do + usrCmp <- E.from $ E.table @UserCompany + E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid + return . E.max_ $ usrCmp E.^. UserCompanyPriority + let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio + suprEnt <- upsertBy (UniqueUserCompany supid cid) + (UserCompany supid cid True False maxPrio True reasonSuperior) + [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior] + E.insertSelectWithConflict UniqueUserSupervisor + (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid + -- E.&&. E.notExists (do -- restrict to primary company only + -- othr <- E.from $ E.table @UserCompany + -- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority + -- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser + -- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving + -- ) + return $ UserSupervisor + E.<# E.val supid + E.<&> (usr E.^. UserCompanyUser) + E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute) + E.<&> E.justVal cid + E.<&> E.val reasonSuperior + ) + (\_old new -> + [ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor -- this is already given in case of conflict + UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + , UserSupervisorReason E.=. new E.^. UserSupervisorReason + ] + ) + reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup + return (cid,supid) + | Just oldSupeEmail <- mbOldAfi ^? _Just . _avsFirmEMailSuperior . _Just -- no more superior, delete old one + = do + void $ runMaybeT $ do + oldAfi <- MaybeT $ pure mbOldAfi + oldCid <- MaybeT $ getAvsCompanyId oldAfi + oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSupeEmail + lift $ deleteOldSuperior oldSup oldCid + return Nothing + | otherwise -- neither new nor old superior + = return Nothing + where + reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior + + deleteOldSuperior oldSup oldCid = + deleteWhere [ UserSupervisorSupervisor ==. oldSup + , UserSupervisorCompany ==. Just oldCid + , UserSupervisorReason ==. reasonSuperior + ] queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64 diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index d82adf69f..d51509f14 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -21,6 +21,14 @@ import qualified Database.Esqueleto.PostgreSQL as E import Handler.Utils.Users import Handler.Utils.Widgets +-- Snippet to restrict to primary company only +-- E.&&. E.notExists (do +-- othr <- E.from $ E.table @UserCompany +-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority +-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser +-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving +-- ) + company2msg :: CompanyId -> SomeMessage UniWorX company2msg = text2message . ciOriginal . unCompanyKey @@ -51,37 +59,94 @@ wgtCompanies = \uid -> do (accPri,accTop,accRem) = procCmp maxPri cs in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool! --- TODO: use this function in company view Handler.Firm #157 --- | add all company supervisors for a given users -addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) - => Key Company -> Key User -> ReaderT backend m () -addCompanySupervisors cid uid = - E.insertSelectWithConflict - UniqueUserSupervisor - ( do - userCompany <- E.from $ E.table @UserCompany - E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid - E.&&. userCompany E.^. UserCompanySupervisor - -- E.&&. E.notExists (do -- restrict to primary company only - -- othr <- E.from $ E.table @UserCompany - -- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority - -- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser - -- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving - -- ) +type AnySuperReason = Either SupervisorReason (Maybe Text) - return $ UserSupervisor - E.<# (userCompany E.^. UserCompanyUser) - E.<&> E.val uid - E.<&> (userCompany E.^. UserCompanySupervisorReroute) - E.<&> E.justVal cid - E.<&> E.justVal (tshow SupervisorReasonCompanyDefault) - ) - (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists - [ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?! - , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ] - ] - ) +addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64 +addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault + +-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company +-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL" +addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64 +addDefaultSupervisors reason cid employees = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (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 + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> usr + E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.justVal cid + E.<&> case reason of + Nothing -> E.justVal $ tshow SupervisorReasonCompanyDefault + Just "NULL" -> E.nothing + other -> E.val other + ) + (\old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. E.justVal cid + , UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given + ]) + + +-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual +-- TODO: check redundancies +addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64 +addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do + superv <- E.from $ E.table @UserSupervisor + E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId + E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + ]) + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.val reason + ) + (\old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + , UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given + ] ) + +-- like `addDefaultSupervisors`, but selects all employees of given companies from database +-- TODO: check redundancies +addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64 +addDefaultSupervisorsAll reason mutualSupervision cids = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.val reason + ) + (\old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + , UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason + ] ) -- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem]) @@ -108,13 +173,14 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d case mbUsrComp of Nothing -> do -- create company user void $ insertUnique newUserComp - addCompanySupervisors newCompanyId uid + void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid return (usrUpdate, mempty) - Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute} + Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason} | newCompanyId == oldCompanyId -> return mempty -- nothing to do | otherwise -> do -- switch company + when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp - [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True] + [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing] -- supervised by uid supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do usrSup <- E.from $ E.table @UserSupervisor @@ -139,7 +205,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d oldAPs <- if keepOldCompanySupervs then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing] else deleteWhereCount oldSubFltr - addCompanySupervisors newCompanyId uid + void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0 problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute) @@ -147,5 +213,27 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d newlyUnsupervised return (usrUpdate ,problems) where - newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done - superReasonComDef = tshow SupervisorReasonCompanyDefault \ No newline at end of file + newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done + superReasonComDef = tshow SupervisorReasonCompanyDefault + +defaultSupervisorReasonFilter :: [Filter UserSupervisor] +defaultSupervisorReasonFilter = + [UserSupervisorReason ==. Nothing] + ||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)] +-- ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] + +-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors +deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64 +deleteDefaultSupervisorsForUsers cids sprs usrs = + deleteWhereCount + $ bcons (notNull cids) (UserSupervisorCompany <-. (cids <&> Just)) + $ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs) + $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter + +-- | deletes user company association and all company related supervision +-- WARNING: does not check for admin problems! +deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64) +deleteCompanyUser cid uids = (,,) + <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] + <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter) + <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids) : defaultSupervisorReasonFilter) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9392ec58c..52df74953 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -77,7 +77,7 @@ import qualified Data.Text.Lazy.Builder as Builder -- import Control.Monad.Catch.Pure (runCatch) import qualified Data.List.NonEmpty as NonEmpty - + {-# ANN module ("HLint: ignore Use const" :: String) #-} @@ -217,7 +217,7 @@ optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews' return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews) - + optionalAction :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool @@ -236,7 +236,7 @@ optionalActionA :: AForm Handler a -> Maybe Bool -> AForm Handler (Maybe a) optionalActionA = optionalActionA' mpopt - + optionalActionNegatedA :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool @@ -740,8 +740,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev) let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess in pure $ Map.singleton iStart fileRes return (addRes', formWidget') - miCell _ initFile _ nudge csrf = - sFileForm nudge (Just initFile) csrf + miCell _ initFile _ nudge = sFileForm nudge (Just initFile) miDelete :: MassInputDelete ListLength miDelete = miDeleteList miAddEmpty _ _ _ = Set.empty @@ -966,9 +965,9 @@ genericFileField mkOpts = Field{..} $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles' return $ mconcat - [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap + [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap , sessionFiles' - , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap + , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap ] handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) () @@ -1002,7 +1001,7 @@ genericFileField mkOpts = Field{..} fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads)) fieldParse vals files' = runExceptT $ do let files = filter (not . null . fileName) files' - + opts@FileField{..} <- liftHandler mkOpts mIdent <- fmap getFirst . flip foldMapM vals $ \v -> @@ -1116,7 +1115,7 @@ genericFileField mkOpts = Field{..} fuiChecked | Right sentVals' <- sentVals = fuiTitle `Set.member` sentVals' - | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap + | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap = fieldOptionDefault | otherwise = False fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles @@ -1201,7 +1200,7 @@ zipFileField :: Bool -- ^ Unpack zips? -> Bool -- ^ Empty files ok? -> Field Handler FileUploads zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing - + zipFileField' :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions -> Bool -- ^ Empty files ok? @@ -1315,16 +1314,16 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) -> hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR - + return (examParts'', editableExams) let examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt) examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber) - + doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints' || not (null examParts) - + acts = Map.fromList $ catMaybes [ pure ( Normal', Normal <$> gradingReq ) , pure ( Bonus' , Bonus <$> gradingReq ) @@ -1346,7 +1345,7 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do Informational' -> return $ i18n MsgSheetTypeInfoInformational NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints - + aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup @@ -1468,7 +1467,7 @@ jsonField fieldKind = Field{..} {- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure yamlField :: ( ToJSON a, FromJSON a , MonadHandler m - , RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) FormMessage ) => Field m a yamlField = Field{..} @@ -1483,7 +1482,14 @@ yamlField = Field{..} #{either id (decodeUtf8 . Yaml.encode) val} |] fieldEnctype = UrlEncoded --} +-} + + +boolField' :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Field m Bool +boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) boolField :: ( MonadHandler m , HandlerSite m ~ UniWorX @@ -2309,7 +2315,7 @@ examModeForm mPrev = examMode <*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev) where examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..} - + examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset) examAidsEither = iso examAidsToEither examAidsFromEither where examAidsToEither (ExamAidsPreset p) = Right p diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 0be567c66..edffdaef1 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1000,11 +1000,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (userCompany E.^. UserCompanySupervisorReroute) E.<&> (userCompany E.^. UserCompanyPriority) E.<&> (userCompany E.^. UserCompanyUseCompanyAddress) + E.<&> (userCompany E.^. UserCompanyReason) ) (\current excluded -> [ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f , UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority) , UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress) + , UserCompanyReason E.=. E.coalesce [current E.^. UserCompanyReason ,excluded E.^. UserCompanyReason] ] ) deleteWhere [ UserCompanyUser ==. oldUserId] diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 10fa045b6..c830bd0f5 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -65,6 +65,8 @@ data SupervisorReason deriving (Eq, Ord, Enum, Bounded, Generic) deriving anyclass (Universe, Finite, NFData) +-- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions +-- so do not change values here without a proper migration instance Show SupervisorReason where show SupervisorReasonCompanyDefault = "Firmenstandard" show SupervisorReasonAvsSuperior = "Vorgesetzer" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5f670eb02..5b611c79e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -10,7 +10,7 @@ module Utils.Form where import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField) import Yesod.Auth (YesodAuth(maybeAuthId)) - + import Data.Kind (Type, Constraint) import qualified Yesod.Form as Yesod import Yesod.Core.Instances () @@ -94,7 +94,7 @@ _olOptionsGrouped :: Traversal' (OptionList a) (Text, [Option a]) _olOptionsGrouped f = \case x@OptionList{} -> pure x x@OptionListGrouped{} -> (\olOptionsGrouped -> x{olOptionsGrouped}) <$> traverse f (olOptionsGrouped x) - + _olReadExternal :: Lens' (OptionList a) (Text -> Maybe a) _olReadExternal f = \case x@OptionList{} -> (\olReadExternal -> x{olReadExternal}) <$> f (olReadExternal x) @@ -103,7 +103,7 @@ _olReadExternal f = \case -- if a field is required, but none should be there noField :: Monad m => Field m a noField = Field{..} - where + where fieldParse _ _ = return $ Right Nothing fieldView _ _ _ _ _ = mempty fieldEnctype = UrlEncoded @@ -576,52 +576,52 @@ runButtonForm' btns fid = do return (btnForm, res) --- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure +-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure -- that the button press still applies to the correct situation -runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site +runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site , Button site ButtonSubmit, Button site a, Finite a, Hashable h) => h -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) runButtonFormHash (hash -> hVal) fid = do currentRoute <- getCurrentRoute let bForm = disambiguateButtons $ combinedButtonFieldF "" - hForm = aopt hiddenField "" $ Just $ Just hVal - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> + hForm = aopt hiddenField "" $ Just $ Just hVal + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute , formEncoding = btnEnctype , formSubmit = FormNoSubmit } - res <- formResultMaybe btnResult $ \case + res <- formResultMaybe btnResult $ \case (btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching - _ -> do - addMessageI Error MsgBtnFormOutdated + _ -> do + addMessageI Error MsgBtnFormOutdated whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value return Nothing return (btnForm, res) -- | like runButtonFormHash, but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass. -runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site +runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site , Button site ButtonSubmit, Button site a, Hashable h) => h -> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) runButtonFormHash' (hash -> hVal) btns fid = do currentRoute <- getCurrentRoute let bForm = disambiguateButtons $ combinedButtonField btns "" - hForm = aopt hiddenField "" $ Just $ Just hVal - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> + hForm = aopt hiddenField "" $ Just $ Just hVal + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute , formEncoding = btnEnctype , formSubmit = FormNoSubmit } - res <- formResultMaybe btnResult $ \case + res <- formResultMaybe btnResult $ \case (btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching - _ -> do - addMessageI Error MsgBtnFormOutdated + _ -> do + addMessageI Error MsgBtnFormOutdated whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value return Nothing return (btnForm, res) - + ------------------- -- Custom Fields -- ------------------- @@ -801,7 +801,7 @@ intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) Fo intMinMaxField lower upper = intF{ fieldView=newView } where intF@Field{ fieldView=oldView } = intField - newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq + newView theId name attrs = oldView theId name (newAttrs <> attrs) newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ] daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime @@ -873,10 +873,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m -- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList) -- where splitConditionally :: Text -> [Text] --- splitConditionally t +-- splitConditionally t -- | ';' `telem` t = T.split (==';') t -- | ',' `telem` t = T.split (==',') t --- | otherwise = T.split C.isSeparator t +-- | otherwise = T.split C.isSeparator t -- -- Our version of Data.Text does not yet support T.elem -- telem :: Char -> Text -> Bool -- telem c = T.any (==c) @@ -885,10 +885,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m -- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList) -- where splitConditionally :: Text -> [Text] --- splitConditionally t +-- splitConditionally t -- | ';' `telem` t = T.split (==';') t -- | ',' `telem` t = T.split (==',') t --- | otherwise = T.split C.isSeparator t +-- | otherwise = T.split C.isSeparator t -- -- Our version of Data.Text does not yet support T.elem -- telem :: Char -> Text -> Bool -- telem c = T.any (==c) @@ -978,7 +978,7 @@ multiSelectField' optMsg mkOpts = Field{..} let rendered = case val of Left _ -> [] - Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] + Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] isSel Nothing = ClassyPrelude.Yesod.null rendered isSel (Just opt) = optionExternalValue opt `elem` rendered [whamlet| @@ -1112,7 +1112,7 @@ urlFieldText :: ( Monad m ) => Field m Text urlFieldText = urlField' (pack . ($ mempty) . uriToString id) id - + ----------- -- Forms -- @@ -1183,7 +1183,7 @@ type RenderAFormSite site = ( RenderMessage site AFormMessage , RenderMessage site UrlFieldMessage , MonadSecretBox (HandlerFor site) , MonadSecretBox (MaybeT (RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (Lazy.WriterT [FieldView site] (HandlerFor site)))) - , YesodAuth site, HasAppSettings site + , YesodAuth site, HasAppSettings site ) renderAForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> FormRender m a @@ -1272,7 +1272,7 @@ doFormHoneypots :: ( MonadHandler m doFormHoneypots = and2M (getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots) (is _Nothing <$> maybeAuthId) - + honeypotSecrets :: ( MonadSecretBox m , MonadThrow m ) @@ -1285,8 +1285,8 @@ honeypotSecrets = secretBoxCSPRNGPure (encodeUtf8 $ tshow 'honeypotSecrets) (Bin secretsNum = 10 randomIdent = decodeUtf8 . Base64.encodeUnpadded . BS.pack <$> replicateM 18 getRandom - - + + aformHoneypot :: forall m a. ( RenderAFormSite (HandlerSite m) , MonadHandler m diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 6ba582a00..5a7ed5486 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -121,6 +121,7 @@ data Icon | IconUserEdit -- IconMagic -- indicates automatic updates | IconReroute -- for notification rerouting + | IconTop -- indicating highest number/quantity/priority for something deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -220,6 +221,7 @@ iconText = \case IconUserEdit -> "user-edit" -- IconMagic -> "wand-magic" IconReroute -> "directions" + IconTop -> "arrow-to-top" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index f9427bcf1..60827a7db 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -68,6 +68,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgAdminUserPostAddress} # ^{updateAutomatic postalAutomatic} + $if isNothing userPostAddress + ^{addressLinkdIcon}
#{addr} $if (not postalAutomatic) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 2b38b164c..996b018ee 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -655,25 +655,25 @@ fillDb = do , let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n) , let rcShort = CI.mk $ "RC" <> tshow n ] - void . insert' $ UserCompany jost fraportAg True True 0 False - void . insert' $ UserCompany svaupel nice True False 2 False - void . insert' $ UserCompany svaupel ffacil False False 1 False - void . insert' $ UserCompany svaupel bpol True False 2 False - void . insert' $ UserCompany svaupel fraGround True False 1 False - void . insert' $ UserCompany gkleen nice False False 1 True - void . insert' $ UserCompany gkleen fraGround False True 2 False - void . insert' $ UserCompany gkleen bpol False True 1 False - void . insert' $ UserCompany fhamann bpol False False 1 True - void . insert' $ UserCompany fhamann ffacil True True 2 True - void . insert' $ UserCompany fhamann nice False False 3 False - void . insert' $ UserCompany sbarth nice False False 3 False - void . insert' $ UserCompany sbarth bpol True True 1 True + void . insert' $ UserCompany jost fraportAg True True 0 False $ Just "Vorgesetzter" + void . insert' $ UserCompany svaupel nice True False 2 False $ Just "Vorgesetzter" + void . insert' $ UserCompany svaupel ffacil False False 1 False $ Just "Irgendwas" + void . insert' $ UserCompany svaupel bpol True False 2 False $ Just "Irgendwas" + void . insert' $ UserCompany svaupel fraGround True False 1 False $ Just "Irgendwas" + void . insert' $ UserCompany gkleen nice False False 1 True $ Just "Winterdienst" + void . insert' $ UserCompany gkleen fraGround False True 2 False $ Just "Irgendwas" + void . insert' $ UserCompany gkleen bpol False True 1 False $ Just "Irgendwas" + void . insert' $ UserCompany fhamann bpol False False 1 True $ Just "Irgendwas" + void . insert' $ UserCompany fhamann ffacil True True 2 True $ Just "Irgendwas" + void . insert' $ UserCompany fhamann nice False False 3 False $ Just "Winterdienst" + void . insert' $ UserCompany sbarth nice False False 3 False $ Just "Winterdienst" + void . insert' $ UserCompany sbarth bpol True True 1 True $ Just "Irgendwas" -- need more tests - insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers] - insertMany_ [UserCompany uid bpol False False 0 False | Entity uid User{userFirstName = "Elizabeth"} <- matUsers] - insertMany_ [UserCompany uid bpol True True 0 True | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] - insertMany_ [UserCompany uid ffacil False False 0 False | Entity uid User{userSurname = "Walker"} <- matUsers] - insertMany_ [UserCompany uid rckey issuper False 0 True + insertMany_ [UserCompany uid fraGround False False 0 True Nothing | Entity uid User{userFirstName = "John"} <- matUsers] + insertMany_ [UserCompany uid bpol False False 0 False Nothing | Entity uid User{userFirstName = "Elizabeth"} <- matUsers] + insertMany_ [UserCompany uid bpol True True 0 True Nothing | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] + insertMany_ [UserCompany uid ffacil False False 0 False Nothing | Entity uid User{userSurname = "Walker"} <- matUsers] + insertMany_ [UserCompany uid rckey issuper False 0 True Nothing | rckey <- randComps , Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey] , Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers @@ -699,9 +699,9 @@ fillDb = do , UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff") , UserSupervisor tinaTester tinaTester False Nothing (Just "Staff") ] - ++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost] - ++ take 123 [ UserSupervisor gkleen uid True Nothing Nothing | Entity uid _ <- drop 369 matUsers ] - ++ take 11 [ UserSupervisor jost uid False Nothing (Just $ tshow SupervisorReasonAvsSuperior) | Entity uid _ <- drop 501 matUsers ] + ++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost] + ++ take 123 [ UserSupervisor gkleen uid True Nothing Nothing | Entity uid _ <- drop 369 matUsers ] + ++ take 11 [ UserSupervisor jost uid False (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) | Entity uid _ <- drop 501 matUsers ] upsertManyWhere supvs [] [] [] -- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error! -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok