diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2e8cf79b3..71fc9843e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -676,6 +676,9 @@ MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{co MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. +MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben +MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen. + MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden. @@ -771,9 +774,11 @@ NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugetei NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert +NotificationTriggerExamResult: Ich kann ein neues Klausurergebnis einsehen NotificationTriggerKindAll: Für alle Benutzer NotificationTriggerKindCourseParticipant: Für Kursteilnehmer +NotificationTriggerKindExamParticipant: Für Klausurteilnehmer NotificationTriggerKindCorrector: Für Korrektoren NotificationTriggerKindLecturer: Für Dozenten NotificationTriggerKindAdmin: Für Administratoren diff --git a/models/exams b/models/exams index a98a427ca..694f1a9bc 100644 --- a/models/exams +++ b/models/exams @@ -47,6 +47,7 @@ ExamResult exam ExamId user UserId result ExamResultGrade + lastChanged UTCTime default=now() UniqueExamResult exam user ExamCorrector exam ExamId diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index bc3cb2dcf..3e7cc80c9 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -465,11 +465,14 @@ postEUsersR tid ssh csh examn = do update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of Nothing -> deleteBy $ UniqueExamResult eid examUserCsvActUser - Just res -> let res' = either (over _examResult $ review passingGrade) id res - in void $ upsert - (ExamResult eid examUserCsvActUser res') - [ ExamResultResult =. res' - ] + Just res -> do + let res' = either (over _examResult $ review passingGrade) id res + now <- liftIO getCurrentTime + void $ upsert + (ExamResult eid examUserCsvActUser res' now) + [ ExamResultResult =. res' + , ExamResultLastChanged =. now + ] ExamUserCsvDeregisterData{..} -> do ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration User{userIdent} <- getJust examRegistrationUser diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 7b2b5344d..5d035d293 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -28,7 +28,7 @@ data SettingsForm = SettingsForm , stgNotificationSettings :: NotificationSettings } -data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKCorrector | NTKLecturer | NTKAdmin +data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKExamParticipant | NTKCorrector | NTKLecturer | NTKAdmin deriving (Eq, Ord, Enum, Bounded, Generic, Typeable) instance Universe NotificationTriggerKind instance Finite NotificationTriggerKind @@ -97,20 +97,24 @@ notificationForm template = wFormToAForm $ do = return False | Just uid <- mbUid , NTKAdmin <- nt - = E.selectExists . E.from $ \userAdmin -> + = fmap not . E.selectExists . E.from $ \userAdmin -> E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid | Just uid <- mbUid , NTKLecturer <- nt - = E.selectExists . E.from $ \userLecturer -> + = fmap not . E.selectExists . E.from $ \userLecturer -> E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid | Just uid <- mbUid , NTKCorrector <- nt - = E.selectExists . E.from $ \sheetCorrector -> + = fmap not . E.selectExists . E.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid | Just uid <- mbUid , NTKCourseParticipant <- nt - = E.selectExists . E.from $ \courseParticipant -> + = fmap not . E.selectExists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid + | Just uid <- mbUid + , NTKExamParticipant <- nt + = fmap not . E.selectExists . E.from $ \examRegistration -> + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid | otherwise = return False @@ -139,6 +143,7 @@ notificationForm template = wFormToAForm $ do NTCorrectionsNotDistributed -> Just NTKLecturer NTUserRightsUpdate -> Just NTKAll NTUserAuthModeUpdate -> Just NTKAll + NTExamResult -> Just NTKExamParticipant -- _other -> Nothing forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate] diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index aecca927e..419fca523 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -4,6 +4,8 @@ module Jobs.Crontab import Import +import Utils.Lens + import qualified Data.HashMap.Strict as HashMap import Jobs.Types @@ -17,6 +19,8 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import qualified Data.Conduit.List as C +import qualified Database.Esqueleto as E + determineCrontab :: DB (Crontab JobCtl) -- ^ Extract all future jobs from the database (sheet deadlines, ...) @@ -118,3 +122,24 @@ determineCrontab = execWriterT $ do transPipe lift ( selectSource [ SubmissionRatingBy !=. Nothing, SubmissionRatingAssigned !=. Nothing ] [] ) .| C.fold collateSubmissionsByCorrector Map.empty + + + let + examJobs (Entity nExam Exam{..}) = do + newestResult <- lift . E.select . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam + return . E.max_ $ examResult E.^. ExamResultLastChanged + + case over (mapped . _Value) ((max `on` NTop) examFinished) newestResult of + [E.Value (NTop (Just ts))] -> + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationExamResult{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ ts + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Left $ 14 * nominalDay + } + _other -> return () + + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index e10494b3b..fc9245b5d 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -55,21 +55,28 @@ determineNotificationCandidates NotificationCorrectionsNotDistributed{nSheet} E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ sheet E.^. SheetId E.==. E.val nSheet return user -determineNotificationCandidates NotificationUserRightsUpdate{..} - = do - -- always send to affected user - affectedUser <- selectList [UserId ==. nUser] [] - -- send to same-school admins only if there was an update - currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] [] - let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ] - newAdminSchools = currentAdminSchools \\ oldAdminSchools - affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do - E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId - E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools - return user - return $ nub $ affectedUser <> affectedAdmins +determineNotificationCandidates NotificationUserRightsUpdate{..} = do + -- always send to affected user + affectedUser <- selectList [UserId ==. nUser] [] + -- send to same-school admins only if there was an update + currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] [] + let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ] + newAdminSchools = currentAdminSchools \\ oldAdminSchools + affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do + E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId + E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools + return user + return $ nub $ affectedUser <> affectedAdmins determineNotificationCandidates NotificationUserAuthModeUpdate{..} = selectList [UserId ==. nUser] [] +determineNotificationCandidates notif@NotificationExamResult{..} = do + lastExec <- fmap (fmap $ cronLastExecTime . entityVal) . getBy . UniqueCronLastExec . toJSON $ JobQueueNotification notif + E.select . E.from $ \(examResult `E.InnerJoin` user) -> do + E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId + E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam + whenIsJust lastExec $ \lastExec' -> + E.where_ $ examResult E.^. ExamResultLastChanged E.>. E.val lastExec' + return user classifyNotification :: Notification -> DB NotificationTrigger @@ -85,4 +92,4 @@ classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAss classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate - +classifyNotification NotificationExamResult{} = return NTExamResult diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 121305c78..6faba5353 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -14,6 +14,7 @@ import Jobs.Handler.SendNotification.CorrectionsAssigned import Jobs.Handler.SendNotification.CorrectionsNotDistributed import Jobs.Handler.SendNotification.UserRightsUpdate import Jobs.Handler.SendNotification.UserAuthModeUpdate +import Jobs.Handler.SendNotification.ExamResult dispatchJobSendNotification :: UserId -> Notification -> Handler () diff --git a/src/Jobs/Handler/SendNotification/ExamResult.hs b/src/Jobs/Handler/SendNotification/ExamResult.hs new file mode 100644 index 000000000..01b76cc0e --- /dev/null +++ b/src/Jobs/Handler/SendNotification/ExamResult.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results + +module Jobs.Handler.SendNotification.ExamResult + ( dispatchNotificationExamResult + ) where + +import Import + +import Handler.Utils.Mail +import Jobs.Handler.SendNotification.Utils + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +dispatchNotificationExamResult :: ExamId -> UserId -> Handler () +dispatchNotificationExamResult nExam jRecipient = userMailT jRecipient $ do + (Course{..}, Exam{..}) <- liftHandlerT . runDB $ do + exam <- getJust nExam + course <- belongsToJust examCourse exam + return (course, exam) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectExamResult courseShorthand examName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + examn = examName + + editNotifications <- mkEditNotifications jRecipient + + addAlternatives $ + providePreferredAlternative ($(ihamletFile "templates/mail/examResult.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index f88986fee..ce89e1d02 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -57,6 +57,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationCorrectionsNotDistributed { nSheet :: SheetId } | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } + | NotificationExamResult { nExam :: ExamId } 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 730de2c05..9fa77cc43 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -30,6 +30,7 @@ data NotificationTrigger | NTCorrectionsNotDistributed | NTUserRightsUpdate | NTUserAuthModeUpdate + | NTExamResult deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe NotificationTrigger @@ -63,6 +64,7 @@ instance Default NotificationSettings where NTCorrectionsNotDistributed -> True NTUserRightsUpdate -> True NTUserAuthModeUpdate -> True + NTExamResult -> True instance ToJSON NotificationSettings where toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF diff --git a/templates/mail/examResult.hamlet b/templates/mail/examResult.hamlet new file mode 100644 index 000000000..78c58fde0 --- /dev/null +++ b/templates/mail/examResult.hamlet @@ -0,0 +1,18 @@ +$newline never +\ + +
+ +