353 lines
16 KiB
Haskell
353 lines
16 KiB
Haskell
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.Semigroup (Max(..))
|
|
|
|
import Data.Time.Zones
|
|
import Data.Time.Clock.POSIX
|
|
|
|
import Handler.Utils.DateTime
|
|
import Handler.Utils.Allocation (allocationDone)
|
|
|
|
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
|
import Control.Monad.Writer.Class (MonadWriter(..))
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
determineCrontab :: DB (Crontab JobCtl)
|
|
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
|
|
determineCrontab = execWriterT $ do
|
|
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
|
|
|
case appJobFlushInterval of
|
|
Just interval -> tell $ HashMap.singleton
|
|
JobCtlFlush
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = interval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
Nothing -> return ()
|
|
|
|
tell $ HashMap.singleton
|
|
JobCtlDetermineCrontab
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = appJobCronInterval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
|
|
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
|
|
}
|
|
|
|
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 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
|
|
}
|
|
|
|
|
|
if
|
|
| is _Just appLdapConf
|
|
, is _Just appLdapConf
|
|
, Just syncWithin <- appSynchroniseLdapUsersWithin
|
|
-> do
|
|
now <- liftIO getPOSIXTime
|
|
let
|
|
epochInterval = syncWithin / 2
|
|
interval = appSynchroniseLdapUsersInterval
|
|
|
|
(ldapEpoch, epochNow) = now `divMod'` epochInterval
|
|
ldapInterval = epochNow `div'` interval
|
|
numIntervals = floor $ epochInterval / interval
|
|
|
|
nextIntervals = do
|
|
let
|
|
n = ceiling $ 4 * appJobCronInterval / appSynchroniseLdapUsersInterval
|
|
i <- [negate (ceiling $ n % 2) .. ceiling $ n % 2]
|
|
let
|
|
((+ ldapEpoch) -> nextEpoch, nextInterval) = (ldapInterval + i) `divMod` numIntervals
|
|
nextIntervalTime
|
|
= posixSecondsToUTCTime $ fromInteger nextEpoch * epochInterval + fromInteger nextInterval * interval
|
|
return (nextEpoch, nextInterval, nextIntervalTime)
|
|
|
|
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime) -> do
|
|
$logDebugS "SynchroniseLdap" [st|currentTime: #{tshow ldapEpoch}.#{tshow epochNow}; upcomingSync: #{tshow nextEpoch}.#{tshow (fromInteger nextInterval * interval)}; upcomingData: #{tshow (numIntervals, nextEpoch, nextInterval)}|]
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue JobSynchroniseLdap
|
|
{ jEpoch = fromInteger nextEpoch
|
|
, jNumIterations = fromInteger numIntervals
|
|
, jIteration = fromInteger nextInterval
|
|
})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appSynchroniseLdapUsersInterval
|
|
, cronNotAfter = Left syncWithin
|
|
}
|
|
| otherwise
|
|
-> return ()
|
|
|
|
|
|
let
|
|
sheetJobs (Entity nSheet Sheet{..}) = do
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
|
|
}
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
|
|
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
|
|
}
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
when sheetAutoDistribute $
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobDistributeCorrections nSheet)
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
|
|
, cronNotAfter = Left nominalDay
|
|
}
|
|
|
|
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
|
|
|
let
|
|
correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) DB ()
|
|
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
|
|
examJobs (Entity nExam Exam{..}) = 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
|
|
}
|
|
|
|
case examClosed of
|
|
Just close -> do
|
|
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 ()
|
|
|
|
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs
|
|
|
|
let
|
|
allocationJobs (Entity nAllocation Allocation{..}) = do
|
|
whenIsJust allocationStaffRegisterFrom $ \staffRegisterFrom ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationAllocationStaffRegister{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ staffRegisterFrom
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffRegisterTo
|
|
}
|
|
whenIsJust allocationRegisterFrom $ \registerFrom ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationAllocationRegister{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerFrom
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationRegisterTo
|
|
}
|
|
whenIsJust allocationStaffAllocationFrom $ \allocationFrom ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationAllocationAllocation{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ allocationFrom
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo
|
|
}
|
|
case allocationRegisterTo of
|
|
Just registerTo
|
|
| maybe True (> registerTo) allocationStaffAllocationTo
|
|
-> do
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationAllocationUnratedApplications{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo
|
|
}
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationAllocationOutdatedRatings{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo
|
|
}
|
|
_other
|
|
-> return ()
|
|
doneSince <- lift $ allocationDone nAllocation
|
|
|
|
whenIsJust doneSince $ \doneSince' ->
|
|
tell $ HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationAllocationResults{..})
|
|
Cron
|
|
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay doneSince'
|
|
, cronRepeat = CronRepeatOnChange
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ . addUTCTime appNotificationCollateDelay $ addUTCTime appNotificationExpiration doneSince'
|
|
}
|
|
|
|
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ allocationJobs
|