diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 0c8732515..f9a26de23 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Re UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benutzer:in. +UnauthorizedAnySupervisor: Sie sind kein Ansprechpartner:in. +UnauthorizedCompanySupervisor fsh@CompanyShorthand: Sie sind kein Standard Ansprechpartner:in für Firma #{fsh}. UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für diesen Bereich eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Bereiche, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist. diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index 87f044580..b539efbf1 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so. UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages. UnauthorizedSupervisor: You are not a supervisor for the requested user. +UnauthorizedAnySupervisor: You are not a supervisor. +UnauthorizedCompanySupervisor fsh: You are not a default supervisor for company #{fsh}. UnauthorizedSiteAdmin: You are no system-wide administrator. UnauthorizedSchoolAdmin: You are no administrator for this department. UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator. diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg new file mode 100644 index 000000000..49fc0d066 --- /dev/null +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -0,0 +1,39 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAssociates: Firmenangehörige +FirmEmail: Allgemeine Email +FirmAddress: Postanschrift +FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige +FirmAllActNotify: Mitteilung versenden +FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? +FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig +FirmUserActNotify: Mitteilung versenden +FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen +FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} +FirmSuperActNotify: Mitteilung versenden +FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen +FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen +FirmsNotification: Firmen Benachrichtigung versenden +FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden +FirmsNotificationTitle: Firmen benachrichtigen +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen +FilterSupervisor: Hat aktiven Ansprechpartner +FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört +FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört +FilterForeignSupervisor: Hat firmenfremde Ansprechpartner +FilterFirmExtern: Externe Firma +FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig +FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit +FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} +NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. +TableIsDefaultSupervisor: Standardansprechpartner +TableIsDefaultReroute: Standardumleitung +ASReqPostal: Benachrichtigungseinstellung +ASReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +RemoveDefaultSupervisors n@Int64: #{n} Standard Ansprechpartner entfernt, aber noch nicht deaktiviert. \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg new file mode 100644 index 000000000..39e46d552 --- /dev/null +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -0,0 +1,39 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAssociates: Company associated users +FirmEmail: General company email +FirmAddress: Postal address +FirmDefaultPreferenceInfo: Default setting for new company associates only +FirmAllActNotify: Send message +FirmAllActResetSupervision: Reset supervisors for all company associates +FirmUserActNotify: Send message +FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? +FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmUserActResetSupervision: Reset supervisors to company default +FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} +FirmUserActMkSuper: Mark as company supervisor +FirmSuperActNotify: Send message +FirmSuperActRMSuperDef: Remove as default supervisor +FirmSuperActRMSuperAll: Remove all active supervisions for this company +FirmsNotification: Send company notification +FirmNotification fsh: Send notification to company #{fsh} +FirmsNotificationTitle: Company notification +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification +FilterSupervisor: Has active supervisor +FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} +FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} +FilterForeignSupervisor: Has company-external supervisors +FilterFirmExtern: External company +FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} +FirmSupervisorIndependent: Independent supervisors +FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users +NoCompanySelected: Select at least one company, please. +TableIsDefaultSupervisor: Default supervisor +TableIsDefaultReroute: Default reroute +ASReqPostal: Notification type +ASReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +ASReqEmpty: No supervisors added +ASReqSetSupers n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +RemoveDefaultSupervisors n: #{n} default supervisors removed, but not yet deactivated. \ No newline at end of file diff --git a/messages/uniworx/categories/jobs_handler/de-de-formal.msg b/messages/uniworx/categories/jobs_handler/de-de-formal.msg index 94fae99d1..dcb48a3fa 100644 --- a/messages/uniworx/categories/jobs_handler/de-de-formal.msg +++ b/messages/uniworx/categories/jobs_handler/de-de-formal.msg @@ -15,7 +15,6 @@ ResetPassword: FRADrive-Passwort ändern bzw. setzen MailSubjectChangeUserDisplayEmail: E-Mail-Adresse in FRADrive verwenden MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer/Die oben genannte Benutzerin möchte „#{displayEmail}“ als E-Mail-Adresse in FRADrive verwenden. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte! MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in FRADrive verwenden -CommCourseSubject: Kursartmitteilung InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat. InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat. diff --git a/messages/uniworx/categories/jobs_handler/en-eu.msg b/messages/uniworx/categories/jobs_handler/en-eu.msg index 3367e7a7a..e18244502 100644 --- a/messages/uniworx/categories/jobs_handler/en-eu.msg +++ b/messages/uniworx/categories/jobs_handler/en-eu.msg @@ -15,7 +15,6 @@ ResetPassword: Reselt FRADrive password MailSubjectChangeUserDisplayEmail: Set email address in FRADrive MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to set “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it! MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to set this email address as their own in FRADrive -CommCourseSubject: Course type message InvitationAcceptDecline: Accept/Decline invitation InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive. InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive. diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 028c2085f..302c38b84 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -37,7 +37,8 @@ PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrich PDFPasswordTip: Achtung, dieses Passwort ist für FRADrive Administratoren einsehbar und wird unverschlüsselt gespeichert! PDFPasswordInvalid c@Char: Bitte ein nicht-triviales Passwort für PDF Email Anhänge eintragen! Ungültiges Zeichen: #{char2Text c} PDFPasswordTooShort n@Int: Bitte ein PDF Passwort mit mindestens #{show n} Zeichen wählen oder Post-Versand aktivieren -PrefersPostal: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email? +PrefersPostal: Bevorzugte Benachrichtigung +PrefersPostalExp: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email? PostalTip: Postversand kann in Rechnung gestellt werden und ist derzeit nur für Benachrichtigungen über Erneuerung und Ablauf von Qualifikation, wie z.B. Führerscheine, verfügbar. PostAddress: Postalische Adresse PostAddressTip: Mindestens eine Zeile mit Straße und Hausnummer und eine Zeile mit Postleitzahl und Ort. Kein Empfängername, denn dieser wird später automatisch hinzugefügt. diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index 5fa8840f5..1a4790f5e 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -37,7 +37,8 @@ PDFPassword: Password to lock PDF email attachments PDFPasswordTip: Please note that this password is displayed to FRADrive admins and is saved unencrypted PDFPasswordInvalid c: Please supply a sensible password for encrypting PDF email attachments! Invalid character #{char2Text c} PDFPasswordTooShort n: Please provide a password with at least #{show n} characters or choose postal mail -PrefersPostal: Should notifications preferably send by post instead of email? +PrefersPostal: Notification preference +PrefersPostalExp: Should notifications preferably send by post instead of email? PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal. PostAddress: Postal address PostAddressTip: Should contain at least one line with street and house number and another line featuring zip code and town. Omit a recipient name, since it will be added later. diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 5ea9b7e59..b306bfdfc 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -133,6 +133,11 @@ MenuLmsFake: Testnutzer generieren MenuLmsLearners: Export Benutzer E‑Learning MenuLmsReport: Ergebnisse E‑Learning +MenuFirms: Firmen +MenuFirmUsers: Angehörige +MenuFirmSupervisors: Ansprechpartner +MenuFirmsComm: Mitteilung + MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b4a66104d..c8c18365f 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -134,6 +134,11 @@ MenuLmsFake: Generate Test Users MenuLmsLearners: E‑learning Users MenuLmsReport: E‑learning Results +MenuFirms: Companies +MenuFirmUsers: Associates +MenuFirmSupervisors: Supervisors +MenuFirmsComm: Messaging + MenuSap: SAP Interface MenuAvs: AVS Interface diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 86b07953e..295648b7e 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -75,8 +75,23 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanyFilter: Firma oder Nummer +TableCompanyShort: Firmenkürzel TableCompanies: Firmen +TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern +TableCompanyUser: Firmenangehöriger +TableCompanyNrUsers: Firmenangehörige +TableCompanyNrSupers: Ansprechpartner +TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner +TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung +TableCompanyNrEmpRerPost: Firmenangehörige mit postalischer Umleitung +TableCompanyNrSupersActive: Mitarbeiter mit Ansprechpartner +TableCompanyNrSupersDefault: Standard Ansprechpartner +TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner +TableCompanyNrRerouteDefault: Standard Umleitungen +TableCompanyNrRerouteActive: Aktive Umleitungen +TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job @@ -87,4 +102,6 @@ TableJobCreationInstance: Ersteller ActJobDelete: Job entfernen TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. -TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. \ No newline at end of file +TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. +TableFilterCommaName: Mehrere Namen mit Komma trennen. +TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 8a9c79bf8..3b7962522 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -75,8 +75,23 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanyFilter: Company/Nr +TableCompanyShort: Company shorthand TableCompanies: Companies +TableCompanyNo: Company number TableCompanyNos: Company numbers +TableCompanyUser: Associate +TableCompanyNrUsers: Associates +TableCompanyNrSupers: Supervisors +TableCompanyNrEmpSupervised: Supervised employees +TableCompanyNrEmpRerouted: Employees having reroute +TableCompanyNrEmpRerPost: Employees having postal reroute +TableCompanyNrSupersActive: Associates having supervisors +TableCompanyNrSupersDefault: Default supervisors +TableCompanyNrForeignSupers: External Supervisors +TableCompanyNrRerouteDefault: Default reroutes +TableCompanyNrRerouteActive: Active reroutes +TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job @@ -87,4 +102,6 @@ TableJobCreationInstance: Creator ActJobDelete: Delete job TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. -TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. \ No newline at end of file +TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. +TableFilterCommaName: Separate names by comma. +TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. \ No newline at end of file diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 13bae27f0..f25770b33 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -13,10 +13,13 @@ RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber:innen RecipientToggleAll: Alle/Keine CommCourseTestSubject customSubject@Text !ident-ok: [TEST] #{customSubject} UtilCommCourseSubject: Kursartmitteilung +UtilCommFirmSubject: Firmenmitteilung CommRecipients: Empfänger:innen CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. UtilEMail: E-Mail +UtilPostal: Brief +UtilUnchanged: Nicht verändern UtilMultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn}) RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“ @@ -93,6 +96,7 @@ RoomReferenceLinkLink !ident-ok: Link RoomReferenceLinkLinkPlaceholder !ident-ok: URL RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen +UtilEmptyChoice: Auswahl war leer #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 27a7eecad..97f5daa22 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -13,10 +13,13 @@ RGCourseUnacceptedApplicants: Applicants not accepted RecipientToggleAll: All/None CommCourseTestSubject customSubject: [TEST] #{customSubject} UtilCommCourseSubject: Course type message +UtilCommFirmSubject: Company message CommRecipients: Recipients CommRecipientsTip: You always receive a copy of the message CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties. UtilEMail: Email +UtilPostal: Postal +UtilUnchanged: No change UtilMultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) RGTutorialParticipants tutn: Course participants (#{tutn}) RGExamRegistered examn: Registered for exam “#{examn}” @@ -93,6 +96,7 @@ RoomReferenceLinkLink: Link RoomReferenceLinkLinkPlaceholder: URL RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions +UtilEmptyChoice: Empty selection #invitation.hs InvitationAction: Action diff --git a/models/company.model b/models/company.model index 5443b64b0..c022ad5f1 100644 --- a/models/company.model +++ b/models/company.model @@ -9,7 +9,8 @@ Company shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future avsId Int default=0 -- primary key from avs prefersPostal Bool default=false -- new company users prefers letters by post instead of email - postAddress StoredMarkup Maybe -- default company postal address + postAddress StoredMarkup Maybe -- default company postal address + email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name UniqueCompanyShorthand shorthand -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id diff --git a/package.yaml b/package.yaml index 04e5ca14e..51bf68fd4 100644 --- a/package.yaml +++ b/package.yaml @@ -259,6 +259,7 @@ ghc-options: - -j - -freduction-depth=0 - -fprof-auto-calls + - -g when: - condition: flag(pedantic) ghc-options: diff --git a/routes b/routes index 7a68b54e3..d341734ac 100644 --- a/routes +++ b/routes @@ -113,6 +113,12 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self +/firms FirmAllR GET POST !supervisor +/firms/comm/+Companies FirmsCommR GET POST +/firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/comm FirmCommR GET POST +/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor +/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office @@ -276,7 +282,7 @@ /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST -- old V1 LMS Interface /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor @@ -285,11 +291,11 @@ /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor -- new V2 LMS Interface /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET -/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST /lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS --- other lms routes +-- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET /lmsuser/#CryptoUUIDUser LmsUserAllR GET diff --git a/src/Application.hs b/src/Application.hs index 90d344bfd..45f24768e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -159,6 +159,7 @@ import Handler.SAP import Handler.PrintCenter import Handler.ApiDocs import Handler.Swagger +import Handler.Firm import ServantApi () -- YesodSubDispatch instances import Servant.API diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 139e955e1..2e97195e8 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -18,7 +18,7 @@ module Database.Esqueleto.Utils , or, and , any, all , subSelectAnd, subSelectOr - , mkExactFilter, mkExactFilterWith + , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith , mkExactFilterMaybeLast, mkExactFilterMaybeLast' , mkContainsFilter, mkContainsFilterWith @@ -43,8 +43,10 @@ module Database.Esqueleto.Utils , (->.), (->>.), (#>>.) , fromSqlKey , unKey + , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe + , num2text , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue @@ -225,8 +227,8 @@ explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nPare ) and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) -and = F.foldr (E.&&.) true -or = F.foldr (E.||.) false +and = F.foldl' (E.&&.) true -- we can use foldl' since Postgresql reorders conditions anyway +or = F.foldl' (E.||.) false -- | Given a test and a set of values, check whether anyone succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) @@ -283,6 +285,17 @@ mkExactFilterWith cast lenslike row criterias | Set.null criterias = true | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) +-- | like `mkExactFilterWith` but splits comma separared Texts into multiple criteria +mkExactFilterWithComma :: (PersistField b) + => (Text -> Maybe b) -- ^ type conversion + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set Text -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkExactFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | otherwise = lenslike row `E.in_` E.valList (mapMaybe cast $ Set.toList criterias) + -- | generic filter creation for dbTable -- Given a lens-like function, make filter for exact matches against last element of a collection mkExactFilterLast :: (PersistField a) @@ -638,6 +651,12 @@ unKey :: ( Coercible (Key entity) a => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a) unKey = E.veryUnsafeCoerceSqlExprValue +-- | distinct version of `Database.Esqueleto.subSelectCount` +subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a) +subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) + +-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) +-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a selectCountRows q = do @@ -660,10 +679,14 @@ selectCountDistinct q = do selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) +-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers +num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) +num2text = E.unsafeSqlCastAs "text" day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" +-- | cast text to day, truly unsafe day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day) day' = E.unsafeSqlCastAs "date" diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 832cf62a7..7ca298622 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -539,8 +539,11 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d return Authorized tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of - ForProfileR cID -> checkSupervisor (mAuthId, cID) - ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + ForProfileR cID -> checkSupervisor (mAuthId, cID) + ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + FirmAllR -> checkAnySupervisor mAuthId + FirmUsersR fsh -> checkCompanySupervisor (mAuthId, fsh) + FirmSupersR fsh -> checkCompanySupervisor (mAuthId, fsh) r -> $unsupportedAuthPredicate AuthSupervisor r where checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do @@ -549,6 +552,16 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of isSupervisor <- lift . existsBy $ UniqueUserSupervisor authId uid guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor) return Authorized + checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) + return Authorized + checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId] + guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor) + return Authorized tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 1271b4da4..8c8a0137b 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -1,7 +1,12 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- To add new language files: +-- 1. include new statement, e.g. mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" +-- 2. create appropriate translation files in the specified folder +-- 3. add constructor to list of module exports + {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,6 +25,7 @@ module Foundation.I18n , UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..) , UniWorXQualificationMessage(..) , UniWorXPrintMessage(..) + , UniWorXFirmMessage(..) , UniWorXAvsMessage(..) , UniWorXAuthorshipStatementMessage(..) , ShortTermIdentifier(..) @@ -197,6 +203,11 @@ maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text maybeToMessage _ Nothing _ = mempty maybeToMessage before (Just x) after = before <> toMessage x <> after +maybeBoolMessage :: Maybe Bool -> Text -> Text -> Text -> Text +maybeBoolMessage Nothing n _ _ = n +maybeBoolMessage (Just True) _ t _ = t +maybeBoolMessage (Just False) _ _ f = f + newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving stock (Eq, Ord, Read, Show) @@ -233,6 +244,7 @@ mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-for mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal" mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal" mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" +mkMessageAddition ''UniWorX "Firm" "messages/uniworx/categories/firm" "de-de-formal" mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal" mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal" mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal" diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1dbc9384a..b029cc0ee 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -123,6 +123,13 @@ breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR +breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing +breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR +breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove +breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR +breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh +breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh + breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR @@ -754,6 +761,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navForceActive = False } } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconCompany + , navLink = NavLink + { navLabel = MsgMenuFirms + , navRoute = FirmAllR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconPrintCenter @@ -2398,6 +2417,28 @@ pageActions ApiDocsR = return , navChildren = [] } ] +pageActions (FirmR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh + , navChildren = [] + } + ] +pageActions (FirmUsersR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh + , navChildren = [] + } + ] +pageActions (FirmSupersR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh + , navChildren = [] + } + ] pageActions PrintCenterR = do openDays <- useRunDB $ Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index a2a1db42f..3773a9c85 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -555,11 +555,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + + pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index 07bce86e7..a584267a5 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -64,8 +64,10 @@ postCCommR tid ssh csh = do return (cid, tuts, exams, sheets) + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs new file mode 100644 index 000000000..a37f59caa --- /dev/null +++ b/src/Handler/Firm.hs @@ -0,0 +1,1078 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{-# LANGUAGE TypeApplications #-} + +module Handler.Firm + ( getFirmAllR , postFirmAllR + , getFirmR , postFirmR + , getFirmUsersR , postFirmUsersR + , getFirmSupersR, postFirmSupersR + , getFirmCommR , postFirmCommR + , getFirmsCommR, postFirmsCommR + ) + where + +import Import + +-- import Jobs +import Handler.Utils +import Handler.Utils.Communication +import Handler.Utils.Avs (guessAvsUser) + +import qualified Data.Set as Set +import qualified Data.Map as Map +-- import qualified Data.Csv as Csv +-- import qualified Data.Text as T +import qualified Data.CaseInsensitive as CI +-- import qualified Data.Conduit.List as C +import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as EL (from, on) +import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH + + +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + +decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +decryptUser = decrypt + +encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser +encryptUser = encrypt + +--------------------------- +-- Firm specific utilities +-- for filters and counts see before FirmAllR Handlers + +-- remove supervisors: +deleteSupervisors :: NonEmpty UserId -> DB Int64 +deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] + +-- reset supervisors given employees of a company to default company supervision, deleting all other supervisors +resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +resetSupervisors cid employees = do + nr_del <- deleteSupervisors employees + 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 + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> usr + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) + +-- like `addDefaultSupervisors`, but selects all employees of given companies from database +addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 +addDefaultSupervisorsAll mutualSupervision cids = do + 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 + ] + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + + +------------------------------ +-- repeatedly useful queries + +fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () +fromUserCompany mbFltr cmpy = do + usrCmpy <- E.from $ E.table @UserCompany + let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr + +firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsers = E.subSelectCount . fromUserCompany Nothing + +firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) +-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do +-- usrCmpy <- E.from $ E.table @UserCompany +-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) +-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) +-- return $ usrCmpy E.^. UserCompanyUser + +firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor)) + + +firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + +firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + +firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool) + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + +firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + +firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr usrc = E.exists $ do + (usrSuper :& usr) <- + E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @User + `E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + E.&&. usr E.^. UserPrefersPostal + E.&&. E.isJust (usr E.^. UserPostAddress) + + +-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountForeignSupervisors cmpy = E.coalesceDefault +-- [E.subSelect $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) +-- return E.countRows +-- ] (E.val 0) + +firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) + pure $ usrSuper E.^. UserSupervisorSupervisor + +-- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications +-- pure $ usrSuper E.^. UserSupervisorSupervisor + +firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes cmpy = E.subSelectCount $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + +firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () +firmQuerySupervisedBy cid mbFltr usr = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr + +firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) +firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy + +firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisors usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + +firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorRerouteNotifications + + +------------------ +-- Debug Handler + +getFirmR, postFirmR :: CompanyShorthand -> Handler Html +getFirmR = postFirmR +postFirmR fsh = do + let cid = CompanyKey fsh + cusers <- runDB $ do + cusers <- selectList [UserCompanyCompany ==. cid] [] + selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] + csuper <- runDB $ do + csuper <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] + selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] + cactSuper <- runDB $ E.select $ do + (usr :& spr :& scmpy) <- E.from $ + E.table @User + `E.innerJoin` E.table @UserSupervisor + `E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) + `E.leftJoin` E.table @UserCompany + `E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser) + E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers) + E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany) + E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany] + let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows + return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows', usr E.^. UserPrefersPostal) + + siteLayoutMsg (SomeMessage fsh) $ do + setTitle $ citext2Html fsh + [whamlet| +

PROVISORISCHE DEBUG SEITE +

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

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

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

      #{length cusers} Employees +
        + $forall u <- cusers +
      • ^{linkUserWidget ForProfileDataR u} + + In the end, this needs to be a dbTable, of course! + |] + + +----------------------- +-- All Firms Table + +data FirmAllAction = FirmAllActNotify + | FirmAllActResetSupervision + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmAllAction id + +data FirmAllActionData = FirmAllActNotifyData + | FirmAllActResetSupervisionData + { firmAllActResetKeepOldSupers :: Maybe Bool + , firmAllActResetMutualSupervision :: Maybe Bool + } + deriving (Eq, Ord, Read, Show, Generic) + +-- just in case for future extensions +type AllCompanyTableExpr = E.SqlExpr (Entity Company) +queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) +queryAllCompany = id + +type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool) +resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) +resultAllCompanyEntity = _dbrOutput . _1 + +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = resultAllCompanyEntity . _entityVal + +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _2 . _unValue + +resultAllCompanySupervisors :: Lens' AllCompanyTableData Bool +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue + +resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool +resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue + + +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable isAdmin uid = do + -- now <- liftIO getCurrentTime + let + resultDBTable = DBTable{..} + where + dbtSQLQuery cmpy = do + unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + return ( cmpy -- 1 + , cmpy & firmCountUsers -- 2 + , cmpy & firmHasSupervisors -- 3 + , cmpy & firmHasDefaultReroutes -- 4 + -- , cmpy & firmCountEmployeeSupervised -- 4 + -- , cmpy & firmCountEmployeeRerouted -- 5 + -- , cmpy & firmCountEmployeeRerPost -- 6 + -- , cmpy & firmCountForeignSupervisors -- 7 + -- , cmpy & firmCountActiveReroutes -- 9 + -- , cmpy & firmCountActiveReroutes' -- 10 + ) + dbtRowKey = (E.^. CompanyId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm + in anchorCell (FirmUsersR fsh) $ toWgt fsh + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm + , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> + anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors + , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok + -- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr + , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + ] + dbtSorting = mconcat + [ singletonMap "name" $ SortColumn (E.^. CompanyName) + , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) + , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) + , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) + , singletonMap "users" $ SortColumn firmCountUsers + , singletonMap "supervisors" $ SortColumn firmHasSupervisors + -- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised + -- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted + -- , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost + , singletonMap "reroute-def" $ SortColumn firmHasDefaultReroutes + -- , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors + -- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes + -- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' + ] + dbtFilter = mconcat + [ single $ fltrCompanyNameNr queryAllCompany + , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) + , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.innerJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) + ) + , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + -- let checkSuper = do -- expensive + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ E.notExists (do + -- spr <- E.from $ E.table @UserCompany + -- E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + -- ) E.&&. E.exists (do + -- usr <- E.from $ E.table @UserCompany + -- E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- ) + let checkSuper = do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + E.&&. E.notExists (do + sprCmp <- E.from $ E.table @UserCompany + E.where_ $ sprCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. sprCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper + ) + , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) + ] + dbtFilterUI mPrev = mconcat + [ fltrCompanyNameUI mPrev + , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) + , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) + , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmAllAction (AForm Handler FirmAllActionData) + acts = mconcat + [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData + , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + ] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtIdent :: Text + dbtIdent = "firm" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess inp = do + (First (Just act), cmpMap) <- inp + let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap + return (act, cmpSet) + + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + resultDBTableValidator = def + & defaultSorting [SortAscBy "short"] + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable + + +getFirmAllR, postFirmAllR :: Handler Html +getFirmAllR = postFirmAllR +postFirmAllR = do + uid <- requireAuthId + isAdmin <- hasReadAccessTo AdminR + (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + formResult firmRes $ \case + (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected + + (FirmAllActResetSupervisionData{..}, fids) -> do + runDB $ do + delSupers <- if firmAllActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists $ do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams FirmAllR -- reload to reflect changes + + (FirmAllActNotifyData , Set.toList -> fids) -> do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + $(i18nWidgetFile "firm-all") + + +----------------------- +-- Firm Users Table + +data FirmUserAction = FirmUserActNotify + | FirmUserActResetSupervision + | FirmUserActMkSuper + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmUserAction id + +data FirmUserActionData = FirmUserActNotifyData + | FirmUserActResetSupervisionData + { firmUserActResetKeepOldSupers :: Maybe Bool + -- , firmUserActResetMutualSupervision :: Maybe Bool + } + | FirmUserActMkSuperData + { firmUserActMkSuperReroute :: Maybe Bool } + + deriving (Eq, Ord, Read, Show, Generic) + +type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) + +queryUserUser :: UserCompanyTableExpr -> E.SqlExpr (Entity User) +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) + +resultUserUser :: Lens' UserCompanyTableData (Entity User) +resultUserUser = _dbrOutput . _1 + +resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) +resultUserUserCompany = _dbrOutput . _2 + +resultUserCompanySupervisors :: Lens' UserCompanyTableData Word64 +resultUserCompanySupervisors = _dbrOutput . _3 . _unValue + +resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 +resultUserCompanyReroutes = _dbrOutput . _4 . _unValue + +instance HasEntity UserCompanyTableData User where + hasEntity = resultUserUser + +instance HasUser UserCompanyTableData where + hasUser = resultUserUser . _entityVal + + +mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) +mkFirmUserTable isAdmin cid = do + let + mkSprOption (E.Value uid, E.Value udn) = do + uuid <- toPathPiece <$> encryptUser uid + return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } + procOptions = fmap mkOptionList . traverse mkSprOption + + rawSupers <- E.select $ do + usr <- E.from $ E.table @User + E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + return (usr E.^. UserId, usr E.^. UserDisplayName) + let + -- supervisorField :: Field Handler UserId + supervisorField = selectField $ procOptions rawSupers + supervisorsField = multiSelectField $ procOptions rawSupers + + fsh = unCompanyKey cid + resultDBTable = DBTable{..} + where + dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do + EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid + return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp) + dbtRowKey = queryUserUser >>> (E.^. UserId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , colUserEmail + ] + dbtSorting = mconcat + [ single $ sortUserNameLink queryUserUser + , single $ sortUserEmail queryUserUser + , singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) + , singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) + , singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber) + , singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors + , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute + ] + dbtFilter = mconcat + [ single $ fltrUserNameEmail queryUserUser + , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper + , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. E.exists (do + spr <- E.from $ E.table @UserCompany + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper + , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. E.notExists (do + spr <- E.from $ E.table @UserCompany + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper + , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> + case criterion of + Just uid -> do + -- uid <- decryptUser uuid + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + _otherwise -> E.true + , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> + case criteria of + _ | Set.null criteria -> E.true + | otherwise -> do + -- uids <- traverse decryptUser criteria + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria + ] + -- superField = selectField $ ???? + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (multiFilter "supervisors-are" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) + , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmUserAction (AForm Handler FirmUserActionData) + acts = mconcat + [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData + <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) + ] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtIdent :: Text + dbtIdent = "firm-users" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + postprocess :: FormResult (First FirmUserActionData, DBFormResult UserId Bool UserCompanyTableData) + -> FormResult ( FirmUserActionData, Set UserId) + postprocess inp = do + (First (Just act), m) <- inp + let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m + return (act, s) + + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + resultDBTableValidator = def + & defaultSorting [SortAscBy "user-name"] + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable + + +getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html +getFirmUsersR = postFirmUsersR +postFirmUsersR fsh = do + isAdmin <- hasReadAccessTo AdminR + let cid = CompanyKey fsh + (( Entity{entityVal=Company{..}} + , E.Value nrCompanyUsers + , E.Value nrCompanySupervisors + , E.Value nrCompanyForeignSupers + , E.Value nrCompanyEmployeeSupervised + , E.Value nrCompanyEmployeeRerouted + , E.Value nrCompanyEmployeeRerPost + , E.Value nrCompanyDefaultReroutes + , E.Value nrCompanyActiveReroutes + ) , (fusrRes, fusrTable)) <- runDB $ (,) + <$> fromMaybeM notFound (E.selectOne $ do + cmpy <- E.from $ E.table @Company + E.where_ $ cmpy E.^. CompanyId E.==. E.val cid + return ( cmpy + , cmpy & firmCountUsers + , cmpy & firmCountSupervisors + , cmpy & firmCountForeignSupervisors + , cmpy & firmCountEmployeeSupervised + , cmpy & firmCountEmployeeRerouted + , cmpy & firmCountEmployeeRerPost + , cmpy & firmCountDefaultReroutes + , cmpy & firmCountActiveReroutes + )) + -- superVs <- E.select $ do + -- usr <- E.from $ E.table @User + -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr + -- return usr + <*> mkFirmUserTable isAdmin cid + + formResult fusrRes $ \case + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] + addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] + redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + (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 + else return 0 + newSupers <- addDefaultSupervisors cid uids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + siteLayout (citext2widget companyName) $ do + setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId + $(widgetFile "firm-users") + + +----------------------------- +-- Firm Supervisors Table + +data FirmSuperAction = FirmSuperActNotify + | FirmSuperActRMSuperDef + | FirmSuperActRMSuperAll + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmSuperAction id + +data FirmSuperActionData = FirmSuperActNotifyData + | FirmSuperActRMSuperDefData + | FirmSuperActRMSuperAllData + deriving (Eq, Ord, Read, Show, Generic) + + +data AddSupervisorRequest = AddSupervisorRequest + { asReqSupers :: Set Text + , asReqReroute :: Bool + , asReqPostal :: Maybe Bool + } deriving (Eq, Ord, Show, Generic) + +instance Default AddSupervisorRequest where + def = AddSupervisorRequest + { asReqSupers = mempty + , asReqReroute = True + , asReqPostal = Nothing + } + +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + +makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest +makeAddSupervisorForm template html = do + flip (renderAForm FormStandard) html $ AddSupervisorRequest + <$> areq (textField & cfAnySeparatedSet) + (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template) + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template) + <*> aopt postalEmailField (fslI MsgASReqPostal & setTooltip MsgASReqPostalTip) (asReqPostal <$> template) + + +type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) + +querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) +querySuperUser = $(sqlLOJproj 2 1) + +querySuperUserCompany :: SuperCompanyTableExpr -> E.SqlExpr (Maybe (Entity UserCompany)) +querySuperUserCompany = $(sqlLOJproj 2 2) + +type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 + , [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] + , E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany) + ) + +resultSuperUser :: Lens' SuperCompanyTableData (Entity User) +resultSuperUser = _dbrOutput . _1 + +resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64 +resultSuperCompanySupervised = _dbrOutput . _2 . _unValue + +resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64 +resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue + +resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] +resultSuperCompanies = _dbrOutput . _4 + +resultSuperCompanyDefaultSuper :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue + +resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue + +instance HasEntity SuperCompanyTableData User where + hasEntity = resultSuperUser + +instance HasUser SuperCompanyTableData where + hasUser = resultSuperUser . _entityVal + + +mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) +mkFirmSuperTable isAdmin cid = do + let + -- fsh = unCompanyKey cid + resultDBTable = DBTable{..} + where + dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do + EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid + E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + return ( usr + , usr & firmCountForSupervisor cid Nothing + , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + , usrCmp E.?. UserCompanySupervisor + , usrCmp E.?. UserCompanySupervisorReroute + ) + dbtRowKey = querySuperUser >>> (E.^. UserId) + dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do + cmps <- E.select $ do + (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) + E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) + E.orderBy [E.asc $ cmp E.^. CompanyName] + return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) + return (usr, supervised, rerouted, cmps, supervisor, reroute) + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) + , colUserNameModalHdr MsgTableSupervisor ForProfileDataR + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> + intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps] + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , colUserEmail + , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr + , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } + , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) + ] + dbtSorting = mconcat + [ single $ sortUserNameLink querySuperUser + , single $ sortUserEmail querySuperUser + , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) + , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) + , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) + , singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing + , singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + , singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do + (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) + E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId + E.orderBy [E.asc $ cmp E.^. CompanyName] + return (cmp E.^. CompanyName) + ) + , singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor) + , singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute) + ] + dbtFilter = mconcat + [ single $ fltrUserNameEmail querySuperUser + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) + acts = mconcat + [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + , singletonMap FirmSuperActRMSuperDef $ pure FirmSuperActRMSuperDefData + , singletonMap FirmSuperActRMSuperAll $ pure FirmSuperActRMSuperAllData + ] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtIdent :: Text + dbtIdent = "firm-supervisors" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + postprocess :: FormResult (First FirmSuperActionData, DBFormResult UserId Bool SuperCompanyTableData) + -> FormResult ( FirmSuperActionData, Set UserId) + postprocess inp = do + (First (Just act), m) <- inp + let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m + return (act, s) + + resultDBTableValidator = def + & defaultSorting [SortAscBy "user-name"] + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable + + +getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html +getFirmSupersR = postFirmSupersR +postFirmSupersR fsh = do + isAdmin <- hasReadAccessTo AdminR + let cid = CompanyKey fsh + (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) + <$> get404 cid + <*> mkFirmSuperTable isAdmin cid + + formResult fsprRes $ \case + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmSuperActRMSuperDefData, Set.toList -> uids) -> do + nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] + addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmSuperActRMSuperAllData, uids) -> addMessage Warning $ text2Html $ "TODO Make " <> tshow (length uids) <> " default and active supervisors. TODO" + (FirmSuperActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] + redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + + ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) + let addSuperAnchor = "add-supervisors-form" :: Text + routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor + addSuperForm = wrapForm asReqWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ routeAddSuperForm + , formEncoding = asReqEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just addSuperAnchor + } + formResult asReqRes $ \AddSupervisorRequest{..} -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +
          + $forall (usr,_) <- usersNotFound +
        • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + when (null usersFound) $ do + addMessageI Warning MsgASReqEmpty + redirect routeAddSuperForm + runDB $ do + putMany [UserCompany uid cid True asReqReroute | uid <- usersFound] + whenIsJust asReqPostal $ \prefPostal -> + updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal + redirect $ FirmSupersR fsh + + siteLayout (citext2widget fsh) $ do + setTitle $ citext2Html $ fsh <> " Supers" + $(i18nWidgetFile "firm-supervisors") + + +getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html +getFirmCommR = postFirmCommR +postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh] + + +getFirmsCommR, postFirmsCommR :: Companies -> Handler Html +getFirmsCommR = postFirmsCommR +postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) + + +handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html +handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] +handleFirmCommR ultDest cs = do + let csKey = CompanyKey <$> cs + -- get employees of chosen companies + empys <- E.unValue <<$>> runDB (E.select $ do + (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey + return $ emp E.^. UserId + ) + -- get supervisors of employees + sprs <- E.unValue <<$>> runDB (E.select $ do + spr <- E.from $ E.table @User + E.where_ $ E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + return $ spr E.^. UserId + ) + -- get companies of all supervisors + sprCmpys <- E.unValue <<$>> runDB (E.select $ do + cmpy <- E.from $ E.table @Company + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs + return $ cmpy E.^.CompanyId + ) + let + queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation + queryLoners = do + spr <- E.from $ E.table @User + E.where_ $ spr E.^. UserId `E.in_` E.valList empys + E.&&. E.notExists (do + sprCmp <- E.from $ E.table @UserCompany + E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId + ) + return spr + + queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) + queryCmpy sORe acid = do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid + E.&&. (if sORe + then -- supervisors only + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + else E.true + ) + return usr + + commR CommunicationRoute + { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } + , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } + , crUltDest = ultDest + , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++ + (RGFirmIndependent, queryLoners) : + [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ] + } + + {- Auswahlbox für Mitteilung: + Wenn Firma gewählt, dann zeige: + Alle Supervisor von Leuten in X, gruppiert nach deren Firma + Alle Teilnehmer von X + Wenn keine Firma gewählt, dann zeige: + Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma + Alle gewählten Personen, gruppiert nach deren Firma + -} diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index ae49a06c5..682e0c7f4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -3,7 +3,6 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# LANGUAGE TypeApplications #-} module Handler.LMS @@ -42,7 +41,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as T -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma @@ -360,9 +359,8 @@ data LmsTableAction = LmsActNotify | LmsActReset | LmsActRestart deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - -instance Universe LmsTableAction -instance Finite LmsTableAction + deriving anyclass (Universe, Finite) + nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id @@ -445,7 +443,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let - csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) + csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" dbtSQLQuery = lmsTableQuery now qid @@ -506,7 +504,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId - testcrit = maybe testname testnumber $ readMay $ CI.original criterion + testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) @@ -633,18 +631,15 @@ postLmsR sid qsh = do <* aformMessage msgRestartWarning ] colChoices cmpMap = mconcat - [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3dde9b54d..e0a12e0b1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -130,7 +130,7 @@ makeSettingForm template html = do <* aformSection MsgFormNotifications <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) - <*> apopt checkBoxField (fslI MsgPrefersPostal & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) + <*> apopt checkBoxField (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index cb04bc67b..65710b884 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -504,8 +504,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional - = renderAForm FormStandard - $ (, mempty) . First . Just + = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id @@ -587,14 +586,11 @@ postQualificationR sid qsh = do , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) - | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , guardMonoid isAdmin colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index ede48066a..ed5349e03 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -32,9 +32,10 @@ postTCommR tid ssh csh tutn = do ) return (tutData, usertuts) - + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index d856a29c4..1133c56d8 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -106,15 +106,16 @@ postUsersR = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies - , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM - (AdminUserR <$> encrypt uid) - (toWgt userCompanyPersonalNumber) - , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + pure $ intercalate (text2widget "; ") companies + -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM + -- (AdminUserR <$> encrypt uid) + -- (toWgt userCompanyPersonalNumber) + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber + , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 93577f8ed..d94f79706 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -8,6 +8,7 @@ module Handler.Utils.Communication , Communication(..) , commR , crJobsCourseCommunication, crTestJobsCourseCommunication + , crJobsFirmCommunication, crTestFirmCommunication -- * Re-Exports , Job(..) ) where @@ -27,9 +28,11 @@ import qualified Data.Conduit.Combinators as C data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants + -- WARNING: no RenderMessage instance, but a pattern match in templates/widgets/communication/recipientLayout.hamlet that needs to be extended | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet + | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientGroup where @@ -77,6 +80,7 @@ data CommunicationRoute = CommunicationRoute , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion , crJobs, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crHeading :: SomeMessage UniWorX + , crTitle :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } @@ -107,110 +111,129 @@ crTestJobsCourseCommunication jCourse comm = do crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) +crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication jCompanies Communication{..} = do + jSender <- requireAuthId + let jMailContent = cContent + allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients + jMailObjectUUID <- liftIO getRandom + jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case + Left email -> return . Address Nothing $ CI.original email + Right rid -> userAddress <$> getJust rid + forM_ allRecipients $ \jRecipientEmail -> + yield JobSendFirmCommunication{..} + +crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crTestFirmCommunication jCompanies comm = do + jSender <- requireAuthId + MsgRenderer mr <- getMsgRenderer + let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) + crJobsFirmCommunication jCompanies comm' .| C.filter ((== Right jSender) . jRecipientEmail) + + + + commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do - cUser <- maybeAuth - - MsgRenderer mr <- getMsgRenderer - mbCurrentRoute <- getCurrentRoute - - (suggestedRecipients, chosenRecipients) <- runDB $ do - suggestedUsers <- for crRecipients $ \(_,user) -> E.select user - let suggested = zip (view _1 <$> crRecipients) suggestedUsers - - let - decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) + let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) getEntity uid + cUser <- maybeAuth + (chosenRecipients, suggestedRecipients) <- runDB $ (,) + <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) + <*> (filter (notNull . snd) <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry)) + $logWarnS "COMM" ("Communication handlerwith (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") - chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient - - return (suggested, chosen') + MsgRenderer mr <- getMsgRenderer + mbCurrentRoute <- getCurrentRoute let - lookupUser :: UserId -> User - lookupUser lId - = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (view _2 <$> suggestedRecipients) ++ chosenRecipients + lookupUser :: UserId -> (UserDisplayName,UserSurname) + lookupUser = + let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients + usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display + usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) + in usrNames . flip Map.lookup usrMap - let chosenRecipients' = Map.fromList $ - [ ( (BoundedPosition $ RecipientGroup g, pos) - , (Right recp, recp `elem` map entityKey chosenRecipients) - ) - | (g, recps) <- suggestedRecipients - , (pos, recp) <- zip [0..] $ map entityKey recps - ] ++ - [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) - ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) - ] - activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom + chosenRecipients' = Map.fromList $ + [ ( (BoundedPosition $ RecipientGroup g, pos) + , (Right recp, recp `elem` map entityKey chosenRecipients) + ) + | (g, recps) <- suggestedRecipients + , (pos, recp) <- zip [0..] $ map entityKey recps + ] ++ + [ ( (BoundedPosition RecipientCustom, pos) + , (Right recp, True) + ) + | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) + ] + activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom - let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) - recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') - where - miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do - (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing - let - addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails - return (addRes', $(widgetFile "widgets/communication/recipientAdd")) - miAdd _ _ _ _ _ = Nothing - miCell _ (Left (CI.original -> email)) initRes nudge csrf = do - (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) - miCell _ (Right uid@(lookupUser -> User{..})) initRes nudge csrf = do - (tickRes, tickView) <- if - | fmap entityKey cUser == Just uid - -> mforced checkBoxField ("" & addName (nudge "tick")) True - | otherwise - -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientName")) - miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True - miAllowAdd _ _ _ = False - miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) - miAddEmpty _ _ _ = Set.empty - miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute - miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength - -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) - -> Map (BoundedPosition RecipientCategory, ListPosition) Widget - -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) - -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget - -> Widget - miLayout liveliness cState cellWdgts _delButtons addWdgts = do - checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState - checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c - hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts - categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness - rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget - rgTutorialParticipantsCaption cID = do - tutId <- decrypt cID - Tutorial{..} <- liftHandler . runDBRead $ get404 tutId - i18n $ MsgRGTutorialParticipants tutorialName - rgExamRegisteredCaption :: CryptoUUIDExam -> Widget - rgExamRegisteredCaption cID = do - eId <- decrypt cID - Exam{..} <- liftHandler . runDBRead $ get404 eId - i18n $ MsgRGExamRegistered examName - rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget - rgSheetSubmittorCaption cID = do - sId <- decrypt cID - Sheet{..} <- liftHandler . runDBRead $ get404 sId - i18n $ MsgRGSheetSubmittor sheetName - $(widgetFile "widgets/communication/recipientLayout") - miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) - -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos - miDelete _ _ = mzero - miIdent :: Text - miIdent = "recipients" - postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) - postProcess = Set.fromList . map fst . filter snd . Map.elems + recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') + where + miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do + (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing + let + addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails + return (addRes', $(widgetFile "widgets/communication/recipientAdd")) + miAdd _ _ _ _ _ = Nothing + miCell _ (Left (CI.original -> email)) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) + miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do + (tickRes, tickView) <- if + | fmap entityKey cUser == Just uid + -> mforced checkBoxField ("" & addName (nudge "tick")) True + | otherwise + -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientName")) + miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True + miAllowAdd _ _ _ = False + miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) + miAddEmpty _ _ _ = Set.empty + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute + miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength + -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) + -> Map (BoundedPosition RecipientCategory, ListPosition) Widget + -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) + -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget + -> Widget + miLayout liveliness cState cellWdgts _delButtons addWdgts = do + checkedIdentBase <- newIdent + let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState + checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c + hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts + categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness + rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget + rgTutorialParticipantsCaption cID = do + tutId <- decrypt cID + Tutorial{..} <- liftHandler . runDBRead $ get404 tutId + i18n $ MsgRGTutorialParticipants tutorialName + rgExamRegisteredCaption :: CryptoUUIDExam -> Widget + rgExamRegisteredCaption cID = do + eId <- decrypt cID + Exam{..} <- liftHandler . runDBRead $ get404 eId + i18n $ MsgRGExamRegistered examName + rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget + rgSheetSubmittorCaption cID = do + sId <- decrypt cID + Sheet{..} <- liftHandler . runDBRead $ get404 sId + i18n $ MsgRGSheetSubmittor sheetName + $(widgetFile "widgets/communication/recipientLayout") + miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) + -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos + miDelete _ _ = mzero + miIdent :: Text + miIdent = "recipients" + postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) + postProcess = Set.fromList . map fst . filter snd . Map.elems recipientsListMsg <- messageI Info MsgCommRecipientsList - + attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing @@ -221,14 +244,16 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg <*> ( CommunicationContent <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) - <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) + <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) + (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) + ) formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs @@ -237,15 +262,15 @@ commR CommunicationRoute{..} = do (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess - + let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit - } + } siteLayoutMsg crHeading $ do - setTitleI crHeading + setTitleI crTitle let commTestTip = $(i18nWidgetFile "comm-test-tip") [whamlet| $newline never diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 1b8b9dafa..440f6c8fa 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -40,14 +40,14 @@ upsertCompany cName cAddr = Nothing -> do let cShort = companyShorthandFromName cName cShort' <- findShort cName' $ CI.mk cShort - let compy = Company cName' cShort' 0 False cAddr -- TODO: Fix this once AVS CR3 SCF-165 is implemented + let compy = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented either entityKey id <$> insertBy compy where findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand findShort fna fsh = aux 0 where aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in - checkUnique (Company fna fsh' 0 False Nothing) >>= \case + checkUnique (Company fna fsh' 0 False Nothing Nothing) >>= \case Nothing -> return fsh' _other -> aux (n+1) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 28b1b9d32..f992e76d8 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1498,7 +1498,20 @@ boolField mkNone = radioGroupField mkNone $ do _other -> Nothing } - +-- | like `boolField` but with custom labels +boolFieldCustom :: (MonadHandler m, HandlerSite m ~ UniWorX) + => SomeMessage UniWorX -> SomeMessage UniWorX -> Maybe (SomeMessage UniWorX) -> Field m Bool +boolFieldCustom mkTrue mkFalse mkNone = radioGroupField mkNone $ do + mr <- getMessageRender + return OptionList + { olOptions = [ Option (mr mkFalse) False "false" + , Option (mr mkTrue) True "true" + ] + , olReadExternal = \case + "false" -> Just False + "true" -> Just True + _other -> Nothing + } sectionedFuncForm :: forall f k v m sec. ( TraversableWithIndex k f diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 42970a046..cf5051ef5 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -29,6 +29,9 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit spacerCell :: IsDBTable m a => DBCell m a spacerCell = cell [whamlet| |] +semicolonCell :: IsDBTable m a => DBCell m a +semicolonCell = cell [whamlet|; |] + tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a tellCell = flip mappend . writerCell . tell @@ -91,6 +94,7 @@ guardAuthCell mkParams = over cellContents $ \act -> do --------------------- -- Icon cells +-- to be used with icons directly, for results of `icon`, use either `wgtCell` or `iconFixedCell` iconCell :: IsDBTable m a => Icon -> DBCell m a iconCell = cell . toWidget . icon @@ -307,6 +311,16 @@ courseCell Course{..} = anchorCell link name `mappend` desc ^{modal "Beschreibung" (Right $ toWidget descr)} |] +companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a +companyCell cid cname isSupervisor = anchorCell link name + where + link = FirmR cid + corg = ciOriginal cname + name + | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor + | otherwise = text2markup corg + + qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name where diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 280becf18..6184d1314 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -753,6 +753,49 @@ sortUserCompany queryUser = ( "user-company" return (comp E.^. CompanyName) )) +-- | Search companies by name or shorthand +fltrCompanyName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) + => (a -> E.SqlExpr (Entity Company)) + -> (d, FilterColumn t fs) +fltrCompanyName query = ( "company-name", FilterColumn $ anyFilter + [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) + , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) + -- , mkExactFilterWithComma id $ query >>> (E.num2text . (E.^. CompanyAvsId)) + ] + ) + +fltrCompanyNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameUI = fltrCompanyNameNrHdrUI MsgTableCompany + +fltrCompanyNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameHdrUI msg mPrev = + prismAForm (singletonFilter "company-name") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) + + + +fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) + => (a -> E.SqlExpr (Entity Company)) + -> (d, FilterColumn t fs) +fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) -> + let numCrits = setMapMaybe readMay criterias + fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias + fltrCShort = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) needle criterias + fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits + in if null numCrits + then fltrCName E.||. fltrCShort + else fltrCName E.||. fltrCShort E.||. fltrCno + ) + where + setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text + setFoldMap = foldMap + +fltrCompanyNameNrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameNrUI = fltrCompanyNameNrHdrUI MsgTableCompanyFilter + +fltrCompanyNameNrHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameNrHdrUI msg mPrev = + prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) + ---------------------------- -- Colonnade manipulation -- diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a2a5fc381..415fb255b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,10 +1,20 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +{- FOP - Frequently occurring problems using dbTable: + + - When changing a dbTable to a form, eg. using `dbSelect` then change the colonnade defnition from `dbColonnade` to `formColonnade`! + Both functions are equal to id, but the types are quite different. + + - Don't mix up the row type alias traditionally ending with ...Data and the Action-Result-Type also ending with ...Data + +-} + module Handler.Utils.Table.Pagination ( module Handler.Utils.Table.Pagination.Types , dbFilterKey @@ -27,7 +37,7 @@ module Handler.Utils.Table.Pagination , dbtProjFilteredPostId, dbtProjFilteredPostSimple , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM , withCsvExtraRep - , singletonFilter + , singletonFilter, multiFilter , DBParams(..) , cellAttrs, cellContents , addCellClass @@ -637,6 +647,13 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) fromInner = maybe Map.empty $ Map.singleton key . pure fromOuter = Map.lookup key >=> listToMaybe +multiFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe [v]) +-- ^ for use with @prismAForm@ +multiFilter key = prism' fromInner fromOuter + where + -- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v]) + fromInner = maybe Map.empty (Map.singleton key) + fromOuter = Just . Map.lookup key data DBTCsvEncode r' k' csv = forall exportData filename sheetName. ( ToNamedRecord csv, CsvColumnsExplained csv @@ -1654,10 +1671,12 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x) -> Colonnade h r (DBCell (HandlerFor UniWorX) x) widgetColonnade = id +-- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) formColonnade = id +-- | force the column list type for simple tables that do not contain forms, and especially no dbSelect, avoids explicit type signatures dbColonnade :: Colonnade h r (DBCell DB x) -> Colonnade h r (DBCell DB x) dbColonnade = id diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index bb1e1c1ce..1785924b4 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -204,7 +204,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act luser E.?. LmsUserUser E.?=. quser E.^. QualificationUserUser E.&&. luser E.?. LmsUserQualification E.?=. quser E.^. QualificationUserQualification) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid + -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index a8a629f60..4edaa2d4d 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -4,6 +4,7 @@ module Jobs.Handler.SendCourseCommunication ( dispatchJobSendCourseCommunication + , dispatchJobSendFirmCommunication ) where import Import @@ -37,7 +38,35 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours _mailFrom .= userAddressFrom sender addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Auto-Submitted" "no" - setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage ccSubject + setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgUtilCommCourseSubject) SomeMessage ccSubject + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + forM_ ccAttachments $ addPart' . toMailPart + when (jRecipientEmail == Right jSender) $ + addPart' $ do + partIsAttachmentCsv MsgCommAllRecipients + toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses) + + +dispatchJobSendFirmCommunication :: Either UserEmail UserId + -> Set Address + -> Companies + -> UserId + -> UUID + -> CommunicationContent + -> JobHandler UniWorX +dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do + -- (sender,mbComp) <- runDB $ (,) + -- <$> getJust jSender + -- <*> ifMaybeM jCompany Nothing get + sender <- runDB $ getJust jSender + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + MsgRenderer mr <- getMailMsgRenderer + + void $ setMailObjectUUID jMailObjectUUID + _mailFrom .= userAddressFrom sender + addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] + addMailHeader "Auto-Submitted" "no" + setSubjectI $ maybe (SomeMessage MsgUtilCommFirmSubject) SomeMessage ccSubject addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) forM_ ccAttachments $ addPart' . toMailPart when (jRecipientEmail == Right jSender) $ diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d5338acf6..e169f1552 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -60,7 +60,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block qname = CI.original qualificationName qshort = CI.original qualificationShorthand - letter = LetterExpireQualification + letter = LetterExpireQualification { leqHolderCFN = encRecShort , leqHolderID = jRecipient , leqHolderDN = userDisplayName @@ -72,16 +72,16 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do , leqSchool = qualificationSchool , leqUrl = pure . urender $ ForProfileDataR encRecipient } - if expDay > utctDay qualificationUserLastNotified + if expDay > utctDay qualificationUserLastNotified then do notifyOk <- sendEmailOrLetter jRecipient letter if notifyOk - then do + then do runDB $ update quId [QualificationUserLastNotified =. now] $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname - else + else $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname - else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification @@ -89,7 +89,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do dispatchNotificationQualificationRenewal :: QualificationId -> Bool -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = do encRecipient :: CryptoUUIDUser <- encrypt jRecipient - query <- runDB $ (,,,) + query <- runDB $ (,,,) <$> get jRecipient <*> get nQualification <*> getBy (UniqueQualificationUser nQualification jRecipient) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index a0717099a..78b4fe50b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -74,6 +74,13 @@ data Job , jMailObjectUUID :: UUID , jMailContent :: CommunicationContent } + | JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId + , jAllRecipientAddresses :: Set Address + , jCompanies :: Companies + , jSender :: UserId + , jMailObjectUUID :: UUID + , jMailContent :: CommunicationContent + } | JobInvitation { jInviter :: Maybe UserId , jInvitee :: UserEmail , jInvitationUrl :: Text diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 5f9940449..fd2e9c810 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -141,6 +141,8 @@ migrateManual = do , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") + , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company + , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] where addIndex :: Text -> Sql -> Migration diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 836d2741e..df9bc1a79 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -42,7 +42,8 @@ type SchoolName = CI Text type SchoolShorthand = CI Text type CompanyName = CI Text -type CompanyShorthand = CI Text +type CompanyShorthand = CI Text +type Companies = [CI Text] type CourseName = CI Text type CourseShorthand = CI Text diff --git a/src/Utils.hs b/src/Utils.hs index 7ff482a96..44b863ae9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -305,6 +305,10 @@ tshowCrop = cropText . tshow stripCI :: Text -> CI Text stripCI = CI.mk . Text.strip +-- | just to avoid adding an import for this +ciOriginal :: CI Text -> Text +ciOriginal = CI.original + citext2lower :: CI Text -> Text citext2lower = Text.toLower . CI.original @@ -360,6 +364,9 @@ text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) text2Html :: Text -> Html text2Html = toHtml +citext2Html :: CI Text -> Html +citext2Html = toHtml . CI.original + char2Text :: Char -> Text char2Text c | isSpace c = "" @@ -839,8 +846,8 @@ _MapUnit = iso Map.keysSet $ Map.fromSet (const ()) -- | Just @flip (.)@ for convenient formatting in some cases, -- Deprecated in favor of Control.Arrow.(>>>) -compose :: (a -> b) -> (b -> c) -> (a -> c) -compose = flip (.) +-- compose :: (a -> b) -> (b -> c) -> (a -> c) +-- compose = flip (.) ----------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2d00d373e..69ec53464 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -316,6 +316,7 @@ data FormIdentifier | FIDBtnAvsImportUnknown | FIDBtnAvsRevokeUnknown | FIDHijackUser + | FIDAddSupervisor deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 2c8d9de6a..0018e74e0 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -109,11 +109,14 @@ data Icon | IconLetter | IconAt | IconSupervisor + | IconSupervisorForeign -- | IconWaitingForUser | IconExpired | IconLocked | IconUnlocked | IconResetTries -- also see IconReset + | IconCompany + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -152,7 +155,7 @@ iconText = \case IconSFTHint -> "life-ring" -- for SheetFileType only IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only - IconEmail -> "envelope" -- envelope is no longer unamibuous + IconEmail -> "envelope" -- envelope is no longer unamibuous, use IconAt or IconLetter if email and postal need to be distinguished IconRegisterTemplate -> "file-alt" IconNoCorrectors -> "user-slash" IconRemoveUser -> "user-slash" @@ -198,13 +201,15 @@ iconText = \case IconCertificate -> "badge-check" IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk" IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well - IconAt -> "at" + IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter IconSupervisor -> "head-side" -- must be notably different to user + IconSupervisorForeign -> "alien" -- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something IconExpired -> "hourglass-end" IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" + IconCompany -> "building" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet new file mode 100644 index 000000000..9acaf1c2f --- /dev/null +++ b/templates/firm-users.hamlet @@ -0,0 +1,68 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
          +
          + $maybe fem <- companyEmail +
          + _{MsgFirmEmail} #{iconLetterOrEmail False} +
          + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
          + _{MsgFirmAddress} #{iconLetterOrEmail True} +
          + #{addr} + +
          +
          + + + + + + + + +
          _{MsgTableCompanyNrSupersDefault} + _{MsgTableCompanyNrRerouteDefault} + _{MsgPrefersPostal} +
          #{nrCompanySupervisors} + #{nrCompanyDefaultReroutes} + #{iconLetterOrEmail companyPrefersPostal} + _{MsgFirmDefaultPreferenceInfo} +
          _{MsgTableCompanyNrUsers} + _{MsgTableCompanyNrForeignSupers} +
          #{nrCompanyUsers} + #{nrCompanyForeignSupers} + + Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel. + +
          _{MsgTableCompanyNrEmpSupervised} + _{MsgTableCompanyNrEmpRerouted} + _{MsgTableCompanyNrEmpRerPost} + _{MsgTableCompanyNrRerouteActive} +
          #{nrCompanyEmployeeSupervised} + #{nrCompanyEmployeeRerouted} + #{nrCompanyEmployeeRerPost} + #{nrCompanyActiveReroutes} +
          + Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! + + Mindestens ein Ansprechpartner mit Umleitung. + + Email oder Brief ist individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. + + Gesamtzahl aller aktiven Benachrichtigungsumleitungen. # + + Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # + würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. + +
          +

          + _{MsgFirmAssociates} +

          + ^{fusrTable} \ No newline at end of file diff --git a/templates/i18n/firm-all/de-de-formal.hamlet b/templates/i18n/firm-all/de-de-formal.hamlet new file mode 100644 index 000000000..480a6fbe9 --- /dev/null +++ b/templates/i18n/firm-all/de-de-formal.hamlet @@ -0,0 +1,15 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

          + + +

          + Die Daten der Firmen wurden aus dem Ausweisverwaltungssystem (AVS) der Fraport AG # + importiert und werden regelmäßig aktualisiert, # + wenn Fahrlizenzinhaber oder deren Verwalter über das AVS einer Firma zugeordnet wurden. +

          + ^{firmTable} diff --git a/templates/i18n/firm-all/en-eu.hamlet b/templates/i18n/firm-all/en-eu.hamlet new file mode 100644 index 000000000..2e32522f3 --- /dev/null +++ b/templates/i18n/firm-all/en-eu.hamlet @@ -0,0 +1,16 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

          + + +

          + Data of all companies that were taken from the id card management system (AVS) of Fraport AG. + A company is importet and regularly update if a driving licence holder or their supervisor + are associated with that company through the AVS. + +

          + ^{firmTable} diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet new file mode 100644 index 000000000..d81248e80 --- /dev/null +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -0,0 +1,27 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

          + Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen. + Daraus folgt zum Beispiel, dass wenn x ein Standard-Ansprechpartner für Firma a ist + und wenn y sowohl Firma a als auch b angehört, + dass dann x als firmenfremd in der Liste der Ansprechpartner von Firma b angezeigt wird. +
          +
          + $maybe fem <- companyEmail +
          + _{MsgFirmEmail} #{iconLetterOrEmail False} +
          + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
          + _{MsgFirmAddress} #{iconLetterOrEmail True} +
          + #{addr} +
          + ^{fsprTable} +
          + ^{addSuperForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet new file mode 100644 index 000000000..400fc543b --- /dev/null +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -0,0 +1,26 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
          + Note that supervision is company independent. + For example, if x is a regular supervisor for company a and y belongs to companies a and b, + then x will be listed as a foreign supervisor for company b. +
          +
          + $maybe fem <- companyEmail +
          + _{MsgFirmEmail} #{iconLetterOrEmail False} +
          + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
          + _{MsgFirmAddress} #{iconLetterOrEmail True} +
          + #{addr} +
          + ^{fsprTable} +
          + ^{addSuperForm} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 91f194fed..9eb2817af 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -49,7 +49,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
          ^{formatTimeW SelFormatDate bday}
          - _{MsgPrefersPostal} + _{MsgPrefersPostalExp}
          #{iconLetterOrEmail userPrefersPostal} $maybe addr <- userPostAddress diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index 7b7f188d1..cd5546277 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -31,6 +31,12 @@ $if not (null activeCategories) ^{rgSheetSubmittorCaption sid} $of RecipientGroup RGCourseUnacceptedApplicants _{MsgRGCourseUnacceptedApplicants} + $of RecipientGroup (RGFirmSupervisor fsh) + _{MsgFirmSupervisorOf fsh} + $of RecipientGroup (RGFirmEmployees fsh) + _{MsgFirmEmployeeOf fsh} + $of RecipientGroup (RGFirmIndependent) + _{MsgFirmSupervisorIndependent} $if hasContent category
          diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index a4d2ab2c4..9e1b9cea6 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -569,7 +569,7 @@ fillDb = do userDisplayEmail' = CI.mk $ case userSurname of "Walker" -> "AVSNO:" <> userMatrikelnummer' "Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de" - "Elizabeth" -> "" + "Jackson" -> "" _ -> userIdent matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) @@ -624,11 +624,12 @@ fillDb = do I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course. |] } - fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 False Nothing - fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 False Nothing -- TODO: better testcases - nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False Nothing - ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing - bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing + fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True (Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text)) (Just "fraport@fraport.de") + fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True (Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text)) Nothing + nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False (Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text)) (Just "badguy@nice.com") + ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing $ Just "gcs@gcs.com" + bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing + _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing void . insert' $ UserCompany jost fraportAg True True void . insert' $ UserCompany svaupel nice True False void . insert' $ UserCompany gkleen nice False False @@ -636,6 +637,11 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann nice False False + -- need more tests + insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers] + insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] + insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] + insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost sbarth False @@ -647,13 +653,17 @@ fillDb = do , UserSupervisor jost svaupel False , UserSupervisor jost sbarth False , UserSupervisor jost tinaTester True + , UserSupervisor jost jost True , UserSupervisor svaupel gkleen False , UserSupervisor svaupel fhamann True , UserSupervisor sbarth tinaTester True , UserSupervisor gkleen fhamann False + , UserSupervisor gkleen gkleen True + , UserSupervisor tinaTester tinaTester False ] - ++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ] - ++ take 111 [ UserSupervisor gkleen uid False | Entity uid _ <- drop 300 matUsers ] + ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] + ++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ] + ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ] upsertManyWhere supvs [] [] [] -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!