refactor(mail): course and firm message are sent only once to each supervisor

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

@@ -34,7 +34,7 @@ FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{
 FirmSuperActNotify: Mitteilung versenden
 FirmSuperActRMSuperDef: Standard 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
 FirmsNotificationTitle: Firmen benachrichtigen
 FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen

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

@@ -34,7 +34,7 @@ FirmUserActMkSuper: Mark as company supervisor
 FirmSuperActNotify: Send message
 FirmSuperActRMSuperDef: Remove as 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}
 FirmsNotificationTitle: Company notification
 FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification

src/Handler/Firm.hs

@@ -535,7 +535,7 @@ mkFirmAllTable isAdmin uid = do
               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) ->
               anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
           , sortable (Just "users")         (i18nCell MsgTableCompanyNrUsers)          $ \(view resultAllCompanyUsers               -> nr) -> wgtCell $ word2widget nr

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
-    Left email -> return . Address Nothing $ CI.original email
-    Right rid  -> userAddress <$> getJust rid
-  forM_ allRecipients $ \jRecipientEmail ->
-    yield JobSendCourseCommunication{..}
+  let jMailContent = cContent
+      (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients
+      adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
+  netReceiverAddresses <- lift $ do
+    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
-    Left email -> return . Address Nothing $ CI.original email
-    Right rid  -> userAddress <$> getJust rid
-  forM_ allRecipients $ \jRecipientEmail ->
-    yield JobSendFirmCommunication{..}
+  let jMailContent = cContent
+      (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients
+      adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
+  netReceiverAddresses <- lift $ do
+    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/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
-      E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
-      E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
+    collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
+      EL.on $ submissionGroupB E.^. SubmissionGroupId 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
-      E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
+    collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
+      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
-      E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
+    collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
+      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
-      E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
+    collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
+      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
-              E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
+          (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
+              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
-      E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
+    collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
+      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
-      E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
-      E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
+    collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
+      EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
+      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
-      E.on (      newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
+  usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
+      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/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
-  let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo'   -- switch receiver on enveloper, if rerouting is active
+  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 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/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 = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
+-- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
+-- 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