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