Cronjobs & notifications for sheet active/inactive
This commit is contained in:
Gregor Kleen
parent
7bdf015560
commit
99c53fee73
@ -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
|
||||
|
||||
5
models
5
models
@ -230,3 +230,8 @@ QueuedJob
|
||||
lockInstance InstanceId Maybe
|
||||
lockTime UTCTime Maybe
|
||||
deriving Eq Read Show Generic Typeable
|
||||
CronLastExec
|
||||
job Value
|
||||
time UTCTime
|
||||
instance InstanceId
|
||||
UniqueCronLastExec job
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
21
src/Cron.hs
21
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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
231
src/Jobs.hs
231
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"|]) []
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
14
templates/mail/sheetActive.hamlet
Normal file
14
templates/mail/sheetActive.hamlet
Normal file
@ -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}
|
||||
14
templates/mail/sheetInactive.hamlet
Normal file
14
templates/mail/sheetInactive.hamlet
Normal file
@ -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}
|
||||
Reference in New Issue
Block a user