never executed always true always false
1 module PureClaw.Scheduler.Cron
2 ( -- * Cron expression
3 CronExpr (..)
4 , CronField (..)
5 , parseCronExpr
6 -- * Matching
7 , cronMatches
8 -- * Scheduler
9 , CronJob (..)
10 , CronScheduler
11 , mkCronScheduler
12 , addJob
13 , removeJob
14 , tickScheduler
15 ) where
16
17 import Data.Map.Strict (Map)
18 import Data.Map.Strict qualified as Map
19 import Data.Text (Text)
20 import Data.Text qualified as T
21 import Data.Time
22
23 -- | A single field in a cron expression.
24 data CronField
25 = Wildcard -- ^ @*@ — matches any value
26 | Exact Int -- ^ A specific value
27 | Range Int Int -- ^ @a-b@ — inclusive range
28 | Step CronField Int -- ^ @field/n@ — every n-th value
29 | ListField [CronField] -- ^ @a,b,c@ — multiple values
30 deriving stock (Show, Eq)
31
32 -- | A parsed cron expression with 5 fields: minute, hour, day-of-month,
33 -- month, day-of-week.
34 data CronExpr = CronExpr
35 { _ce_minute :: CronField
36 , _ce_hour :: CronField
37 , _ce_dayOfMonth :: CronField
38 , _ce_month :: CronField
39 , _ce_dayOfWeek :: CronField
40 }
41 deriving stock (Show, Eq)
42
43 -- | Parse a cron expression string (5 space-separated fields).
44 -- Returns 'Left' with an error message on failure.
45 parseCronExpr :: Text -> Either String CronExpr
46 parseCronExpr input =
47 case T.words (T.strip input) of
48 [m, h, dom, mon, dow] -> do
49 minute <- parseField m
50 hour <- parseField h
51 dayOfMonth <- parseField dom
52 month <- parseField mon
53 dow' <- parseField dow
54 Right CronExpr
55 { _ce_minute = minute
56 , _ce_hour = hour
57 , _ce_dayOfMonth = dayOfMonth
58 , _ce_month = month
59 , _ce_dayOfWeek = dow'
60 }
61 _ -> Left "Expected 5 space-separated fields"
62
63 -- | Parse a single cron field.
64 parseField :: Text -> Either String CronField
65 parseField txt
66 | T.any (== ',') txt = do
67 let parts = T.splitOn "," txt
68 fields <- traverse parseField parts
69 Right (ListField fields)
70 | T.any (== '/') txt =
71 case T.splitOn "/" txt of
72 [base, step] -> do
73 baseField <- parseBaseField base
74 case readInt step of
75 Just n -> Right (Step baseField n)
76 Nothing -> Left ("Invalid step: " <> T.unpack step)
77 _ -> Left ("Invalid step expression: " <> T.unpack txt)
78 | otherwise = parseBaseField txt
79
80 -- | Parse a base field (no commas or slashes).
81 parseBaseField :: Text -> Either String CronField
82 parseBaseField txt
83 | txt == "*" = Right Wildcard
84 | T.any (== '-') txt =
85 case T.splitOn "-" txt of
86 [lo, hi] -> case (readInt lo, readInt hi) of
87 (Just l, Just h) -> Right (Range l h)
88 _ -> Left ("Invalid range: " <> T.unpack txt)
89 _ -> Left ("Invalid range: " <> T.unpack txt)
90 | otherwise = case readInt txt of
91 Just n -> Right (Exact n)
92 Nothing -> Left ("Invalid field: " <> T.unpack txt)
93
94 -- | Read an integer from text.
95 readInt :: Text -> Maybe Int
96 readInt txt = case reads (T.unpack txt) of
97 [(n, "")] -> Just n
98 _ -> Nothing
99
100 -- | Check if a cron expression matches a given UTC time.
101 cronMatches :: CronExpr -> UTCTime -> Bool
102 cronMatches expr time =
103 let (_year, monthVal, day) = toGregorian (utctDay time)
104 TimeOfDay hourVal minuteVal _ = timeToTimeOfDay (utctDayTime time)
105 -- Sunday = 0 in cron, Data.Time uses Monday = 1 .. Sunday = 7
106 dowRaw = let d = dayOfWeek (utctDay time)
107 in case d of
108 Sunday -> 0
109 _ -> fromEnum d
110 in fieldMatches (_ce_minute expr) minuteVal
111 && fieldMatches (_ce_hour expr) hourVal
112 && fieldMatches (_ce_dayOfMonth expr) day
113 && fieldMatches (_ce_month expr) monthVal
114 && fieldMatches (_ce_dayOfWeek expr) dowRaw
115
116 -- | Check if a cron field matches a specific integer value.
117 fieldMatches :: CronField -> Int -> Bool
118 fieldMatches Wildcard _ = True
119 fieldMatches (Exact n) v = n == v
120 fieldMatches (Range lo hi) v = v >= lo && v <= hi
121 fieldMatches (Step base n) v =
122 case base of
123 Wildcard -> v `mod` n == 0
124 Range lo _ -> v >= lo && (v - lo) `mod` n == 0
125 _ -> fieldMatches base v
126 fieldMatches (ListField fields) v = any (`fieldMatches` v) fields
127
128 -- | A scheduled job with a cron expression and an IO action.
129 data CronJob = CronJob
130 { _cj_name :: Text
131 , _cj_expr :: CronExpr
132 , _cj_action :: IO ()
133 }
134
135 -- | A scheduler that manages named cron jobs.
136 newtype CronScheduler = CronScheduler
137 { _cs_jobs :: Map Text CronJob
138 }
139
140 -- | Create an empty scheduler.
141 mkCronScheduler :: CronScheduler
142 mkCronScheduler = CronScheduler Map.empty
143
144 -- | Add a job to the scheduler. Replaces any existing job with the same name.
145 addJob :: CronJob -> CronScheduler -> CronScheduler
146 addJob job sched = sched { _cs_jobs = Map.insert (_cj_name job) job (_cs_jobs sched) }
147
148 -- | Remove a job by name.
149 removeJob :: Text -> CronScheduler -> CronScheduler
150 removeJob name sched = sched { _cs_jobs = Map.delete name (_cs_jobs sched) }
151
152 -- | Run all jobs whose cron expression matches the given time.
153 -- Returns the names of jobs that were executed.
154 tickScheduler :: CronScheduler -> UTCTime -> IO [Text]
155 tickScheduler sched time = do
156 let matching = Map.filter (\job -> cronMatches (_cj_expr job) time) (_cs_jobs sched)
157 mapM_ _cj_action (Map.elems matching)
158 pure (Map.keys matching)