121 lines
4.5 KiB
Haskell
121 lines
4.5 KiB
Haskell
module Jobs.Crontab
|
|
( determineCrontab
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import Jobs.Types
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Semigroup (Max(..))
|
|
|
|
import Data.Time.Zones
|
|
|
|
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
|
import Control.Monad.Writer.Class (MonadWriter(..))
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
|
|
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 = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = interval
|
|
, cronNotAfter = Right CronNotScheduled
|
|
}
|
|
Nothing -> return ()
|
|
|
|
tell $ HashMap.singleton
|
|
JobCtlDetermineCrontab
|
|
Cron
|
|
{ cronInitial = CronAsap
|
|
, cronRepeat = CronRepeatScheduled CronAsap
|
|
, cronRateLimit = appJobCronInterval
|
|
, 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
|
|
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
|