From ff174d9536db26945189593bf8194f18fbd5ce3f Mon Sep 17 00:00:00 2001 From: evuez Date: Mon, 1 Apr 2024 15:16:52 +0200 Subject: Initial commit --- src/Cron/Expr.hs | 21 +++++++++++++ src/Cron/Parser.hs | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Cron/Schedule.hs | 72 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 181 insertions(+) create mode 100644 src/Cron/Expr.hs create mode 100644 src/Cron/Parser.hs create mode 100644 src/Cron/Schedule.hs (limited to 'src/Cron') diff --git a/src/Cron/Expr.hs b/src/Cron/Expr.hs new file mode 100644 index 0000000..a6cb4ca --- /dev/null +++ b/src/Cron/Expr.hs @@ -0,0 +1,21 @@ +module Cron.Expr (Expr (..), StepLExpr (..), showExpr) where + +import Data.List.NonEmpty (NonEmpty, intersperse) +import Data.Semigroup (sconcat) +import Intro + +data Expr = Every | Multi (NonEmpty Int) | Range Int Int | Step StepLExpr Int deriving (Show) + +data StepLExpr = StepLEvery | StepLRange Int Int deriving (Show) + +showExpr :: Expr -> String +showExpr = \case + Every -> "*" + Multi ns -> sconcat $ intersperse "," (fmap show ns) + Range n m -> mconcat [show n, "-", show m] + Step n m -> mconcat [showStepLExpr n, "/", show m] + +showStepLExpr :: StepLExpr -> String +showStepLExpr = \case + StepLEvery -> "*" + StepLRange n m -> mconcat [show n, "-", show m] diff --git a/src/Cron/Parser.hs b/src/Cron/Parser.hs new file mode 100644 index 0000000..304a1e3 --- /dev/null +++ b/src/Cron/Parser.hs @@ -0,0 +1,88 @@ +module Cron.Parser (parse) where + +import Common (fromDigits) +import Control.Applicative (Alternative, empty, liftA2, many, some, (*>), (<$), (<|>)) +import Control.Arrow (first, (>>>)) +import qualified Cron.Expr as E +import Data.List.NonEmpty (NonEmpty ((:|))) +import Intro +import Text.Read (readMaybe) + +type Token = Char + +newtype Parser a = Parser {runParser :: [Token] -> Maybe (a, [Token])} + +instance Functor Parser where + fmap f (Parser p) = Parser (p >>> fmap (first f)) + +instance Applicative Parser where + pure a = Parser (\input -> Just (a, input)) + Parser pF <*> Parser pA = Parser $ \input -> do + (f, rest) <- pF input + (a, s) <- pA rest + pure (f a, s) + +instance Alternative Parser where + empty = Parser (const Nothing) + Parser pA <|> Parser pB = Parser $ \input -> case (pA input, pB input) of + (Nothing, expr) -> expr + (expr, _) -> expr + +match :: (Token -> Bool) -> Parser Token +match p = Parser $ \case + t : ts | p t -> Just (t, ts) + _ -> Nothing + +token :: Token -> Parser Token +token = (==) >>> match + +read :: (Token -> Maybe a) -> Parser a +read f = Parser $ \case + t : ts -> case f t of + Just x -> Just (x, ts) + _ -> Nothing + _ -> Nothing + +sepBy1 :: Parser a -> Parser b -> Parser (NonEmpty a) +sepBy1 p s = liftA2 (:|) p (many (s *> p)) + +pair :: Parser a -> Parser b -> Parser c -> Parser (a, b) +pair p1 p2 s = liftA2 (,) p1 (s *> p2) + +digit :: Parser Int +digit = read $ \case + x | x `elem` ['0' .. '9'] -> readMaybe [x] :: Maybe Int + _ -> Nothing + +number :: Parser Int +number = fromDigits <$> some digit + +-- +-- Cron Exprs +-- + +cRange :: Parser E.Expr +cRange = uncurry E.Range <$> pair number number (token '-') + +cStepL :: Parser E.StepLExpr +cStepL = + (E.StepLEvery <$ token '*') + <|> (uncurry E.StepLRange <$> pair number number (token '-')) + +cStep :: Parser E.Expr +cStep = uncurry E.Step <$> pair cStepL number (token '/') + +cMulti :: Parser E.Expr +cMulti = E.Multi <$> sepBy1 number (token ',') + +cEvery :: Parser E.Expr +cEvery = E.Every <$ token '*' + +cExpr :: Parser E.Expr +cExpr = cStep <|> cEvery <|> cRange <|> cMulti + +parse :: [Token] -> Either String E.Expr +parse xs = case runParser cExpr xs of + Nothing -> Left "Invalid cron expression" + Just (expr, []) -> Right expr + Just (_, rest) -> Left ("Invalid cron expression. Couldn't parse `" ++ rest ++ "`") diff --git a/src/Cron/Schedule.hs b/src/Cron/Schedule.hs new file mode 100644 index 0000000..2ea56ab --- /dev/null +++ b/src/Cron/Schedule.hs @@ -0,0 +1,72 @@ +module Cron.Schedule (Schedule (..), fromParts) where + +import Common ((?)) +import qualified Cron.Expr as E +import qualified Cron.Parser as P +import Intro + +data Schedule = Schedule + { minute :: E.Expr + , hour :: E.Expr + , dayOfMonth :: E.Expr + , month :: E.Expr + , dayOfWeek :: E.Expr + } + deriving (Show) + +fromParts :: String -> String -> String -> String -> String -> Either String Schedule +fromParts mn h d m wd = + Schedule + <$> parseMinute mn + <*> parseHour h + <*> parseDayOfMonth d + <*> parseMonth m + <*> parseDayOfWeek wd + +parseMinute :: String -> Either String E.Expr +parseMinute s = P.parse s >>= validateMinute + +parseHour :: String -> Either String E.Expr +parseHour s = P.parse s >>= validateHour + +parseDayOfMonth :: String -> Either String E.Expr +parseDayOfMonth s = P.parse s >>= validateDayOfMonth + +parseMonth :: String -> Either String E.Expr +parseMonth s = P.parse s >>= validateMonth + +parseDayOfWeek :: String -> Either String E.Expr +parseDayOfWeek s = P.parse s >>= validateDayOfWeek + +validateMinute :: E.Expr -> Either String E.Expr +validateMinute expr = validateExpr expr >>= flip validateInRange [0 .. 59] + +validateHour :: E.Expr -> Either String E.Expr +validateHour expr = validateExpr expr >>= flip validateInRange [0 .. 23] + +validateDayOfMonth :: E.Expr -> Either String E.Expr +validateDayOfMonth expr = validateExpr expr >>= flip validateInRange [1 .. 31] + +validateMonth :: E.Expr -> Either String E.Expr +validateMonth expr = validateExpr expr >>= flip validateInRange [1 .. 12] + +validateDayOfWeek :: E.Expr -> Either String E.Expr +validateDayOfWeek expr = validateExpr expr >>= flip validateInRange [0 .. 6] + +validateExpr :: E.Expr -> Either String E.Expr +validateExpr expr = validate expr $ \case + E.Range n m -> n < m + _ -> True + +validateInRange :: E.Expr -> [Int] -> Either String E.Expr +validateInRange expr range = validate expr $ \case + E.Multi ns -> all inRange ns + E.Range n m -> inRange n && inRange m + E.Step _ _ -> True + E.Every -> True + where + inRange :: Int -> Bool + inRange = flip elem range + +validate :: E.Expr -> (E.Expr -> Bool) -> Either String E.Expr +validate expr p = p expr ? Right expr $ Left ("Invalid cron expression " ++ E.showExpr expr) -- cgit v1.2.3