fradrive/src/Jobs/Crontab.hs

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 Data.Time.Clock.POSIX

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
      }

  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
          interval = appSynchroniseLdapUsersInterval
          
          (ldapEpoch, epochNow) = now `divMod'` syncWithin
          ldapInterval = epochNow `div'` interval
          numIntervals = floor $ syncWithin / 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 * syncWithin + 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

      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 ts
              , cronRepeat = CronRepeatOnChange
              , cronRateLimit = appNotificationRateLimit
              , cronNotAfter = Left $ 14 * nominalDay
              }
        _other -> return ()
  
  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs