{-# LANGUAGE RecordWildCards #-}
module System.Cron.Internal.Check where

-------------------------------------------------------------------------------
import           Control.Applicative         as A
import qualified Data.Foldable               as FT
import           Data.List
import           Data.List.NonEmpty          (NonEmpty (..))
import qualified Data.List.NonEmpty          as NE
import           Data.Maybe
import           Data.Semigroup              (sconcat)
import           Data.Time                   (Day, DiffTime, UTCTime (..),
                                              addUTCTime, fromGregorianValid,
                                              toGregorian)
import           Data.Time.Calendar.WeekDate
import qualified Data.Traversable            as FT
-------------------------------------------------------------------------------
import           System.Cron.Types           as CT
-------------------------------------------------------------------------------


-------------------------------------------------------------------------------
-- Schedule projection
-------------------------------------------------------------------------------


-- | Will return the next time from the given starting point where
-- this schedule will match. Returns Nothing if the schedule will
-- never match. Note that this function is not inclusive of the given
-- time: the result will always be at least 1 minute beyond the given
-- time. This is usually used to implement absolute timestamp
-- schedulers. If you need to see multiple matches ahead, just keep
-- feeding the result into nextMatch. Note that because nextMatch only
-- returns Nothing on a schedule that will *never* be matched, it is
-- safe to assume that if a schedule returns a Just once, it will
-- always return a Just.
nextMatch :: CronSchedule -> UTCTime -> Maybe UTCTime
nextMatch cs@CronSchedule {..} now
  | domRestricted && dowRestricted = do
      -- this trick is courtesy of Python's croniter: run the schedule
      -- once with * in the DOM spot and once with * in the DOW slot
      -- and then choose the earlier of the two.
      domStarSpec <- mkDayOfMonthSpec (Field Star)
      dowStarSpec <- mkDayOfWeekSpec (Field Star)
      let domStarResult = nextMatch cs { dayOfMonth = domStarSpec } now
      let dowStarResult = nextMatch cs { CT.dayOfWeek = dowStarSpec} now
      listToMaybe (sort (catMaybes [domStarResult, dowStarResult]))
  | otherwise = do
    expanded@Expanded {..} <- expand cs
    let daysSource = validDays monthF domF startDay
    listToMaybe (nextMatches daysSource expanded now)
  where
    UTCTime startDay _ = addUTCTime 60 now
    domRestricted = restricted (dayOfMonthSpec dayOfMonth)
    dowRestricted = restricted (dayOfWeekSpec dayOfWeek)


-------------------------------------------------------------------------------
nextMatches :: [Day] -> Expanded -> UTCTime -> [UTCTime]
nextMatches daysSource Expanded {..} now = solutions
  where
    -- move to next minute
    solutions = filter validSolution [UTCTime d tod
                                     | d <- daysSource
                                     , tod <- validTODs hourF minF
                                     ]
    validSolution t = t > now && dowMatch t dowF


-------------------------------------------------------------------------------
dowMatch :: UTCTime -> EField -> Bool
dowMatch (UTCTime d _) dows = (getDOW d `FT.elem` dows)


-------------------------------------------------------------------------------
-- | ISO8601 maps Sunday as 7 and Monday as 1, we want Sunday as 0
getDOW :: Day -> Int
getDOW d
  | iso8601DOW == 7 = 0
  | otherwise       = iso8601DOW
  where
    (_, _, iso8601DOW) = toWeekDate d


-------------------------------------------------------------------------------
validDays :: EField -> EField -> Day -> [Day]
validDays months days start =
  concat (firstYearDates:subsequentYearDates)
  where
    (startYear, startMonth, _) = toGregorian start
    firstYearMonths = dropWhile (< startMonth) subsequentYearMonths
    subsequentYearMonths = sortBy compare (FT.toList months)
    firstYearDates = dateSequence firstYearMonths startYear
    subsequentYearDates = [ dateSequence subsequentYearMonths y | y <- [startYear+1..]]
    dateSequence mseq y = catMaybes [fromGregorianValid y m d
                                    | m <- mseq
                                    , d <- sortBy compare (FT.toList days)]


-------------------------------------------------------------------------------
-- | Guarantees: the Expanded will be satisfiable (no invalid dates,
-- no empties). dow 7 will be normalized to 0 (Sunday)
expand :: CronSchedule -> Maybe Expanded
expand CronSchedule {..} = do
  expanded <- Expanded A.<$> minF'
                       <*> hourF'
                       <*> domF'
                       <*> monthF'
                       <*> dowF'
  if satisfiable expanded
     then Just expanded
     else Nothing
  where
    minF' = expandF (0, 59) (minuteSpec minute)
    hourF' = expandF (0, 23) (hourSpec hour)
    domF' = expandF (1, 31) (dayOfMonthSpec dayOfMonth)
    monthF' = expandF (1, 12) (monthSpec month)
    dowF' = remapSunday <$> expandF (0, 7) (dayOfWeekSpec dayOfWeek)
    remapSunday lst = case NE.partition (\n -> n == 0 || n == 7) lst of
                        ([], _)       -> lst
                        (_, noSunday) -> 0 :| noSunday
    domRestricted = restricted (dayOfMonthSpec dayOfMonth)
    dowRestricted = restricted (dayOfWeekSpec dayOfWeek)
    -- If DOM and DOW are restricted, they are ORed, so even if
    -- there's an invalid day for the month, it is still satisfiable
    -- because it will just choose the DOW path
    satisfiable Expanded {..} = (domRestricted && dowRestricted) ||
      or [hasValidForMonth m domF | m <- (FT.toList monthF)]


-------------------------------------------------------------------------------
expandF :: (Int, Int) -> CronField -> Maybe EField
expandF rng (Field f)       = expandBF rng f
expandF rng (ListField fs)  = NE.nub . sconcat <$> FT.mapM (expandBF rng) fs
expandF rng (StepField' sf) = expandBFStepped rng (sfField sf) (sfStepping sf)


-------------------------------------------------------------------------------
expandBFStepped :: (Int, Int) -> BaseField -> Int -> Maybe EField
expandBFStepped rng Star step = NE.nonEmpty (fillTo rng step)
expandBFStepped (_, unitMax) (RangeField' rf) step = NE.nonEmpty (fillTo (start, finish') step)
  where
    finish' = min finish unitMax
    start = rfBegin rf
    finish = rfEnd rf
expandBFStepped (_, unitMax) (SpecificField' sf) step =
  expandBFStepped (startAt, unitMax) Star step
  where
    startAt = specificField sf


-------------------------------------------------------------------------------
fillTo :: (Int, Int)
       -> Int
       -> [Int]
fillTo (start, finish) step
  | step <= 0      = []
  | finish < start = []
  | otherwise      = takeWhile (<= finish) nums
  where
    nums = [ start + (step * iter) | iter <- [0..]]


-------------------------------------------------------------------------------
expandBF :: (Int, Int) -> BaseField -> Maybe EField
expandBF (lo, hi) Star         = Just (NE.fromList (enumFromTo lo hi))
expandBF _ (SpecificField' sf) = Just (specificField sf :| [])
expandBF _ (RangeField' rf)    = Just (NE.fromList (enumFromTo (rfBegin rf) (rfEnd rf)))


-------------------------------------------------------------------------------
validTODs :: EField -> EField -> [DiffTime]
validTODs hrs mns = dtSequence
  where
    minuteSequence = sortBy compare (FT.toList mns)
    hourSequence = sortBy compare (FT.toList hrs)
    -- order here ensures we'll count up minutes before hours
    dtSequence = [ todToDiffTime hr mn | hr <- hourSequence, mn <- minuteSequence]


-------------------------------------------------------------------------------
todToDiffTime :: Int -> Int -> DiffTime
todToDiffTime nextHour nextMin = fromIntegral ((nextHour * 60 * 60) + nextMin * 60)


-------------------------------------------------------------------------------
timeOfDay :: DiffTime -> (Int, Int)
timeOfDay t = (h, m)
  where
    seconds = floor t
    minutes = seconds `div` 60
    (h, m) = minutes `divMod` 60


-------------------------------------------------------------------------------
hasValidForMonth
    :: Int
    -- ^ Month
    -> EField
    -> Bool
hasValidForMonth 1 days  = FT.minimum days <= 31
hasValidForMonth 2 days  = FT.minimum days <= 29
hasValidForMonth 3 days  = FT.minimum days <= 31
hasValidForMonth 4 days  = FT.minimum days <= 30
hasValidForMonth 5 days  = FT.minimum days <= 31
hasValidForMonth 6 days  = FT.minimum days <= 30
hasValidForMonth 7 days  = FT.minimum days <= 31
hasValidForMonth 8 days  = FT.minimum days <= 31
hasValidForMonth 9 days  = FT.minimum days <= 30
hasValidForMonth 10 days = FT.minimum days <= 31
hasValidForMonth 11 days = FT.minimum days <= 30
hasValidForMonth 12 days = FT.minimum days <= 31
hasValidForMonth _ _     = False


-------------------------------------------------------------------------------
data Expanded = Expanded {
     minF   :: EField
   , hourF  :: EField
   , domF   :: EField
   , monthF :: EField
   , dowF   :: EField
   } deriving (Show)


-------------------------------------------------------------------------------
-- This could be an intmap but I'm not convinced there's significant
-- performance to be gained
type EField = NonEmpty Int



-- | Does the given cron schedule match for the given timestamp? This
-- is usually used for implementing polling-type schedulers like cron
-- itself.
scheduleMatches
    :: CronSchedule
    -> UTCTime
    -> Bool
scheduleMatches cs@CronSchedule {..} (UTCTime d t) =
  maybe False go (expand cs)
  where
    go Expanded {..} = and
      [ FT.elem mn minF
      , FT.elem hr hourF
      , FT.elem mth monthF
      , checkDOMAndDOW
      ]
      where
        -- turns out if neither dom and dow are stars, you're supposed to
        -- OR and not AND them:
        --
        -- Note: The day of a command's execution can
        -- be specified by two fields — day of month, and day of week. If
        -- both fields are restricted (i.e., aren't *), the command will
        -- be run when either field matches the current time. For example,
        -- ``30 4 1,15 * 5'' would cause a command to be run at 4:30 am on
        -- the 1st and 15th of each month, plus every Friday. One can,
        -- however, achieve the desired result by adding a test to the
        -- command (see the last example in EXAMPLE CRON FILE below).
        checkDOMAndDOW
          | restricted (dayOfMonthSpec dayOfMonth) && restricted (dayOfWeekSpec dayOfWeek) =
              domMatches || dowMatches
          | otherwise = domMatches && dowMatches
        domMatches = FT.elem dom domF
        dowMatches = FT.elem dow dowF
    (_, mth, dom) = toGregorian d
    (hr, mn) = timeOfDay t
    dow = getDOW d


restricted :: CronField -> Bool
restricted = not . isStar

isStar :: CronField -> Bool
isStar (Field Star)    = True
isStar (ListField bfs) = FT.any (== Star) bfs
isStar (StepField' sf) = sfField sf == Star && sfStepping sf == 1
isStar _               = False