Merge branch 'fradrive/company'

messages/uniworx/categories/firm/de-de-formal.msg

@@ -9,29 +9,35 @@ FirmEmail: Allgemeine Email
 FirmAddress: Postanschrift
 FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
 FirmAction: Firmenweite Aktion
-FirmActionInfo: Betrifft alle Firmenangehörigen.
+FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
 FirmActNotify: Mitteilung versenden
 FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
 FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
 FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
 FirmActAddSupersvisors: Ansprechpartner hinzufügen
 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)}
-FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern
+FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
 FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
 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
 FirmUserActNotify: Mitteilung versenden
 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
 FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
 FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
 FirmSuperActNotify: Mitteilung versenden
-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
-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
 FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen
 FilterSupervisor: Hat aktiven Ansprechpartner
@@ -47,4 +53,5 @@ TableIsDefaultSupervisor: Standardansprechpartner
 TableIsDefaultReroute: Standardumleitung
 FormFieldPostal: Benachrichtigungseinstellung
 FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
-FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
+FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
+FirmSupervisionKeyData: Kennzahlen Ansprechpartner

messages/uniworx/categories/firm/en-eu.msg

@@ -9,29 +9,35 @@ FirmEmail: General company email
 FirmAddress: Postal address
 FirmDefaultPreferenceInfo: Default setting for new company associates only
 FirmAction: Companywide action
-FirmActionInfo: Affects alle company associates.
+FirmActionInfo: Affects alle company associates under your supervision.
 FirmActNotify: Send message
 FirmActResetSupervision: Reset supervisors for all company associates
 FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
 FirmActResetMutualSupervision: Supervisors supervise each other
 FirmActAddSupersvisors: Add supervisors
 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
 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
 FirmUserActNotify: Send message
 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)}
 FirmUserActChangeContact: Change contact data for selected company associates
 FirmUserActMkSuper: Mark as company supervisor
 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
-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
 FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification
 FilterSupervisor: Has active supervisor
@@ -47,4 +53,5 @@ TableIsDefaultSupervisor: Default supervisor
 TableIsDefaultReroute: Default reroute
 FormFieldPostal: Notification type
 FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
-FirmUserChanges n: Notification settings changed for #{n} company associates
+FirmUserChanges n: Notification settings changed for #{n} company associates
+FirmSupervisionKeyData: Supervision key data

messages/uniworx/categories/send/send_notifications/de-de-formal.msg

@@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen E
 MailSupervisedNote: Hinweis
 MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:
 MailSupervisorReroute: Benachrichtigungsumleitung
-MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt
+MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt

messages/uniworx/categories/send/send_notifications/en-eu.msg

@@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warning: This message was not sent to the original recipie
 MailSupervisedNote: Please note
 MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:
 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

messages/uniworx/misc/de-de-formal.msg

@@ -10,6 +10,7 @@ BoolIrrelevant !ident-ok: —
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
 MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
+MultiSelectTip: Mehrfachauswahl mit Strg-Klick
 WeekDay: Wochentag
 LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
 Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}

messages/uniworx/misc/en-eu.msg

@@ -10,6 +10,7 @@ BoolIrrelevant: —
 FieldPrimary: Major
 FieldSecondary: Minor
 MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
+MultiSelectTip: Multiple selection via Ctrl-Click
 WeekDay: Day of the week
 LdapIdentificationOrEmail: Fraport AG-Kennung / email address
 Months num: #{num} #{pluralEN num "Month" "Months"}

messages/uniworx/utils/utils/de-de-formal.msg

@@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder !ident-ok: URL
 RoomReferenceLinkInstructions: Anweisungen
 RoomReferenceLinkInstructionsPlaceholder: Anweisungen
 UtilEmptyChoice: Auswahl war leer
+UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
 
 #invitation.hs
 InvitationAction: Aktion

messages/uniworx/utils/utils/en-eu.msg

@@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder: URL
 RoomReferenceLinkInstructions: Instructions
 RoomReferenceLinkInstructionsPlaceholder: Instructions
 UtilEmptyChoice: Empty selection
+UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
 
 #invitation.hs
 InvitationAction: Action

models/users.model

@@ -2,7 +2,7 @@
 --
 -- 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.
 -- 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

routes

@@ -113,12 +113,11 @@
 /for/#CryptoUUIDUser/user         ForProfileR       GET POST    !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
-/firm/#CompanyShorthand/debug   FirmR               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:
   /                        EOExamsR            GET POST        !system-exam-office

src/Foundation/Authorization.hs

@@ -554,7 +554,8 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
       return Authorized
     checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do
       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)
       return Authorized
     checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do

src/Foundation/I18n.hs

@@ -43,6 +43,8 @@ module Foundation.I18n
   , UniWorXMessages(..)
   , uniworxMessages
   , unRenderMessage, unRenderMessage', unRenderMessageLenient
+  , SomeMessages(..)
+  , someMessages
   , module Foundation.I18n.TH
   ) where
 
@@ -266,6 +268,18 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma
 
 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
   renderMessage f ls (Just s) = renderMessage f ls s
   renderMessage f ls Nothing  = renderMessage f ls MsgLmsStateOpen

src/Foundation/Navigation.hs

@@ -125,7 +125,6 @@ breadcrumb ProblemAvsErrorR     = i18nCrumb MsgProblemsAvsErrorHeading    $ Just
 
 breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms              Nothing
 breadcrumb FirmsCommR{}     = i18nCrumb MsgMenuFirmsComm        $ Just   FirmAllR
-breadcrumb FirmR{}          = i18nCrumb MsgMenuAdminHeading     $ Just   FirmAllR  -- TODO: change heading or remove
 breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirmUsers        $ Just   FirmAllR
 breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors  $ Just $ FirmUsersR fsh
 breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh                       
@@ -2417,16 +2416,6 @@ pageActions ApiDocsR = return
     , navChildren = []
     }
   ]
-pageActions (FirmR fsh) = return
-  [ NavPageActionPrimary
-    { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = defNavLink MsgTableCompanyNrUsers  $ FirmUsersR fsh
-    , navChildren = []
-    }
-  ]
 pageActions (FirmUsersR fsh) = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh

src/Handler/Admin/Avs.hs

@@ -548,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
                                 --  (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal
         , colUserNameLink AdminUserR
-        , sortable (Just "avspersonno")  (i18nCell MsgAvsPersonNo)    $ \(view  resultUserAvs -> a) -> avsPersonNoLinkedCell a
+        , sortable (Just "avspersonno")  (i18nCell MsgAvsPersonNo)    $ \(view  resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
         -- , 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"
             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)
             let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
                 companies = 
-                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
+                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
                 
             pure $ intercalate (text2widget "; ") companies
         , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
@@ -752,7 +752,7 @@ getProblemAvsErrorR = do
         dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
         dbtProj = dbtProjId
         dbtColonnade = dbColonnade $ mconcat
-          [ colUserNameModalHdr MsgLmsUser AdminUserR
+          [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
           , sortable (Just "avs-nr")          (i18nCell MsgAvsPersonNo)
               $ avsPersonNoLinkedCell . view reserrUsrAvs
           , sortable Nothing                  (i18nCell MsgAvsPersonId)

src/Handler/Course/Users.hs

@@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do
           , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
           , guardOn showSex . cap' $ colUserSex'
           , pure . cap' $ colUserEmail
-          , pure . cap' $ colUserMatriclenr
+          , pure . cap' $ colUserMatriclenr False
           , pure . cap' $ colUserQualifications nowaday
           , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
           , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh

src/Handler/Exam/Users.hs

@@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do
           dbtColonnade = mconcat $ catMaybes
             [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
             , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
-            , pure   colUserMatriclenr
+            , pure $ colUserMatriclenr False
             , 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
             , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->

src/Handler/Firm.hs

@@ -7,8 +7,7 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Handler.Firm
-  ( getFirmAllR   , postFirmAllR
+  ( getFirmAllR   , postFirmAllR  
-  , getFirmR      , postFirmR
   , getFirmUsersR , postFirmUsersR
   , getFirmSupersR, postFirmSupersR
   , getFirmCommR  , postFirmCommR
@@ -98,13 +97,13 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute )                                                            (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
     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))
     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
 
 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 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
     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
       usrs <- runDB $ E.select $ E.distinct $ do
@@ -139,6 +125,26 @@ firmActionHandler route = flip formResult faHandler
       cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
       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
       avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
       let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
@@ -204,11 +210,11 @@ runFirmActionFormPost cid route isAdmin acts = do
                         , formSubmit = FormSubmit
                         , formAnchor = Just faAnchor
                         }
-  firmActionHandler route faRes
+  firmActionHandler route isAdmin faRes
   return [whamlet|
           <section>
             <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
-              _{MsgFirmAction}
+              _{MsgFirmAction}              
             <div>
               <p>
                 _{MsgFirmActionInfo}
@@ -249,6 +255,30 @@ addDefaultSupervisors cid employees = do
     )
     (\_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
 addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
 addDefaultSupervisorsAll mutualSupervision cids = do
@@ -384,65 +414,6 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
       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
 
@@ -499,14 +470,13 @@ mkFirmAllTable isAdmin uid = do
         dbtRowKey = (E.^. CompanyId)
         dbtProj = dbtProjId
         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) ->
               anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm
           , sortable (Just "short")         (i18nCell MsgTableCompanyShort)            $ \(view resultAllCompany -> firm) ->
               let fsh = companyShorthand firm
-              in  anchorCell (FirmUsersR fsh) $ toWgt fsh
+              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 "supervisors")   (i18nCell MsgTableCompanyNrSupersDefault)  $ \row ->
               anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
@@ -621,7 +591,7 @@ postFirmAllR = do
   uid <- requireAuthId
   isAdmin <- checkAdmin
   (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
-  firmActionHandler FirmAllR firmRes
+  firmActionHandler FirmAllR isAdmin firmRes
   siteLayoutMsg MsgMenuFirms $ do
     setTitleI MsgMenuFirms
     $(i18nWidgetFile "firm-all")
@@ -633,6 +603,7 @@ postFirmAllR = do
 
 data FirmUserAction = FirmUserActNotify
                     | FirmUserActResetSupervision
+                    | FirmUserActSetSupervisor
                     | FirmUserActMkSuper
                     | FirmUserActChangeContact
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -641,11 +612,17 @@ data FirmUserAction = FirmUserActNotify
 nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3
 embedRenderMessage ''UniWorX ''FirmUserAction id
 
-data FirmUserActionData = FirmUserActNotifyData
+data FirmUserActionData = FirmUserActNotifyData                        
                         | FirmUserActResetSupervisionData
                             { firmUserActResetKeepOldSupers     :: Maybe Bool
                             -- , firmUserActResetMutualSupervision :: Maybe Bool
                             }
+                        | FirmUserActSetSupervisorData
+                            {  firmUserActSetSuperNames   :: Set Text
+                            ,  firmUserActSetSuperIds     :: [UserId]
+                            ,  firmUserActSetSuperReroute :: Bool
+                            ,  firmUserActSetSuperKeep    :: Bool
+                            }
                         | FirmUserActMkSuperData
                             { firmUserActMkSuperReroute   :: Maybe Bool }
                         | FirmUserActChangeContactData
@@ -697,7 +674,7 @@ mkFirmUserTable isAdmin cid = do
     return (usr E.^. UserId, usr E.^. UserDisplayName)
   let
     -- supervisorField :: Field Handler UserId
-    supervisorField  =      selectField $ procOptions rawSupers
+    -- supervisorField  =      selectField $ procOptions rawSupers
     supervisorsField = multiSelectField $ procOptions rawSupers
 
     fsh = unCompanyKey cid
@@ -710,9 +687,9 @@ mkFirmUserTable isAdmin cid = do
         dbtRowKey = queryUserUser >>> (E.^. UserId)
         dbtProj = dbtProjId
         dbtColonnade = formColonnade $ mconcat
-          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
+          [ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
           , 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 "supervisors")     (i18nCell MsgTableCompanyNrSupers       )  $ \(view resultUserCompanySupervisors  -> 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 $ ????
         dbtFilterUI mPrev = mconcat
           [ 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-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)
@@ -796,15 +773,20 @@ mkFirmUserTable isAdmin cid = do
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
         acts = mconcat
-          [ singletonMap FirmUserActNotify      $ pure FirmUserActNotifyData
+          [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
           , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
               <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)         (Just $ Just False)
               -- <*> 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
               <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
           , 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
           { dbParamsFormMethod = POST
@@ -840,7 +822,7 @@ mkFirmUserTable isAdmin cid = do
 getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
 getFirmUsersR  = postFirmUsersR
 postFirmUsersR fsh = do
-  isAdmin <- checkAdmin
+  isAdmin <- checkAdmin  
   let cid = CompanyKey fsh
   ((    Entity{entityVal=Company{..}}
       , E.Value nrCompanyUsers
@@ -873,10 +855,6 @@ postFirmUsersR fsh = do
 
   formResult fusrRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
-    (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
-      nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
-      addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
-      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmUserActNotifyData , uids) -> do
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
@@ -888,6 +866,31 @@ postFirmUsersR fsh = do
         newSupers <- addDefaultSupervisors cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
+      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) ->
       let changes = catMaybes
             [ (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr  -- note that Nothing means no change and not delete address!
@@ -910,6 +913,7 @@ postFirmUsersR fsh = do
 -- Firm Supervisors Table
 
 data FirmSuperAction = FirmSuperActNotify
+                     | FirmSuperActSwitchSuper
                      | FirmSuperActRMSuperDef
 
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -919,6 +923,10 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3
 embedRenderMessage ''UniWorX ''FirmSuperAction id
 
 data FirmSuperActionData = FirmSuperActNotifyData
+                         | FirmSuperActSwitchSuperData 
+                            { firmSuperActSwitchSuper   :: Maybe Bool
+                            , firmSuperActSwitchReroute :: Maybe Bool
+                            }
                          | FirmSuperActRMSuperDefData
                             { firmSuperActRMSuperActive :: Maybe Bool }
 
@@ -965,6 +973,7 @@ instance HasUser SuperCompanyTableData where
 
 mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
 mkFirmSuperTable isAdmin cid = do
+  msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
   let
     -- fsh = unCompanyKey cid
     resultDBTable = DBTable{..}
@@ -988,9 +997,9 @@ mkFirmSuperTable isAdmin cid = do
               return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
             return (usr, supervised, rerouted, cmps, supervisor, reroute)
         dbtColonnade = formColonnade $ mconcat
-          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
+          [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
           , 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) ->
               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
@@ -1028,7 +1037,11 @@ mkFirmSuperTable isAdmin cid = do
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
         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
               <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
           ]
@@ -1076,7 +1089,7 @@ postFirmSupersR fsh = do
     (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
       (nrRmSuper,nrRmActual) <- runDB $ (,)
         <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
-        <*> if firmSuperActRMSuperActive /= Just True
+        <*> if firmSuperActRMSuperActive /= Just True 
               then return 0
               else E.deleteCount $ do
                 spr <- E.from $ E.table @UserSupervisor
@@ -1088,7 +1101,18 @@ postFirmSupersR fsh = do
                     )
       addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
       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
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])

src/Handler/LMS.hs

@@ -633,7 +633,7 @@ postLmsR sid qsh = do
           ]        
         colChoices cmpMap = mconcat
           [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
-          , colUserNameModalHdr MsgLmsUser AdminUserR
+          , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
           , colUserEmail
           , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
               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                        
                         ]
               in intercalate spacerCell cs
-          , colUserMatriclenr
+          , colUserMatriclenr isAdmin
           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)          
           , 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

src/Handler/Qualification.hs

@@ -591,7 +591,7 @@ postQualificationR sid qsh = do
                         , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
                         ]
               in intercalate spacerCell cs
-          , guardMonoid isAdmin colUserMatriclenr
+          , guardMonoid isAdmin $ colUserMatriclenr isAdmin
           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
           , 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          

src/Handler/Tutorial/Users.hs

@@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do
         colChoices  = mconcat $ catMaybes
           [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
           , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR          
-          , pure  colUserEmail
+          , pure   colUserEmail
-          , pure  colUserMatriclenr
+          , pure $ colUserMatriclenr isAdmin
           , pure $ colUserQualifications nowaday
           , pure $ colUserQualificationBlocked isAdmin nowaday
           ]

src/Handler/Users.hs

@@ -100,7 +100,7 @@ postUsersR = do
       , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
           (AdminUserR <$> encrypt uid)
           (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"
             companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
               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)            
             let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
                 companies = 
-                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
+                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
             pure $ intercalate (text2widget "; ") companies
       -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
       --     (AdminUserR <$> encrypt uid)

src/Handler/Utils/Communication.hs

@@ -15,6 +15,7 @@ module Handler.Utils.Communication
 
 import Import
 import Handler.Utils
+import Handler.Utils.Users 
 
 import Jobs.Queue
 
@@ -95,35 +96,40 @@ makeLenses_ ''Communication
 crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
 crJobsCourseCommunication jCourse Communication{..} = do
   jSender <- requireAuthId
-  let jMailContent = cContent
-      allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
   jMailObjectUUID <- liftIO getRandom
-  jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
+  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
   jSender <- requireAuthId
-
   MsgRenderer mr <- getMsgRenderer
   let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject)
   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
   jSender <- requireAuthId
-  let jMailContent = cContent
-      allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
   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
   jSender <- requireAuthId
   MsgRenderer mr <- getMsgRenderer

src/Handler/Utils/Mail.hs

@@ -4,7 +4,8 @@
 
 module Handler.Utils.Mail
   ( addRecipientsDB
-  , userAddress, userAddressFrom
+  , userAddress, userAddress'
+  , userAddressFrom
   , userMailT, userMailTdirect
   , addFileDB
   , addHtmlMarkdownAlternatives
@@ -52,6 +53,11 @@ userAddress :: User -> Address
 userAddress User{userEmail, userDisplayEmail, userDisplayName}
   = 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 User{userEmail, userDisplayEmail, userDisplayName} 
   | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)

src/Handler/Utils/Table/Cells.hs

@@ -218,7 +218,7 @@ cellHasUserLink toLink user =
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
   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 toLink user = 
   let userEntity = user ^. hasEntityUser
@@ -226,10 +226,21 @@ cellHasUserModal toLink user =
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
       lWdgt = do 
                 uuid <- liftHandler $ encrypt uid
-                modalAccess False nWdgt nWdgt $ toLink uuid                
+                modalAccess nWdgt nWdgt False $ toLink uuid                
   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 user = 
   let userEntity = user ^. hasEntityUser
@@ -237,16 +248,39 @@ cellEditUserModal user =
       nWdgt = toWidget $ icon IconUserEdit      
       lWdgt = do 
                 uuid <- liftHandler $ encrypt uid
-                modalAccess True nWdgt mempty $ ForProfileR uuid
+                modalAccess mempty nWdgt True $ ForProfileR uuid
   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 = 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 
         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
   where 
     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 cid cname isSupervisor = anchorCell link name
   where
-    link = FirmR cid
+    link = FirmUsersR cid
     corg = ciOriginal cname
     name 
       | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
@@ -364,7 +398,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
     Nothing     -> headWgt <> dateWgt
     Just toLink -> do 
       uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
-      let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid
+      let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
       headWgt <> modalWgt
   where       
     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
           uuid <- liftHandler $ encrypt uid
           let dWgt = formatTimeW SelFormatDate tstamp
-          modalAccess False dWgt dWgt $ toLink uuid
+          modalAccess dWgt dWgt False $ toLink uuid
         --  anchorCellM (toLink <$> encrypt uid) 
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -405,7 +439,7 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
       | Just toLink <- mbToLink = cell $ do
           uuid <- liftHandler $ encrypt uid
           let dWgt = formatTimeW SelFormatDate tstamp
-          modalAccess False dWgt dWgt $ toLink uuid
+          modalAccess dWgt dWgt False $ toLink uuid
         --  anchorCellM (toLink <$> encrypt uid) 
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -466,7 +500,13 @@ avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
 avsPersonNoLinkedCell a = cell $ do
   uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
   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 cards = wgtCell 

src/Handler/Utils/Table/Columns.hs

@@ -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 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
 sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
 sortUserName = ("user-name",) . sortUserNameBare
@@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI
 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 queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))

src/Handler/Utils/Table/Pagination.hs

@@ -1723,6 +1723,7 @@ i18nCell msg = cell $ do
 cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
 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 msgs = cellTooltipWgt Nothing [whamlet|
   $forall msg <- msgs

src/Handler/Utils/Users.hs

@@ -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
 
+{-# LANGUAGE TypeApplications #-}
+
 -- NOTE: Also see Handler.Utils.Profile for similar utilities
 module Handler.Utils.Users
   ( computeUserAuthenticationDigest
@@ -17,7 +19,7 @@ module Handler.Utils.Users
   , getEmailAddress
   , getPostalAddress, getPostalPreferenceAndAddress
   , abbrvName
-  , getReceivers
+  , getReceivers, getReceiversFor
   , getSupervisees
   ) where
 
@@ -38,7 +40,9 @@ import qualified Data.Set as Set
 -- import qualified Data.List as List
 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.Utils as E
 
@@ -111,6 +115,14 @@ getReceivers uid = do
         then directResult
         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
 getSupervisees :: DB (Set UserId)
 getSupervisees = do 
@@ -185,7 +197,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
       GuessUserFirstName              userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'
 
     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
             when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
             return user
@@ -307,7 +319,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueCourseFavourite
-    (E.from $ \courseFavourite -> do
+    (EL.from $ \courseFavourite -> do
         E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
         return $ CourseFavourite
           E.<#  E.val newUserId
@@ -320,7 +332,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueCourseNoFavourite
-    (E.from $ \courseNoFavourite -> do
+    (EL.from $ \courseNoFavourite -> do
         E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId
         return $ CourseNoFavourite
           E.<#  E.val newUserId
@@ -331,7 +343,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueExamOfficeField
-    (E.from $ \examOfficeField -> do
+    (EL.from $ \examOfficeField -> do
         E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId
         return $ ExamOfficeField
           E.<#  E.val newUserId
@@ -343,7 +355,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueExamOfficeUser
-    (E.from $ \examOfficeUser -> do
+    (EL.from $ \examOfficeUser -> do
         E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId
         return $ ExamOfficeUser
           E.<#  E.val newUserId
@@ -353,7 +365,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamOfficeUserOffice ==. oldUserId ]
   E.insertSelectWithConflict
     UniqueExamOfficeUser
-    (E.from $ \examOfficeUser -> do
+    (EL.from $ \examOfficeUser -> do
         E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId
         return $ ExamOfficeUser
           E.<#  (examOfficeUser E.^. ExamOfficeUserOffice)
@@ -362,7 +374,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     (\_current _excluded -> [])
   deleteWhere [ ExamOfficeUserUser ==. oldUserId ]
 
-  E.insertSelect . E.from $ \examOfficeResultSynced -> do
+  E.insertSelect . EL.from $ \examOfficeResultSynced -> do
     E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId
     return $ ExamOfficeResultSynced
           E.<#  (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool)
@@ -371,7 +383,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
           E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime)
   deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ]
 
-  E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do
+  E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do
     E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId
     return $ ExamOfficeExternalResultSynced
           E.<#  (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool)
@@ -400,7 +412,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueExternalExamStaff
-    (E.from $ \externalExamStaff -> do
+    (EL.from $ \externalExamStaff -> do
        E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId
        return $ ExternalExamStaff
          E.<#  E.val newUserId
@@ -415,7 +427,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueSubmissionUser
-    (E.from $ \submissionUser -> do
+    (EL.from $ \submissionUser -> do
        E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId
        return $ SubmissionUser
          E.<#  E.val newUserId
@@ -425,19 +437,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ SubmissionUserUser ==. oldUserId ]
 
   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.&&. 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
       return (submissionGroupUserA, submissionGroupUserB)
     forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) ->
       tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB
   E.insertSelectWithConflict
     UniqueSubmissionGroupUser
-    (E.from $ \submissionGroupUser -> do
+    (EL.from $ \submissionGroupUser -> do
        E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId
        return $ SubmissionGroupUser
          E.<#  (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup)
@@ -454,7 +466,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueLecturer
-    (E.from $ \lecturer -> do
+    (EL.from $ \lecturer -> do
         E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId
         return $ Lecturer
           E.<#  E.val newUserId
@@ -466,7 +478,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueParticipant
-    (E.from $ \courseParticipant -> do
+    (EL.from $ \courseParticipant -> do
         E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
         return $ CourseParticipant
           E.<#  (courseParticipant E.^. CourseParticipantCourse)
@@ -496,7 +508,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueCourseUserExamOfficeOptOut
-    (E.from $ \examOfficeOptOut -> do
+    (EL.from $ \examOfficeOptOut -> do
         E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId
         return $ CourseUserExamOfficeOptOut
           E.<#  (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse)
@@ -508,7 +520,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserFunction
-    (E.from $ \userFunction -> do
+    (EL.from $ \userFunction -> do
         E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId
         return $ UserFunction
           E.<#  E.val newUserId
@@ -520,7 +532,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserSystemFunction
-    (E.from $ \userSystemFunction -> do
+    (EL.from $ \userSystemFunction -> do
         E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId
         return $ UserSystemFunction
           E.<#  E.val newUserId
@@ -533,7 +545,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserExamOffice
-    (E.from $ \userExamOffice -> do
+    (EL.from $ \userExamOffice -> do
         E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId
         return $ UserExamOffice
           E.<#  E.val newUserId
@@ -544,7 +556,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserSchool
-    (E.from $ \userSchool -> do
+    (EL.from $ \userSchool -> do
         E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId
         return $ UserSchool
           E.<#  E.val newUserId
@@ -557,7 +569,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ]
   E.insertSelectWithConflict
     UniqueUserGroupMember
-    (E.from $ \userGroupMember -> do
+    (EL.from $ \userGroupMember -> do
         E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId
         return $ UserGroupMember
           E.<#  (userGroupMember E.^. UserGroupMemberGroup)
@@ -568,8 +580,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ UserGroupMemberUser ==. oldUserId ]
 
   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.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId
       E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence
@@ -580,7 +592,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration
   E.insertSelectWithConflict
     UniqueExamRegistration
-    (E.from $ \examRegistration -> do
+    (EL.from $ \examRegistration -> do
         E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId
         return $ ExamRegistration
           E.<#  (examRegistration E.^. ExamRegistrationExam)
@@ -592,8 +604,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamRegistrationUser ==. oldUserId ]
 
   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.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
       E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
@@ -602,7 +614,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
   E.insertSelectWithConflict
     UniqueExamPartResult
-    (E.from $ \examPartResult -> do
+    (EL.from $ \examPartResult -> do
         E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
         return $ ExamPartResult
           E.<#  (examPartResult E.^. ExamPartResultExamPart)
@@ -614,8 +626,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamPartResultUser ==. oldUserId ]
 
   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.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
       E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
@@ -624,7 +636,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
   E.insertSelectWithConflict
     UniqueExamBonus
-    (E.from $ \examBonus -> do
+    (EL.from $ \examBonus -> do
         E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
         return $ ExamBonus
           E.<#  (examBonus E.^. ExamBonusExam)
@@ -657,8 +669,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } []
         E.insertSelectWithConflict
           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.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector)
               return $ ExamPartCorrector
@@ -704,8 +716,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
    in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
 
   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.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
        E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
@@ -716,7 +728,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
   E.insertSelectWithConflict
     UniquePersonalisedSheetFile
-    (E.from $ \personalisedSheetFile -> do
+    (EL.from $ \personalisedSheetFile -> do
         E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
         return $ PersonalisedSheetFile
           E.<#  (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
@@ -731,7 +743,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueTutor
-    (E.from $ \tutor -> do
+    (EL.from $ \tutor -> do
         E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
         return $ Tutor
           E.<#  (tutor E.^. TutorTutorial)
@@ -740,12 +752,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     (\_current _excluded -> [])
 
   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.&&. 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.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
       return (tutorialParticipantA, tutorialParticipantB)
@@ -753,7 +765,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
   E.insertSelectWithConflict
     UniqueTutorialParticipant
-    (E.from $ \tutorialParticipant -> do
+    (EL.from $ \tutorialParticipant -> do
         E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
         return $ TutorialParticipant
           E.<#  (tutorialParticipant E.^. TutorialParticipantTutorial)
@@ -764,7 +776,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueSystemMessageHidden
-    (E.from $ \systemMessageHidden -> do
+    (EL.from $ \systemMessageHidden -> do
         E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
         return $ SystemMessageHidden
           E.<#  (systemMessageHidden E.^. SystemMessageHiddenMessage)
@@ -789,7 +801,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
               ]
             E.insertSelectWithConflict
               UniqueRelevantStudyFeatures
-              (E.from $ \relevantStudyFeatures -> do
+              (EL.from $ \relevantStudyFeatures -> do
                   E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
                   return $ RelevantStudyFeatures
                     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
   updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. 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.where_ $  oldQual E.^. QualificationUserUser          E.==. E.val oldUserId          
@@ -838,7 +850,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   -- Supervision is fully merged
   E.insertSelectWithConflict
     UniqueUserSupervisor
-    (E.from $ \userSupervisor -> do
+    (EL.from $ \userSupervisor -> do
       E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
       return $ UserSupervisor
         E.<#  E.val newUserId
@@ -850,7 +862,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserSupervisor
-    (E.from $ \userSupervisor -> do
+    (EL.from $ \userSupervisor -> do
       E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
       return $ UserSupervisor
         E.<#  (userSupervisor E.^. UserSupervisorSupervisor)
@@ -863,7 +875,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   -- Companies, in conflict, keep the newUser-Company as is
   E.insertSelectWithConflict
     UniqueUserCompany
-    (E.from $ \userCompany -> do
+    (EL.from $ \userCompany -> do
       E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
       return $ UserCompany
         E.<#  E.val newUserId

src/Handler/Utils/Widgets.hs

@@ -123,15 +123,14 @@ editedByW fmt tm usr  = do
   [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
   if authOk
     then modal wdgtYes (Left $ SomeRoute route)
     else       wdgtNo
 
-
 ----------
 -- HEAT --
 ----------

src/Jobs/Handler/SendCourseCommunication.hs

@@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
   (sender, Course{..}) <- runDB $ (,)
     <$> getJust jSender
     <*> 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
 
     void $ setMailObjectUUID jMailObjectUUID
@@ -59,7 +59,7 @@ dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompan
   --   <$> getJust jSender
   --   <*> ifMaybeM jCompany Nothing get
   sender <- runDB $ getJust jSender    
-  either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
+  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
 
     void $ setMailObjectUUID jMailObjectUUID

src/Mail.hs

@@ -10,6 +10,7 @@
 module Mail
   ( -- * Structured MIME emails
     module Network.Mail.Mime
+  , AddressEqIgnoreName(..)
     -- * MailT
   , MailT, defMailT
   , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
@@ -137,6 +138,14 @@ import Network.HTTP.Types.Header (hETag)
 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_ ''Mail
 makeLenses_ ''Part
@@ -339,8 +348,8 @@ defMailT ls (MailT mailC) = do
     return $ mail0
       & _mailFrom     .~ fromAddress
       & _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 } )
       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

src/Utils/Frontend/Modal.hs

@@ -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
 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
 modal modalTrigger' modalContent = customModal Modal{..}
   where

src/Utils/Set.hs

@@ -5,7 +5,7 @@
 module Utils.Set
 ( setIntersectNotOne
 , setIntersections
-, setMapMaybe
+, setMapMaybe, setMapMaybeMonotonic
 , concatMapSet
 , setSymmDiff
 , setProduct
@@ -56,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t
 setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
 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 f = Set.foldl ((. f) . (<>)) mempty
 -- 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
 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 = Set.fromList . flip filter universeF

templates/firm-users.hamlet

@@ -8,7 +8,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 ^{formFirmAction}
 
-<section>        
+<section>
+  <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
+    _{MsgFirmSupervisionKeyData}
   <div .scrolltable .scrolltable--bordered>
     <table .table>      
         <tr .table__row .table__row--head>