{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Cron.Parser
(
cronSchedule
, cronScheduleLoose
, crontab
, crontabEntry
, parseCronSchedule
, parseCrontab
, parseCrontabEntry
) where
import Control.Applicative as Ap
import Control.Monad.Fail as F
import Data.Attoparsec.Combinator (choice)
import Data.Attoparsec.Text (Parser)
import qualified Data.Attoparsec.Text as A
import Data.Char (isSpace)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text, toLower)
import System.Cron.Types
cronSchedule :: Parser CronSchedule
cronSchedule = cronScheduleLoose <* A.endOfInput
cronScheduleLoose :: Parser CronSchedule
cronScheduleLoose = yearlyP <|>
monthlyP <|>
weeklyP <|>
dailyP <|>
hourlyP <|>
classicP
crontab :: Parser Crontab
crontab = Crontab <$> A.sepBy lineP (A.char '\n')
where lineP = A.skipMany commentP *> crontabEntry
commentP = A.skipSpace *> A.char '#' *> skipToEOL
crontabEntry :: Parser CrontabEntry
crontabEntry = A.skipSpace *> parser
where parser = envVariableP <|>
commandEntryP
envVariableP = do var <- A.takeWhile1 (A.notInClass " =")
A.skipSpace
_ <- A.char '='
A.skipSpace
val <- A.takeWhile1 $ not . isSpace
A.skipWhile (\c -> c == ' ' || c == '\t')
return $ EnvVariable var val
commandEntryP = CommandEntry <$> cronScheduleLoose
<*> (A.skipSpace *> (CronCommand <$> takeToEOL))
parseCronSchedule :: Text -> Either String CronSchedule
parseCronSchedule = A.parseOnly cronSchedule . toLower
parseCrontab :: Text -> Either String Crontab
parseCrontab = A.parseOnly crontab
parseCrontabEntry :: Text -> Either String CrontabEntry
parseCrontabEntry = A.parseOnly crontabEntry
takeToEOL :: Parser Text
takeToEOL = A.takeTill (== '\n')
skipToEOL :: Parser ()
skipToEOL = A.skipWhile (/= '\n')
classicP :: Parser CronSchedule
classicP = CronSchedule <$> (minutesP <* space)
<*> (hoursP <* space)
<*> (dayOfMonthP <* space)
<*> (monthP <* space)
<*> dayOfWeekP
where space = A.char ' '
cronFieldP :: StringSupport -> Parser CronField
cronFieldP stringSupport =
stepP <|>
listP <|>
fieldP
where
fieldP = Field <$> baseFieldP stringSupport
listP = ListField <$> neListP (baseFieldP stringSupport)
stepP = StepField' <$> stepFieldP stringSupport
stepFieldP :: StringSupport -> Parser StepField
stepFieldP ss = do
f <- baseFieldP ss
_ <- A.char '/'
mParse (mkStepField f) "invalid stepping" =<< parseInt
neListP :: Parser a -> Parser (NonEmpty a)
neListP p = coerceNE =<< A.sepBy1 p (A.char ',')
where
coerceNE [] = F.fail "expected non-empty list"
coerceNE [_] = F.fail "invalid singleton list"
coerceNE (x:xs) = return $ x :| xs
baseFieldP :: StringSupport -> Parser BaseField
baseFieldP ss = rangeP <|>
starP <|>
specificP
where starP = A.char '*' *> Ap.pure Star
rangeP = RangeField' <$> rangeFieldP ss
specificP = SpecificField' <$> specificFieldP ss
specificFieldP :: StringSupport -> Parser SpecificField
specificFieldP ss =
mParse mkSpecificField "specific field value out of range"
=<< supportParser ss
rangeFieldP :: StringSupport -> Parser RangeField
rangeFieldP ss = do
begin <- supportParser ss
_ <- A.char '-'
end <- supportParser ss
mParse (mkRangeField begin) "start of range must be less than or equal to end" end
yearlyP :: Parser CronSchedule
yearlyP = A.string "@yearly" *> pure yearly
monthlyP :: Parser CronSchedule
monthlyP = A.string "@monthly" *> pure monthly
weeklyP :: Parser CronSchedule
weeklyP = A.string "@weekly" *> pure weekly
dailyP :: Parser CronSchedule
dailyP = A.string "@daily" *> pure daily
hourlyP :: Parser CronSchedule
hourlyP = A.string "@hourly" *> pure hourly
minutesP :: Parser MinuteSpec
minutesP = mParse mkMinuteSpec "minutes out of range" =<< cronFieldP NoString
hoursP :: Parser HourSpec
hoursP = mParse mkHourSpec "hours out of range" =<< cronFieldP NoString
dayOfMonthP :: Parser DayOfMonthSpec
dayOfMonthP = mParse mkDayOfMonthSpec "day of month out of range" =<< cronFieldP NoString
monthP :: Parser MonthSpec
monthP = mParse mkMonthSpec "month out of range" =<< cronFieldP MonthString
dayOfWeekP :: Parser DayOfWeekSpec
dayOfWeekP = mParse mkDayOfWeekSpec "day of week out of range" =<< cronFieldP DayString
parseInt :: Parser Int
parseInt = A.decimal
data StringSupport
= MonthString
| DayString
| NoString
deriving Eq
supportParser :: StringSupport -> Parser Int
supportParser = \case
MonthString -> choice [parseMonth, parseInt]
DayString -> choice [parseDay, parseInt]
NoString -> parseInt
toI :: Int -> Text -> Parser Int
toI int str = const int <$> A.string str
parseDay :: Parser Int
parseDay =
choice $
zipWith toI
[1 .. 7]
[ "mon"
, "tue"
, "wed"
, "thu"
, "fri"
, "sat"
, "sun"
]
parseMonth :: Parser Int
parseMonth =
choice $
zipWith toI
[1 .. 12]
[ "jan"
, "feb"
, "mar"
, "apr"
, "may"
, "jun"
, "jul"
, "aug"
, "sep"
, "oct"
, "nov"
, "dec"]
mParse :: (Monad m, MonadFail m) => (a -> Maybe b) -> String -> a -> m b
mParse f msg = maybe (F.fail msg) return . f