Command-line and Emacs Calendar Client
ryan.freumh.org
1type filter =
2 | SummaryContains of string
3 | DescriptionContains of string
4 | LocationContains of string
5 | InCollections of Calendar_dir.collection list
6 | RecurringOnly
7 | NonRecurringOnly
8 | WithId of Event.event_id
9 | And of filter list
10 | Or of filter list
11 | Not of filter
12
13type sort_order = [ `Ascending | `Descending ]
14type sort_by = [ `Start | `End | `Summary | `Location | `Calendar ]
15
16let calendar_to_ptime date =
17 let open CalendarLib in
18 let year = Calendar.year date in
19 let month = Date.int_of_month (Calendar.month date) in
20 let day = Calendar.day_of_month date in
21 let time = Calendar.to_time date in
22 let hour = Time.hour time in
23 let minute = Time.minute time in
24 let second = Time.second time in
25 match
26 Ptime.of_date_time ((year, month, day), ((hour, minute, second), 0))
27 with
28 | Some t -> t
29 | None -> failwith "Invalid date conversion from Calendar to Ptime"
30
31let ptime_to_calendar ptime =
32 let (year, month, day), ((hour, minute, second), _) =
33 Ptime.to_date_time ptime
34 in
35 let open CalendarLib in
36 let date = Date.make year month day in
37 let time = Time.make hour minute second in
38 Calendar.create date time
39
40let get_today =
41 ref (fun () ->
42 let today_date = CalendarLib.Date.today () in
43 let midnight = CalendarLib.Time.make 0 0 0 in
44 let today_with_midnight =
45 CalendarLib.Calendar.create today_date midnight
46 in
47 calendar_to_ptime today_with_midnight)
48
49(* Convert a midnight timestamp to end-of-day (23:59:59) *)
50let to_end_of_day date =
51 let cal_date = ptime_to_calendar date in
52 let date_only = CalendarLib.Calendar.to_date cal_date in
53 let end_of_day_time = CalendarLib.Time.make 23 59 59 in
54 let end_of_day = CalendarLib.Calendar.create date_only end_of_day_time in
55 calendar_to_ptime end_of_day
56
57let add_days date days =
58 let cal_date = ptime_to_calendar date in
59 let period = CalendarLib.Calendar.Period.day days in
60 let new_date = CalendarLib.Calendar.add cal_date period in
61 calendar_to_ptime new_date
62
63let add_weeks date weeks =
64 let cal_date = ptime_to_calendar date in
65 let period = CalendarLib.Calendar.Period.week weeks in
66 let new_date = CalendarLib.Calendar.add cal_date period in
67 calendar_to_ptime new_date
68
69let add_months date months =
70 let cal_date = ptime_to_calendar date in
71 let period = CalendarLib.Calendar.Period.month months in
72 let new_date = CalendarLib.Calendar.add cal_date period in
73 calendar_to_ptime new_date
74
75let add_years date years =
76 let cal_date = ptime_to_calendar date in
77 let period = CalendarLib.Calendar.Period.year years in
78 let new_date = CalendarLib.Calendar.add cal_date period in
79 calendar_to_ptime new_date
80
81let get_start_of_week date =
82 let cal_date = ptime_to_calendar date in
83 let day_of_week = CalendarLib.Calendar.day_of_week cal_date in
84 let days_to_subtract =
85 match day_of_week with
86 | CalendarLib.Date.Mon -> 0
87 | CalendarLib.Date.Tue -> 1
88 | CalendarLib.Date.Wed -> 2
89 | CalendarLib.Date.Thu -> 3
90 | CalendarLib.Date.Fri -> 4
91 | CalendarLib.Date.Sat -> 5
92 | CalendarLib.Date.Sun -> 6
93 in
94 let monday =
95 CalendarLib.Calendar.add cal_date
96 (CalendarLib.Calendar.Period.day (-days_to_subtract))
97 in
98 (* Extract the date part and create a new calendar with midnight time *)
99 let monday_date = CalendarLib.Calendar.to_date monday in
100 let midnight = CalendarLib.Time.make 0 0 0 in
101 let monday_at_midnight = CalendarLib.Calendar.create monday_date midnight in
102 calendar_to_ptime monday_at_midnight
103
104let get_start_of_current_week () = get_start_of_week (!get_today ())
105let get_start_of_next_week () = add_days (get_start_of_current_week ()) 7
106let get_end_of_week date = add_days (get_start_of_week date) 6
107let get_end_of_current_week () = get_end_of_week (!get_today ())
108let get_end_of_next_week () = get_end_of_week (get_start_of_next_week ())
109
110let get_start_of_month date =
111 let cal_date = ptime_to_calendar date in
112 (* Extract year and month from calendar date *)
113 let year = CalendarLib.Calendar.year cal_date in
114 let month = CalendarLib.Calendar.month cal_date in
115 (* Create a date for the first of the month *)
116 let month_int = CalendarLib.Date.int_of_month month in
117 let first_day = CalendarLib.Date.make year month_int 1 in
118 let midnight = CalendarLib.Time.make 0 0 0 in
119 let first_of_month = CalendarLib.Calendar.create first_day midnight in
120 calendar_to_ptime first_of_month
121
122let get_start_of_current_month () = get_start_of_month (!get_today ())
123let get_start_of_next_month () = add_months (get_start_of_current_month ()) 1
124
125let get_end_of_month date =
126 let cal_date = ptime_to_calendar date in
127 let year = CalendarLib.Calendar.year cal_date in
128 let month = CalendarLib.Calendar.month cal_date in
129 let month_int = CalendarLib.Date.int_of_month month in
130 (* Create a calendar for the first of next month *)
131 let next_month_int = if month_int == 12 then 1 else month_int + 1 in
132 let next_month_year = if month_int == 12 then year + 1 else year in
133 let first_of_next_month =
134 CalendarLib.Date.make next_month_year next_month_int 1
135 in
136 let midnight = CalendarLib.Time.make 0 0 0 in
137 let first_of_next_month_cal =
138 CalendarLib.Calendar.create first_of_next_month midnight
139 in
140 (* Subtract one second to get the end of the current month *)
141 let period = CalendarLib.Calendar.Period.second (-1) in
142 let last_of_month = CalendarLib.Calendar.add first_of_next_month_cal period in
143 calendar_to_ptime last_of_month
144
145let get_end_of_current_month () = get_end_of_month (!get_today ())
146let get_end_of_next_month () = get_end_of_month (get_start_of_next_month ())
147
148(* Parse a date string that could be ISO format or a relative expression *)
149let parse_date_expression expr parameter =
150 let iso_date_regex = Re.Pcre.regexp "^(\\d{4})-(\\d{2})-(\\d{2})$" in
151 let relative_regex = Re.Pcre.regexp "^([+-])(\\d+)([dwm])$" in
152 match expr with
153 | "today" -> !get_today ()
154 | "tomorrow" -> add_days (!get_today ()) 1
155 | "yesterday" -> add_days (!get_today ()) (-1)
156 | "this-week" -> (
157 match parameter with
158 | `From -> get_start_of_current_week ()
159 | `To -> get_end_of_current_week ())
160 | "next-week" -> (
161 match parameter with
162 | `From -> get_start_of_next_week ()
163 | `To -> get_end_of_next_week ())
164 | "this-month" -> (
165 match parameter with
166 | `From -> get_start_of_current_month ()
167 | `To -> get_end_of_current_month ())
168 | "next-month" -> (
169 match parameter with
170 | `From -> get_start_of_next_month ()
171 | `To -> get_end_of_next_month ())
172 | _ ->
173 (* Try to parse as ISO date *)
174 if Re.Pcre.pmatch ~rex:iso_date_regex expr then
175 try
176 let year =
177 int_of_string
178 (Re.Pcre.get_substring (Re.Pcre.exec ~rex:iso_date_regex expr) 1)
179 in
180 let month =
181 int_of_string
182 (Re.Pcre.get_substring (Re.Pcre.exec ~rex:iso_date_regex expr) 2)
183 in
184 let day =
185 int_of_string
186 (Re.Pcre.get_substring (Re.Pcre.exec ~rex:iso_date_regex expr) 3)
187 in
188 match Ptime.of_date_time ((year, month, day), ((0, 0, 0), 0)) with
189 | Some date -> date
190 | None -> failwith (Printf.sprintf "Invalid date: %s" expr)
191 with e ->
192 failwith
193 (Printf.sprintf "Failed to parse ISO date '%s': %s" expr
194 (Printexc.to_string e))
195 (* Try to parse as relative expression +Nd, -Nd, etc. *)
196 else if Re.Pcre.pmatch ~rex:relative_regex expr then
197 try
198 let sign =
199 Re.Pcre.get_substring (Re.Pcre.exec ~rex:relative_regex expr) 1
200 in
201 let num =
202 int_of_string
203 (Re.Pcre.get_substring (Re.Pcre.exec ~rex:relative_regex expr) 2)
204 in
205 let unit =
206 Re.Pcre.get_substring (Re.Pcre.exec ~rex:relative_regex expr) 3
207 in
208 let multiplier = if sign = "+" then 1 else -1 in
209 let value = num * multiplier in
210 let today = !get_today () in
211 match unit with
212 | "d" -> add_days today value
213 | "w" -> (
214 let date = add_weeks today value in
215 match parameter with
216 | `From -> get_start_of_week date
217 | `To -> get_end_of_week date)
218 | "m" -> (
219 let date = add_months today value in
220 match parameter with
221 | `From -> get_start_of_month date
222 | `To -> get_end_of_month date)
223 | _ -> failwith (Printf.sprintf "Invalid date unit: %s" unit)
224 with e ->
225 failwith
226 (Printf.sprintf "Failed to parse relative date '%s': %s" expr
227 (Printexc.to_string e))
228 else failwith (Printf.sprintf "Invalid date format: %s" expr)
229
230let convert_relative_date_formats ~today ~tomorrow ~week ~month =
231 if today then
232 let today_date = !get_today () in
233 (* Set the end date to end-of-day to include all events on that day *)
234 let end_of_today = to_end_of_day today_date in
235 Some (today_date, end_of_today)
236 else if tomorrow then
237 let today = !get_today () in
238 let tomorrow_date = add_days today 1 in
239 (* Set the end date to end-of-day to include all events on that day *)
240 let end_of_tomorrow = to_end_of_day tomorrow_date in
241 Some (tomorrow_date, end_of_tomorrow)
242 else if week then
243 let week_start = get_start_of_current_week () in
244 let week_end_date = add_days week_start 6 in
245 (* Sunday is 6 days from Monday *)
246 (* Set the end date to end-of-day to include all events on Sunday *)
247 let end_of_week = to_end_of_day week_end_date in
248 Some (week_start, end_of_week)
249 else if month then
250 let month_start = get_start_of_current_month () in
251 let month_end = get_end_of_month month_start in
252 Some (month_start, month_end)
253 else None
254
255let summary_contains text = SummaryContains text
256let description_contains text = DescriptionContains text
257let location_contains text = LocationContains text
258let in_collections ids = InCollections ids
259let recurring_only () = RecurringOnly
260let non_recurring_only () = NonRecurringOnly
261let with_id id = WithId id
262let and_filter filters = And filters
263let or_filter filters = Or filters
264let not_filter filter = Not filter
265
266let rec matches_filter event = function
267 | SummaryContains text ->
268 let summary = Event.get_summary event in
269 let re = Re.Pcre.regexp ~flags:[ `CASELESS ] (Re.Pcre.quote text) in
270 Re.Pcre.pmatch ~rex:re summary
271 | DescriptionContains text -> (
272 match Event.get_description event with
273 | Some desc ->
274 let re = Re.Pcre.regexp ~flags:[ `CASELESS ] (Re.Pcre.quote text) in
275 Re.Pcre.pmatch ~rex:re desc
276 | None -> false)
277 | LocationContains text -> (
278 match Event.get_location event with
279 | Some loc ->
280 let re = Re.Pcre.regexp ~flags:[ `CASELESS ] (Re.Pcre.quote text) in
281 Re.Pcre.pmatch ~rex:re loc
282 | None -> false)
283 | InCollections ids -> (
284 match Event.get_collection event with
285 | Some id -> List.exists (fun col -> col = id) ids
286 | None -> false)
287 | RecurringOnly -> Event.get_recurrence event <> None
288 | NonRecurringOnly -> Event.get_recurrence event = None
289 | WithId id -> Event.get_id event = id
290 | And filters -> List.for_all (matches_filter event) filters
291 | Or filters -> List.exists (matches_filter event) filters
292 | Not filter -> not (matches_filter event filter)
293
294let compare_events sort_by order e1 e2 =
295 let compare =
296 match sort_by with
297 | `Start ->
298 let t1 = Event.get_start e1 in
299 let t2 = Event.get_start e2 in
300 Ptime.compare t1 t2
301 | `End -> (
302 match (Event.get_end e1, Event.get_end e2) with
303 | Some t1, Some t2 -> Ptime.compare t1 t2
304 | Some _, None -> 1
305 | None, Some _ -> -1
306 | None, None -> 0)
307 | `Summary -> String.compare (Event.get_summary e1) (Event.get_summary e2)
308 | `Location -> (
309 match (Event.get_location e1, Event.get_location e2) with
310 | Some l1, Some l2 -> String.compare l1 l2
311 | Some _, None -> 1
312 | None, Some _ -> -1
313 | None, None -> 0)
314 | `Calendar -> (
315 match (Event.get_collection e1, Event.get_collection e2) with
316 | Some (Calendar_dir.Collection c1), Some (Calendar_dir.Collection c2)
317 ->
318 String.compare c1 c2
319 | Some _, None -> 1
320 | None, Some _ -> -1
321 | None, None -> 0)
322 in
323 match order with `Ascending -> compare | `Descending -> -compare
324
325let get_all_events ~fs calendar_dir =
326 match Calendar_dir.get_collections ~fs calendar_dir with
327 | Ok collections ->
328 let events =
329 List.concat_map
330 (fun (collection, calendar_files) ->
331 List.concat_map
332 (fun calendar_file ->
333 List.filter_map
334 (function
335 | `Event e -> (
336 match Event.of_icalendar collection e with
337 | Ok event -> Some event
338 | Error (`Msg msg) ->
339 Printf.eprintf "Error parsing event from %s: %s\n%!"
340 calendar_file.Calendar_dir.file_path msg;
341 None)
342 | _ -> None)
343 (snd calendar_file.Calendar_dir.calendar))
344 calendar_files)
345 collections
346 in
347 Ok events
348 | Error e -> Error e
349
350let query_events ~fs calendar_dir ?filter ?sort_by ?order ?limit () =
351 match get_all_events ~fs calendar_dir with
352 | Ok events ->
353 let filtered_events =
354 match filter with
355 | Some f -> List.filter (fun event -> matches_filter event f) events
356 | None -> events
357 in
358 let sorted_events =
359 match (sort_by, order) with
360 | Some criteria, Some ord ->
361 List.sort (compare_events criteria ord) filtered_events
362 | Some criteria, None ->
363 List.sort (compare_events criteria `Ascending) filtered_events
364 | None, _ ->
365 List.sort (compare_events `Start `Ascending) filtered_events
366 in
367 Ok
368 (match limit with
369 | Some n when n > 0 ->
370 let rec take n lst acc =
371 match (lst, n) with
372 | _, 0 -> List.rev acc
373 | [], _ -> List.rev acc
374 | x :: xs, n -> take (n - 1) xs (x :: acc)
375 in
376 take n sorted_events []
377 | _ -> sorted_events)
378 | Error e -> Error e
379
380let query ~fs calendar_dir ?filter ~from ~to_ ?sort_by ?order ?limit () =
381 match query_events ~fs calendar_dir ?filter ?sort_by ?order () with
382 | Ok events ->
383 let instances =
384 List.concat_map
385 (fun event -> Recur.expand_event event ~from ~to_)
386 events
387 in
388 let compare_instances criteria ord i1 i2 =
389 match criteria with
390 | `Start ->
391 let c = Ptime.compare i1.Recur.start i2.Recur.start in
392 if ord = `Ascending then c else -c
393 | `End -> (
394 match (i1.Recur.end_, i2.Recur.end_) with
395 | Some t1, Some t2 ->
396 let c = Ptime.compare t1 t2 in
397 if ord = `Ascending then c else -c
398 | Some _, None -> if ord = `Ascending then 1 else -1
399 | None, Some _ -> if ord = `Ascending then -1 else 1
400 | None, None -> 0)
401 | other ->
402 let c = compare_events other ord i1.Recur.event i2.Recur.event in
403 if ord = `Ascending then c else -c
404 in
405 let sorted_instances =
406 match (sort_by, order) with
407 | Some criteria, Some ord ->
408 List.sort (compare_instances criteria ord) instances
409 | Some criteria, None ->
410 List.sort (compare_instances criteria `Ascending) instances
411 | None, _ -> List.sort (compare_instances `Start `Ascending) instances
412 in
413 Ok
414 (match limit with
415 | Some n when n > 0 ->
416 let rec take n lst acc =
417 match (lst, n) with
418 | _, 0 -> List.rev acc
419 | [], _ -> List.rev acc
420 | x :: xs, n -> take (n - 1) xs (x :: acc)
421 in
422 take n sorted_instances []
423 | _ -> sorted_instances)
424 | Error e -> Error e