Cronjobs & notifications for sheet active/inactive

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

models

@@ -229,4 +229,9 @@ QueuedJob
     creationTime        UTCTime
     lockInstance        InstanceId Maybe
     lockTime            UTCTime Maybe
-    deriving Eq Read Show Generic Typeable
+    deriving Eq Read Show Generic Typeable
+CronLastExec
+    job                 Value
+    time                UTCTime
+    instance            InstanceId
+    UniqueCronLastExec job

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.

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
+    -- -- * for DevelMain
-    , foundationStoreNum
+    -- , foundationStoreNum
-    , getApplicationRepl
+    -- , getApplicationRepl
-    , shutdownApp
+    -- , 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
+    appLogger <- liftIO $ newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
-    appStatic <-
+    appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
-        (if appMutableStatic then staticDevel else static)
-        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 :: MonadIO m => FilePath -> m UUID
-readInstanceIDFile idFile = handle generateInstead $ LBS.readFile idFile >>= parseBS
+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 :: MonadIO m => UniWorX -> m Application
-makeApplication foundation = do
+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 :: MonadIO m => UniWorX -> m Middleware
-makeLogWare foundation =
+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 :: MonadIO m => m AppSettings
-getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
+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 :: MonadResourceBase m => m ()
-appMain = do
+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)
+-- -- Functions for DevelMain.hs (a way to run the app from GHCi)
---------------------------------------------------------------
+-- --------------------------------------------------------------
-foundationStoreNum :: Word32
+-- foundationStoreNum :: Word32
-foundationStoreNum = 2
+-- foundationStoreNum = 2
   
-getApplicationRepl :: IO (Int, UniWorX, Application)
+-- getApplicationRepl :: IO (Int, UniWorX, Application)
-getApplicationRepl = do
+-- getApplicationRepl = do
-    settings <- getAppDevSettings
+--     settings <- getAppDevSettings
-    foundation <- makeFoundation settings
+--     foundation <- makeFoundation settings
-    wsettings <- getDevSettings $ warpSettings foundation
+--     wsettings <- getDevSettings $ warpSettings foundation
-    app1 <- makeApplication foundation
+--     app1 <- makeApplication foundation
 
-    let foundationStore = Store foundationStoreNum
+--     let foundationStore = Store foundationStoreNum
-    deleteStore foundationStore
+--     deleteStore foundationStore
-    writeStore foundationStore foundation
+--     writeStore foundationStore foundation
   
-    return (getPort wsettings, foundation, app1)
+--     return (getPort wsettings, foundation, app1)
 
-shutdownApp :: UniWorX -> IO ()
+-- shutdownApp :: UniWorX -> IO ()
-shutdownApp UniWorX{..} = do
+-- shutdownApp UniWorX{..} = do
-  atomically $ mapM_ closeTMChan appJobCtl
+--   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

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

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)
 

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
+handleJobs recvChans foundation@UniWorX{..} = do
-  jobCrontab <- newTVarIO HashMap.empty
+  jobCrontab <- liftIO $ newTVarIO HashMap.empty
-  jobConfirm <- 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{..}
+  void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
-  unsafeHandler foundation . flip runReaderT JobContext{..} $
+  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
+        mJid <- mapStateT (mapReaderT $ liftHandlerT . runDB . setSerializable) $ do
-        State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
+          newCrontab <- lift . lift $ determineCrontab
-        writeJobCtl jobCtl
+          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 :: (Eq a, MonadResourceBase m) => TVar a -> a -> UTCTime -> m Bool
-    waitUntil crontabTV crontab nextTime = liftIO $ do
+    waitUntil crontabTV crontab nextTime = runResourceT $ do
-      diffT <- diffUTCTime nextTime <$> getCurrentTime
+      diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
       if
         | diffT < acc -> return True
         | otherwise   -> do
-            retVar <- newEmptyTMVarIO
+            retVar <- liftIO newEmptyTMVarIO
-            delayThread <- forkFinally (threadDelay . floor $ toRational acc * 1e6) (atomically . putTMVar retVar)
+            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
+            crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
-            bool (waitUntil crontabTV crontab nextTime) (False <$ killThread delayThread) crontabChanged
+            bool (waitUntil crontabTV crontab nextTime) (return False) 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
-      }
 
 
 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
+performJob JobQueueNotification{jNotification} = do
-  jIds <- runDB . setSerializable $ do
+  jIds <- runDB. setSerializable $ do
-    Submission{submissionSheet} <- getJust nSubmission
+    candidates <- determineNotificationCandidates jNotification
-    isGraded <- (/= NotGraded) . sheetType <$> getJust submissionSheet
+    nClass <- classifyNotification jNotification
-    res <- E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
+    mapM (queueJobUnsafe . flip JobSendNotification jNotification) $ do
-      E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
+      Entity uid User{userNotificationSettings} <- candidates
-      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
+      guard $ notificationAllowed userNotificationSettings nClass
-      return (user E.^. UserId, user E.^. UserNotificationSettings)
+      return uid
-    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
   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

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

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

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"|]) []
         ]
       ]
     ]

templates/mail/sheetActive.hamlet

@@ -0,0 +1,14 @@
+<html>
+  <head>
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSheetActiveIntro (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SShowR}>
+        #{sheetName}

templates/mail/sheetInactive.hamlet

@@ -0,0 +1,14 @@
+<html>
+  <head>
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSheetInactiveIntro (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SShowR}>
+        #{sheetName}