aboutsummaryrefslogtreecommitdiff
path: root/src/Cron
diff options
context:
space:
mode:
Diffstat (limited to 'src/Cron')
-rw-r--r--src/Cron/Expr.hs21
-rw-r--r--src/Cron/Parser.hs88
-rw-r--r--src/Cron/Schedule.hs72
3 files changed, 181 insertions, 0 deletions
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)