Merge branch 'fradrive/newletter'
This commit is contained in:
commit
e6f0454e78
@ -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
|
||||
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!
|
||||
|
||||
@ -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
|
||||
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!
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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.
|
||||
@ -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
|
||||
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.
|
||||
@ -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
|
||||
PaginationError: Paginierung Parameter dürfen nicht negativ sein
|
||||
|
||||
NullDeletes: Zum Löschen NULL eingeben.
|
||||
@ -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
|
||||
PaginationError: Pagination parameter must not be negative
|
||||
|
||||
NullDeletes: Enter NULL to delete.
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -68,6 +68,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserPostAddress} #
|
||||
^{updateAutomatic postalAutomatic}
|
||||
$if isNothing userPostAddress
|
||||
^{addressLinkdIcon}
|
||||
<dd .deflist__dd>
|
||||
#{addr}
|
||||
$if (not postalAutomatic)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user