feat(notifications): add NotificationExamResult

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

models/exams

@@ -47,6 +47,7 @@ ExamResult
   exam ExamId
   user UserId
   result ExamResultGrade
+  lastChanged UTCTime default=now()
   UniqueExamResult exam user
 ExamCorrector
   exam ExamId

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

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]

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

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

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 ()

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))

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

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

templates/mail/examResult.hamlet

@@ -0,0 +1,18 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailExamResultIntro (CI.original courseName) termDesc examName}
+    <p>
+      <a href=@{CExamR tid ssh csh examn EShowR}>
+        #{examName}
+    ^{editNotifications}