107 lines
3.9 KiB
Haskell
107 lines
3.9 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, RecordWildCards
|
|
, FlexibleContexts
|
|
, MultiWayIf
|
|
, NamedFieldPuns
|
|
, TypeFamilies
|
|
#-}
|
|
|
|
module Jobs.Crontab
|
|
( determineCrontab
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import Jobs.Types
|
|
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Map as Map
|
|
import Data.Semigroup (Max(..))
|
|
|
|
import Data.Time
|
|
import Data.Time.Zones
|
|
|
|
import Control.Monad.Trans.Writer (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
|
|
}
|
|
|
|
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
|
|
}
|
|
|
|
sheetSubmissions <- lift $ collateSubmissions <$>
|
|
selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []
|
|
tell $ flip Map.foldMapWithKey sheetSubmissions $
|
|
\nUser (Max mbTime) -> if
|
|
| Just time <- mbTime -> HashMap.singleton
|
|
(JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
|
|
Cron
|
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
|
|
, cronRepeat = CronRepeatNever
|
|
, cronRateLimit = appNotificationRateLimit
|
|
, cronNotAfter = Left appNotificationExpiration
|
|
}
|
|
| otherwise -> mempty
|
|
|
|
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
|
|
|
-- | Partial function: Submission must not have Nothing at ratingBy
|
|
collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime))
|
|
collateSubmissions = Map.fromListWith (<>) . fmap procCorrector
|
|
where
|
|
procCorrector :: Entity Submission -> (UserId , (Max (Maybe UTCTime)))
|
|
procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal
|
|
<*> Max . submissionRatingAssigned . entityVal
|
|
|