diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f507f651c..a761061bf 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -860,6 +860,11 @@ NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Ü NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert NotificationTriggerExamResult: Ich kann ein neues Prüfungsergebnis einsehen +NotificationTriggerAllocationStaffRegister: Ich kann Kurse bei einer neuen Zentralanmeldung eintragen +NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen für einen meiner Kurse bewerten +NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben +NotificationTriggerAllocationOutdatedRatings: Zentralanmeldung-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden +NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldung-Bewerbungen für einen meiner Kurse stehen aus NotificationTriggerKindAll: Für alle Benutzer NotificationTriggerKindCourseParticipant: Für Kursteilnehmer @@ -869,6 +874,7 @@ NotificationTriggerKindLecturer: Für Dozenten NotificationTriggerKindAdmin: Für Administratoren NotificationTriggerKindExamOffice: Für das Prüfungsamt NotificationTriggerKindEvaluation: Für Vorlesungsumfragen +NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen CorrCreate: Abgaben erstellen UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" @@ -1596,4 +1602,24 @@ ApplicationEditTip: Während des Bewerbungszeitraums können eigene Bewerbungen UserLdapSync: LDAP-Synchronisieren SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer" "Benutzern"} angestoßen -UserHijack: Sitzung übernehmen \ No newline at end of file +UserHijack: Sitzung übernehmen + +MailSubjectAllocationStaffRegister allocation@AllocationName: Sie können nun Kurse für die Zentralameldung „#{allocation}“ registrieren +MailAllocationStaffRegisterNewCourse: Sie können auf der unten aufgeführten Seite neue Kurse in Uni2work anlegen. Hierbei haben Sie die Möglichkeit anzugeben, dass der Kurs an der Zentralanmeldung teilnimmt. +MailAllocationStaffRegisterDeadline deadline@Text: Bitte beachten Sie, dass alle Kurse, die an der Zentralanmeldung teilnehmen, bis #{deadline} eingetragen sein müssen. + +MailSubjectAllocationRegister allocation@AllocationName: Sie können sich nun für Kurse der Zentralameldung „#{allocation}“ bewerben +MailAllocationRegister: Sie können sich, auf der unten aufgeführten Seite, für alle Kurse der Zentralanmeldung jeweils einzeln bewerben. +MailAllocationRegisterDeadline deadline@Text: Bitte beachten Sie, dass alle Bewerbungen bis #{deadline} eingegangen sein müssen. + +MailSubjectAllocationAllocation allocation@AllocationName: Sie können nun Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ bewerten +MailAllocationAllocation: Sie können nun auf den unten aufgeführten Seiten Bewerbungen, die im Rahmen der Zentralanmeldung an ihre Kurse gestellt wurden, bewerten. Die Bewertungen werden bei der Vergabe der Plätze berücksichtigt. +MailAllocationApplicationsMayChange deadline@Text: Bitte beachten Sie, dass Studierende noch bis #{deadline} Bewerbungen stellen, verändern und zurückziehen können. Bewerbungen, die sich nach ihrer Bewertung noch verändern, müssen neu bewertet werden. +MailAllocationAllocationDeadline deadline@Text: Bitte beachten Sie, dass alle Bewertungen bis #{deadline} erfolgt sein müssen. + +MailSubjectAllocationUnratedApplications allocation@AllocationName: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ aus +MailAllocationUnratedApplications: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die noch nicht bewertet wurden. + +MailSubjectAllocationOutdatedRatings allocation@AllocationName: Bereits bewertete Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ haben sich geändert +MailAllocationOutdatedRatings: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die sich verändert haben, seit sie zuletzt bewertet wurden. +MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet. \ No newline at end of file diff --git a/src/Handler/Course/Application/Edit.hs b/src/Handler/Course/Application/Edit.hs index 29544bd90..bd7615614 100644 --- a/src/Handler/Course/Application/Edit.hs +++ b/src/Handler/Course/Application/Edit.hs @@ -13,18 +13,18 @@ getCAEditR = postCAEditR postCAEditR tid ssh csh cID = do uid <- requireAuthId appId <- decrypt cID - (mAlloc, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do + (mAlloc, Entity cid Course{..}, CourseApplication{..}, User{..}) <- runDB $ do course <- getBy404 $ TermSchoolCourseShort tid ssh csh app <- get404 appId mAlloc <- traverse getEntity404 $ courseApplicationAllocation app appUser <- get404 $ courseApplicationUser app - isAdmin <- case mAlloc of - Just alloc -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. alloc ^. _entityVal . _allocationSchool, UserFunctionFunction ==. SchoolAdmin] - Nothing -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. course ^. _entityVal . _courseSchool, UserFunctionFunction ==. SchoolAdmin] - return (mAlloc, course, app, isAdmin, appUser) + return (mAlloc, course, app, appUser) + isAdmin <- case mAlloc of + Just alloc -> hasWriteAccessTo $ SchoolR (alloc ^. _entityVal . _allocationSchool) SchoolEditR + Nothing -> hasWriteAccessTo $ SchoolR (course ^. _entityVal . _courseSchool ) SchoolEditR afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR - afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR + afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR -- TODO: Wrong. courseCID <- encrypt cid :: Handler CryptoUUIDCourse let afMode = ApplicationFormMode @@ -33,7 +33,7 @@ postCAEditR tid ssh csh cID = do , afmLecturer } - (ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) uid cid (Just appId) afMode (/= BtnAllocationApply) $ if + (ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) courseApplicationUser cid (Just appId) afMode (/= BtnAllocationApply) $ if | uid == courseApplicationUser , Just (Entity _ Allocation{..}) <- mAlloc -> SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: courseCID diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e9d0a6ad0..b4a38f4f3 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -35,6 +35,7 @@ data NotificationTriggerKind | NTKCourseParticipant | NTKExamParticipant | NTKCorrector + | NTKAllocationStaff | NTKFunctionary SchoolFunction deriving (Eq, Ord, Generic, Typeable) deriveFinite ''NotificationTriggerKind @@ -45,6 +46,7 @@ instance RenderMessage UniWorX NotificationTriggerKind where NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant NTKCorrector -> mr MsgNotificationTriggerKindCorrector + NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice @@ -149,17 +151,22 @@ notificationForm template = wFormToAForm $ do = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template) ntSection = \case - NTSubmissionRatedGraded -> Just NTKCourseParticipant - NTSubmissionRated -> Just NTKCourseParticipant - NTSheetActive -> Just NTKCourseParticipant - NTSheetSoonInactive -> Just NTKCourseParticipant - NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer - NTCorrectionsAssigned -> Just NTKCorrector - NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer - NTUserRightsUpdate -> Just NTKAll - NTUserAuthModeUpdate -> Just NTKAll - NTExamResult -> Just NTKExamParticipant - -- _other -> Nothing + NTSubmissionRatedGraded -> Just NTKCourseParticipant + NTSubmissionRated -> Just NTKCourseParticipant + NTSheetActive -> Just NTKCourseParticipant + NTSheetSoonInactive -> Just NTKCourseParticipant + NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer + NTCorrectionsAssigned -> Just NTKCorrector + NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer + NTUserRightsUpdate -> Just NTKAll + NTUserAuthModeUpdate -> Just NTKAll + NTExamResult -> Just NTKExamParticipant + NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer + NTAllocationAllocation -> Just NTKAllocationStaff + NTAllocationRegister -> Just NTKAll + NTAllocationOutdatedRatings -> Just NTKAllocationStaff + NTAllocationUnratedApplications -> Just NTKAllocationStaff + -- _other -> Nothing forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 598c8479b..e0068c291 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -57,7 +57,7 @@ import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup, Min(..), Max(..)) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..)) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..)) import Data.Binary as Import (Binary) import Numeric.Natural as Import (Natural) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 014160f3c..8131c2194 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -224,3 +224,57 @@ determineCrontab = execWriterT $ do _other -> return () runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs + + let + allocationJobs (Entity nAllocation Allocation{..}) = do + whenIsJust allocationStaffRegisterFrom $ \staffRegisterFrom -> + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationAllocationStaffRegister{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ staffRegisterFrom + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffRegisterTo + } + whenIsJust allocationRegisterFrom $ \registerFrom -> + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationAllocationRegister{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerFrom + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationRegisterTo + } + whenIsJust allocationStaffAllocationFrom $ \allocationFrom -> + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationAllocationAllocation{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ allocationFrom + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo + } + case allocationRegisterTo of + Just registerTo + | maybe True (> registerTo) allocationStaffAllocationTo + -> do + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationAllocationUnratedApplications{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo + } + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationAllocationOutdatedRatings{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo + } + _other + -> return () + + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ allocationJobs diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 52421e576..56b3b1bbb 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -9,6 +9,7 @@ import Data.List (nub) import Jobs.Types import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Utils.Sql import Jobs.Queue @@ -80,6 +81,86 @@ determineNotificationCandidates notif@NotificationExamResult{..} = do whenIsJust lastExec $ \lastExec' -> E.where_ $ examResult E.^. ExamResultLastChanged E.>. E.val lastExec' return user +determineNotificationCandidates NotificationAllocationStaffRegister{..} = do + Allocation{..} <- getJust nAllocation + E.select . E.from $ \(user `E.InnerJoin` userFunction) -> do + E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser + E.&&. userFunction E.^. UserFunctionSchool E.==. E.val allocationSchool + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer + + E.where_ . E.exists . E.from $ \userSchool -> + E.where_ $ userSchool E.^. UserSchoolUser E.==. user E.^. UserId + E.&&. userSchool E.^. UserSchoolSchool E.==. E.val allocationSchool + E.&&. E.not_ (userSchool E.^. UserSchoolIsOptOut) + + E.where_ . E.not_ . E.exists . E.from $ \(course `E.InnerJoin` lecturer) -> do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. user E.^. UserId + E.where_ . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + + return user +determineNotificationCandidates NotificationAllocationAllocation{..} = + E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId + + E.where_ . E.not_ . E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) + E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId + E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId + E.&&. E.not_ (E.isNothing $ application E.^. CourseApplicationRatingTime) + + E.where_ . E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) + E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId + E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId + + return user +determineNotificationCandidates NotificationAllocationUnratedApplications{..} = + E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId + + E.where_ . E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) + E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId + E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId + E.&&. E.isNothing (application E.^. CourseApplicationRatingTime) + + return user +determineNotificationCandidates NotificationAllocationRegister{..} = do + Allocation{..} <- getJust nAllocation + E.select . E.from $ \user -> do + E.where_ . E.exists . E.from $ \userSchool -> + E.where_ $ userSchool E.^. UserSchoolUser E.==. user E.^. UserId + E.&&. userSchool E.^. UserSchoolSchool E.==. E.val allocationSchool + E.&&. E.not_ (userSchool E.^. UserSchoolIsOptOut) + + E.where_ . E.not_ . E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) + E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId + + return user +determineNotificationCandidates NotificationAllocationOutdatedRatings{..} = + E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId + + E.where_ . E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) + E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId + E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId + E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime) + + return user classifyNotification :: Notification -> DB NotificationTrigger @@ -96,3 +177,8 @@ classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrecti classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate classifyNotification NotificationExamResult{} = return NTExamResult +classifyNotification NotificationAllocationStaffRegister{} = return NTAllocationStaffRegister +classifyNotification NotificationAllocationAllocation{} = return NTAllocationAllocation +classifyNotification NotificationAllocationRegister{} = return NTAllocationRegister +classifyNotification NotificationAllocationOutdatedRatings{} = return NTAllocationOutdatedRatings +classifyNotification NotificationAllocationUnratedApplications{} = return NTAllocationUnratedApplications diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 6faba5353..82214fe04 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -15,6 +15,7 @@ import Jobs.Handler.SendNotification.CorrectionsNotDistributed import Jobs.Handler.SendNotification.UserRightsUpdate import Jobs.Handler.SendNotification.UserAuthModeUpdate import Jobs.Handler.SendNotification.ExamResult +import Jobs.Handler.SendNotification.Allocation dispatchJobSendNotification :: UserId -> Notification -> Handler () diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs new file mode 100644 index 000000000..cc0746bba --- /dev/null +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -0,0 +1,159 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results + +module Jobs.Handler.SendNotification.Allocation + ( dispatchNotificationAllocationStaffRegister + , dispatchNotificationAllocationRegister + , dispatchNotificationAllocationAllocation + , dispatchNotificationAllocationUnratedApplications + , dispatchNotificationAllocationOutdatedRatings + ) where + +import Import + +import Handler.Utils +import Jobs.Handler.SendNotification.Utils + +import Text.Hamlet + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + + +dispatchNotificationAllocationStaffRegister :: AllocationId -> UserId -> Handler () +dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT jRecipient $ do + Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationStaffRegister allocationName + editNotifications <- mkEditNotifications jRecipient + registerDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffRegisterTo + addAlternatives $ + providePreferredAlternative $(ihamletFile "templates/mail/allocationStaffRegister.hamlet") + +dispatchNotificationAllocationRegister :: AllocationId -> UserId -> Handler () +dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecipient $ do + Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationRegister allocationName + editNotifications <- mkEditNotifications jRecipient + registerDeadline <- traverse (formatTime SelFormatDateTime) allocationRegisterTo + addAlternatives $ + providePreferredAlternative $(ihamletFile "templates/mail/allocationRegister.hamlet") + +dispatchNotificationAllocationAllocation :: AllocationId -> UserId -> Handler () +dispatchNotificationAllocationAllocation nAllocation jRecipient = do + (Allocation{..}, courses) <- liftHandlerT . runDB $ do + allocation <- getJust nAllocation + courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. E.val jRecipient + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + return ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + , course E.^. CourseName + ) + let courses' = courses + & over (traverse . _1) E.unValue + & over (traverse . _2) E.unValue + & over (traverse . _3) E.unValue + & over (traverse . _4) E.unValue + return (allocation, courses') + + unless (null courses) . userMailT jRecipient $ do + now <- liftIO getCurrentTime + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationAllocation allocationName + editNotifications <- mkEditNotifications jRecipient + allocationDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo + registerDeadline <- traverse (formatTime SelFormatDateTime) $ assertM (> now) allocationRegisterTo + addAlternatives $ + providePreferredAlternative $(ihamletFile "templates/mail/allocationAllocation.hamlet") + +dispatchNotificationAllocationUnratedApplications :: AllocationId -> UserId -> Handler () +dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do + (Allocation{..}, courses) <- liftHandlerT . runDB $ do + allocation <- getJust nAllocation + courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. E.val jRecipient + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + + let + unratedAppCount :: E.SqlExpr (E.Value Natural) + unratedAppCount = E.sub_select . E.from $ \application -> do + E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId + E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) + E.&&. E.isNothing (application E.^. CourseApplicationRatingTime) + return E.countRows + + return ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + , course E.^. CourseName + , unratedAppCount + ) + let courses' = courses + & over (traverse . _1) E.unValue + & over (traverse . _2) E.unValue + & over (traverse . _3) E.unValue + & over (traverse . _4) E.unValue + & over (traverse . _5) E.unValue + & filter ((> 0) . view _5) + return (allocation, courses') + + + unless (null courses) . userMailT jRecipient $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationUnratedApplications allocationName + editNotifications <- mkEditNotifications jRecipient + allocationDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo + addAlternatives $ + providePreferredAlternative $(ihamletFile "templates/mail/allocationUnratedApplications.hamlet") + +dispatchNotificationAllocationOutdatedRatings :: AllocationId -> UserId -> Handler () +dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do + (Allocation{..}, courses) <- liftHandlerT . runDB $ do + allocation <- getJust nAllocation + courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. E.val jRecipient + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + + let + outdatedRatingsAppCount :: E.SqlExpr (E.Value Natural) + outdatedRatingsAppCount = E.sub_select . E.from $ \application -> do + E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId + E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) + E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime) + return E.countRows + + return ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + , course E.^. CourseName + , outdatedRatingsAppCount + ) + let courses' = courses + & over (traverse . _1) E.unValue + & over (traverse . _2) E.unValue + & over (traverse . _3) E.unValue + & over (traverse . _4) E.unValue + & over (traverse . _5) E.unValue + & filter ((> 0) . view _5) + return (allocation, courses') + + + unless (null courses) . userMailT jRecipient $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationOutdatedRatings allocationName + editNotifications <- mkEditNotifications jRecipient + allocationDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo + addAlternatives $ + providePreferredAlternative $(ihamletFile "templates/mail/allocationOutdatedRatings.hamlet") + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 6b3209f6f..7aa1a3237 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -67,6 +67,11 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } | NotificationExamResult { nExam :: ExamId } + | NotificationAllocationStaffRegister { nAllocation :: AllocationId } + | NotificationAllocationRegister { nAllocation :: AllocationId } + | NotificationAllocationAllocation { nAllocation :: AllocationId } + | NotificationAllocationUnratedApplications { nAllocation :: AllocationId } + | NotificationAllocationOutdatedRatings { nAllocation :: AllocationId } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Hashable Job diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index 9fa77cc43..4dda93065 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -14,6 +14,7 @@ import Import.NoModel import qualified Data.Aeson.Types as Aeson +import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap @@ -31,6 +32,11 @@ data NotificationTrigger | NTUserRightsUpdate | NTUserAuthModeUpdate | NTExamResult + | NTAllocationStaffRegister + | NTAllocationAllocation + | NTAllocationRegister + | NTAllocationOutdatedRatings + | NTAllocationUnratedApplications deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe NotificationTrigger @@ -54,17 +60,12 @@ newtype NotificationSettings = NotificationSettings { notificationAllowed :: Not deriving newtype (Eq, Ord, Read, Show) instance Default NotificationSettings where - def = NotificationSettings $ \case - NTSubmissionRatedGraded -> True - NTSubmissionRated -> True - NTSheetActive -> True - NTSheetSoonInactive -> False - NTSheetInactive -> True - NTCorrectionsAssigned -> True - NTCorrectionsNotDistributed -> True - NTUserRightsUpdate -> True - NTUserAuthModeUpdate -> True - NTExamResult -> True + def = NotificationSettings $ not . flip HashSet.member defaultOff + where + defaultOff :: HashSet NotificationTrigger + defaultOff = HashSet.fromList + [ NTSheetSoonInactive + ] instance ToJSON NotificationSettings where toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF diff --git a/templates/mail/allocationAllocation.hamlet b/templates/mail/allocationAllocation.hamlet new file mode 100644 index 000000000..a5a59d81a --- /dev/null +++ b/templates/mail/allocationAllocation.hamlet @@ -0,0 +1,32 @@ +$newline never +\ + +
+ +