fradrive/src/Cron.hs

module Cron
  ( evalCronMatch
  , CronNextMatch(..)
  , nextCronMatch
  , module Cron.Types
  ) where

import ClassyPrelude
import Prelude (lcm)
import Cron.Types

import Data.Time
import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid)
import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid)
import Data.Time.Zones

import Numeric.Natural
import Data.Ratio ((%))

import qualified Data.Set as Set

import Utils.Lens hiding (from, to)

  
data CronDate = CronDate
  { cdYear, cdWeekYear, cdWeekOfYear, cdDayOfYear
  , cdMonth, cdWeekOfMonth, cdDayOfMonth
  , cdDayOfWeek
  , cdHour, cdMinute, cdSecond :: Natural
  } deriving (Eq, Show, Read)

makeLenses_ ''CronDate


evalCronMatch :: CronMatch -> Natural -> Bool
evalCronMatch CronMatchAny _ = True
evalCronMatch CronMatchNone _ = False
evalCronMatch (CronMatchSome xs) x = Set.member x $ toNullable xs
evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0
evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to
evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x
evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x

toCronDate :: LocalTime -> CronDate
toCronDate LocalTime{..} = CronDate{..}
  where
    (fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth)
      = toGregorian localDay
    (_, fromIntegral -> cdDayOfYear)
      = toOrdinalDate localDay
    (fromInteger -> cdWeekYear, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
      = toWeekDate localDay
    cdWeekOfMonth = go 1 localDay
      where
        go :: Natural -> Day -> Natural
        go n day
          | dow /= 4  = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday
          | m == m'   = go (succ n) day'
          | otherwise = n
          where
            (y, w, dow) = toWeekDate day
            day'
              | w > 1     = fromWeekDate y        (pred w) dow
              | otherwise = fromWeekDate (pred y) 53       dow
            (_, m, _) = toGregorian day
            (_, m', _) = toGregorian day'
    TimeOfDay
      { todHour = fromIntegral -> cdHour
      , todMin = fromIntegral -> cdMinute
      , todSec = round -> cdSecond
      } = localTimeOfDay

consistentCronDate :: CronDate -> Bool
consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
  gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth)
  wDay <- fromWeekDateValid (fromIntegral cdWeekYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
  guard $ gDay == wDay
  oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear)
  guard $ wDay == oDay
  guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate"))
  return True


data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
  deriving (Eq, Ord, Show, Read, Functor)

instance Applicative CronNextMatch where
  pure = MatchAt
  _ <*> MatchNone = MatchNone
  MatchNone <*> _ = MatchNone
  _ <*> MatchAsap = MatchAsap
  MatchAsap <*> _ = MatchAsap
  MatchAt f <*> MatchAt x = MatchAt $ f x

instance Alternative CronNextMatch where
  empty = MatchNone
  x <|> MatchNone = x
  MatchNone <|> x = x
  _ <|> MatchAsap = MatchAsap
  MatchAsap <|> _ = MatchAsap
  (MatchAt a) <|> (MatchAt _) = MatchAt a
  

listToMatch :: [a] -> CronNextMatch a
listToMatch [] = MatchNone
listToMatch (t:_) = MatchAt t

genMatch :: Int -- ^ Period
         -> Bool -- ^ Modular
         -> Bool -- ^ Zero based
         -> Natural -- ^ Start value
         -> CronMatch
         -> [Natural]
genMatch p m z st CronMatchAny = take p $ map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) [st..]
genMatch _ _ _ _ CronMatchNone = []
genMatch p m z _ (CronMatchSome xs) = take p . map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) . Set.toAscList $ toNullable xs
genMatch p m z st (CronMatchStep step) = do
  start <- [st..st + step]
  guard $ (start `mod` step) == 0
  take (ceiling $ fromIntegral p % step) $ map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) [start,start + step..]
genMatch p m z st (CronMatchContiguous from to) = take p . map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) $ [max st from..to]
genMatch _ _ _ _ (CronMatchIntersect CronMatchNone _) = []
genMatch _ _ _ _ (CronMatchIntersect _ CronMatchNone) = []
genMatch p m z st (CronMatchIntersect CronMatchAny other) = genMatch p m z st other
genMatch p m z st (CronMatchIntersect other CronMatchAny) = genMatch p m z st other
genMatch p m z st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
  = genMatch p m z st . CronMatchStep $ lcm st1 st2
genMatch p m z st (CronMatchIntersect aGen bGen)
  | [] <- as' = []
  | (a:as) <- as' = mergeAnd (a:as) (genMatch p m z a bGen)
  where
    as' = genMatch p m z st aGen
    mergeAnd [] _ = []
    mergeAnd _ [] = []
    mergeAnd (a:as) (b:bs)
      | a <  b    = mergeAnd as (b:bs)
      | a == b    = a : mergeAnd as bs
      | otherwise = mergeAnd (a:as) bs
genMatch p m z st (CronMatchUnion CronMatchNone other) = genMatch p m z st other
genMatch p m z st (CronMatchUnion other CronMatchNone) = genMatch p m z st other
genMatch p m z st (CronMatchUnion CronMatchAny _) = genMatch p m z st CronMatchAny
genMatch p m z st (CronMatchUnion _ CronMatchAny) = genMatch p m z st CronMatchAny
genMatch p m z st (CronMatchUnion aGen bGen) = merge (genMatch p m z st aGen) (genMatch p m z st bGen)
  where
    merge [] bs = bs
    merge as [] = as
    merge (a:as) (b:bs)
      | a <  b    = a : merge as (b:bs)
      | a == b    = a : merge as bs
      | otherwise = b : merge (a:as) bs

nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
              -> Maybe UTCTime -- ^ Time of last execution of the job
              -> NominalDiffTime -- ^ Scheduling precision
              -> UTCTime -- ^ Current time, used only for `CronCalendar`
              -> Cron
              -> CronNextMatch UTCTime
nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
  MatchAsap -> MatchNone
  MatchAt ts
    | MatchAt ts' <- nextMatch
    , ts' <= ts -> MatchAt ts'
    | MatchAsap <- nextMatch
    , now <= ts -> MatchAsap
    | otherwise -> MatchNone
  MatchNone -> nextMatch
  where
    notAfter
      | Right c' <- cronNotAfter
      , Just ref <- notAfterRef
      = execRef' ref False c'
      | Left diff <- cronNotAfter
      , Just ref <- notAfterRef
      = MatchAt $ diff `addUTCTime` ref
      | otherwise = MatchNone
    notAfterRef
      | Just prevT <- mPrev = Just prevT
      | otherwise = case execRef' now False cronInitial of
          MatchAsap -> error "execRef' should not return MatchAsap"
          MatchAt t -> Just t
          MatchNone -> Nothing
    nextMatch = case mPrev of
      Nothing
        -> execRef now False cronInitial
      Just prevT
        -> case cronRepeat of
            CronRepeatOnChange
              | not $ matchesCron tz Nothing prec prevT c
                -> let
                     cutoffTime = addUTCTime cronRateLimit prevT
                   in case execRef now False cronInitial of
                        MatchAsap
                          | now < cutoffTime -> MatchAt cutoffTime
                        MatchAt ts 
                          | ts < cutoffTime -> MatchAt cutoffTime
                        other -> other
            CronRepeatScheduled cronNext
              -> case cronNext of
                   CronAsap
                     | addUTCTime cronRateLimit prevT <= now
                       -> MatchAsap
                     | otherwise
                       -> MatchAt $ addUTCTime cronRateLimit prevT
                   _other
                     -> execRef (addUTCTime cronRateLimit prevT) True cronNext
            _other -> MatchNone

    execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of
      MatchAt t
        | t <= ref -> MatchAsap
      other -> other

    execRef' ref wasExecd cronAbsolute = case cronAbsolute of
      CronAsap -> MatchAt ref
      CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts }
        | ref <= ts || not wasExecd -> MatchAt ts
        | otherwise -> MatchNone
      CronCalendar{..} -> listToMatch $ do
        let
          localRef = utcToLocalTimeTZ tz ref
          CronDate{..} = toCronDate localRef

        mCronWeekDate <- if
          | cronWeekYear == CronMatchAny
          , cronWeekOfYear == CronMatchAny
          , cronDayOfWeek == CronMatchAny
            -> return Nothing
          | otherwise
            -> fmap Just $ (,,)
               <$> genMatch 400 False True cdWeekYear cronWeekYear
               <*> genMatch 53 True False cdWeekOfYear cronWeekOfYear
               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek

        mCronGregorianDate <- if
          | cronYear == CronMatchAny
          , cronMonth == CronMatchAny
          , cronDayOfMonth == CronMatchAny
            -> return Nothing
          | otherwise
            -> fmap Just $ (,,)
               <$> genMatch 400 False True cdYear cronYear
               <*> genMatch 12 True False cdMonth cronMonth
               <*> genMatch 31 True False cdDayOfMonth cronDayOfMonth

        mCronWeekOfMonthDate <- if
          | cronWeekOfMonth == CronMatchAny
            -> return Nothing
          | Just (wY, _, wd) <- mCronWeekDate
            -> fmap Just $ (,,,)
                 <$> pure wY
                 <*> maybe (genMatch 12 True False cdMonth cronMonth) (pure . view _2) mCronGregorianDate
                 <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
                 <*> pure wd
          | Just (_, m, _) <- mCronGregorianDate
            -> fmap Just $ (,,,)
               <$> genMatch 400 False True cdWeekYear cronWeekYear
               <*> pure m
               <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek
          | otherwise
            -> fmap Just $ (,,,)
               <$> genMatch 400 False True cdWeekYear cronWeekYear
               <*> genMatch 12 True False cdMonth cronMonth
               <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek

        mCronOrdinalDate <- if
          | cronYear == CronMatchAny
          , cronDayOfYear == CronMatchAny
            -> return Nothing
          | Just (y, _, _) <- mCronGregorianDate
            -> Just . (y,) <$> genMatch 366 True False cdDayOfYear cronDayOfYear
          | otherwise
            -> fmap Just $ (,)
               <$> genMatch 400 False True cdYear cronYear
               <*> genMatch 366 True False cdDayOfYear cronDayOfYear

        mCronTime <- if
          | cronHour == CronMatchAny
          , cronMinute == CronMatchAny
          , cronSecond == CronMatchAny
            -> return Nothing
          | otherwise
            -> fmap Just $ (,,)
               <$> genMatch 24 True True cdHour cronHour
               <*> genMatch 60 True True cdMinute cronMinute
               <*> genMatch 60 True True cdSecond cronSecond

        let toGregorian' = over _1 fromIntegral . over _2 fromIntegral . over _3 fromIntegral . toGregorian
        (mCronYear, mCronMonth, mCronDayOfMonth) <- if
            | Just (year, month, dayOfMonth) <- mCronGregorianDate
              -> return (year, month, dayOfMonth)
            | Just (weekYear, week, dayOfWeek) <- mCronWeekDate
              -> return . toGregorian' $ fromWeekDate (fromIntegral weekYear) (fromIntegral week) (fromIntegral dayOfWeek)
            | Just (year, dayOfYear) <- mCronOrdinalDate
              -> maybeToList . fmap toGregorian' $ fromOrdinalDateValid (fromIntegral year) (fromIntegral dayOfYear)
            | Just (weekYear, month, weekOfMonth, dayOfWeek) <- mCronWeekOfMonthDate
              -> do
                   year <- genMatch 400 False True cdYear cronYear
                   day <- genMatch 31 True False cdDayOfMonth cronDayOfMonth
                   jDay <- maybeToList $ fromGregorianValid (fromIntegral year) (fromIntegral month) (fromIntegral day)
                   guard $ consistentCronDate (toCronDate localRef{ localDay = jDay }) { cdWeekYear = weekYear, cdMonth = month, cdWeekOfMonth = weekOfMonth, cdDayOfWeek = dayOfWeek }
                   return (year, month, day)
            | otherwise
              -> fmap toGregorian' [localDay localRef, succ $ localDay localRef]

        julDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)

        mCronDayOfYear <- if
            | Just (year, dayOfYear) <- mCronOrdinalDate
              -> dayOfYear <$ guard (year == mCronYear)
            | otherwise
              -> return . fromIntegral . snd $ toOrdinalDate julDay

        (mCronWeekYear, mCronWeekOfYear, mCronDayOfWeek) <- if
            | Just weekDate <- mCronWeekDate
              -> return weekDate
            | otherwise
              -> return . over _1 fromIntegral . over _2 fromIntegral . over _3 fromIntegral $ toWeekDate julDay

        mCronWeekOfMonth <- if
            | Just (weekYear, month, weekOfMonth, dayOfWeek) <- mCronWeekOfMonthDate
              -> weekOfMonth <$ guard (weekYear == mCronWeekYear && month == mCronMonth && dayOfWeek == mCronDayOfWeek)
            | otherwise
              -> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth

        (mCronHour, mCronMinute, mCronSecond) <- if
            | Just (h, m, s) <- mCronTime
              -> return (h, m, s)
            | otherwise
              -> [(0, 0, 0), (cdHour, cdMinute, cdSecond)]

        guard $ consistentCronDate CronDate
          { cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth
          , cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond
          , cdWeekYear = mCronWeekYear, cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
          , cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek
          }

        localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
        let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond)
            res = localTimeToUTCTZ tz LocalTime{..}

        guard $ res >= ref

        return res
      CronNotScheduled -> MatchNone

matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
            -> Maybe UTCTime -- ^ Previous execution of the job
            -> NominalDiffTime -- ^ Scheduling precision
            -> UTCTime -- ^ "Current" time
            -> Cron
            -> Bool
-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron`
--   specification @c@ should match @now@, under the assumption that the next
--   check will occur no earlier than @now + prec@.
matchesCron tz mPrev prec now cron = case nextCronMatch tz mPrev prec now cron of
  MatchAsap -> True
  MatchNone -> False
  MatchAt ts -> ts <= addUTCTime prec now