From 99c53fee73a63327d03be080b739a49d05601010 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 13 Oct 2018 15:41:02 +0200 Subject: [PATCH] Cronjobs & notifications for sheet active/inactive --- messages/uniworx/de.msg | 6 + models | 7 +- package.yaml | 1 + src/Application.hs | 92 +++++------ src/Cron.hs | 21 +-- src/Cron/Types.hs | 10 -- src/Jobs.hs | 231 ++++++++++++++++++++-------- src/Jobs/Types.hs | 2 + src/Model/Types.hs | 4 + src/Model/Types/JSON.hs | 2 +- templates/mail/sheetActive.hamlet | 14 ++ templates/mail/sheetInactive.hamlet | 14 ++ 12 files changed, 266 insertions(+), 138 deletions(-) create mode 100644 templates/mail/sheetActive.hamlet create mode 100644 templates/mail/sheetInactive.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 86bf5c732..8fa5ea174 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -322,6 +322,12 @@ GermanGermany: Deutsch (Deutschland) MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde bewertet MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde bewertet. +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. + +MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden +MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können #{sheetName} im Kurs #{courseName} (#{termDesc}) nur noch kurze Zeit abgeben. + SheetTypeBonus: Bonus SheetTypeNormal: Normal SheetTypePass: Bestehen diff --git a/models b/models index 048b2876c..c4dca6cac 100644 --- a/models +++ b/models @@ -229,4 +229,9 @@ QueuedJob creationTime UTCTime lockInstance InstanceId Maybe lockTime UTCTime Maybe - deriving Eq Read Show Generic Typeable \ No newline at end of file + deriving Eq Read Show Generic Typeable +CronLastExec + job Value + time UTCTime + instance InstanceId + UniqueCronLastExec job \ No newline at end of file diff --git a/package.yaml b/package.yaml index 3fce97630..c240d4fc0 100644 --- a/package.yaml +++ b/package.yaml @@ -102,6 +102,7 @@ dependencies: - mime-mail - hashable - aeson-pretty +- resourcet # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Application.hs b/src/Application.hs index bf77cecc9..bdbed1b60 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Application ( getApplicationDev, getAppDevSettings @@ -12,10 +13,10 @@ module Application , develMain , makeFoundation , makeLogWare - -- * for DevelMain - , foundationStoreNum - , getApplicationRepl - , shutdownApp + -- -- * for DevelMain + -- , foundationStoreNum + -- , getApplicationRepl + -- , shutdownApp -- * for GHCI , handler , db @@ -58,6 +59,8 @@ import Network.HaskellNet.SSL hiding (Settings) import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings) import Data.Pool +import Control.Monad.Trans.Resource + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -83,18 +86,16 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeFoundation :: AppSettings -> IO UniWorX +makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX makeFoundation appSettings@(AppSettings{..}) = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager - appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger - appStatic <- - (if appMutableStatic then staticDevel else static) - appStaticDir + appLogger <- liftIO $ newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir appCryptoIDKey <- readKeyFile appCryptoIDKeyFile - appInstanceID <- maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile + appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do chan <- newBroadcastTMChan @@ -132,8 +133,8 @@ makeFoundation appSettings@(AppSettings{..}) = do -- Return the foundation return $ mkFoundation sqlPool smtpPool -readInstanceIDFile :: FilePath -> IO UUID -readInstanceIDFile idFile = handle generateInstead $ LBS.readFile idFile >>= parseBS +readInstanceIDFile :: MonadIO m => FilePath -> m UUID +readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS where parseBS :: LBS.ByteString -> IO UUID parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString @@ -174,15 +175,15 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. -makeApplication :: UniWorX -> IO Application -makeApplication foundation = do +makeApplication :: MonadIO m => UniWorX -> m Application +makeApplication foundation = liftIO $ do logWare <- makeLogWare foundation -- Create the WAI application and apply middlewares appPlain <- toWaiAppPlain foundation return $ logWare $ defaultMiddlewaresNoLogging appPlain -makeLogWare :: UniWorX -> IO Middleware -makeLogWare foundation = +makeLogWare :: MonadIO m => UniWorX -> m Middleware +makeLogWare foundation = liftIO $ mkRequestLogger def { outputFormat = if appDetailedRequestLogging $ appSettings foundation @@ -211,26 +212,29 @@ warpSettings foundation = defaultSettings -- | For yesod devel, return the Warp settings and WAI Application. -getApplicationDev :: IO (Settings, Application) +getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application) getApplicationDev = do settings <- getAppDevSettings foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation + wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation return (wsettings, app) -getAppDevSettings :: IO AppSettings -getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppDevSettings :: MonadIO m => m AppSettings +getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv -- | main function for use by yesod devel develMain :: IO () -develMain = develMainHelper getApplicationDev +develMain = runResourceT $ do + app <- getApplicationDev + liftIO . develMainHelper $ return app -- | The @main@ function for an executable running this site. -appMain :: IO () -appMain = do +appMain :: MonadResourceBase m => m () +appMain = runResourceT $ do -- Get the settings from all relevant sources - settings <- loadYamlSettingsArgs + settings <- liftIO $ + loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime [configSettingsYmlValue] @@ -244,31 +248,31 @@ appMain = do app <- makeApplication foundation -- Run the application with Warp - runSettings (warpSettings foundation) app + liftIO $ runSettings (warpSettings foundation) app --------------------------------------------------------------- --- Functions for DevelMain.hs (a way to run the app from GHCi) --------------------------------------------------------------- -foundationStoreNum :: Word32 -foundationStoreNum = 2 +-- -------------------------------------------------------------- +-- -- Functions for DevelMain.hs (a way to run the app from GHCi) +-- -------------------------------------------------------------- +-- foundationStoreNum :: Word32 +-- foundationStoreNum = 2 -getApplicationRepl :: IO (Int, UniWorX, Application) -getApplicationRepl = do - settings <- getAppDevSettings - foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation - app1 <- makeApplication foundation +-- getApplicationRepl :: IO (Int, UniWorX, Application) +-- getApplicationRepl = do +-- settings <- getAppDevSettings +-- foundation <- makeFoundation settings +-- wsettings <- getDevSettings $ warpSettings foundation +-- app1 <- makeApplication foundation - let foundationStore = Store foundationStoreNum - deleteStore foundationStore - writeStore foundationStore foundation +-- let foundationStore = Store foundationStoreNum +-- deleteStore foundationStore +-- writeStore foundationStore foundation - return (getPort wsettings, foundation, app1) +-- return (getPort wsettings, foundation, app1) -shutdownApp :: UniWorX -> IO () -shutdownApp UniWorX{..} = do - atomically $ mapM_ closeTMChan appJobCtl +-- shutdownApp :: UniWorX -> IO () +-- shutdownApp UniWorX{..} = do +-- atomically $ mapM_ closeTMChan appJobCtl --------------------------------------------- @@ -277,7 +281,7 @@ shutdownApp UniWorX{..} = do -- | Run a handler handler :: Handler a -> IO a -handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h +handler h = runResourceT $ liftIO getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a diff --git a/src/Cron.hs b/src/Cron.hs index ceb86510e..6ded8a6ec 100644 --- a/src/Cron.hs +++ b/src/Cron.hs @@ -8,8 +8,7 @@ #-} module Cron - ( matchesCron - , CronNextMatch(..) + ( CronNextMatch(..) , nextCronMatch , module Cron.Types ) where @@ -204,21 +203,3 @@ nextCronMatch tz mPrev now c@Cron{..} localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) return $ localTimeToUTCTZ tz LocalTime{..} - -matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry - -> Maybe UTCTime -- ^ Previous execution of the job - -> NominalDiffTime -- ^ Approximate time until next check - -> UTCTime -- ^ "Current" time - -> Cron - -> Bool --- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron` --- specification @c@ should match @now@, under the assumption that the next --- check will occur no earlier than @now + prec@. -matchesCron tz mPrev prec now cron@Cron{cronOffset} = case nextCronMatch tz mPrev now cron of - MatchAsap -> True - MatchNone -> False - MatchAt ts -> ts < toT - where - toT = case cronOffset of - CronScheduleBefore -> addUTCTime prec now - CronScheduleAfter -> now diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs index d9cfbf67f..283edce87 100644 --- a/src/Cron/Types.hs +++ b/src/Cron/Types.hs @@ -5,7 +5,6 @@ module Cron.Types ( Cron(..), Crontab - , CronScheduleOffset(..) , CronMatch(..) , CronAbsolute(..) , CronPeriod(..) @@ -23,14 +22,6 @@ import Numeric.Natural import Data.HashMap.Strict (HashMap) --- | When the scheduled time for a job falls between two wakeups of the timing --- thread, execute the job on the wakeup before or after the scheduled time -data CronScheduleOffset - = CronScheduleBefore | CronScheduleAfter - deriving (Eq, Ord, Show, Read, Enum, Bounded) - -makePrisms ''CronScheduleOffset - data CronMatch = CronMatchAny | CronMatchNone @@ -67,7 +58,6 @@ makeLenses_ ''CronPeriod data Cron = Cron { cronInitial :: CronAbsolute , cronRepeat :: Maybe CronPeriod - , cronOffset :: CronScheduleOffset } deriving (Eq, Show) diff --git a/src/Jobs.hs b/src/Jobs.hs index 089a4fcab..9155d59a6 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -13,7 +13,7 @@ #-} module Jobs - ( module Jobs.Types + ( module Types , writeJobCtl , queueJob, queueJob' , handleJobs @@ -23,7 +23,8 @@ import Import hiding ((.=), Proxy) import Handler.Utils.Mail import Handler.Utils.DateTime -import Jobs.Types +import Jobs.Types as Types hiding (JobCtl(JobCtlQueue)) +import Jobs.Types (JobCtl(JobCtlQueue)) import Data.Conduit.TMChan import qualified Data.Conduit.List as C @@ -32,6 +33,7 @@ import qualified Data.Text.Lazy as LT import Data.Aeson (fromJSON, toJSON) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson import Database.Persist.Sql (executeQQ, fromSqlKey, transactionSave) import Data.Monoid (Last(..)) @@ -63,6 +65,7 @@ import Control.Monad.Trans.State (StateT, evalStateT, mapStateT) import qualified Control.Monad.State.Class as State import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate) import Control.Monad.Random (MonadRandom(..), evalRand) @@ -80,24 +83,25 @@ data JobQueueException = JInvalid QueuedJobId QueuedJob instance Exception JobQueueException -handleJobs :: MonadIO m => [TMChan JobCtl] -> UniWorX -> m () +handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m () -- | Read control commands from `appJobCtl` and address them as they come in -- -- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders. -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ... -handleJobs recvChans foundation@UniWorX{..} = liftIO $ do - jobCrontab <- newTVarIO HashMap.empty - jobConfirm <- newTVarIO HashMap.empty +handleJobs recvChans foundation@UniWorX{..} = do + jobCrontab <- liftIO $ newTVarIO HashMap.empty + jobConfirm <- liftIO $ newTVarIO HashMap.empty forM_ (zip [1..] recvChans) $ \(n, chan) -> let logStart = $logDebugS ("Jobs #" <> tshow n) "Starting" logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping" - in void . fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n + doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n + in void $ allocate (liftIO doFork) (liftIO . killThread) -- Start cron operation - void . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..} - unsafeHandler foundation . flip runReaderT JobContext{..} $ + void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread) + liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ writeJobCtlBlock JobCtlDetermineCrontab @@ -105,9 +109,18 @@ execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) () -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have -- seen, wait for the time of the next job and fire it execCrontab = flip evalStateT HashMap.empty . forever $ do + mapStateT (liftHandlerT . runDB . setSerializable) $ do + let + merge (Entity leId CronLastExec{..}) + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime) + | otherwise = lift $ delete leId + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge + now <- liftIO getCurrentTime (currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do crontab <- liftBase . readTVar =<< asks jobCrontab + State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab prevExec <- State.get case earliestJob prevExec crontab now of Nothing -> liftBase retry @@ -115,9 +128,30 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do Just x -> return (crontab, x) let doJob = do - now <- liftIO $ getCurrentTime - State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl - writeJobCtl jobCtl + mJid <- mapStateT (mapReaderT $ liftHandlerT . runDB . setSerializable) $ do + newCrontab <- lift . lift $ determineCrontab + if + | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab + -> do + now <- liftIO $ getCurrentTime + instanceID <- getsYesod appInstanceID + State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl + case jobCtl of + JobCtlQueue job -> do + lift . lift $ upsertBy + (UniqueCronLastExec $ toJSON job) + CronLastExec + { cronLastExecJob = toJSON job + , cronLastExecTime = now + , cronLastExecInstance = instanceID + } + [ CronLastExecTime =. now ] + Just <$> lift (lift $ queueJobUnsafe job) + other -> Nothing <$ writeJobCtl other + | otherwise + -> lift . fmap (const Nothing) . mapReaderT (liftIO . atomically) $ + lift . flip writeTVar newCrontab =<< asks jobCrontab + maybe (return ()) (writeJobCtl . JobCtlPerform) mJid case nextMatch of MatchAsap -> doJob @@ -151,48 +185,21 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do where t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron - waitUntil :: (Eq a, MonadIO m) => TVar a -> a -> UTCTime -> m Bool - waitUntil crontabTV crontab nextTime = liftIO $ do - diffT <- diffUTCTime nextTime <$> getCurrentTime + waitUntil :: (Eq a, MonadResourceBase m) => TVar a -> a -> UTCTime -> m Bool + waitUntil crontabTV crontab nextTime = runResourceT $ do + diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime if | diffT < acc -> return True | otherwise -> do - retVar <- newEmptyTMVarIO - delayThread <- forkFinally (threadDelay . floor $ toRational acc * 1e6) (atomically . putTMVar retVar) + retVar <- liftIO newEmptyTMVarIO + void $ allocate (liftIO $ forkFinally (threadDelay . floor $ toRational acc * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread) let awaitDelayThread = False <$ takeTMVar retVar awaitCrontabChange = do crontab' <- readTVar crontabTV True <$ guard (crontab /= crontab') - crontabChanged <- atomically $ awaitCrontabChange <|> awaitDelayThread - bool (waitUntil crontabTV crontab nextTime) (False <$ killThread delayThread) crontabChanged - - -determineCrontab :: Handler (Crontab JobCtl) -determineCrontab = execWriterT $ do - AppSettings{..} <- getsYesod appSettings - - case appJobFlushInterval of - Just interval -> tell $ HashMap.singleton - JobCtlFlush - Cron - { cronInitial = CronAsap - , cronRepeat = Just CronPeriod - { cronMinInterval = interval - , cronNext = CronAsap - } - , cronOffset = CronScheduleBefore - } - Nothing -> return () - - now <- liftIO getCurrentTime - tell $ HashMap.singleton - JobCtlDetermineCrontab - Cron - { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appJobCronInterval now - , cronRepeat = Nothing - , cronOffset = CronScheduleBefore - } + crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread + bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) () @@ -227,10 +234,10 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do performJob content - -- `performJob` is expected to throw a notification if it detects that the job was not done + -- `performJob` is expected to throw an exception if it detects that the job was not done runDB $ delete jId handleCmd JobCtlDetermineCrontab = do - newCTab <- lift determineCrontab + newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab $logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . flip writeTVar newCTab =<< asks jobCrontab @@ -303,20 +310,88 @@ queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform setSerializable :: DB a -> DB a setSerializable = ([executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *>) + +determineCrontab :: DB (Crontab JobCtl) +-- ^ Extract all future jobs from the database (sheet deadlines, ...) +determineCrontab = execWriterT $ do + AppSettings{..} <- getsYesod appSettings + + case appJobFlushInterval of + Just interval -> tell $ HashMap.singleton + JobCtlFlush + Cron + { cronInitial = CronAsap + , cronRepeat = Just CronPeriod + { cronMinInterval = interval + , cronNext = CronAsap + } + } + Nothing -> return () + + now <- liftIO getCurrentTime + tell $ HashMap.singleton + JobCtlDetermineCrontab + Cron + { cronInitial = CronAsap + , cronRepeat = Just CronPeriod + { cronMinInterval = appJobCronInterval + , cronNext = CronAsap + } + } + + let + sheetJobs (Entity nSheet Sheet{..}) = do + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom + , cronRepeat = Nothing + } + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..}) + Cron + { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo + , cronRepeat = Nothing + } + + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs + + +determineNotificationCandidates :: Notification -> DB [Entity User] +determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do + E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission + return user +determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse + E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ sheet E.^. SheetId E.==. E.val nSheet + return user +determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse + E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ sheet E.^. SheetId E.==. E.val nSheet + return user + +classifyNotification :: Notification -> DB NotificationTrigger +classifyNotification NotificationSubmissionRated{..} = do + Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission + return $ case sheetType of + NotGraded -> NTSubmissionRated + _other -> NTSubmissionRatedGraded +classifyNotification NotificationSheetActive{} = return NTSheetActive +classifyNotification NotificationSheetInactive{} = return NTSheetInactive + + performJob :: Job -> HandlerT UniWorX IO () -performJob JobQueueNotification{ jNotification = n@NotificationSubmissionRated{..} } = do - jIds <- runDB . setSerializable $ do - Submission{submissionSheet} <- getJust nSubmission - isGraded <- (/= NotGraded) . sheetType <$> getJust submissionSheet - res <- E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do - E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission - return (user E.^. UserId, user E.^. UserNotificationSettings) - let recipients = do - (E.Value uid, E.Value nSettings) <- res - guard . notificationAllowed nSettings $ bool NTSubmissionRated NTSubmissionRatedGraded isGraded - return uid - forM recipients $ queueJobUnsafe . flip JobSendNotification n +performJob JobQueueNotification{jNotification} = do + jIds <- runDB. setSerializable $ do + candidates <- determineNotificationCandidates jNotification + nClass <- classifyNotification jNotification + mapM (queueJobUnsafe . flip JobSendNotification jNotification) $ do + Entity uid User{userNotificationSettings} <- candidates + guard $ notificationAllowed userNotificationSettings nClass + return uid forM_ jIds $ writeJobCtl . JobCtlPerform performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, jRecipient } = userMailT jRecipient $ do (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do @@ -353,7 +428,39 @@ performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, , "course-school" Aeson..= courseSchool ] -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements - providePreferredAlternative $ \(MsgRenderer mr) -> ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) +performJob JobSendNotification{ jNotification = NotificationSheetActive{..}, jRecipient } = userMailT jRecipient $ do + (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + return (course, sheet) + setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) +performJob JobSendNotification{ jNotification = NotificationSheetInactive{..}, jRecipient } = userMailT jRecipient $ do + (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + return (course, sheet) + setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) performJob JobSendTestEmail{..} = mailT jMailContext $ do _mailTo .= [Address Nothing jEmail] setSubjectI MsgMailTestSubject diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 99cfee4cd..59ad06e2f 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -23,6 +23,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobQueueNotification { jNotification :: Notification } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } + | NotificationSheetActive { nSheet :: SheetId } + | NotificationSheetInactive { nSheet :: SheetId } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Hashable Job diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 48c60a44c..87d6d579d 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -467,6 +467,8 @@ derivePersistFieldJSON ''Value -- Could maybe be replaced with `Structure Notification` in the long term data NotificationTrigger = NTSubmissionRatedGraded | NTSubmissionRated + | NTSheetActive + | NTSheetInactive deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe NotificationTrigger @@ -493,6 +495,8 @@ instance Default NotificationSettings where def = NotificationSettings $ \case NTSubmissionRatedGraded -> True NTSubmissionRated -> False + NTSheetActive -> True + NTSheetInactive -> True instance ToJSON NotificationSettings where toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs index 655c95294..dc5a5eec6 100644 --- a/src/Model/Types/JSON.hs +++ b/src/Model/Types/JSON.hs @@ -50,7 +50,7 @@ derivePersistFieldJSON n = do ] , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t) [ funD (mkName "sqlType") - [ clause [wildP] (normalB [e|SqlOther "json"|]) [] + [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) [] ] ] ] diff --git a/templates/mail/sheetActive.hamlet b/templates/mail/sheetActive.hamlet new file mode 100644 index 000000000..384b2c516 --- /dev/null +++ b/templates/mail/sheetActive.hamlet @@ -0,0 +1,14 @@ + + +