{-# 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
import           Data.Time.Calendar.WeekDate
import qualified Data.Traversable            as FT
-------------------------------------------------------------------------------
import           System.Cron.Types
-------------------------------------------------------------------------------


-------------------------------------------------------------------------------
-- 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 { 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 _            = False