feat(courses): add NotificationCourseRegistered

messages/uniworx/de.msg

@@ -777,6 +777,11 @@ 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.
 
+MailSubjectCourseRegistered csh@CourseShorthand: Sie wurden zu #{csh} angemeldet
+MailSubjectCourseRegisteredOther displayName@Text csh@CourseShorthand: #{displayName} wurde zu #{csh} angemeldet
+MailCourseRegisteredIntro courseName@Text termDesc@Text: Sie wurden im Kurs #{courseName} (#{termDesc}) angemeldet.
+MailCourseRegisteredIntroOther displayName@Text courseName@Text termDesc@Text: #{displayName} wurde im Kurs #{courseName} (#{termDesc}) angemeldet.
+
 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.
 
@@ -829,7 +834,7 @@ InvitationAcceptDecline: Einladung annehmen/ablehnen
 InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in Uni2work ausgelöst hat.
 InvitationUniWorXTip: Uni2work ist ein webbasiertes Lehrverwaltungssystem der LMU München.
 
-MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursteilname
+MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursteilnahme
 
 MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für #{shn}
 
@@ -909,12 +914,14 @@ NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldun
 NotificationTriggerAllocationResults: Plätze wurden für eine meiner Zentralanmeldungen verteilt
 NotificationTriggerExamOfficeExamResults: Ich kann neue Prüfungsergebnisse einsehen
 NotificationTriggerExamOfficeExamResultsChanged: Prüfungsergebnisse wurden verändert
+NotificationTriggerCourseRegistered: Ein Kursverwalter hat mich zu einem Kurs angemeldet
 
 NotificationTriggerKindAll: Für alle Benutzer
 NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
 NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer
 NotificationTriggerKindCorrector: Für Korrektoren
 NotificationTriggerKindLecturer: Für Dozenten
+NotificationTriggerKindCourseLecturer: Für Kursverwalter
 NotificationTriggerKindAdmin: Für Administratoren
 NotificationTriggerKindExamOffice: Für das Prüfungsamt
 NotificationTriggerKindEvaluation: Für Vorlesungsumfragen

src/Handler/Course/ParticipantInvite.hs

@@ -169,10 +169,9 @@ addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
     tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
 
 
-registerUser :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
+registerUser :: CourseId
-             => CourseId
              -> UserId
-             -> WriterT AddParticipantsResult (ReaderT (YesodPersistBackend UniWorX) m) ()
+             -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
 registerUser cid uid = exceptT tell tell $ do
   whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
     throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
@@ -197,6 +196,7 @@ registerUser cid uid = exceptT tell tell $ do
     , ..
     }
   lift . lift . audit $ TransactionCourseParticipantEdit cid uid
+  lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
 
   return $ case courseParticipantField of
     Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }

src/Handler/Course/User.hs

@@ -16,6 +16,8 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
 
 import Handler.Course.Register
 
+import Jobs.Queue
+
 
 getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
 getCUserR = postCUserR
@@ -161,9 +163,10 @@ postCUserR tid ssh csh uCId = do
             = Just featId
             | otherwise
             = Nothing
-      pId <- runDB $ do
+      pId <- runDBJobs $ do
         pId <- insertUnique $ CourseParticipant cid uid now field Nothing
-        when (is _Just pId) $
+        when (is _Just pId) $ do
+          queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
           audit $ TransactionCourseParticipantEdit cid uid
         return pId
       case pId of

src/Handler/Exam/AddUser.hs

@@ -151,6 +151,7 @@ postEAddUserR tid ssh csh examn = do
         , ..
         }
       lift . lift . audit $ TransactionCourseParticipantEdit cid uid
+      lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
       lift $ lift examRegister
 
       return $ case courseParticipantField of

src/Handler/Exam/RegistrationInvite.hs

@@ -18,6 +18,8 @@ import qualified Data.Set as Set
 import Text.Hamlet (ihamlet)
   
 import Data.Aeson hiding (Result(..))
+
+import Jobs.Queue
   
 
 instance IsInvitableJunction ExamRegistration where
@@ -98,6 +100,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
     invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
       whenIsJust mField $ \cpField -> do
         insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing
+        queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
         audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
       
       let doAudit = audit $ TransactionExamRegister eid examRegistrationUser

src/Handler/Exam/Users.hs

@@ -37,6 +37,8 @@ import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
 
 import Control.Lens.Indexed ((<.), (.>))
 
+import Jobs.Queue
+
 
 type ExamUserTableExpr = (              E.SqlExpr (Entity ExamRegistration)
                           `E.InnerJoin` E.SqlExpr (Entity User)
@@ -744,6 +746,7 @@ postEUsersR tid ssh csh examn = do
                       , courseParticipantField = examUserCsvActCourseField
                       , courseParticipantAllocated = Nothing
                       }
+                    queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
                     audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
                     insert_ ExamRegistration
                       { examRegistrationExam = eid

src/Handler/Profile.hs

@@ -49,6 +49,7 @@ data NotificationTriggerKind
   | NTKCourseParticipant
   | NTKExamParticipant
   | NTKCorrector
+  | NTKCourseLecturer
   | NTKAllocationStaff
   | NTKAllocationParticipant
   | NTKFunctionary SchoolFunction
@@ -61,6 +62,7 @@ instance RenderMessage UniWorX NotificationTriggerKind where
     NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
     NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
     NTKCorrector -> mr MsgNotificationTriggerKindCorrector
+    NTKCourseLecturer -> mr MsgNotificationTriggerKindCourseLecturer
     NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff
     NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant
     NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
@@ -153,6 +155,10 @@ notificationForm template = wFormToAForm $ do
       , NTKExamParticipant <- nt
       = fmap not . E.selectExists . E.from $ \examRegistration ->
           E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKCourseLecturer <- nt
+      = fmap not . E.selectExists . E.from $ \lecturer ->
+          E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
       | otherwise
       = return False
 
@@ -176,9 +182,9 @@ notificationForm template = wFormToAForm $ do
       NTSubmissionRated                -> Just NTKCourseParticipant
       NTSheetActive                    -> Just NTKCourseParticipant
       NTSheetSoonInactive              -> Just NTKCourseParticipant
-      NTSheetInactive                  -> Just $ NTKFunctionary SchoolLecturer
+      NTSheetInactive                  -> Just NTKCourseLecturer
       NTCorrectionsAssigned            -> Just NTKCorrector
-      NTCorrectionsNotDistributed      -> Just $ NTKFunctionary SchoolLecturer
+      NTCorrectionsNotDistributed      -> Just NTKCourseLecturer
       NTUserRightsUpdate               -> Just NTKAll
       NTUserAuthModeUpdate             -> Just NTKAll
       NTExamRegistrationActive         -> Just NTKCourseParticipant
@@ -193,6 +199,7 @@ notificationForm template = wFormToAForm $ do
       NTAllocationResults              -> Just NTKAllocationParticipant
       NTExamOfficeExamResults          -> Just $ NTKFunctionary SchoolExamOffice
       NTExamOfficeExamResultsChanged   -> Just $ NTKFunctionary SchoolExamOffice
+      NTCourseRegistered               -> Just NTKAll
       -- _other                        -> Nothing
 
     forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]

src/Handler/Utils/Invitations.hs

@@ -134,7 +134,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
     -- ^ Additional restrictions to check before allowing an user to redeem an invitation token
   , invitationForm        :: Entity (InvitationFor junction) -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction, formCtx)
     -- ^ Assimilate the additional data entered by the redeeming user
-  , invitationInsertHook  :: forall a. Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (DB a -> DB a)
+  , invitationInsertHook  :: forall a. Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (YesodJobDB UniWorX a -> YesodJobDB UniWorX a)
     -- ^ Perform additional actions before or after insertion of the junction into the database
   , invitationSuccessMsg  :: Entity (InvitationFor junction) -> Entity junction         -> DB (SomeMessage UniWorX)
     -- ^ What to tell the redeeming user after accepting the invitation
@@ -368,8 +368,8 @@ invitationR' InvitationConfig{..} = liftHandler $ do
   invitee <- requireAuthId
   cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
 
-  (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
+  (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDBJobs $ do
-    fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k)
+    fEnt@(Entity fid _) <- hoist lift (invitationResolveFor itData) >>= (\k -> Entity k <$> get404 k)
     dbData <- case ephemeralInvitation @junction of
       Nothing -> do
         Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
@@ -380,8 +380,8 @@ invitationR' InvitationConfig{..} = liftHandler $ do
     let
       iData :: InvitationData junction
       iData = review _InvitationData (dbData, itData)
-    guardAuthResult =<< invitationRestriction fEnt iData
+    guardAuthResult =<< hoist lift (invitationRestriction fEnt iData)
-    ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
+    ((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
       dataRes <- aFormToWForm $ invitationForm fEnt iData invitee
       btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
       case btnRes of
@@ -390,8 +390,8 @@ invitationR' InvitationConfig{..} = liftHandler $ do
 
     MsgRenderer mr <- getMsgRenderer
     ur <- getUrlRenderParams
-    heading <- invitationHeading fEnt iData
+    heading <- hoist lift $ invitationHeading fEnt iData
-    explanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> invitationExplanation fEnt iData
+    explanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> hoist lift (invitationExplanation fEnt iData)
 
     fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
       Nothing -> do
@@ -405,8 +405,8 @@ invitationR' InvitationConfig{..} = liftHandler $ do
           Nothing -> invalidArgsI [MsgInvitationCollision]
           Just res -> do
             deleteBy . UniqueInvitation itEmail $ invRef @junction fid
-            addMessageI Success =<< invitationSuccessMsg fEnt res
+            addMessageI Success =<< hoist lift (invitationSuccessMsg fEnt res)
-            Just <$> invitationUltDest fEnt res
+            Just <$> hoist lift (invitationUltDest fEnt res)
 
   whenIsJust tRoute redirect
 

src/Handler/Utils/Table/Pagination.hs

@@ -120,6 +120,8 @@ import Data.Dynamic
 
 import qualified Data.Csv as Csv
 
+import Jobs.Queue
+
 
 #if MIN_VERSION_base(4,11,0)
 type Monoid' = Monoid
@@ -545,7 +547,7 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
   , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) ()
   , dbtCsvClassifyAction :: csvAction -> csvActionClass
   , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
-  , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodDB UniWorX) route
+  , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route
   , dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
   , dbtCsvRenderActionClass :: csvActionClass -> Widget
   , dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
@@ -1190,7 +1192,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
               addMessageI Info MsgCsvImportAborted
               redirect $ tblLink id
           | otherwise -> FormSuccess $ do
-              finalDest <- runConduit $ C.sourceList acts .| dbtCsvExecuteActions
+              finalDest <- runDBJobs' . runConduit $ C.sourceList acts .| dbtCsvExecuteActions
               addMessageI Success . MsgCsvImportSuccessful $ length acts
               E.transactionSave
               redirect finalDest

src/Jobs/Handler/QueueNotification.hs

@@ -210,6 +210,8 @@ determineNotificationCandidates NotificationAllocationResults{..} =
     E.where_ $ isStudent E.||. isLecturer
 
     return user
+determineNotificationCandidates NotificationCourseRegistered{..} =
+  maybeToList <$> getEntity nUser
 
 
 classifyNotification :: Notification -> DB NotificationTrigger
@@ -237,3 +239,4 @@ classifyNotification NotificationAllocationUnratedApplications{}  = return NTAll
 classifyNotification NotificationExamOfficeExamResults{}          = return NTExamOfficeExamResults
 classifyNotification NotificationExamOfficeExamResultsChanged{}   = return NTExamOfficeExamResultsChanged
 classifyNotification NotificationAllocationResults{}              = return NTAllocationResults
+classifyNotification NotificationCourseRegistered{}               = return NTCourseRegistered

src/Jobs/Handler/SendNotification.hs

@@ -18,6 +18,7 @@ import Jobs.Handler.SendNotification.ExamActive
 import Jobs.Handler.SendNotification.ExamResult
 import Jobs.Handler.SendNotification.Allocation
 import Jobs.Handler.SendNotification.ExamOffice
+import Jobs.Handler.SendNotification.CourseRegistered
 
 
 dispatchJobSendNotification :: UserId -> Notification -> Handler ()

src/Jobs/Handler/SendNotification/CourseRegistered.hs

@@ -0,0 +1,35 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
+
+module Jobs.Handler.SendNotification.CourseRegistered
+  ( dispatchNotificationCourseRegistered
+  ) where
+
+import Import
+
+import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationCourseRegistered :: UserId -> CourseId -> UserId -> Handler ()
+dispatchNotificationCourseRegistered nUser nCourse jRecipient = userMailT jRecipient $ do
+  (User{..}, Course{..}) <- liftHandler . runDB $ (,) <$> getJust nUser <*> getJust nCourse
+
+  let isSelf = nUser == jRecipient 
+  
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  setSubjectI $ if
+    | isSelf    -> MsgMailSubjectCourseRegistered courseShorthand
+    | otherwise -> MsgMailSubjectCourseRegisteredOther userDisplayName courseShorthand
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+      tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+
+  editNotifications <- mkEditNotifications jRecipient
+
+  addAlternatives $
+    providePreferredAlternative ($(ihamletFile "templates/mail/courseRegistered.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Queue.hs

@@ -4,6 +4,7 @@ module Jobs.Queue
   , queueJob, queueJob'
   , YesodJobDB
   , runDBJobs, queueDBJob, sinkDBJobs
+  , runDBJobs'
   , queueDBJobCron
   , module Jobs.Types
   ) where
@@ -29,6 +30,8 @@ import qualified Data.Conduit.List as C
 import Data.Semigroup ((<>))
 
 import UnliftIO.Concurrent (myThreadId)
+
+import Control.Monad.Trans.Resource (register)
   
 
 data JobQueueException = JobQueuePoolEmpty
@@ -128,3 +131,17 @@ runDBJobs act = do
   app <- getYesod
   forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform
   return ret
+
+
+runDBJobs' :: YesodJobDB UniWorX a -> DB a
+runDBJobs' act = do
+  (ret, jIds) <- mapReaderT runWriterT act
+
+  void . liftHandler $ do
+    UnliftIO{..} <- askUnliftIO
+    register . unliftIO . runDB $
+      forM_ jIds $ \jId ->
+        whenM (existsKey jId) $
+          runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
+  
+  return ret

src/Jobs/Types.hs

@@ -88,6 +88,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationExamOfficeExamResults { nExam :: ExamId }
                   | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
                   | NotificationAllocationResults { nAllocation :: AllocationId }
+                  | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Hashable Job

src/Model/Types/Mail.hs

@@ -43,6 +43,7 @@ data NotificationTrigger
   | NTAllocationResults
   | NTExamOfficeExamResults
   | NTExamOfficeExamResultsChanged
+  | NTCourseRegistered
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 
 instance Universe NotificationTrigger

templates/mail/courseRegistered.hamlet

@@ -0,0 +1,21 @@
+$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>
+      $if isSelf
+        _{MsgMailCourseRegisteredIntro (CI.original courseName) termDesc}
+      $else
+        _{MsgMailCourseRegisteredIntroOther userDisplayName (CI.original courseName) termDesc}
+    <p>
+      <a href=@{CourseR tid ssh csh CShowR}>
+        #{courseName}
+    ^{editNotifications}