605 lines
30 KiB
Haskell
605 lines
30 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-incomplete-record-updates #-}
|
|
|
|
module Jobs.Crontab
|
|
( determineCrontab
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import Jobs.Types
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Ratio ((%))
|
|
import Data.Time.Zones
|
|
import Data.Time.Clock.POSIX
|
|
|
|
import Handler.Utils.DateTime
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Jobs.Handler.Intervals.Utils
|
|
|
|
import System.IO.Unsafe
|
|
|
|
import Crypto.Hash (hashDigestSize, digestFromByteString)
|
|
|
|
import Data.List (iterate)
|
|
|
|
{-# NOINLINE prewarmCacheIntervalsCache #-}
|
|
prewarmCacheIntervalsCache :: TVar (Map Natural [(Maybe FileContentChunkReference, Maybe FileContentChunkReference)])
|
|
prewarmCacheIntervalsCache = unsafePerformIO $ newTVarIO Map.empty
|
|
|
|
determineCrontab :: ReaderT SqlReadBackend (HandlerFor UniWorX) (Crontab JobCtl)
|
|
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
|
|
determineCrontab = execWriterT $ do
|
|
UniWorX{ appSettings' = AppSettings{..} } <- getYesod
|
|
|
|
whenIsJust appJobCronInterval $ \interval ->
|
|
tell $ HashMap.singleton
|
|
JobCtlDetermineCrontab
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = interval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
tell . flip foldMap universeF $ \kind ->
|
|
case appHealthCheckInterval kind of
|
|
Just int -> HashMap.singleton
|
|
(JobCtlGenerateHealthReport kind)
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = int
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
Nothing -> mempty
|
|
|
|
let
|
|
tellPrewarmJobs :: JobCtlPrewarmSource -> UTCTime -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
|
|
tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT_ $ do
|
|
PrewarmCacheConf{..} <- hoistMaybe appFileSourcePrewarmConf
|
|
|
|
let
|
|
chunkHashBytes :: forall h.
|
|
( Unwrapped FileContentChunkReference ~ Digest h )
|
|
=> Integer
|
|
chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h))
|
|
intervals <- mkIntervalsCached prewarmCacheIntervalsCache chunkHashBytes (fmap (review _Wrapped) . digestFromByteString) precSteps
|
|
|
|
let step = realToFrac $ toRational (precStart - precEnd) / toRational precSteps
|
|
step' = realToFrac $ toRational step / precMaxSpeedup
|
|
|
|
mapM_ tell
|
|
[ HashMap.singleton
|
|
JobCtlPrewarmCache{..}
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ ts
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = step'
|
|
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ ts'
|
|
}
|
|
| jcChunkInterval <- intervals
|
|
| ts <- iterate (addUTCTime step) $ addUTCTime (-precStart) jcTargetTime
|
|
| ts' <- iterate (addUTCTime step') $ addUTCTime (subtract precStart . realToFrac $ toRational (precStart - precEnd) * (1 - recip precMaxSpeedup)) jcTargetTime
|
|
]
|
|
|
|
lift . maybeT_ $ do
|
|
injectInterval <- fmap abs . MaybeT . getsYesod $ view _appInjectFiles
|
|
tell $ HashMap.singleton
|
|
JobCtlInhibitInject{..}
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime (negate $ precStart + injectInterval + 10) jcTargetTime
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = injectInterval / 2
|
|
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime (precInhibit - precStart) jcTargetTime
|
|
}
|
|
|
|
let
|
|
sheetJobs (Entity nSheet Sheet{..}) = do
|
|
for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> do
|
|
tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetExercise) aFrom
|
|
|
|
when (isn't _JobsOffload appJobMode) $ do
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aFrom
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
|
|
}
|
|
for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> do
|
|
tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetHint) hFrom
|
|
|
|
when (isn't _JobsOffload appJobMode) . maybeT_ $ do
|
|
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom hFrom) > 300) sheetActiveFrom
|
|
guardM $ or2M (return $ maybe True (\sFrom -> abs (diffUTCTime sFrom hFrom) > 300) sheetSolutionFrom)
|
|
(fmap not . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet])
|
|
guardM . lift . lift $ exists [SheetFileType ==. SheetHint, SheetFileSheet ==. nSheet]
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetHint{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ hFrom
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
|
|
}
|
|
for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> do
|
|
tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetSolution) sFrom
|
|
|
|
when (isn't _JobsOffload appJobMode) . maybeT_ $ do
|
|
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom sFrom) > 300) sheetActiveFrom
|
|
guardM . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet]
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetSolution{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sFrom
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left nominalDay
|
|
}
|
|
when (isn't _JobsOffload appJobMode) $ do
|
|
for_ sheetActiveTo $ \aTo -> do
|
|
whenIsJust (max aTo <$> sheetVisibleFrom) $ \aTo' -> do
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . maybe id max sheetActiveFrom $ addUTCTime (-nominalDay) aTo'
|
|
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ aTo
|
|
}
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
when sheetAutoDistribute $
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobDistributeCorrections nSheet)
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
|
|
, cronNotAfter = Left nominalDay
|
|
}
|
|
|
|
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
|
|
|
|
|
when (isn't _JobsOffload appJobMode) $ do
|
|
case appJobFlushInterval of
|
|
Just interval | maybe True (> 0) appJobMaxFlush -> tell $ HashMap.singleton
|
|
JobCtlFlush
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = interval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
_other -> return ()
|
|
|
|
oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1]
|
|
whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton
|
|
(JobCtlQueue JobPruneInvitations)
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTime oldestInvUTC
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = nominalDay
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
oldestSessionFile <- lift $ preview (_head . _entityVal . _sessionFileTouched) <$> selectList [] [Asc SessionFileTouched, LimitTo 1]
|
|
whenIsJust oldestSessionFile $ \oldest -> tell $ HashMap.singleton
|
|
(JobCtlQueue JobPruneSessionFiles)
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appSessionFilesExpire oldest
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appSessionFilesExpire / 2
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
oldestFallbackPersonalisedSheetFilesKey <- lift $ preview (_head . _entityVal . _fallbackPersonalisedSheetFilesKeyGenerated) <$> selectList [] [Asc FallbackPersonalisedSheetFilesKeyGenerated, LimitTo 1]
|
|
whenIsJust oldestFallbackPersonalisedSheetFilesKey $ \oldest -> tell $ HashMap.singleton
|
|
(JobCtlQueue JobPruneFallbackPersonalisedSheetFilesKeys)
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appFallbackPersonalisedSheetFilesKeysExpire oldest
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appFallbackPersonalisedSheetFilesKeysExpire / 2
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
oldestSentMail <- lift $ preview (_head . _entityVal . _sentMailSentAt) <$> selectList [] [Asc SentMailSentAt, LimitTo 1]
|
|
whenIsJust ((,) <$> appMailRetainSent <*> oldestSentMail) $ \(retain, oldest) -> tell $ HashMap.singleton
|
|
(JobCtlQueue JobPruneOldSentMails)
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime retain oldest
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = retain / 2
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
|
|
whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobInjectFiles)
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = iInterval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
whenIsJust appRechunkFiles $ \rInterval ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobRechunkFiles)
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = rInterval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
whenIsJust appCheckMissingFiles $ \rInterval ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobDetectMissingFiles)
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = rInterval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
let newyear = cronCalendarAny
|
|
{ cronDayOfYear = cronMatchOne 1
|
|
}
|
|
in tell $ HashMap.singleton
|
|
(JobCtlQueue JobTruncateTransactionLog)
|
|
Cron
|
|
{ cronInitial = newyear
|
|
, cronRepeat = CronRepeatScheduled newyear
|
|
, cronRateLimit = minNominalYear
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
oldestLogEntry <- fmap listToMaybe . lift . E.select . E.from $ \transactionLog -> do
|
|
E.where_ . E.not_ . E.isNothing $ transactionLog E.^. TransactionLogRemote
|
|
E.orderBy [E.asc $ transactionLog E.^. TransactionLogTime]
|
|
E.limit 1
|
|
return $ transactionLog E.^. TransactionLogTime
|
|
for_ oldestLogEntry $ \(E.Value oldestEntry) ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobDeleteTransactionLogIPs)
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appTransactionLogIPRetentionTime oldestEntry
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = nominalDay
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
let
|
|
getNextIntervals within interval cInterval = do
|
|
now <- liftIO getPOSIXTime
|
|
return $ do
|
|
let
|
|
epochInterval = within / 2
|
|
(currEpoch, epochNow) = now `divMod'` epochInterval
|
|
currInterval = epochNow `div'` interval
|
|
numIntervals = max 1 . floor $ epochInterval / interval
|
|
n = ceiling $ 4 * cInterval / interval
|
|
i <- [ negate (ceiling $ n % 2) .. ceiling $ n % 2 ]
|
|
let
|
|
((+ currEpoch) -> nextEpoch, nextInterval) = (currInterval + i) `divMod` numIntervals
|
|
nextIntervalTime
|
|
= posixSecondsToUTCTime $ fromInteger nextEpoch * epochInterval + fromInteger nextInterval * interval
|
|
return (nextEpoch, nextInterval, nextIntervalTime, numIntervals)
|
|
|
|
if
|
|
| is _Just appLdapConf
|
|
, Just syncWithin <- appSynchroniseLdapUsersWithin
|
|
, Just cInterval <- appJobCronInterval
|
|
-> do
|
|
nextIntervals <- getNextIntervals syncWithin appSynchroniseLdapUsersInterval cInterval
|
|
|
|
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobSynchroniseLdap
|
|
{ jEpoch = fromInteger nextEpoch
|
|
, jNumIterations = fromInteger numIntervals
|
|
, jIteration = fromInteger nextInterval
|
|
})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ toTimeOfDay 23 30 0 $ utctDay nextIntervalTime
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appSynchroniseLdapUsersInterval
|
|
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appSynchroniseLdapUsersInterval nextIntervalTime
|
|
}
|
|
| otherwise
|
|
-> return ()
|
|
|
|
if
|
|
| is _Just appAvsConf
|
|
, Just syncWithin <- appSynchroniseAvsUsersWithin
|
|
, Just cInterval <- appJobCronInterval
|
|
-> do
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
nextIntervals <- getNextIntervals syncWithin appSynchroniseAvsUsersInterval cInterval
|
|
|
|
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobSynchroniseAvs
|
|
{ jEpoch = fromInteger nextEpoch
|
|
, jNumIterations = fromInteger numIntervals
|
|
, jIteration = fromInteger nextInterval
|
|
, jSynchAfter = Just $ addDays (-7) nowaday -- at most once per week
|
|
})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ toTimeOfDay 22 0 0 $ utctDay nextIntervalTime
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appSynchroniseAvsUsersInterval
|
|
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appSynchroniseAvsUsersInterval nextIntervalTime
|
|
}
|
|
| otherwise
|
|
-> return ()
|
|
|
|
whenIsJust ((,) <$> appPruneUnreferencedFilesWithin <*> appJobCronInterval) $ \(within, cInterval) -> do
|
|
nextIntervals <- getNextIntervals within appPruneUnreferencedFilesInterval cInterval
|
|
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobPruneUnreferencedFiles
|
|
{ jEpoch = fromInteger nextEpoch
|
|
, jNumIterations = fromInteger numIntervals
|
|
, jIteration = fromInteger nextInterval
|
|
}
|
|
)
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ toTimeOfDay 22 0 0 $ utctDay nextIntervalTime
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appPruneUnreferencedFilesInterval
|
|
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appPruneUnreferencedFilesInterval nextIntervalTime
|
|
}
|
|
|
|
-- whenIsJust ((,) <$> appStudyFeaturesRecacheRelevanceWithin <*> appJobCronInterval) $ \(within, cInterval) -> do
|
|
-- nextIntervals <- getNextIntervals within appStudyFeaturesRecacheRelevanceInterval cInterval
|
|
-- forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
|
|
-- tell $ HashMap.singleton
|
|
-- (JobCtlQueue JobStudyFeaturesRecacheRelevance
|
|
-- { jEpoch = fromInteger nextEpoch
|
|
-- , jNumIterations = fromInteger numIntervals
|
|
-- , jIteration = fromInteger nextInterval
|
|
-- }
|
|
-- )
|
|
-- Cron
|
|
-- { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ toTimeOfDay 22 0 0 $ utctDay nextIntervalTime
|
|
-- , cronRepeat = CronRepeatNever
|
|
-- , cronRateLimit = appStudyFeaturesRecacheRelevanceInterval
|
|
-- , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appStudyFeaturesRecacheRelevanceInterval nextIntervalTime
|
|
-- }
|
|
|
|
|
|
whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton
|
|
(JobCtlQueue JobLmsQualificationsEnqueue)
|
|
Cron
|
|
{ cronInitial = CronAsap -- time after scheduling
|
|
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
|
|
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
|
, cronMinute = cronMatchOne 2
|
|
, cronSecond = cronMatchOne 27
|
|
}
|
|
, cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped
|
|
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
|
}
|
|
|
|
whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton
|
|
(JobCtlQueue JobLmsQualificationsDequeue)
|
|
Cron
|
|
{ cronInitial = CronAsap -- time after scheduling
|
|
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
|
|
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
|
, cronMinute = cronMatchOne 7
|
|
, cronSecond = cronMatchOne 27
|
|
}
|
|
, cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped
|
|
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
|
}
|
|
|
|
let
|
|
correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
|
|
correctorNotifications = (tell .) . Map.foldMapWithKey $ \(nUser, nSheet) (Max time) -> HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
|
|
submissionsByCorrector :: Entity Submission -> Map (UserId, SheetId) (Max UTCTime)
|
|
submissionsByCorrector (Entity _ sub)
|
|
| Just ratingBy <- submissionRatingBy sub
|
|
, Just assigned <- submissionRatingAssigned sub
|
|
, not $ submissionRatingDone sub
|
|
= Map.singleton (ratingBy, submissionSheet sub) $ Max assigned
|
|
| otherwise
|
|
= Map.empty
|
|
|
|
collateSubmissionsByCorrector acc entity = Map.unionWith (<>) acc $ submissionsByCorrector entity
|
|
correctorNotifications <=< runConduit $
|
|
transPipe lift ( selectSource [ SubmissionRatingBy !=. Nothing, SubmissionRatingAssigned !=. Nothing ] []
|
|
)
|
|
.| C.fold collateSubmissionsByCorrector Map.empty
|
|
|
|
let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do
|
|
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ sqlSubmissionRatingDone submission
|
|
E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal (toMidnight $ fromGregorian 2024 1 1) -- no submissions used in FRADrive as of this date, previously cut off by an old legacy migration
|
|
return (submission, sheet E.^. SheetType)
|
|
submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do
|
|
examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do
|
|
ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
|
|
Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
|
|
return examFinished
|
|
notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs
|
|
|
|
let
|
|
examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do
|
|
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
return (exam, course, school)
|
|
examJobs (Entity nExam Exam{..}, _, Entity _ School{..}) = do
|
|
newestResult <- lift . E.select . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
|
|
return . E.max_ $ examResult E.^. ExamResultLastChanged
|
|
|
|
whenIsJust examVisibleFrom $ \visibleFrom -> do
|
|
case over (mapped . _Value) ((max `on` NTop) examFinished) newestResult of
|
|
[E.Value (NTop (Just ts))] ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationExamResult{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ max visibleFrom ts
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ . addUTCTime appNotificationExpiration $ max visibleFrom ts
|
|
}
|
|
_other -> return ()
|
|
|
|
whenIsJust examRegisterFrom $ \registerFrom ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationExamRegistrationActive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ max visibleFrom registerFrom
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) examRegisterTo
|
|
}
|
|
whenIsJust ((,) <$> examRegisterFrom <*> examRegisterTo) $ \(registerFrom, registerTo) ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationExamRegistrationSoonInactive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max visibleFrom . max registerFrom $ addUTCTime (-nominalDay) registerTo
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
|
|
}
|
|
whenIsJust ((,) <$> examRegisterFrom <*> examDeregisterUntil) $ \(registerFrom, deregisterUntil) ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationExamDeregistrationSoonInactive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max visibleFrom . max registerFrom $ addUTCTime (-nominalDay) deregisterUntil
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ deregisterUntil
|
|
}
|
|
|
|
let closeTime = case (examClosed, examFinished) of
|
|
(mClose, Just finish)
|
|
| isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish
|
|
(Just close, _)
|
|
| is _ExamCloseSeparate schoolExamCloseMode -> Just close
|
|
_other -> Nothing
|
|
|
|
case closeTime of
|
|
Just close -> do
|
|
-- If an exam that was previously under `ExamCloseSeparate` rules transitions to `ExamCloseOnFinish`, it might suddenly have been closed an arbitrary time ago
|
|
-- If `cronNotAfter` was only `appNotificationExpiration` in that case, no notification might ever be sent
|
|
-- That's probably fine.
|
|
|
|
changedResults <- lift . E.select . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
|
|
E.&&. examResult E.^. ExamResultLastChanged E.>. E.val close
|
|
return $ examResult E.^. ExamResultId
|
|
|
|
case newestResult of
|
|
[E.Value (Just lastChange)]
|
|
| not $ null changedResults
|
|
-> tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExamResultsChanged{ nExamResults = Set.fromList $ map E.unValue changedResults })
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastChange
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
_other -> return ()
|
|
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExamResults{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ close
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
Nothing -> return ()
|
|
in runConduit $ transPipe lift examSelect .| C.mapM_ examJobs
|
|
|
|
|
|
let
|
|
externalExamJobs nExternalExam = do
|
|
newestResult <- lift . E.select . E.from $ \externalExamResult -> do
|
|
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
|
|
return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged
|
|
|
|
case newestResult of
|
|
[E.Value (Just lastChange)] ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExternalExamResults{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastChange
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = nominalDay
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
_other -> return ()
|
|
|
|
runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs
|
|
|
|
hasRelevanceUncached <- lift $ exists [StudyFeaturesRelevanceCached ==. Nothing]
|
|
when hasRelevanceUncached . tell $ HashMap.singleton
|
|
(JobCtlQueue JobStudyFeaturesCacheRelevance)
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = nominalDay
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
|
|
let externalApiJobs (Entity jExternalApi ExternalApi{..}) =
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobExternalApiExpire{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appExternalApisExpiry externalApiLastAlive
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appExternalApisExpiry
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalApiJobs
|