fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'fradrive/company'

Browse Source
This commit is contained in:
Steffen Jost 2023-11-17 17:55:35 +00:00
commit 975c9c6c00
53 changed files with 1820 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/authorization/de-de-formal.msg
View File

@ -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.

2
messages/uniworx/categories/authorization/en-eu.msg
View File

@ -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.

39
messages/uniworx/categories/firm/de-de-formal.msg Normal file
View File

@ -0,0 +1,39 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
#
# 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.

39
messages/uniworx/categories/firm/en-eu.msg Normal file
View File

@ -0,0 +1,39 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
#
# 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.

1
messages/uniworx/categories/jobs_handler/de-de-formal.msg
View File

@ -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.

1
messages/uniworx/categories/jobs_handler/en-eu.msg
View File

@ -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.

3
messages/uniworx/categories/settings/de-de-formal.msg
View File

@ -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.

3
messages/uniworx/categories/settings/en-eu.msg
View File

@ -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.

5
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -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

5
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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

19
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -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.
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.

19
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -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.
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.

4
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -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

4
messages/uniworx/utils/utils/en-eu.msg
View File

@ -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

3
models/company.model
View File

@ -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

1
package.yaml
View File

@ -259,6 +259,7 @@ ghc-options:
- -j
- -freduction-depth=0
- -fprof-auto-calls
- -g
when:
- condition: flag(pedantic)
ghc-options:

12
routes
View File

@ -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

1
src/Application.hs
View File

@ -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

29
src/Database/Esqueleto/Utils.hs
View File

@ -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"

17
src/Foundation/Authorization.hs
View File

@ -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

14
src/Foundation/I18n.hs
View File

@ -1,7 +1,12 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- 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"

41
src/Foundation/Navigation.hs
View File

@ -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

11
src/Handler/Admin/Avs.hs
View File

@ -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

4
src/Handler/Course/Communication.hs
View File

@ -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

1078
src/Handler/Firm.hs Normal file
View File

File diff suppressed because it is too large Load Diff

21
src/Handler/LMS.hs
View File

@ -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

2
src/Handler/Profile.hs
View File

@ -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)

14
src/Handler/Qualification.hs
View File

@ -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

5
src/Handler/Tutorial/Communication.hs
View File

@ -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

19
src/Handler/Users.hs
View File

@ -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)

217
src/Handler/Utils/Communication.hs
View File

@ -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

4
src/Handler/Utils/Company.hs
View File

@ -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)

15
src/Handler/Utils/Form.hs
View File

@ -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

14
src/Handler/Utils/Table/Cells.hs
View File

@ -29,6 +29,9 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
spacerCell :: IsDBTable m a => DBCell m a
spacerCell = cell [whamlet|&emsp;|]
semicolonCell :: IsDBTable m a => DBCell m a
semicolonCell = cell [whamlet|;&emsp;|]
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

43
src/Handler/Utils/Table/Columns.hs
View File

@ -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 --

23
src/Handler/Utils/Table/Pagination.hs
View File

@ -1,10 +1,20 @@
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

2
src/Jobs/Handler/LMS.hs
View File

@ -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)

31
src/Jobs/Handler/SendCourseCommunication.hs
View File

@ -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) $

12
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -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)

7
src/Jobs/Types.hs
View File

@ -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

2
src/Model/Migration/Definitions.hs
View File

@ -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

3
src/Model/Types/Common.hs
View File

@ -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

11
src/Utils.hs
View File

@ -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 = "<Space>"
@ -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 (.)
-----------

1
src/Utils/Form.hs
View File

@ -316,6 +316,7 @@ data FormIdentifier
| FIDBtnAvsImportUnknown
| FIDBtnAvsRevokeUnknown
| FIDHijackUser
| FIDAddSupervisor
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where

11
src/Utils/Icon.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

68
templates/firm-users.hamlet Normal file
View File

@ -0,0 +1,68 @@
$newline never
$# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section .profile>
<dl .deflist.profile-dl>
$maybe fem <- companyEmail
<dt .deflist__dt>
_{MsgFirmEmail} #{iconLetterOrEmail False}
<dd .deflist__dd .email>
#{mailtoHtml fem}
$maybe addr <- companyPostAddress
<dt .deflist__dt>
_{MsgFirmAddress} #{iconLetterOrEmail True}
<dd .deflist__dd>
#{addr}
<section>
<div .scrolltable .scrolltable--bordered>
<table .table>
<tr .table__row .table__row--head>
<th .table__th>_{MsgTableCompanyNrSupersDefault}
<th .table__th>_{MsgTableCompanyNrRerouteDefault}
<th .table__th colspan=2>_{MsgPrefersPostal}
<tr .table__row>
<td .table__td>#{nrCompanySupervisors}
<td .table__td>#{nrCompanyDefaultReroutes}
<td .table__td>#{iconLetterOrEmail companyPrefersPostal}
<td .table__td>_{MsgFirmDefaultPreferenceInfo}
<tr .table__row .table__row--head>
<th .table__th>_{MsgTableCompanyNrUsers}
<th .table__th colspan=3>_{MsgTableCompanyNrForeignSupers}
<tr .table__row>
<td .table__td>#{nrCompanyUsers}
<td .table__td>#{nrCompanyForeignSupers}
<td .table__td colspan=2>
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.
<tr .table__row .table__row--head>
<th .table__th>_{MsgTableCompanyNrEmpSupervised}
<th .table__th>_{MsgTableCompanyNrEmpRerouted}
<th .table__th>_{MsgTableCompanyNrEmpRerPost}
<th .table__th>_{MsgTableCompanyNrRerouteActive}
<tr .table__row>
<td .table__td>#{nrCompanyEmployeeSupervised}
<td .table__td>#{nrCompanyEmployeeRerouted}
<td .table__td>#{nrCompanyEmployeeRerPost}
<td .table__td>#{nrCompanyActiveReroutes}
<tr .table__row>
<td .table__td>
Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören!
<td .table__td>
Mindestens ein Ansprechpartner mit Umleitung.
<td .table__td>
Email oder Brief ist individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner.
<td .table__td>
Gesamtzahl aller aktiven Benachrichtigungsumleitungen. #
<em>
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.
<section>
<h2>
_{MsgFirmAssociates}
<p>
^{fusrTable}

15
templates/i18n/firm-all/de-de-formal.hamlet Normal file
View File

@ -0,0 +1,15 @@
$newline never
$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<p>
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.
<p>
^{firmTable}

16
templates/i18n/firm-all/en-eu.hamlet Normal file
View File

@ -0,0 +1,16 @@
$newline never
$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<p>
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.
<p>
^{firmTable}

27
templates/i18n/firm-supervisors/de-de-formal.hamlet Normal file
View File

@ -0,0 +1,27 @@
$newline never
$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen.
Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist
und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört,
dass dann <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird.
<section .profile>
<dl .deflist.profile-dl>
$maybe fem <- companyEmail
<dt .deflist__dt>
_{MsgFirmEmail} #{iconLetterOrEmail False}
<dd .deflist__dd .email>
#{mailtoHtml fem}
$maybe addr <- companyPostAddress
<dt .deflist__dt>
_{MsgFirmAddress} #{iconLetterOrEmail True}
<dd .deflist__dd>
#{addr}
<section>
^{fsprTable}
<section>
^{addSuperForm}

26
templates/i18n/firm-supervisors/en-eu.hamlet Normal file
View File

@ -0,0 +1,26 @@
$newline never
$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
Note that supervision is company independent.
For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>,
then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>.
<section .profile>
<dl .deflist.profile-dl>
$maybe fem <- companyEmail
<dt .deflist__dt>
_{MsgFirmEmail} #{iconLetterOrEmail False}
<dd .deflist__dd .email>
#{mailtoHtml fem}
$maybe addr <- companyPostAddress
<dt .deflist__dt>
_{MsgFirmAddress} #{iconLetterOrEmail True}
<dd .deflist__dd>
#{addr}
<section>
^{fsprTable}
<section>
^{addSuperForm}

2
templates/profileData.hamlet
View File

@ -49,7 +49,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dd .deflist__dd>
^{formatTimeW SelFormatDate bday}
<dt .deflist__dt>
_{MsgPrefersPostal}
_{MsgPrefersPostalExp}
<dd .deflist__dd>
#{iconLetterOrEmail userPrefersPostal}
$maybe addr <- userPostAddress

6
templates/widgets/communication/recipientLayout.hamlet
View File

@ -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
<fieldset .recipient-category__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{checkedIdent category}>

26
test/Database/Fill.hs
View File

@ -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!