Merge branch 'fradrive/company'
This commit is contained in:
commit
6aa06292b8
@ -9,29 +9,35 @@ FirmEmail: Allgemeine Email
|
|||||||
FirmAddress: Postanschrift
|
FirmAddress: Postanschrift
|
||||||
FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
|
FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
|
||||||
FirmAction: Firmenweite Aktion
|
FirmAction: Firmenweite Aktion
|
||||||
FirmActionInfo: Betrifft alle Firmenangehörigen.
|
FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
|
||||||
FirmActNotify: Mitteilung versenden
|
FirmActNotify: Mitteilung versenden
|
||||||
FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
|
FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
|
||||||
FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
|
FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
|
||||||
FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
|
FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
|
||||||
FirmActAddSupersvisors: Ansprechpartner hinzufügen
|
FirmActAddSupersvisors: Ansprechpartner hinzufügen
|
||||||
FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
|
FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
|
||||||
FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
|
FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
|
||||||
RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
|
RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
|
||||||
FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern
|
FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
|
||||||
FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
|
FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
|
||||||
FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
|
FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
|
||||||
FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen
|
FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen
|
||||||
FirmUserActNotify: Mitteilung versenden
|
FirmUserActNotify: Mitteilung versenden
|
||||||
FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
|
FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
|
||||||
|
FirmUserActSetSupervisor: Ansprechpartner ändern
|
||||||
|
FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
|
||||||
|
FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
|
||||||
|
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
|
||||||
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
||||||
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
|
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
|
||||||
FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
|
FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
|
||||||
FirmSuperActNotify: Mitteilung versenden
|
FirmSuperActNotify: Mitteilung versenden
|
||||||
FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen
|
FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
|
||||||
|
FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
|
||||||
|
FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
|
||||||
FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
|
FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
|
||||||
FirmsNotification: Firmen Benachrichtigung versenden
|
FirmsNotification: Firmen E-Mail versenden
|
||||||
FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden
|
FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
|
||||||
FirmsNotificationTitle: Firmen benachrichtigen
|
FirmsNotificationTitle: Firmen benachrichtigen
|
||||||
FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen
|
FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen
|
||||||
FilterSupervisor: Hat aktiven Ansprechpartner
|
FilterSupervisor: Hat aktiven Ansprechpartner
|
||||||
@ -48,3 +54,4 @@ TableIsDefaultReroute: Standardumleitung
|
|||||||
FormFieldPostal: Benachrichtigungseinstellung
|
FormFieldPostal: Benachrichtigungseinstellung
|
||||||
FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
|
FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
|
||||||
FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
|
FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
|
||||||
|
FirmSupervisionKeyData: Kennzahlen Ansprechpartner
|
||||||
@ -9,29 +9,35 @@ FirmEmail: General company email
|
|||||||
FirmAddress: Postal address
|
FirmAddress: Postal address
|
||||||
FirmDefaultPreferenceInfo: Default setting for new company associates only
|
FirmDefaultPreferenceInfo: Default setting for new company associates only
|
||||||
FirmAction: Companywide action
|
FirmAction: Companywide action
|
||||||
FirmActionInfo: Affects alle company associates.
|
FirmActionInfo: Affects alle company associates under your supervision.
|
||||||
FirmActNotify: Send message
|
FirmActNotify: Send message
|
||||||
FirmActResetSupervision: Reset supervisors for all company associates
|
FirmActResetSupervision: Reset supervisors for all company associates
|
||||||
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
|
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
|
||||||
FirmActResetMutualSupervision: Supervisors supervise each other
|
FirmActResetMutualSupervision: Supervisors supervise each other
|
||||||
FirmActAddSupersvisors: Add supervisors
|
FirmActAddSupersvisors: Add supervisors
|
||||||
FirmActAddSupersEmpty: No supervisors added
|
FirmActAddSupersEmpty: No supervisors added
|
||||||
FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
|
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
|
||||||
RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)}
|
RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
|
||||||
FirmActChangeContactUser: Change contact data for company associates
|
FirmActChangeContactUser: Change contact data for all company associates
|
||||||
FirmActChangeContactFirm: Change company contact data
|
FirmActChangeContactFirm: Change company contact data
|
||||||
FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
|
FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
|
||||||
FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only
|
FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only
|
||||||
FirmUserActNotify: Send message
|
FirmUserActNotify: Send message
|
||||||
FirmUserActResetSupervision: Reset supervisors to company default
|
FirmUserActResetSupervision: Reset supervisors to company default
|
||||||
|
FirmUserActSetSupervisor: Change supervision
|
||||||
|
FirmNewSupervisor: Appoint new individual supervisors
|
||||||
|
FirmSetSupervisor: Add existing supervisors
|
||||||
|
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
|
||||||
FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
|
FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
|
||||||
FirmUserActChangeContact: Change contact data for selected company associates
|
FirmUserActChangeContact: Change contact data for selected company associates
|
||||||
FirmUserActMkSuper: Mark as company supervisor
|
FirmUserActMkSuper: Mark as company supervisor
|
||||||
FirmSuperActNotify: Send message
|
FirmSuperActNotify: Send message
|
||||||
FirmSuperActRMSuperDef: Remove as default supervisor
|
FirmSuperActSwitchSuper: Change default company supervisor
|
||||||
|
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired.
|
||||||
|
FirmSuperActRMSuperDef: Remove default supervisor
|
||||||
FirmSuperActRMSuperActive: Also remove active supervisions within this company
|
FirmSuperActRMSuperActive: Also remove active supervisions within this company
|
||||||
FirmsNotification: Send company notification
|
FirmsNotification: Send company notification e-mail
|
||||||
FirmNotification fsh: Send notification to company #{fsh}
|
FirmNotification fsh: Send e-mail to #{fsh}
|
||||||
FirmsNotificationTitle: Company notification
|
FirmsNotificationTitle: Company notification
|
||||||
FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification
|
FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification
|
||||||
FilterSupervisor: Has active supervisor
|
FilterSupervisor: Has active supervisor
|
||||||
@ -48,3 +54,4 @@ TableIsDefaultReroute: Default reroute
|
|||||||
FormFieldPostal: Notification type
|
FormFieldPostal: Notification type
|
||||||
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
|
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
|
||||||
FirmUserChanges n: Notification settings changed for #{n} company associates
|
FirmUserChanges n: Notification settings changed for #{n} company associates
|
||||||
|
FirmSupervisionKeyData: Supervision key data
|
||||||
@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen E
|
|||||||
MailSupervisedNote: Hinweis
|
MailSupervisedNote: Hinweis
|
||||||
MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:
|
MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:
|
||||||
MailSupervisorReroute: Benachrichtigungsumleitung
|
MailSupervisorReroute: Benachrichtigungsumleitung
|
||||||
MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt
|
MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt
|
||||||
@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warning: This message was not sent to the original recipie
|
|||||||
MailSupervisedNote: Please note
|
MailSupervisedNote: Please note
|
||||||
MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:
|
MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:
|
||||||
MailSupervisorReroute: Reroute notifications
|
MailSupervisorReroute: Reroute notifications
|
||||||
MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead
|
MailSupervisorRerouteTooltip: All notification will be rerouted to these supervisors instead
|
||||||
@ -10,6 +10,7 @@ BoolIrrelevant !ident-ok: —
|
|||||||
FieldPrimary: Hauptfach
|
FieldPrimary: Hauptfach
|
||||||
FieldSecondary: Nebenfach
|
FieldSecondary: Nebenfach
|
||||||
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
|
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
|
||||||
|
MultiSelectTip: Mehrfachauswahl mit Strg-Klick
|
||||||
WeekDay: Wochentag
|
WeekDay: Wochentag
|
||||||
LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
|
LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
|
||||||
Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
|
Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
|
||||||
|
|||||||
@ -10,6 +10,7 @@ BoolIrrelevant: —
|
|||||||
FieldPrimary: Major
|
FieldPrimary: Major
|
||||||
FieldSecondary: Minor
|
FieldSecondary: Minor
|
||||||
MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
|
MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
|
||||||
|
MultiSelectTip: Multiple selection via Ctrl-Click
|
||||||
WeekDay: Day of the week
|
WeekDay: Day of the week
|
||||||
LdapIdentificationOrEmail: Fraport AG-Kennung / email address
|
LdapIdentificationOrEmail: Fraport AG-Kennung / email address
|
||||||
Months num: #{num} #{pluralEN num "Month" "Months"}
|
Months num: #{num} #{pluralEN num "Month" "Months"}
|
||||||
|
|||||||
@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder !ident-ok: URL
|
|||||||
RoomReferenceLinkInstructions: Anweisungen
|
RoomReferenceLinkInstructions: Anweisungen
|
||||||
RoomReferenceLinkInstructionsPlaceholder: Anweisungen
|
RoomReferenceLinkInstructionsPlaceholder: Anweisungen
|
||||||
UtilEmptyChoice: Auswahl war leer
|
UtilEmptyChoice: Auswahl war leer
|
||||||
|
UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
|
||||||
|
|
||||||
#invitation.hs
|
#invitation.hs
|
||||||
InvitationAction: Aktion
|
InvitationAction: Aktion
|
||||||
|
|||||||
@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder: URL
|
|||||||
RoomReferenceLinkInstructions: Instructions
|
RoomReferenceLinkInstructions: Instructions
|
||||||
RoomReferenceLinkInstructionsPlaceholder: Instructions
|
RoomReferenceLinkInstructionsPlaceholder: Instructions
|
||||||
UtilEmptyChoice: Empty selection
|
UtilEmptyChoice: Empty selection
|
||||||
|
UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
|
||||||
|
|
||||||
#invitation.hs
|
#invitation.hs
|
||||||
InvitationAction: Action
|
InvitationAction: Action
|
||||||
|
|||||||
@ -2,7 +2,7 @@
|
|||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
-- The files in /models determine the database scheme.
|
-- The files in /models determine t he database scheme.
|
||||||
-- The organisational split into several files has no operational effects.
|
-- The organisational split into several files has no operational effects.
|
||||||
-- White-space and case matters: Each SQL table is named in 1st column of this file
|
-- White-space and case matters: Each SQL table is named in 1st column of this file
|
||||||
-- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
|
-- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
|
||||||
|
|||||||
7
routes
7
routes
@ -113,12 +113,11 @@
|
|||||||
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
||||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
||||||
|
|
||||||
/firms FirmAllR GET POST !supervisor
|
/firms FirmAllR GET POST -- not yet !supervisor
|
||||||
/firms/comm/+Companies FirmsCommR GET POST
|
/firms/comm/+Companies FirmsCommR GET POST
|
||||||
/firm/#CompanyShorthand/debug FirmR GET POST
|
|
||||||
/firm/#CompanyShorthand/comm FirmCommR GET POST
|
/firm/#CompanyShorthand/comm FirmCommR GET POST
|
||||||
/firm/#CompanyShorthand FirmUsersR GET POST !supervisor
|
/firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor
|
||||||
/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor
|
/firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor
|
||||||
|
|
||||||
/exam-office ExamOfficeR !exam-office:
|
/exam-office ExamOfficeR !exam-office:
|
||||||
/ EOExamsR GET POST !system-exam-office
|
/ EOExamsR GET POST !system-exam-office
|
||||||
|
|||||||
@ -554,7 +554,8 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
|
|||||||
return Authorized
|
return Authorized
|
||||||
checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do
|
checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do
|
||||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||||
isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh
|
-- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh
|
||||||
|
isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True]
|
||||||
guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh)
|
guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh)
|
||||||
return Authorized
|
return Authorized
|
||||||
checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do
|
checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do
|
||||||
|
|||||||
@ -43,6 +43,8 @@ module Foundation.I18n
|
|||||||
, UniWorXMessages(..)
|
, UniWorXMessages(..)
|
||||||
, uniworxMessages
|
, uniworxMessages
|
||||||
, unRenderMessage, unRenderMessage', unRenderMessageLenient
|
, unRenderMessage, unRenderMessage', unRenderMessageLenient
|
||||||
|
, SomeMessages(..)
|
||||||
|
, someMessages
|
||||||
, module Foundation.I18n.TH
|
, module Foundation.I18n.TH
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -266,6 +268,18 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma
|
|||||||
|
|
||||||
embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
|
embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
|
||||||
|
|
||||||
|
|
||||||
|
newtype SomeMessages master = SomeMessages [SomeMessage master]
|
||||||
|
deriving newtype (Semigroup, Monoid)
|
||||||
|
|
||||||
|
instance master ~ master' => RenderMessage master (SomeMessages master') where
|
||||||
|
renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs
|
||||||
|
|
||||||
|
-- | convenienience function if all messages happen to belong to the exact same type
|
||||||
|
someMessages :: RenderMessage master msg => [msg] -> SomeMessages master
|
||||||
|
someMessages msgs = SomeMessages $ SomeMessage <$> msgs
|
||||||
|
|
||||||
|
|
||||||
instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite
|
instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite
|
||||||
renderMessage f ls (Just s) = renderMessage f ls s
|
renderMessage f ls (Just s) = renderMessage f ls s
|
||||||
renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen
|
renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen
|
||||||
|
|||||||
@ -125,7 +125,6 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just
|
|||||||
|
|
||||||
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
|
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
|
||||||
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
|
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
|
||||||
breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove
|
|
||||||
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
|
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
|
||||||
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
|
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
|
||||||
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
|
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
|
||||||
@ -2417,16 +2416,6 @@ pageActions ApiDocsR = return
|
|||||||
, navChildren = []
|
, navChildren = []
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
pageActions (FirmR fsh) = return
|
|
||||||
[ NavPageActionPrimary
|
|
||||||
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
|
||||||
, navChildren = []
|
|
||||||
}
|
|
||||||
, NavPageActionPrimary
|
|
||||||
{ navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh
|
|
||||||
, navChildren = []
|
|
||||||
}
|
|
||||||
]
|
|
||||||
pageActions (FirmUsersR fsh) = return
|
pageActions (FirmUsersR fsh) = return
|
||||||
[ NavPageActionPrimary
|
[ NavPageActionPrimary
|
||||||
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
||||||
|
|||||||
@ -548,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|||||||
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
|
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
|
||||||
-- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal
|
-- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal
|
||||||
, colUserNameLink AdminUserR
|
, colUserNameLink AdminUserR
|
||||||
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
|
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
|
||||||
-- , colUserCompany
|
-- , colUserCompany
|
||||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||||
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
@ -558,7 +558,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|||||||
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||||
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
||||||
companies =
|
companies =
|
||||||
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||||
|
|
||||||
pure $ intercalate (text2widget "; ") companies
|
pure $ intercalate (text2widget "; ") companies
|
||||||
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
||||||
@ -752,7 +752,7 @@ getProblemAvsErrorR = do
|
|||||||
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
|
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
|
||||||
dbtProj = dbtProjId
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ colUserNameModalHdr MsgLmsUser AdminUserR
|
[ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
|
||||||
, sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo)
|
, sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo)
|
||||||
$ avsPersonNoLinkedCell . view reserrUsrAvs
|
$ avsPersonNoLinkedCell . view reserrUsrAvs
|
||||||
, sortable Nothing (i18nCell MsgAvsPersonId)
|
, sortable Nothing (i18nCell MsgAvsPersonId)
|
||||||
|
|||||||
@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do
|
|||||||
, pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
, pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||||
, guardOn showSex . cap' $ colUserSex'
|
, guardOn showSex . cap' $ colUserSex'
|
||||||
, pure . cap' $ colUserEmail
|
, pure . cap' $ colUserEmail
|
||||||
, pure . cap' $ colUserMatriclenr
|
, pure . cap' $ colUserMatriclenr False
|
||||||
, pure . cap' $ colUserQualifications nowaday
|
, pure . cap' $ colUserQualifications nowaday
|
||||||
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
|
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
|
||||||
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
|
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
|
||||||
|
|||||||
@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
dbtColonnade = mconcat $ catMaybes
|
dbtColonnade = mconcat $ catMaybes
|
||||||
[ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
|
[ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
|
||||||
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||||
, pure colUserMatriclenr
|
, pure $ colUserMatriclenr False
|
||||||
, pure $ colStudyFeatures resultStudyFeatures
|
, pure $ colStudyFeatures resultStudyFeatures
|
||||||
, pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
|
, pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
|
||||||
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
|
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
|
||||||
|
|||||||
@ -8,7 +8,6 @@
|
|||||||
|
|
||||||
module Handler.Firm
|
module Handler.Firm
|
||||||
( getFirmAllR , postFirmAllR
|
( getFirmAllR , postFirmAllR
|
||||||
, getFirmR , postFirmR
|
|
||||||
, getFirmUsersR , postFirmUsersR
|
, getFirmUsersR , postFirmUsersR
|
||||||
, getFirmSupersR, postFirmSupersR
|
, getFirmSupersR, postFirmSupersR
|
||||||
, getFirmCommR , postFirmCommR
|
, getFirmCommR , postFirmCommR
|
||||||
@ -98,13 +97,13 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
|
|||||||
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True)
|
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True)
|
||||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||||
mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
|
mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
|
||||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
|
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||||
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing
|
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
|
||||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||||
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
|
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
|
||||||
mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
|
mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
|
||||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
|
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||||
mkAct _ _ = mempty
|
mkAct _ _ = mempty
|
||||||
|
|
||||||
firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
|
firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
|
||||||
@ -113,23 +112,10 @@ firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (f
|
|||||||
makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
|
makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
|
||||||
makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts
|
makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts
|
||||||
|
|
||||||
firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
|
firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
|
||||||
firmActionHandler route = flip formResult faHandler
|
firmActionHandler route isAdmin = flip formResult faHandler
|
||||||
where
|
where
|
||||||
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
|
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
|
||||||
faHandler (FirmActResetSupervisionData{..}, fids) = do
|
|
||||||
runDB $ do
|
|
||||||
delSupers <- if firmActResetKeepOldSupers == Just False
|
|
||||||
then E.deleteCount $ do
|
|
||||||
spr <- E.from $ E.table @UserSupervisor
|
|
||||||
E.where_ $ E.exists $ do
|
|
||||||
usr <- E.from $ E.table @UserCompany
|
|
||||||
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
|
||||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
|
||||||
else return 0
|
|
||||||
newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids
|
|
||||||
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
|
|
||||||
reloadKeepGetParams route -- reload to reflect changes
|
|
||||||
|
|
||||||
faHandler (FirmActNotifyData, Set.toList -> fids) = do
|
faHandler (FirmActNotifyData, Set.toList -> fids) = do
|
||||||
usrs <- runDB $ E.select $ E.distinct $ do
|
usrs <- runDB $ E.select $ E.distinct $ do
|
||||||
@ -139,6 +125,26 @@ firmActionHandler route = flip formResult faHandler
|
|||||||
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
|
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
|
||||||
redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||||
|
|
||||||
|
faHandler (FirmActResetSupervisionData{..}, fids) = do
|
||||||
|
madId <- bool maybeAuthId (return Nothing) isAdmin
|
||||||
|
let suprFltr = if
|
||||||
|
| isAdmin -> const E.true
|
||||||
|
| (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId
|
||||||
|
| otherwise -> const E.false
|
||||||
|
runDB $ do
|
||||||
|
delSupers <- if firmActResetKeepOldSupers == Just False
|
||||||
|
then E.deleteCount $ do
|
||||||
|
spr <- E.from $ E.table @UserSupervisor
|
||||||
|
E.where_ $ suprFltr spr E.&&. E.exists (do
|
||||||
|
usr <- E.from $ E.table @UserCompany
|
||||||
|
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
||||||
|
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||||
|
)
|
||||||
|
else return 0
|
||||||
|
newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
|
||||||
|
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
|
||||||
|
reloadKeepGetParams route -- reload to reflect changes
|
||||||
|
|
||||||
faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
|
faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
|
||||||
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
|
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
|
||||||
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
||||||
@ -204,7 +210,7 @@ runFirmActionFormPost cid route isAdmin acts = do
|
|||||||
, formSubmit = FormSubmit
|
, formSubmit = FormSubmit
|
||||||
, formAnchor = Just faAnchor
|
, formAnchor = Just faAnchor
|
||||||
}
|
}
|
||||||
firmActionHandler route faRes
|
firmActionHandler route isAdmin faRes
|
||||||
return [whamlet|
|
return [whamlet|
|
||||||
<section>
|
<section>
|
||||||
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
||||||
@ -249,6 +255,30 @@ addDefaultSupervisors cid employees = do
|
|||||||
)
|
)
|
||||||
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
|
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
|
||||||
|
|
||||||
|
-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||||
|
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
|
||||||
|
addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
|
||||||
|
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||||
|
(do
|
||||||
|
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||||
|
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||||
|
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||||
|
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||||
|
superv <- E.from $ E.table @UserSupervisor
|
||||||
|
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||||
|
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||||
|
])
|
||||||
|
<> [ spr E.^. UserCompanySupervisor
|
||||||
|
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||||
|
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||||
|
]
|
||||||
|
return $ UserSupervisor
|
||||||
|
E.<# (spr E.^. UserCompanyUser)
|
||||||
|
E.<&> (usr E.^. UserCompanyUser)
|
||||||
|
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||||
|
)
|
||||||
|
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
|
||||||
|
|
||||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
|
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
|
||||||
addDefaultSupervisorsAll mutualSupervision cids = do
|
addDefaultSupervisorsAll mutualSupervision cids = do
|
||||||
@ -384,65 +414,6 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
|
|||||||
E.&&. usrSpr E.^. UserSupervisorRerouteNotifications
|
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|
|
|
||||||
<h2>PROVISORISCHE DEBUG SEITE
|
|
||||||
<p>Diese Seite wird in der finalen Version nicht mehr enthalten sein.
|
|
||||||
|
|
||||||
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
|
|
||||||
<ul>
|
|
||||||
$forall u <- csuper
|
|
||||||
<li>^{linkUserWidget ForProfileDataR u}
|
|
||||||
|
|
||||||
<h3>#{length cactSuper} Active Supervisors for Employees
|
|
||||||
<ul>
|
|
||||||
$forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper
|
|
||||||
<li>#{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
|
|
||||||
|
|
||||||
<h3>#{length cusers} Employees
|
|
||||||
<ul>
|
|
||||||
$forall u <- cusers
|
|
||||||
<li>^{linkUserWidget ForProfileDataR u}
|
|
||||||
|
|
||||||
In the end, this needs to be a dbTable, of course!
|
|
||||||
|]
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------
|
-----------------------
|
||||||
-- All Firms Table
|
-- All Firms Table
|
||||||
|
|
||||||
@ -499,14 +470,13 @@ mkFirmAllTable isAdmin uid = do
|
|||||||
dbtRowKey = (E.^. CompanyId)
|
dbtRowKey = (E.^. CompanyId)
|
||||||
dbtProj = dbtProjId
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = formColonnade $ mconcat
|
dbtColonnade = formColonnade $ mconcat
|
||||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
|
[ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
|
||||||
, sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
|
, sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
|
||||||
anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm
|
anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm
|
||||||
, sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
|
, sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
|
||||||
let fsh = companyShorthand firm
|
let fsh = companyShorthand firm
|
||||||
in anchorCell (FirmUsersR fsh) $ toWgt fsh
|
in anchorCell (FirmSupersR fsh) $ toWgt fsh
|
||||||
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
|
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm
|
||||||
anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
|
|
||||||
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
|
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
|
||||||
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row ->
|
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row ->
|
||||||
anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
|
anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
|
||||||
@ -621,7 +591,7 @@ postFirmAllR = do
|
|||||||
uid <- requireAuthId
|
uid <- requireAuthId
|
||||||
isAdmin <- checkAdmin
|
isAdmin <- checkAdmin
|
||||||
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
|
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
|
||||||
firmActionHandler FirmAllR firmRes
|
firmActionHandler FirmAllR isAdmin firmRes
|
||||||
siteLayoutMsg MsgMenuFirms $ do
|
siteLayoutMsg MsgMenuFirms $ do
|
||||||
setTitleI MsgMenuFirms
|
setTitleI MsgMenuFirms
|
||||||
$(i18nWidgetFile "firm-all")
|
$(i18nWidgetFile "firm-all")
|
||||||
@ -633,6 +603,7 @@ postFirmAllR = do
|
|||||||
|
|
||||||
data FirmUserAction = FirmUserActNotify
|
data FirmUserAction = FirmUserActNotify
|
||||||
| FirmUserActResetSupervision
|
| FirmUserActResetSupervision
|
||||||
|
| FirmUserActSetSupervisor
|
||||||
| FirmUserActMkSuper
|
| FirmUserActMkSuper
|
||||||
| FirmUserActChangeContact
|
| FirmUserActChangeContact
|
||||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||||
@ -646,6 +617,12 @@ data FirmUserActionData = FirmUserActNotifyData
|
|||||||
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
||||||
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
||||||
}
|
}
|
||||||
|
| FirmUserActSetSupervisorData
|
||||||
|
{ firmUserActSetSuperNames :: Set Text
|
||||||
|
, firmUserActSetSuperIds :: [UserId]
|
||||||
|
, firmUserActSetSuperReroute :: Bool
|
||||||
|
, firmUserActSetSuperKeep :: Bool
|
||||||
|
}
|
||||||
| FirmUserActMkSuperData
|
| FirmUserActMkSuperData
|
||||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||||
| FirmUserActChangeContactData
|
| FirmUserActChangeContactData
|
||||||
@ -697,7 +674,7 @@ mkFirmUserTable isAdmin cid = do
|
|||||||
return (usr E.^. UserId, usr E.^. UserDisplayName)
|
return (usr E.^. UserId, usr E.^. UserDisplayName)
|
||||||
let
|
let
|
||||||
-- supervisorField :: Field Handler UserId
|
-- supervisorField :: Field Handler UserId
|
||||||
supervisorField = selectField $ procOptions rawSupers
|
-- supervisorField = selectField $ procOptions rawSupers
|
||||||
supervisorsField = multiSelectField $ procOptions rawSupers
|
supervisorsField = multiSelectField $ procOptions rawSupers
|
||||||
|
|
||||||
fsh = unCompanyKey cid
|
fsh = unCompanyKey cid
|
||||||
@ -710,9 +687,9 @@ mkFirmUserTable isAdmin cid = do
|
|||||||
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
||||||
dbtProj = dbtProjId
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = formColonnade $ mconcat
|
dbtColonnade = formColonnade $ mconcat
|
||||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
[ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
||||||
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
|
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
|
||||||
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
|
, guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr
|
||||||
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
, 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 "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
|
||||||
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||||
@ -787,8 +764,8 @@ mkFirmUserTable isAdmin cid = do
|
|||||||
-- superField = selectField $ ????
|
-- superField = selectField $ ????
|
||||||
dbtFilterUI mPrev = mconcat
|
dbtFilterUI mPrev = mconcat
|
||||||
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
||||||
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
-- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
||||||
, prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
|
, prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip )
|
||||||
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (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-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)
|
, prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
|
||||||
@ -796,15 +773,20 @@ mkFirmUserTable isAdmin cid = do
|
|||||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
|
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
|
||||||
acts = mconcat
|
acts = mconcat
|
||||||
[ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
[ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
||||||
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
|
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
|
||||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||||
-- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
-- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||||
|
, singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
|
||||||
|
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||||
|
<*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing
|
||||||
|
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||||
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
|
||||||
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
||||||
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
||||||
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
|
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
|
||||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
|
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||||
]
|
]
|
||||||
dbtParams = DBParamsForm
|
dbtParams = DBParamsForm
|
||||||
{ dbParamsFormMethod = POST
|
{ dbParamsFormMethod = POST
|
||||||
@ -873,10 +855,6 @@ postFirmUsersR fsh = do
|
|||||||
|
|
||||||
formResult fusrRes $ \case
|
formResult fusrRes $ \case
|
||||||
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
(_, 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 $ MsgFirmActAddSupersSet nrMkSuper Nothing
|
|
||||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
||||||
(FirmUserActNotifyData , uids) -> do
|
(FirmUserActNotifyData , uids) -> do
|
||||||
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
||||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||||
@ -888,6 +866,31 @@ postFirmUsersR fsh = do
|
|||||||
newSupers <- addDefaultSupervisors cid uids
|
newSupers <- addDefaultSupervisors cid uids
|
||||||
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
||||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||||
|
(FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
|
||||||
|
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames
|
||||||
|
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
||||||
|
usersFound = mapMaybe snd usersFound'
|
||||||
|
newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound
|
||||||
|
nrSupers = fromIntegral $ length newSupers
|
||||||
|
nrUsers = fromIntegral $ length uids
|
||||||
|
unless (null usersNotFound) $
|
||||||
|
let msgContent = [whamlet|
|
||||||
|
$newline never
|
||||||
|
<ul>
|
||||||
|
$forall (usr,_) <- usersNotFound
|
||||||
|
<li>#{usr}
|
||||||
|
|]
|
||||||
|
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
||||||
|
delSupers <- runDB
|
||||||
|
$ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep
|
||||||
|
<* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers]
|
||||||
|
addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
|
||||||
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||||
|
|
||||||
|
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
|
||||||
|
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
||||||
|
addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
|
||||||
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||||
(FirmUserActChangeContactData{..}, Set.toList -> uids) ->
|
(FirmUserActChangeContactData{..}, Set.toList -> uids) ->
|
||||||
let changes = catMaybes
|
let changes = catMaybes
|
||||||
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
||||||
@ -910,6 +913,7 @@ postFirmUsersR fsh = do
|
|||||||
-- Firm Supervisors Table
|
-- Firm Supervisors Table
|
||||||
|
|
||||||
data FirmSuperAction = FirmSuperActNotify
|
data FirmSuperAction = FirmSuperActNotify
|
||||||
|
| FirmSuperActSwitchSuper
|
||||||
| FirmSuperActRMSuperDef
|
| FirmSuperActRMSuperDef
|
||||||
|
|
||||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||||
@ -919,6 +923,10 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3
|
|||||||
embedRenderMessage ''UniWorX ''FirmSuperAction id
|
embedRenderMessage ''UniWorX ''FirmSuperAction id
|
||||||
|
|
||||||
data FirmSuperActionData = FirmSuperActNotifyData
|
data FirmSuperActionData = FirmSuperActNotifyData
|
||||||
|
| FirmSuperActSwitchSuperData
|
||||||
|
{ firmSuperActSwitchSuper :: Maybe Bool
|
||||||
|
, firmSuperActSwitchReroute :: Maybe Bool
|
||||||
|
}
|
||||||
| FirmSuperActRMSuperDefData
|
| FirmSuperActRMSuperDefData
|
||||||
{ firmSuperActRMSuperActive :: Maybe Bool }
|
{ firmSuperActRMSuperActive :: Maybe Bool }
|
||||||
|
|
||||||
@ -965,6 +973,7 @@ instance HasUser SuperCompanyTableData where
|
|||||||
|
|
||||||
mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
|
mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
|
||||||
mkFirmSuperTable isAdmin cid = do
|
mkFirmSuperTable isAdmin cid = do
|
||||||
|
msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
|
||||||
let
|
let
|
||||||
-- fsh = unCompanyKey cid
|
-- fsh = unCompanyKey cid
|
||||||
resultDBTable = DBTable{..}
|
resultDBTable = DBTable{..}
|
||||||
@ -988,9 +997,9 @@ mkFirmSuperTable isAdmin cid = do
|
|||||||
return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
|
return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
|
||||||
return (usr, supervised, rerouted, cmps, supervisor, reroute)
|
return (usr, supervised, rerouted, cmps, supervisor, reroute)
|
||||||
dbtColonnade = formColonnade $ mconcat
|
dbtColonnade = formColonnade $ mconcat
|
||||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
|
[ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
|
||||||
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
|
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
|
||||||
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr
|
, guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr
|
||||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) ->
|
, 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]
|
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 "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
||||||
@ -1028,7 +1037,11 @@ mkFirmSuperTable isAdmin cid = do
|
|||||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
|
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
|
||||||
acts = mconcat
|
acts = mconcat
|
||||||
[ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
[ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
||||||
|
, singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
|
||||||
|
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True)
|
||||||
|
<*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) (Nothing)
|
||||||
|
<* aformMessage msgSupervisorUnchanged
|
||||||
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
||||||
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
||||||
]
|
]
|
||||||
@ -1088,7 +1101,18 @@ postFirmSupersR fsh = do
|
|||||||
)
|
)
|
||||||
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
||||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||||
|
(FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
|
||||||
|
let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
|
||||||
|
(Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ])
|
||||||
|
(Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer]
|
||||||
|
, [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ])
|
||||||
|
(Just False, _) -> ([UserCompanySupervisor ==. True ], [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False])
|
||||||
|
(Nothing, Just True) -> ([UserCompanySupervisor ==. True, UserCompanySupervisorReroute ==. False], [UserCompanySupervisorReroute =. True ])
|
||||||
|
(Nothing, Just False) -> ([ UserCompanySupervisorReroute ==. True ], [UserCompanySupervisorReroute =. False])
|
||||||
|
(Nothing, Nothing ) -> ([],[])
|
||||||
|
nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes
|
||||||
|
addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing
|
||||||
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||||
(FirmSuperActNotifyData , uids) -> do
|
(FirmSuperActNotifyData , uids) -> do
|
||||||
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
||||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||||
|
|||||||
@ -633,7 +633,7 @@ postLmsR sid qsh = do
|
|||||||
]
|
]
|
||||||
colChoices cmpMap = mconcat
|
colChoices cmpMap = mconcat
|
||||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
||||||
, colUserNameModalHdr MsgLmsUser AdminUserR
|
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
|
||||||
, colUserEmail
|
, colUserEmail
|
||||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
||||||
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||||
@ -641,7 +641,7 @@ postLmsR sid qsh = do
|
|||||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||||
]
|
]
|
||||||
in intercalate spacerCell cs
|
in intercalate spacerCell cs
|
||||||
, colUserMatriclenr
|
, colUserMatriclenr isAdmin
|
||||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||||
|
|||||||
@ -591,7 +591,7 @@ postQualificationR sid qsh = do
|
|||||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||||
]
|
]
|
||||||
in intercalate spacerCell cs
|
in intercalate spacerCell cs
|
||||||
, guardMonoid isAdmin colUserMatriclenr
|
, guardMonoid isAdmin $ colUserMatriclenr isAdmin
|
||||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||||
|
|||||||
@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do
|
|||||||
colChoices = mconcat $ catMaybes
|
colChoices = mconcat $ catMaybes
|
||||||
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||||
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
||||||
, pure colUserEmail
|
, pure colUserEmail
|
||||||
, pure colUserMatriclenr
|
, pure $ colUserMatriclenr isAdmin
|
||||||
, pure $ colUserQualifications nowaday
|
, pure $ colUserQualifications nowaday
|
||||||
, pure $ colUserQualificationBlocked isAdmin nowaday
|
, pure $ colUserQualificationBlocked isAdmin nowaday
|
||||||
]
|
]
|
||||||
|
|||||||
@ -100,7 +100,7 @@ postUsersR = do
|
|||||||
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||||
(AdminUserR <$> encrypt uid)
|
(AdminUserR <$> encrypt uid)
|
||||||
(nameWidget userDisplayName userSurname)
|
(nameWidget userDisplayName userSurname)
|
||||||
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
|
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
|
||||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||||
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
@ -109,7 +109,7 @@ postUsersR = do
|
|||||||
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||||
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
||||||
companies =
|
companies =
|
||||||
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||||
pure $ intercalate (text2widget "; ") companies
|
pure $ intercalate (text2widget "; ") companies
|
||||||
-- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
-- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||||
-- (AdminUserR <$> encrypt uid)
|
-- (AdminUserR <$> encrypt uid)
|
||||||
|
|||||||
@ -15,6 +15,7 @@ module Handler.Utils.Communication
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
import Handler.Utils.Users
|
||||||
|
|
||||||
import Jobs.Queue
|
import Jobs.Queue
|
||||||
|
|
||||||
@ -95,35 +96,40 @@ makeLenses_ ''Communication
|
|||||||
crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||||
crJobsCourseCommunication jCourse Communication{..} = do
|
crJobsCourseCommunication jCourse Communication{..} = do
|
||||||
jSender <- requireAuthId
|
jSender <- requireAuthId
|
||||||
let jMailContent = cContent
|
|
||||||
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
|
|
||||||
jMailObjectUUID <- liftIO getRandom
|
jMailObjectUUID <- liftIO getRandom
|
||||||
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
|
let jMailContent = cContent
|
||||||
Left email -> return . Address Nothing $ CI.original email
|
(rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients
|
||||||
Right rid -> userAddress <$> getJust rid
|
adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
|
||||||
forM_ allRecipients $ \jRecipientEmail ->
|
netReceiverAddresses <- lift $ do
|
||||||
yield JobSendCourseCommunication{..}
|
netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
|
||||||
|
(userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
|
||||||
|
-- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
|
||||||
|
let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
|
||||||
|
forM_ jAllRecipientAddresses $ \raddr ->
|
||||||
|
yield JobSendCourseCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email
|
||||||
|
|
||||||
crTestJobsCourseCommunication jCourse comm = do
|
crTestJobsCourseCommunication jCourse comm = do
|
||||||
jSender <- requireAuthId
|
jSender <- requireAuthId
|
||||||
|
|
||||||
MsgRenderer mr <- getMsgRenderer
|
MsgRenderer mr <- getMsgRenderer
|
||||||
let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject)
|
let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject)
|
||||||
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
|
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
|
||||||
|
|
||||||
|
|
||||||
crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
crJobsFirmCommunication, crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||||
crJobsFirmCommunication jCompanies Communication{..} = do
|
crJobsFirmCommunication jCompanies Communication{..} = do
|
||||||
jSender <- requireAuthId
|
jSender <- requireAuthId
|
||||||
let jMailContent = cContent
|
|
||||||
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
|
|
||||||
jMailObjectUUID <- liftIO getRandom
|
jMailObjectUUID <- liftIO getRandom
|
||||||
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
|
let jMailContent = cContent
|
||||||
Left email -> return . Address Nothing $ CI.original email
|
(rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients
|
||||||
Right rid -> userAddress <$> getJust rid
|
adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
|
||||||
forM_ allRecipients $ \jRecipientEmail ->
|
netReceiverAddresses <- lift $ do
|
||||||
yield JobSendFirmCommunication{..}
|
netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
|
||||||
|
(userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
|
||||||
|
-- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
|
||||||
|
let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
|
||||||
|
forM_ jAllRecipientAddresses $ \raddr ->
|
||||||
|
yield JobSendFirmCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email
|
||||||
|
|
||||||
crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
||||||
crTestFirmCommunication jCompanies comm = do
|
crTestFirmCommunication jCompanies comm = do
|
||||||
jSender <- requireAuthId
|
jSender <- requireAuthId
|
||||||
MsgRenderer mr <- getMsgRenderer
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
|||||||
@ -4,7 +4,8 @@
|
|||||||
|
|
||||||
module Handler.Utils.Mail
|
module Handler.Utils.Mail
|
||||||
( addRecipientsDB
|
( addRecipientsDB
|
||||||
, userAddress, userAddressFrom
|
, userAddress, userAddress'
|
||||||
|
, userAddressFrom
|
||||||
, userMailT, userMailTdirect
|
, userMailT, userMailTdirect
|
||||||
, addFileDB
|
, addFileDB
|
||||||
, addHtmlMarkdownAlternatives
|
, addHtmlMarkdownAlternatives
|
||||||
@ -52,6 +53,11 @@ userAddress :: User -> Address
|
|||||||
userAddress User{userEmail, userDisplayEmail, userDisplayName}
|
userAddress User{userEmail, userDisplayEmail, userDisplayName}
|
||||||
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
||||||
|
|
||||||
|
userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address
|
||||||
|
-- Like userAddress', but does not require a complete entity
|
||||||
|
userAddress' userEmail userDisplayEmail userDisplayName
|
||||||
|
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
||||||
|
|
||||||
userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
|
userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
|
||||||
userAddressError User{userEmail, userDisplayEmail, userDisplayName}
|
userAddressError User{userEmail, userDisplayEmail, userDisplayName}
|
||||||
| Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
|
| Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
|
||||||
|
|||||||
@ -218,7 +218,7 @@ cellHasUserLink toLink user =
|
|||||||
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||||
in anchorCellM (toLink <$> encrypt uid) nWdgt
|
in anchorCellM (toLink <$> encrypt uid) nWdgt
|
||||||
|
|
||||||
-- | like `cellHasUserLink` but opens the user in a modal instead
|
-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights
|
||||||
cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
||||||
cellHasUserModal toLink user =
|
cellHasUserModal toLink user =
|
||||||
let userEntity = user ^. hasEntityUser
|
let userEntity = user ^. hasEntityUser
|
||||||
@ -226,10 +226,21 @@ cellHasUserModal toLink user =
|
|||||||
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||||
lWdgt = do
|
lWdgt = do
|
||||||
uuid <- liftHandler $ encrypt uid
|
uuid <- liftHandler $ encrypt uid
|
||||||
modalAccess False nWdgt nWdgt $ toLink uuid
|
modalAccess nWdgt nWdgt False $ toLink uuid
|
||||||
in cell lWdgt
|
in cell lWdgt
|
||||||
|
|
||||||
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead
|
-- | like `cellHasUserModal` but but always display link without prior access rights checks
|
||||||
|
cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
||||||
|
cellHasUserModalAdmin toLink user =
|
||||||
|
let userEntity = user ^. hasEntityUser
|
||||||
|
uid = userEntity ^. _entityKey
|
||||||
|
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||||
|
lWdgt = do
|
||||||
|
uuid <- liftHandler $ encrypt uid
|
||||||
|
modal nWdgt $ Left $ SomeRoute $ toLink uuid
|
||||||
|
in cell lWdgt
|
||||||
|
|
||||||
|
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights
|
||||||
cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
||||||
cellEditUserModal user =
|
cellEditUserModal user =
|
||||||
let userEntity = user ^. hasEntityUser
|
let userEntity = user ^. hasEntityUser
|
||||||
@ -237,16 +248,39 @@ cellEditUserModal user =
|
|||||||
nWdgt = toWidget $ icon IconUserEdit
|
nWdgt = toWidget $ icon IconUserEdit
|
||||||
lWdgt = do
|
lWdgt = do
|
||||||
uuid <- liftHandler $ encrypt uid
|
uuid <- liftHandler $ encrypt uid
|
||||||
modalAccess True nWdgt mempty $ ForProfileR uuid
|
modalAccess mempty nWdgt True $ ForProfileR uuid
|
||||||
in cell lWdgt
|
in cell lWdgt
|
||||||
|
|
||||||
|
-- | like `cellEditUserModal` but always displays the link without prior access rights checks
|
||||||
|
cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
||||||
|
cellEditUserModalAdmin user =
|
||||||
|
let userEntity = user ^. hasEntityUser
|
||||||
|
uid = userEntity ^. _entityKey
|
||||||
|
nWdgt = toWidget $ icon IconUserEdit
|
||||||
|
lWdgt = do
|
||||||
|
uuid <- liftHandler $ encrypt uid
|
||||||
|
modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
|
||||||
|
in cell lWdgt
|
||||||
|
|
||||||
cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
|
cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
|
||||||
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
|
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
|
||||||
|
|
||||||
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
|
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
|
||||||
cellHasMatrikelnummerLinked usr
|
cellHasMatrikelnummerLinked isAdmin usr
|
||||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||||
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
||||||
modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid)
|
if isAdmin
|
||||||
|
then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||||
|
else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid)
|
||||||
|
| otherwise = mempty
|
||||||
|
where
|
||||||
|
usrEntity = usr ^. hasEntityUser
|
||||||
|
|
||||||
|
cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
|
||||||
|
cellHasMatrikelnummerLinkedAdmin usr
|
||||||
|
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||||
|
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
||||||
|
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||||
| otherwise = mempty
|
| otherwise = mempty
|
||||||
where
|
where
|
||||||
usrEntity = usr ^. hasEntityUser
|
usrEntity = usr ^. hasEntityUser
|
||||||
@ -324,7 +358,7 @@ courseCell Course{..} = anchorCell link name `mappend` desc
|
|||||||
companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a
|
companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a
|
||||||
companyCell cid cname isSupervisor = anchorCell link name
|
companyCell cid cname isSupervisor = anchorCell link name
|
||||||
where
|
where
|
||||||
link = FirmR cid
|
link = FirmUsersR cid
|
||||||
corg = ciOriginal cname
|
corg = ciOriginal cname
|
||||||
name
|
name
|
||||||
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
|
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
|
||||||
@ -364,7 +398,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
|
|||||||
Nothing -> headWgt <> dateWgt
|
Nothing -> headWgt <> dateWgt
|
||||||
Just toLink -> do
|
Just toLink -> do
|
||||||
uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
|
uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
|
||||||
let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid
|
let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
|
||||||
headWgt <> modalWgt
|
headWgt <> modalWgt
|
||||||
where
|
where
|
||||||
dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
|
dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
|
||||||
@ -386,7 +420,7 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
|
|||||||
| Just toLink <- mbToLink = cell $ do
|
| Just toLink <- mbToLink = cell $ do
|
||||||
uuid <- liftHandler $ encrypt uid
|
uuid <- liftHandler $ encrypt uid
|
||||||
let dWgt = formatTimeW SelFormatDate tstamp
|
let dWgt = formatTimeW SelFormatDate tstamp
|
||||||
modalAccess False dWgt dWgt $ toLink uuid
|
modalAccess dWgt dWgt False $ toLink uuid
|
||||||
-- anchorCellM (toLink <$> encrypt uid)
|
-- anchorCellM (toLink <$> encrypt uid)
|
||||||
| otherwise = dateCell tstamp
|
| otherwise = dateCell tstamp
|
||||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||||
@ -405,7 +439,7 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
|
|||||||
| Just toLink <- mbToLink = cell $ do
|
| Just toLink <- mbToLink = cell $ do
|
||||||
uuid <- liftHandler $ encrypt uid
|
uuid <- liftHandler $ encrypt uid
|
||||||
let dWgt = formatTimeW SelFormatDate tstamp
|
let dWgt = formatTimeW SelFormatDate tstamp
|
||||||
modalAccess False dWgt dWgt $ toLink uuid
|
modalAccess dWgt dWgt False $ toLink uuid
|
||||||
-- anchorCellM (toLink <$> encrypt uid)
|
-- anchorCellM (toLink <$> encrypt uid)
|
||||||
| otherwise = dateCell tstamp
|
| otherwise = dateCell tstamp
|
||||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||||
@ -466,7 +500,13 @@ avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
|
|||||||
avsPersonNoLinkedCell a = cell $ do
|
avsPersonNoLinkedCell a = cell $ do
|
||||||
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
|
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
|
||||||
let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
|
let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
|
||||||
modalAccess False nWgt nWgt $ AdminAvsUserR uuid
|
modalAccess nWgt nWgt False $ AdminAvsUserR uuid
|
||||||
|
|
||||||
|
avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
|
||||||
|
avsPersonNoLinkedCellAdmin a = cell $ do
|
||||||
|
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
|
||||||
|
let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
|
||||||
|
modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||||
|
|
||||||
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
|
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
|
||||||
avsPersonCardCell cards = wgtCell
|
avsPersonCardCell cards = wgtCell
|
||||||
|
|||||||
@ -336,6 +336,10 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co
|
|||||||
colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
|
colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
|
||||||
colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink)
|
colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink)
|
||||||
|
|
||||||
|
-- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them)
|
||||||
|
colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
|
||||||
|
colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink)
|
||||||
|
|
||||||
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
||||||
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
|
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
|
||||||
sortUserName = ("user-name",) . sortUserNameBare
|
sortUserName = ("user-name",) . sortUserNameBare
|
||||||
@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI
|
|||||||
fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation)
|
fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation)
|
||||||
|
|
||||||
|
|
||||||
colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
|
colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c)
|
||||||
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked
|
colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin
|
||||||
|
|
||||||
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
|
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
|
||||||
sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
|
sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
|
||||||
|
|||||||
@ -1723,6 +1723,7 @@ i18nCell msg = cell $ do
|
|||||||
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
|
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
|
||||||
cellTooltip = cellTooltipIcon Nothing
|
cellTooltip = cellTooltipIcon Nothing
|
||||||
|
|
||||||
|
-- note that you can also use `cellTooltip` with `SomeMessages`, which uses ' ' for separation only
|
||||||
cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a
|
cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a
|
||||||
cellTooltips msgs = cellTooltipWgt Nothing [whamlet|
|
cellTooltips msgs = cellTooltipWgt Nothing [whamlet|
|
||||||
$forall msg <- msgs
|
$forall msg <- msgs
|
||||||
|
|||||||
@ -1,7 +1,9 @@
|
|||||||
-- 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>
|
-- 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>,Steffen Jost <s.jost@fraport.de>
|
||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
-- NOTE: Also see Handler.Utils.Profile for similar utilities
|
-- NOTE: Also see Handler.Utils.Profile for similar utilities
|
||||||
module Handler.Utils.Users
|
module Handler.Utils.Users
|
||||||
( computeUserAuthenticationDigest
|
( computeUserAuthenticationDigest
|
||||||
@ -17,7 +19,7 @@ module Handler.Utils.Users
|
|||||||
, getEmailAddress
|
, getEmailAddress
|
||||||
, getPostalAddress, getPostalPreferenceAndAddress
|
, getPostalAddress, getPostalPreferenceAndAddress
|
||||||
, abbrvName
|
, abbrvName
|
||||||
, getReceivers
|
, getReceivers, getReceiversFor
|
||||||
, getSupervisees
|
, getSupervisees
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -38,7 +40,9 @@ import qualified Data.Set as Set
|
|||||||
-- import qualified Data.List as List
|
-- import qualified Data.List as List
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import qualified Database.Esqueleto.Legacy as E
|
import Database.Esqueleto.Experimental ((:&)(..))
|
||||||
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||||
|
import qualified Database.Esqueleto.Legacy as EL (on,from)
|
||||||
import qualified Database.Esqueleto.PostgreSQL as E
|
import qualified Database.Esqueleto.PostgreSQL as E
|
||||||
import qualified Database.Esqueleto.Utils as E
|
import qualified Database.Esqueleto.Utils as E
|
||||||
|
|
||||||
@ -111,6 +115,14 @@ getReceivers uid = do
|
|||||||
then directResult
|
then directResult
|
||||||
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
|
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
|
||||||
|
|
||||||
|
-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates
|
||||||
|
getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId]
|
||||||
|
getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do
|
||||||
|
usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor
|
||||||
|
`E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications))
|
||||||
|
E.where_ $ usr E.^. UserId `E.in_` E.vals uids
|
||||||
|
return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId
|
||||||
|
|
||||||
-- | return underlings for currently logged in user
|
-- | return underlings for currently logged in user
|
||||||
getSupervisees :: DB (Set UserId)
|
getSupervisees :: DB (Set UserId)
|
||||||
getSupervisees = do
|
getSupervisees = do
|
||||||
@ -185,7 +197,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
|||||||
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName'
|
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName'
|
||||||
|
|
||||||
go didLdap = do
|
go didLdap = do
|
||||||
let retrieveUsers = E.select . E.from $ \user -> do
|
let retrieveUsers = E.select . EL.from $ \user -> do
|
||||||
E.where_ . E.or $ map (E.and . map (toSql user)) criteria
|
E.where_ . E.or $ map (E.and . map (toSql user)) criteria
|
||||||
when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
|
when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
|
||||||
return user
|
return user
|
||||||
@ -307,7 +319,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueCourseFavourite
|
UniqueCourseFavourite
|
||||||
(E.from $ \courseFavourite -> do
|
(EL.from $ \courseFavourite -> do
|
||||||
E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
|
E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
|
||||||
return $ CourseFavourite
|
return $ CourseFavourite
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -320,7 +332,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueCourseNoFavourite
|
UniqueCourseNoFavourite
|
||||||
(E.from $ \courseNoFavourite -> do
|
(EL.from $ \courseNoFavourite -> do
|
||||||
E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId
|
E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId
|
||||||
return $ CourseNoFavourite
|
return $ CourseNoFavourite
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -331,7 +343,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExamOfficeField
|
UniqueExamOfficeField
|
||||||
(E.from $ \examOfficeField -> do
|
(EL.from $ \examOfficeField -> do
|
||||||
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId
|
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId
|
||||||
return $ ExamOfficeField
|
return $ ExamOfficeField
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -343,7 +355,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExamOfficeUser
|
UniqueExamOfficeUser
|
||||||
(E.from $ \examOfficeUser -> do
|
(EL.from $ \examOfficeUser -> do
|
||||||
E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId
|
E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId
|
||||||
return $ ExamOfficeUser
|
return $ ExamOfficeUser
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -353,7 +365,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
deleteWhere [ ExamOfficeUserOffice ==. oldUserId ]
|
deleteWhere [ ExamOfficeUserOffice ==. oldUserId ]
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExamOfficeUser
|
UniqueExamOfficeUser
|
||||||
(E.from $ \examOfficeUser -> do
|
(EL.from $ \examOfficeUser -> do
|
||||||
E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId
|
E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId
|
||||||
return $ ExamOfficeUser
|
return $ ExamOfficeUser
|
||||||
E.<# (examOfficeUser E.^. ExamOfficeUserOffice)
|
E.<# (examOfficeUser E.^. ExamOfficeUserOffice)
|
||||||
@ -362,7 +374,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
(\_current _excluded -> [])
|
(\_current _excluded -> [])
|
||||||
deleteWhere [ ExamOfficeUserUser ==. oldUserId ]
|
deleteWhere [ ExamOfficeUserUser ==. oldUserId ]
|
||||||
|
|
||||||
E.insertSelect . E.from $ \examOfficeResultSynced -> do
|
E.insertSelect . EL.from $ \examOfficeResultSynced -> do
|
||||||
E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId
|
E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId
|
||||||
return $ ExamOfficeResultSynced
|
return $ ExamOfficeResultSynced
|
||||||
E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool)
|
E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool)
|
||||||
@ -371,7 +383,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime)
|
E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime)
|
||||||
deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ]
|
deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ]
|
||||||
|
|
||||||
E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do
|
E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do
|
||||||
E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId
|
E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId
|
||||||
return $ ExamOfficeExternalResultSynced
|
return $ ExamOfficeExternalResultSynced
|
||||||
E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool)
|
E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool)
|
||||||
@ -400,7 +412,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExternalExamStaff
|
UniqueExternalExamStaff
|
||||||
(E.from $ \externalExamStaff -> do
|
(EL.from $ \externalExamStaff -> do
|
||||||
E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId
|
E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId
|
||||||
return $ ExternalExamStaff
|
return $ ExternalExamStaff
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -415,7 +427,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueSubmissionUser
|
UniqueSubmissionUser
|
||||||
(E.from $ \submissionUser -> do
|
(EL.from $ \submissionUser -> do
|
||||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId
|
||||||
return $ SubmissionUser
|
return $ SubmissionUser
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -425,19 +437,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
deleteWhere [ SubmissionUserUser ==. oldUserId ]
|
deleteWhere [ SubmissionUserUser ==. oldUserId ]
|
||||||
|
|
||||||
do
|
do
|
||||||
collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
|
collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
|
||||||
E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
||||||
E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
||||||
E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
|
E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
|
||||||
E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
|
E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
|
||||||
E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup
|
EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup
|
||||||
E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse
|
E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse
|
||||||
return (submissionGroupUserA, submissionGroupUserB)
|
return (submissionGroupUserA, submissionGroupUserB)
|
||||||
forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) ->
|
forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) ->
|
||||||
tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB
|
tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueSubmissionGroupUser
|
UniqueSubmissionGroupUser
|
||||||
(E.from $ \submissionGroupUser -> do
|
(EL.from $ \submissionGroupUser -> do
|
||||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId
|
||||||
return $ SubmissionGroupUser
|
return $ SubmissionGroupUser
|
||||||
E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup)
|
E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup)
|
||||||
@ -454,7 +466,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueLecturer
|
UniqueLecturer
|
||||||
(E.from $ \lecturer -> do
|
(EL.from $ \lecturer -> do
|
||||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId
|
||||||
return $ Lecturer
|
return $ Lecturer
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -466,7 +478,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueParticipant
|
UniqueParticipant
|
||||||
(E.from $ \courseParticipant -> do
|
(EL.from $ \courseParticipant -> do
|
||||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
|
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
|
||||||
return $ CourseParticipant
|
return $ CourseParticipant
|
||||||
E.<# (courseParticipant E.^. CourseParticipantCourse)
|
E.<# (courseParticipant E.^. CourseParticipantCourse)
|
||||||
@ -496,7 +508,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueCourseUserExamOfficeOptOut
|
UniqueCourseUserExamOfficeOptOut
|
||||||
(E.from $ \examOfficeOptOut -> do
|
(EL.from $ \examOfficeOptOut -> do
|
||||||
E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId
|
E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId
|
||||||
return $ CourseUserExamOfficeOptOut
|
return $ CourseUserExamOfficeOptOut
|
||||||
E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse)
|
E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse)
|
||||||
@ -508,7 +520,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserFunction
|
UniqueUserFunction
|
||||||
(E.from $ \userFunction -> do
|
(EL.from $ \userFunction -> do
|
||||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId
|
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId
|
||||||
return $ UserFunction
|
return $ UserFunction
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -520,7 +532,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserSystemFunction
|
UniqueUserSystemFunction
|
||||||
(E.from $ \userSystemFunction -> do
|
(EL.from $ \userSystemFunction -> do
|
||||||
E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId
|
E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId
|
||||||
return $ UserSystemFunction
|
return $ UserSystemFunction
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -533,7 +545,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserExamOffice
|
UniqueUserExamOffice
|
||||||
(E.from $ \userExamOffice -> do
|
(EL.from $ \userExamOffice -> do
|
||||||
E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId
|
E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId
|
||||||
return $ UserExamOffice
|
return $ UserExamOffice
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -544,7 +556,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserSchool
|
UniqueUserSchool
|
||||||
(E.from $ \userSchool -> do
|
(EL.from $ \userSchool -> do
|
||||||
E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId
|
E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId
|
||||||
return $ UserSchool
|
return $ UserSchool
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -557,7 +569,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ]
|
updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ]
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserGroupMember
|
UniqueUserGroupMember
|
||||||
(E.from $ \userGroupMember -> do
|
(EL.from $ \userGroupMember -> do
|
||||||
E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId
|
E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId
|
||||||
return $ UserGroupMember
|
return $ UserGroupMember
|
||||||
E.<# (userGroupMember E.^. UserGroupMemberGroup)
|
E.<# (userGroupMember E.^. UserGroupMemberGroup)
|
||||||
@ -568,8 +580,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
deleteWhere [ UserGroupMemberUser ==. oldUserId ]
|
deleteWhere [ UserGroupMemberUser ==. oldUserId ]
|
||||||
|
|
||||||
do
|
do
|
||||||
collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
|
collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
|
||||||
E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
|
EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
|
||||||
E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId
|
E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId
|
||||||
E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId
|
E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId
|
||||||
E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence
|
E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence
|
||||||
@ -580,7 +592,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
-> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration
|
-> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExamRegistration
|
UniqueExamRegistration
|
||||||
(E.from $ \examRegistration -> do
|
(EL.from $ \examRegistration -> do
|
||||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId
|
||||||
return $ ExamRegistration
|
return $ ExamRegistration
|
||||||
E.<# (examRegistration E.^. ExamRegistrationExam)
|
E.<# (examRegistration E.^. ExamRegistrationExam)
|
||||||
@ -592,8 +604,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
deleteWhere [ ExamRegistrationUser ==. oldUserId ]
|
deleteWhere [ ExamRegistrationUser ==. oldUserId ]
|
||||||
|
|
||||||
do
|
do
|
||||||
collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
|
collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
|
||||||
E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
|
EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
|
||||||
E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
|
E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
|
||||||
E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
|
E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
|
||||||
E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
|
E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
|
||||||
@ -602,7 +614,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
-> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
|
-> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExamPartResult
|
UniqueExamPartResult
|
||||||
(E.from $ \examPartResult -> do
|
(EL.from $ \examPartResult -> do
|
||||||
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
|
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
|
||||||
return $ ExamPartResult
|
return $ ExamPartResult
|
||||||
E.<# (examPartResult E.^. ExamPartResultExamPart)
|
E.<# (examPartResult E.^. ExamPartResultExamPart)
|
||||||
@ -614,8 +626,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
deleteWhere [ ExamPartResultUser ==. oldUserId ]
|
deleteWhere [ ExamPartResultUser ==. oldUserId ]
|
||||||
|
|
||||||
do
|
do
|
||||||
collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
|
collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
|
||||||
E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
|
EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
|
||||||
E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
|
E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
|
||||||
E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
|
E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
|
||||||
E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
|
E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
|
||||||
@ -624,7 +636,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
-> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
|
-> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExamBonus
|
UniqueExamBonus
|
||||||
(E.from $ \examBonus -> do
|
(EL.from $ \examBonus -> do
|
||||||
E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
|
E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
|
||||||
return $ ExamBonus
|
return $ ExamBonus
|
||||||
E.<# (examBonus E.^. ExamBonusExam)
|
E.<# (examBonus E.^. ExamBonusExam)
|
||||||
@ -657,8 +669,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } []
|
Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } []
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueExamPartCorrector
|
UniqueExamPartCorrector
|
||||||
(E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
|
(EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
|
||||||
E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
|
EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
|
||||||
E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId
|
E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId
|
||||||
E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector)
|
E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector)
|
||||||
return $ ExamPartCorrector
|
return $ ExamPartCorrector
|
||||||
@ -704,8 +716,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
|
in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
|
||||||
|
|
||||||
do
|
do
|
||||||
collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
|
collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
|
||||||
E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
|
EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
|
||||||
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
|
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
|
||||||
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
|
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
|
||||||
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
|
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
|
||||||
@ -716,7 +728,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
-> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
|
-> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniquePersonalisedSheetFile
|
UniquePersonalisedSheetFile
|
||||||
(E.from $ \personalisedSheetFile -> do
|
(EL.from $ \personalisedSheetFile -> do
|
||||||
E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
|
E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
|
||||||
return $ PersonalisedSheetFile
|
return $ PersonalisedSheetFile
|
||||||
E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
|
E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
|
||||||
@ -731,7 +743,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueTutor
|
UniqueTutor
|
||||||
(E.from $ \tutor -> do
|
(EL.from $ \tutor -> do
|
||||||
E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
|
E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
|
||||||
return $ Tutor
|
return $ Tutor
|
||||||
E.<# (tutor E.^. TutorTutorial)
|
E.<# (tutor E.^. TutorTutorial)
|
||||||
@ -740,12 +752,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
(\_current _excluded -> [])
|
(\_current _excluded -> [])
|
||||||
|
|
||||||
do
|
do
|
||||||
collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
|
collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
|
||||||
E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
|
EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
|
||||||
E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
|
EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
|
||||||
E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
|
E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
|
||||||
E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
|
E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
|
||||||
E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
|
EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
|
||||||
E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId
|
E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId
|
||||||
E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
|
E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
|
||||||
return (tutorialParticipantA, tutorialParticipantB)
|
return (tutorialParticipantA, tutorialParticipantB)
|
||||||
@ -753,7 +765,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
-> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
|
-> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueTutorialParticipant
|
UniqueTutorialParticipant
|
||||||
(E.from $ \tutorialParticipant -> do
|
(EL.from $ \tutorialParticipant -> do
|
||||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
|
||||||
return $ TutorialParticipant
|
return $ TutorialParticipant
|
||||||
E.<# (tutorialParticipant E.^. TutorialParticipantTutorial)
|
E.<# (tutorialParticipant E.^. TutorialParticipantTutorial)
|
||||||
@ -764,7 +776,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueSystemMessageHidden
|
UniqueSystemMessageHidden
|
||||||
(E.from $ \systemMessageHidden -> do
|
(EL.from $ \systemMessageHidden -> do
|
||||||
E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
|
E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
|
||||||
return $ SystemMessageHidden
|
return $ SystemMessageHidden
|
||||||
E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage)
|
E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage)
|
||||||
@ -789,7 +801,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
]
|
]
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueRelevantStudyFeatures
|
UniqueRelevantStudyFeatures
|
||||||
(E.from $ \relevantStudyFeatures -> do
|
(EL.from $ \relevantStudyFeatures -> do
|
||||||
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
|
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
|
||||||
return $ RelevantStudyFeatures
|
return $ RelevantStudyFeatures
|
||||||
E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm)
|
E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm)
|
||||||
@ -815,8 +827,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
|
unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
|
||||||
updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
|
updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
|
||||||
updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
|
updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
|
||||||
usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
|
usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
|
||||||
E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
|
EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
|
||||||
E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId
|
E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId
|
||||||
)
|
)
|
||||||
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
|
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
|
||||||
@ -838,7 +850,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
-- Supervision is fully merged
|
-- Supervision is fully merged
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserSupervisor
|
UniqueUserSupervisor
|
||||||
(E.from $ \userSupervisor -> do
|
(EL.from $ \userSupervisor -> do
|
||||||
E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
|
E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
|
||||||
return $ UserSupervisor
|
return $ UserSupervisor
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
@ -850,7 +862,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
|
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserSupervisor
|
UniqueUserSupervisor
|
||||||
(E.from $ \userSupervisor -> do
|
(EL.from $ \userSupervisor -> do
|
||||||
E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
|
E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
|
||||||
return $ UserSupervisor
|
return $ UserSupervisor
|
||||||
E.<# (userSupervisor E.^. UserSupervisorSupervisor)
|
E.<# (userSupervisor E.^. UserSupervisorSupervisor)
|
||||||
@ -863,7 +875,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
|||||||
-- Companies, in conflict, keep the newUser-Company as is
|
-- Companies, in conflict, keep the newUser-Company as is
|
||||||
E.insertSelectWithConflict
|
E.insertSelectWithConflict
|
||||||
UniqueUserCompany
|
UniqueUserCompany
|
||||||
(E.from $ \userCompany -> do
|
(EL.from $ \userCompany -> do
|
||||||
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
|
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
|
||||||
return $ UserCompany
|
return $ UserCompany
|
||||||
E.<# E.val newUserId
|
E.<# E.val newUserId
|
||||||
|
|||||||
@ -123,15 +123,14 @@ editedByW fmt tm usr = do
|
|||||||
[whamlet|_{MsgUtilEditedBy usr ft}|]
|
[whamlet|_{MsgUtilEditedBy usr ft}|]
|
||||||
|
|
||||||
|
|
||||||
-- | like `modal`, but checks access rights to the link
|
-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead
|
||||||
modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget
|
modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget
|
||||||
modalAccess writeAccess wdgtYes wdgtNo route = do
|
modalAccess wdgtNo wdgtYes writeAccess route = do
|
||||||
authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
|
authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
|
||||||
if authOk
|
if authOk
|
||||||
then modal wdgtYes (Left $ SomeRoute route)
|
then modal wdgtYes (Left $ SomeRoute route)
|
||||||
else wdgtNo
|
else wdgtNo
|
||||||
|
|
||||||
|
|
||||||
----------
|
----------
|
||||||
-- HEAT --
|
-- HEAT --
|
||||||
----------
|
----------
|
||||||
|
|||||||
@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
|
|||||||
(sender, Course{..}) <- runDB $ (,)
|
(sender, Course{..}) <- runDB $ (,)
|
||||||
<$> getJust jSender
|
<$> getJust jSender
|
||||||
<*> getJust jCourse
|
<*> getJust jCourse
|
||||||
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
|
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not
|
||||||
MsgRenderer mr <- getMailMsgRenderer
|
MsgRenderer mr <- getMailMsgRenderer
|
||||||
|
|
||||||
void $ setMailObjectUUID jMailObjectUUID
|
void $ setMailObjectUUID jMailObjectUUID
|
||||||
@ -59,7 +59,7 @@ dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompan
|
|||||||
-- <$> getJust jSender
|
-- <$> getJust jSender
|
||||||
-- <*> ifMaybeM jCompany Nothing get
|
-- <*> ifMaybeM jCompany Nothing get
|
||||||
sender <- runDB $ getJust jSender
|
sender <- runDB $ getJust jSender
|
||||||
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
|
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not
|
||||||
MsgRenderer mr <- getMailMsgRenderer
|
MsgRenderer mr <- getMailMsgRenderer
|
||||||
|
|
||||||
void $ setMailObjectUUID jMailObjectUUID
|
void $ setMailObjectUUID jMailObjectUUID
|
||||||
|
|||||||
13
src/Mail.hs
13
src/Mail.hs
@ -10,6 +10,7 @@
|
|||||||
module Mail
|
module Mail
|
||||||
( -- * Structured MIME emails
|
( -- * Structured MIME emails
|
||||||
module Network.Mail.Mime
|
module Network.Mail.Mime
|
||||||
|
, AddressEqIgnoreName(..)
|
||||||
-- * MailT
|
-- * MailT
|
||||||
, MailT, defMailT
|
, MailT, defMailT
|
||||||
, MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
|
, MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
|
||||||
@ -137,6 +138,14 @@ import Network.HTTP.Types.Header (hETag)
|
|||||||
import Web.HttpApiData (ToHttpApiData(toHeader))
|
import Web.HttpApiData (ToHttpApiData(toHeader))
|
||||||
|
|
||||||
|
|
||||||
|
newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
|
||||||
|
deriving (Show, Generic)
|
||||||
|
instance Eq AddressEqIgnoreName where
|
||||||
|
(==) = (==) `on` (addressEmail . getAddress)
|
||||||
|
instance Ord AddressEqIgnoreName where
|
||||||
|
compare = compare `on` (addressEmail . getAddress)
|
||||||
|
|
||||||
|
|
||||||
makeLenses_ ''Address
|
makeLenses_ ''Address
|
||||||
makeLenses_ ''Mail
|
makeLenses_ ''Mail
|
||||||
makeLenses_ ''Part
|
makeLenses_ ''Part
|
||||||
@ -339,8 +348,8 @@ defMailT ls (MailT mailC) = do
|
|||||||
return $ mail0
|
return $ mail0
|
||||||
& _mailFrom .~ fromAddress
|
& _mailFrom .~ fromAddress
|
||||||
& _mailReplyTo .~ sender
|
& _mailReplyTo .~ sender
|
||||||
mailRerouteTo' <- mailRerouteTo
|
mailRerouteTo' <- mailRerouteTo -- this is the general reroute, e.g. for test instances, not for supervisors
|
||||||
let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on enveloper, if rerouting is active
|
let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on envelope, if rerouting is active
|
||||||
switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } )
|
switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } )
|
||||||
switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)]
|
switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)]
|
||||||
mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2
|
mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2
|
||||||
|
|||||||
@ -40,7 +40,7 @@ customModal Modal{..} = do
|
|||||||
|
|
||||||
-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant
|
-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant
|
||||||
modal :: WidgetFor site () -- ^ Widget that represents the link
|
modal :: WidgetFor site () -- ^ Widget that represents the link
|
||||||
-> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget
|
-> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal content: either dynamic link or static widget
|
||||||
-> WidgetFor site () -- ^ result widget
|
-> WidgetFor site () -- ^ result widget
|
||||||
modal modalTrigger' modalContent = customModal Modal{..}
|
modal modalTrigger' modalContent = customModal Modal{..}
|
||||||
where
|
where
|
||||||
|
|||||||
@ -5,7 +5,7 @@
|
|||||||
module Utils.Set
|
module Utils.Set
|
||||||
( setIntersectNotOne
|
( setIntersectNotOne
|
||||||
, setIntersections
|
, setIntersections
|
||||||
, setMapMaybe
|
, setMapMaybe, setMapMaybeMonotonic
|
||||||
, concatMapSet
|
, concatMapSet
|
||||||
, setSymmDiff
|
, setSymmDiff
|
||||||
, setProduct
|
, setProduct
|
||||||
@ -56,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t
|
|||||||
setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
|
setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
|
||||||
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
|
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
|
||||||
|
|
||||||
|
-- | like `setMapMaybe`, but only when f is strictly increasing
|
||||||
|
setMapMaybeMonotonic :: (a -> Maybe b) -> Set a -> Set b
|
||||||
|
setMapMaybeMonotonic f = Set.fromDistinctAscList . mapMaybe f . Set.toAscList
|
||||||
|
|
||||||
concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b
|
concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b
|
||||||
concatMapSet f = Set.foldl ((. f) . (<>)) mempty
|
concatMapSet f = Set.foldl ((. f) . (<>)) mempty
|
||||||
-- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway
|
-- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway
|
||||||
@ -68,8 +72,11 @@ setProduct :: Set a -> Set b -> Set (a, b)
|
|||||||
-- ^ Depends on the valid internal structure of the given sets
|
-- ^ Depends on the valid internal structure of the given sets
|
||||||
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
|
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
|
||||||
|
|
||||||
setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
|
-- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
|
||||||
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
|
-- setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
|
||||||
|
--
|
||||||
|
setPartitionEithers :: Set (Either a b) -> (Set a, Set b)
|
||||||
|
setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMaybeMonotonic (preview _Right)
|
||||||
|
|
||||||
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
|
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
|
||||||
setFromFunc = Set.fromList . flip filter universeF
|
setFromFunc = Set.fromList . flip filter universeF
|
||||||
|
|||||||
@ -9,6 +9,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
^{formFirmAction}
|
^{formFirmAction}
|
||||||
|
|
||||||
<section>
|
<section>
|
||||||
|
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
||||||
|
_{MsgFirmSupervisionKeyData}
|
||||||
<div .scrolltable .scrolltable--bordered>
|
<div .scrolltable .scrolltable--bordered>
|
||||||
<table .table>
|
<table .table>
|
||||||
<tr .table__row .table__row--head>
|
<tr .table__row .table__row--head>
|
||||||
|
|||||||
Reference in New Issue
Block a user