diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index b6937ce3a..b83eb1cf6 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index fe9b96804..6e2baca9d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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) - => CourseId +registerUser :: 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 } diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index abb8df144..fabc5ce6a 100644 --- a/src/Handler/Course/User.hs +++ b/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 diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index a475e7ef6..9ebbc150a 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/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 diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 483071cad..8a157f72d 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 084263183..a5f49fb46 100644 --- a/src/Handler/Exam/Users.hs +++ b/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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a3f93daea..9487e9b55 100644 --- a/src/Handler/Profile.hs +++ b/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] diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index c7ea02cb3..7780709a1 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/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 - fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k) + (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDBJobs $ do + 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 - ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do + guardAuthResult =<< hoist lift (invitationRestriction fEnt iData) + ((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 - explanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> invitationExplanation fEnt iData + heading <- hoist lift $ invitationHeading 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 - Just <$> invitationUltDest fEnt res + addMessageI Success =<< hoist lift (invitationSuccessMsg fEnt res) + Just <$> hoist lift (invitationUltDest fEnt res) whenIsJust tRoute redirect diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index b62b8cc52..cf7543204 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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 diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 08a1b6ff0..8812d2f48 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/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 diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index b4cbaf0be..ef98df834 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/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 () diff --git a/src/Jobs/Handler/SendNotification/CourseRegistered.hs b/src/Jobs/Handler/SendNotification/CourseRegistered.hs new file mode 100644 index 000000000..1c2659368 --- /dev/null +++ b/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)) diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index fea68d5cc..28deae9af 100644 --- a/src/Jobs/Queue.hs +++ b/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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 85a410b89..f1768c69c 100644 --- a/src/Jobs/Types.hs +++ b/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 diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index 2ee82574f..c626bad7b 100644 --- a/src/Model/Types/Mail.hs +++ b/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 diff --git a/templates/mail/courseRegistered.hamlet b/templates/mail/courseRegistered.hamlet new file mode 100644 index 000000000..40613f52d --- /dev/null +++ b/templates/mail/courseRegistered.hamlet @@ -0,0 +1,21 @@ +$newline never +\ + + + +