Command-line and Emacs Calendar Client
ryan.freumh.org
1open Icalendar
2
3type event_id = string
4
5type t = {
6 calendar_name : string;
7 file : Eio.Fs.dir_ty Eio.Path.t;
8 event : event;
9 calendar : calendar;
10}
11
12type date_error = [ `Msg of string ]
13
14let generate_uuid () =
15 let uuid = Uuidm.v4_gen (Random.State.make_self_init ()) () in
16 Uuidm.to_string uuid
17
18let default_prodid = `Prodid (Params.empty, "-//Freumh//Caledonia//EN")
19let ( let* ) = Result.bind
20
21let create ~(fs : Eio.Fs.dir_ty Eio.Path.t) ~calendar_dir_path ~summary ~start
22 ?end_ ?location ?description ?recurrence calendar_name =
23 let uuid = generate_uuid () in
24 let uid = (Params.empty, uuid) in
25 let file_name = uuid ^ ".ics" in
26 let file =
27 Eio.Path.(
28 fs / calendar_dir_path / (match calendar_name with s -> s) / file_name)
29 in
30 let dtstart = start in
31 let dtend_or_duration = end_ in
32 let* _ =
33 match (dtstart, dtend_or_duration) with
34 | (_, `Date _), Some (`Dtend (_, `Datetime _)) ->
35 Error (`Msg "If the start is a date the end must also be a date.")
36 | (_, `Datetime _), Some (`Dtend (_, `Date _)) ->
37 Error
38 (`Msg "If the start is a datetime the end must also be a datetime.")
39 | _ -> Ok ()
40 in
41 let rrule = Option.map (fun r -> (Params.empty, r)) recurrence in
42 let now = Ptime_clock.now () in
43 let props = [ `Summary (Params.empty, summary) ] in
44 let props =
45 match location with
46 | Some loc -> `Location (Params.empty, loc) :: props
47 | None -> props
48 in
49 let props =
50 match description with
51 | Some desc -> `Description (Params.empty, desc) :: props
52 | None -> props
53 in
54 let event =
55 {
56 dtstamp = (Params.empty, now);
57 uid;
58 dtstart;
59 dtend_or_duration;
60 rrule;
61 props;
62 alarms = [];
63 }
64 in
65 let calendar =
66 let props = [ default_prodid ] in
67 let components = [ `Event event ] in
68 (props, components)
69 in
70 Ok { calendar_name; file; event; calendar }
71
72let edit ?summary ?start ?end_ ?location ?description ?recurrence t =
73 let now = Ptime_clock.now () in
74 let uid = t.event.uid in
75 let dtstart = match start with None -> t.event.dtstart | Some s -> s in
76 let dtend_or_duration =
77 match end_ with None -> t.event.dtend_or_duration | Some _ -> end_
78 in
79 let* _ =
80 match (dtstart, dtend_or_duration) with
81 | (_, `Date _), Some (`Dtend (_, `Datetime _)) ->
82 Error (`Msg "If the start is a date the end must also be a date.")
83 | (_, `Datetime _), Some (`Dtend (_, `Date _)) ->
84 Error
85 (`Msg "If the start is a datetime the end must also be a datetime.")
86 | _ -> Ok ()
87 in
88 let rrule =
89 match recurrence with
90 | None -> t.event.rrule
91 | Some r -> Some (Params.empty, r)
92 in
93 let props =
94 List.filter
95 (function
96 | `Summary _ -> ( match summary with None -> true | Some _ -> false)
97 | `Location _ -> ( match location with None -> true | Some _ -> false)
98 | `Description _ -> (
99 match description with None -> true | Some _ -> false)
100 | _ -> true)
101 t.event.props
102 in
103 let props =
104 match summary with
105 | Some summary -> `Summary (Params.empty, summary) :: props
106 | None -> props
107 in
108 let props =
109 match location with
110 | Some loc -> `Location (Params.empty, loc) :: props
111 | None -> props
112 in
113 let props =
114 match description with
115 | Some desc -> `Description (Params.empty, desc) :: props
116 | None -> props
117 in
118 let alarms = t.event.alarms in
119 let event =
120 {
121 dtstamp = (Params.empty, now);
122 uid;
123 dtstart;
124 dtend_or_duration;
125 rrule;
126 props;
127 alarms;
128 }
129 in
130 let calendar_name = t.calendar_name in
131 let file = t.file in
132 let calendar = t.calendar in
133 Ok { calendar_name; file; event; calendar }
134
135let events_of_icalendar calendar_name ~file calendar =
136 let remove_dup_ids lst =
137 let rec aux acc = function
138 | [] -> acc
139 | x :: xs ->
140 if List.exists (fun r -> r.uid = x.uid) acc then aux acc xs
141 else aux (x :: acc) xs
142 in
143 aux [] lst
144 in
145 let events =
146 List.filter_map
147 (function `Event event -> Some event | _ -> None)
148 (snd calendar)
149 in
150 let events = remove_dup_ids events in
151 List.map (function event -> { calendar_name; file; event; calendar }) events
152
153let to_ical_event t = t.event
154let to_ical_calendar t = t.calendar
155let get_id t = snd t.event.uid
156
157let get_summary t =
158 match
159 List.filter_map
160 (function `Summary (_, s) when s <> "" -> Some s | _ -> None)
161 t.event.props
162 with
163 | s :: _ -> Some s
164 | _ -> None
165
166let get_ical_start event = Date.ptime_of_ical (snd event.dtstart)
167let get_start t = get_ical_start t.event
168
169let get_ical_end event =
170 match event.dtend_or_duration with
171 | Some (`Dtend (_, d)) -> Some (Date.ptime_of_ical d)
172 | Some (`Duration (_, span)) -> (
173 let start = get_ical_start event in
174 match Ptime.add_span start span with
175 | Some t -> Some t
176 | None ->
177 failwith
178 (Printf.sprintf "Invalid duration calculation: %s + %s"
179 (Ptime.to_rfc3339 start)
180 (Printf.sprintf "%.2fs" (Ptime.Span.to_float_s span))))
181 | None -> None
182
183let get_end t = get_ical_end t.event
184
185let get_start_timezone t =
186 match t.event.dtstart with
187 | _, `Datetime (`With_tzid (_, (_, tzid))) -> Some tzid
188 | _, `Datetime (`Utc _) -> Some "UTC"
189 | _ -> None
190
191let get_end_timezone t =
192 match t.event.dtend_or_duration with
193 | Some (`Dtend (_, `Datetime (`With_tzid (_, (_, tzid))))) -> Some tzid
194 | Some (`Dtend (_, `Datetime (`Utc _))) -> Some "UTC"
195 | _ -> None
196
197let get_duration t =
198 match t.event.dtend_or_duration with
199 | Some (`Duration (_, span)) -> Some span
200 | Some (`Dtend (_, e)) ->
201 let span = Ptime.diff (Date.ptime_of_ical e) (get_start t) in
202 Some span
203 | None -> None
204
205let is_date t =
206 match (t.event.dtstart, t.event.dtend_or_duration) with
207 | (_, `Date _), _ -> true
208 | _, Some (`Dtend (_, `Date _)) -> true
209 | _ -> false
210
211let get_location t =
212 match
213 List.filter_map
214 (function `Location (_, s) when s <> "" -> Some s | _ -> None)
215 t.event.props
216 with
217 | s :: _ -> Some s
218 | _ -> None
219
220let get_description t =
221 match
222 List.filter_map
223 (function `Description (_, s) when s <> "" -> Some s | _ -> None)
224 t.event.props
225 with
226 | s :: _ -> Some s
227 | _ -> None
228
229let get_recurrence t = Option.map (fun r -> snd r) t.event.rrule
230let get_calendar_name t = t.calendar_name
231let get_file t = t.file
232
233type comparator = t -> t -> int
234
235let by_start e1 e2 =
236 let t1 = get_start e1 in
237 let t2 = get_start e2 in
238 Ptime.compare t1 t2
239
240let by_end e1 e2 =
241 match (get_end e1, get_end e2) with
242 | Some t1, Some t2 -> Ptime.compare t1 t2
243 | Some _, None -> 1
244 | None, Some _ -> -1
245 | None, None -> 0
246
247let by_summary e1 e2 =
248 match (get_summary e1, get_summary e2) with
249 | Some s1, Some s2 -> String.compare s1 s2
250 | Some _, None -> 1
251 | None, Some _ -> -1
252 | None, None -> 0
253
254let by_location e1 e2 =
255 match (get_location e1, get_location e2) with
256 | Some l1, Some l2 -> String.compare l1 l2
257 | Some _, None -> 1
258 | None, Some _ -> -1
259 | None, None -> 0
260
261let by_calendar_name e1 e2 =
262 match (get_calendar_name e1, get_calendar_name e2) with
263 | c1, c2 -> String.compare c1 c2
264
265let descending comp e1 e2 = -1 * comp e1 e2
266
267let chain comp1 comp2 e1 e2 =
268 let result = comp1 e1 e2 in
269 if result <> 0 then result else comp2 e1 e2
270
271let clone_with_event t event =
272 let calendar_name = t.calendar_name in
273 let file = t.file in
274 let calendar = t.calendar in
275 { calendar_name; file; event; calendar }
276
277type format = [ `Text | `Entries | `Json | `Csv | `Ics | `Sexp ]
278
279let format_date ?tz date =
280 let dt = Date.ptime_to_timedesc ?tz date in
281 let y = Timedesc.year dt in
282 let m = Timedesc.month dt in
283 let d = Timedesc.day dt in
284 let weekday =
285 match Timedesc.weekday dt with
286 | `Mon -> "Mon"
287 | `Tue -> "Tue"
288 | `Wed -> "Wed"
289 | `Thu -> "Thu"
290 | `Fri -> "Fri"
291 | `Sat -> "Sat"
292 | `Sun -> "Sun"
293 in
294 Printf.sprintf "%04d-%02d-%02d %s" y m d weekday
295
296let format_time ?tz date =
297 let dt = Date.ptime_to_timedesc ?tz date in
298 let h = Timedesc.hour dt in
299 let m = Timedesc.minute dt in
300 Printf.sprintf "%02d:%02d" h m
301
302let format_datetime ?tz date =
303 let tz_str =
304 match tz with
305 | Some tz -> Printf.sprintf "(%s)" (Timedesc.Time_zone.name tz)
306 | None -> ""
307 in
308 Printf.sprintf "%s %s%s" (format_date ?tz date) (format_time ?tz date) tz_str
309
310let day_diff day ~next =
311 let span = Ptime.diff next day in
312 let d, _ = Ptime.Span.to_d_ps span in
313 d
314
315(* exosed from icalendar *)
316
317let weekday_strings =
318 [
319 (`Monday, "MO");
320 (`Tuesday, "TU");
321 (`Wednesday, "WE");
322 (`Thursday, "TH");
323 (`Friday, "FR");
324 (`Saturday, "SA");
325 (`Sunday, "SU");
326 ]
327
328let freq_strings =
329 [
330 (`Daily, "DAILY");
331 (`Hourly, "HOURLY");
332 (`Minutely, "MINUTELY");
333 (`Monthly, "MONTHLY");
334 (`Secondly, "SECONDLY");
335 (`Weekly, "WEEKLY");
336 (`Yearly, "YEARLY");
337 ]
338
339let date_to_str (y, m, d) = Printf.sprintf "%04d%02d%02d" y m d
340
341let datetime_to_str ptime utc =
342 let date, ((hh, mm, ss), _) = Ptime.to_date_time ptime in
343 Printf.sprintf "%sT%02d%02d%02d%s" (date_to_str date) hh mm ss
344 (if utc then "Z" else "")
345
346let timestamp_to_ics ts buf =
347 Buffer.add_string buf
348 @@
349 match ts with
350 | `Utc ts -> datetime_to_str ts true
351 | `Local ts -> datetime_to_str ts false
352 | `With_tzid (ts, _str) -> (* TODO *) datetime_to_str ts false
353
354let recurs_to_ics (freq, count_or_until, interval, l) buf =
355 let write_rulepart key value =
356 Buffer.add_string buf key;
357 Buffer.add_char buf '=';
358 Buffer.add_string buf value
359 in
360 let int_list l = String.concat "," @@ List.map string_of_int l in
361 let recur_to_ics = function
362 | `Byminute byminlist -> write_rulepart "BYMINUTE" (int_list byminlist)
363 | `Byday bywdaylist ->
364 let wday (weeknumber, weekday) =
365 (if weeknumber = 0 then "" else string_of_int weeknumber)
366 ^ List.assoc weekday weekday_strings
367 in
368 write_rulepart "BYDAY" (String.concat "," @@ List.map wday bywdaylist)
369 | `Byhour byhrlist -> write_rulepart "BYHOUR" (int_list byhrlist)
370 | `Bymonth bymolist -> write_rulepart "BYMONTH" (int_list bymolist)
371 | `Bymonthday bymodaylist ->
372 write_rulepart "BYMONTHDAY" (int_list bymodaylist)
373 | `Bysecond byseclist -> write_rulepart "BYSECOND" (int_list byseclist)
374 | `Bysetposday bysplist -> write_rulepart "BYSETPOS" (int_list bysplist)
375 | `Byweek bywknolist -> write_rulepart "BYWEEKNO" (int_list bywknolist)
376 | `Byyearday byyrdaylist ->
377 write_rulepart "BYYEARDAY" (int_list byyrdaylist)
378 | `Weekday weekday ->
379 write_rulepart "WKST" (List.assoc weekday weekday_strings)
380 in
381 write_rulepart "FREQ" (List.assoc freq freq_strings);
382 (match count_or_until with
383 | None -> ()
384 | Some x -> (
385 Buffer.add_char buf ';';
386 match x with
387 | `Count c -> write_rulepart "COUNT" (string_of_int c)
388 | `Until enddate ->
389 (* TODO cleanup *)
390 Buffer.add_string buf "UNTIL=";
391 timestamp_to_ics enddate buf));
392 (match interval with
393 | None -> ()
394 | Some i ->
395 Buffer.add_char buf ';';
396 write_rulepart "INTERVAL" (string_of_int i));
397 List.iter
398 (fun recur ->
399 Buffer.add_char buf ';';
400 recur_to_ics recur)
401 l
402
403let text_event_data ?tz event =
404 let id = get_id event in
405 let start = get_start event in
406 let end_ = get_end event in
407 let start_date = format_date ?tz start in
408 let start_timezone = get_start_timezone event in
409 let end_timezone = get_end_timezone event in
410 let same_timezone =
411 match (start_timezone, end_timezone) with
412 | Some tz1, Some tz2 when tz1 = tz2 -> true
413 | _ -> false
414 in
415 let start_time =
416 match is_date event with
417 | true -> ""
418 | false ->
419 let tz_str =
420 if same_timezone then " " ^ format_time ?tz start
421 else
422 match start_timezone with
423 | Some tzid -> " " ^ format_time ?tz start ^ " (" ^ tzid ^ ")"
424 | None -> " " ^ format_time ?tz start
425 in
426 tz_str
427 in
428 let end_date, end_time =
429 match end_ with
430 | None -> ("", "")
431 | Some end_ -> (
432 match is_date event with
433 | true -> (
434 match day_diff start ~next:end_ <= 1 with
435 | true -> ("", "")
436 | false -> (" - " ^ format_date ?tz end_, ""))
437 | false -> (
438 match day_diff start ~next:end_ == 0 with
439 | true ->
440 let tz_str =
441 match end_timezone with
442 | Some tzid when same_timezone ->
443 ("", " - " ^ format_time ?tz end_ ^ " (" ^ tzid ^ ")")
444 | Some tzid ->
445 ("", " - " ^ format_time ?tz end_ ^ " (" ^ tzid ^ ")")
446 | None -> ("", " - " ^ format_time ?tz end_)
447 in
448 tz_str
449 | false ->
450 let tz_str =
451 match end_timezone with
452 | Some tzid when same_timezone ->
453 ( " - " ^ format_date ?tz end_,
454 " " ^ format_time ?tz end_ ^ " (" ^ tzid ^ ")" )
455 | Some tzid ->
456 ( " - " ^ format_date ?tz end_,
457 " " ^ format_time ?tz end_ ^ " (" ^ tzid ^ ")" )
458 | None ->
459 (" - " ^ format_date ?tz end_, " " ^ format_time ?tz end_)
460 in
461 tz_str))
462 in
463 let summary =
464 match get_summary event with
465 | Some summary when summary <> "" -> summary
466 | _ -> ""
467 in
468 let location =
469 match get_location event with
470 | Some loc when loc <> "" -> "@" ^ loc
471 | _ -> ""
472 in
473 let calendar_name = get_calendar_name event in
474 let date_time = start_date ^ start_time ^ end_date ^ end_time in
475 (id, calendar_name, date_time, summary, location)
476
477let format_event ?(format = `Text) ?tz event =
478 let start = get_start event in
479 let end_ = get_end event in
480 match format with
481 | `Text ->
482 let id, calendar_name, date_time, summary, location =
483 text_event_data ?tz event
484 in
485 Printf.sprintf "%s\t%s\t%s\t%s\t%s" calendar_name date_time summary
486 location id
487 | `Entries ->
488 let format_opt label f opt =
489 Option.map (fun x -> Printf.sprintf "%s: %s\n" label (f x)) opt
490 |> Option.value ~default:""
491 in
492 let start_timezone = get_start_timezone event in
493 let end_timezone = get_end_timezone event in
494 let same_timezone =
495 match (start_timezone, end_timezone) with
496 | Some tz1, Some tz2 when tz1 = tz2 -> true
497 | _ -> false
498 in
499 let format timezone datetime is_end =
500 match is_date event with
501 | true -> format_date ?tz datetime
502 | false ->
503 let tz_suffix =
504 if (not is_end) && same_timezone then ""
505 else match timezone with None -> "" | Some t -> " (" ^ t ^ ")"
506 in
507 format_datetime ?tz datetime ^ tz_suffix
508 in
509 let start_str =
510 format_opt "Start" (fun d -> format start_timezone d false) (Some start)
511 in
512 let end_str =
513 format_opt "End" (fun d -> format end_timezone d true) end_
514 in
515 let location_str = format_opt "Location" Fun.id (get_location event) in
516 let description_str =
517 format_opt "Description" Fun.id (get_description event)
518 in
519 let rrule_str =
520 Option.map
521 (fun r ->
522 let buf = Buffer.create 128 in
523 recurs_to_ics r buf;
524 Printf.sprintf "%s: %s\n" "Reccurence" (Buffer.contents buf))
525 (get_recurrence event)
526 |> Option.value ~default:""
527 in
528 let summary_str = format_opt "Summary" Fun.id (get_summary event) in
529 let file_str = format_opt "File" Fun.id (Some (snd (get_file event))) in
530 Printf.sprintf "%s%s%s%s%s%s%s" summary_str start_str end_str location_str
531 description_str rrule_str file_str
532 | `Json ->
533 let open Yojson.Safe in
534 let json =
535 `Assoc
536 [
537 ("id", `String (get_id event));
538 ( "summary",
539 match get_summary event with
540 | Some summary -> `String summary
541 | None -> `Null );
542 ("start", `String (format_datetime ?tz start));
543 ( "end",
544 match end_ with
545 | Some e -> `String (format_datetime ?tz e)
546 | None -> `Null );
547 ( "location",
548 match get_location event with
549 | Some loc -> `String loc
550 | None -> `Null );
551 ( "description",
552 match get_description event with
553 | Some desc -> `String desc
554 | None -> `Null );
555 ("calendar", match get_calendar_name event with cal -> `String cal);
556 ]
557 in
558 to_string json
559 | `Csv ->
560 let summary =
561 match get_summary event with Some summary -> summary | None -> ""
562 in
563 let start = format_datetime ?tz start in
564 let end_str =
565 match end_ with Some e -> format_datetime ?tz e | None -> ""
566 in
567 let location =
568 match get_location event with Some loc -> loc | None -> ""
569 in
570 let cal_id = match get_calendar_name event with cal -> cal in
571 Printf.sprintf "\"%s\",\"%s\",\"%s\",\"%s\",\"%s\"" summary start end_str
572 location cal_id
573 | `Ics ->
574 let calendar = to_ical_calendar event in
575 Icalendar.to_ics ~cr:true calendar
576 | `Sexp ->
577 let summary =
578 match get_summary event with Some summary -> summary | None -> ""
579 in
580 let start_str =
581 let dt = Date.ptime_to_timedesc ?tz start in
582 let y = Timedesc.year dt in
583 let m = Timedesc.month dt in
584 let d = Timedesc.day dt in
585 let h = Timedesc.hour dt in
586 let min = Timedesc.minute dt in
587 let s = Timedesc.second dt in
588 (* Format as a single timestamp string that's easy for Emacs to parse *)
589 Printf.sprintf "\"%04d-%02d-%02dT%02d:%02d:%02d\"" y m d h min s
590 in
591 let end_str =
592 match end_ with
593 | Some end_date ->
594 let dt = Date.ptime_to_timedesc ?tz end_date in
595 let y = Timedesc.year dt in
596 let m = Timedesc.month dt in
597 let d = Timedesc.day dt in
598 let h = Timedesc.hour dt in
599 let min = Timedesc.minute dt in
600 let s = Timedesc.second dt in
601 Printf.sprintf "\"%04d-%02d-%02dT%02d:%02d:%02d\"" y m d h min s
602 | None -> "nil"
603 in
604 let location =
605 match get_location event with
606 | Some loc -> Printf.sprintf "\"%s\"" (String.escaped loc)
607 | None -> "nil"
608 in
609 let description =
610 match get_description event with
611 | Some desc -> Printf.sprintf "\"%s\"" (String.escaped desc)
612 | None -> "nil"
613 in
614 let calendar =
615 match get_calendar_name event with
616 | cal -> Printf.sprintf "\"%s\"" (String.escaped cal)
617 in
618 let id = get_id event in
619 Printf.sprintf
620 "((:id \"%s\" :summary \"%s\" :start %s :end %s :location %s \
621 :description %s :calendar %s))"
622 (String.escaped id) (String.escaped summary) start_str end_str location
623 description calendar
624
625let format_events_with_dynamic_columns ?tz events =
626 if events = [] then ""
627 else
628 let event_data = List.map (text_event_data ?tz) events in
629 (* Calculate max width for each column *)
630 let max_id_width =
631 List.fold_left
632 (fun acc (id, _, _, _, _) -> max acc (String.length id))
633 0 event_data
634 in
635 let max_cal_width =
636 List.fold_left
637 (fun acc (_, cal, _, _, _) -> max acc (String.length cal))
638 0 event_data
639 in
640 let max_date_width =
641 List.fold_left
642 (fun acc (_, _, date, _, _) -> max acc (String.length date))
643 0 event_data
644 in
645 (* Calculate max width for summary+location *)
646 let max_summary_loc_width =
647 List.fold_left
648 (fun acc (_, _, _, summary, location) ->
649 let full_length =
650 String.length summary
651 + if location <> "" then String.length location + 1 else 0
652 in
653 max acc full_length)
654 0 event_data
655 in
656 (* Format each event with calculated widths *)
657 let formatted_events =
658 List.map
659 (fun (id, cal, date, summary, location) ->
660 let summary_loc =
661 summary ^ if location <> "" then " " ^ location else ""
662 in
663 Printf.sprintf "%-*s %-*s %-*s %-*s" max_cal_width cal
664 max_date_width date max_summary_loc_width summary_loc max_id_width
665 id)
666 event_data
667 in
668 String.concat "\n" formatted_events
669
670let format_events ?(format = `Text) ?tz events =
671 match format with
672 | `Json ->
673 let json_events =
674 List.map
675 (fun e -> Yojson.Safe.from_string (format_event ~format:`Json ?tz e))
676 events
677 in
678 Yojson.Safe.to_string (`List json_events)
679 | `Csv ->
680 "\"Summary\",\"Start\",\"End\",\"Location\",\"Calendar\"\n"
681 ^ String.concat "\n" (List.map (format_event ~format:`Csv ?tz) events)
682 | `Sexp ->
683 "("
684 ^ String.concat "\n "
685 (List.map (fun e -> format_event ~format:`Sexp ?tz e) events)
686 ^ ")"
687 | `Text -> format_events_with_dynamic_columns ?tz events
688 | _ ->
689 String.concat "\n" (List.map (fun e -> format_event ~format ?tz e) events)
690
691let expand_recurrences ~from ~to_ event =
692 let rule = get_recurrence event in
693 match rule with
694 (* If there's no recurrence we just return the original event. *)
695 | None ->
696 (* Include the original event instance only if it falls within the query range. *)
697 let start = get_start event in
698 let end_ = match get_end event with None -> start | Some e -> e in
699 if
700 Ptime.compare start to_ < 0
701 &&
702 (* end_ > f, meaning we don't include events that end at the exact start of our range.
703 This is handy to exclude date events that end at 00:00 the next day. *)
704 match from with Some f -> Ptime.compare end_ f > 0 | None -> true
705 then [ event ]
706 else []
707 | Some _ ->
708 let rec collect generator acc =
709 match generator () with
710 | None -> List.rev acc
711 | Some recur ->
712 let start = get_ical_start recur in
713 let end_ =
714 match get_ical_end recur with None -> start | Some e -> e
715 in
716 (* if start >= to then we're outside our (exclusive) date range and we terminate *)
717 if Ptime.compare start to_ >= 0 then List.rev acc
718 (* if end > from then, *)
719 else if
720 match from with
721 | Some f -> Ptime.compare end_ f > 0
722 | None -> true
723 (* we include the event *)
724 then collect generator (clone_with_event event recur :: acc)
725 (* otherwise we iterate till the event is in range *)
726 else collect generator acc
727 in
728 let generator =
729 let ical_event = to_ical_event event in
730 (* The first event is the non recurrence-id one *)
731 let _, other_events =
732 match
733 List.partition
734 (function `Event _ -> true | _ -> false)
735 (snd event.calendar)
736 with
737 | `Event hd :: tl, _ ->
738 (hd, List.map (function `Event e -> e | _ -> assert false) tl)
739 | _ -> assert false
740 in
741 recur_events ~recurrence_ids:other_events ical_event
742 in
743 collect generator []
744
745let sexp_of_t event =
746 let open Sexplib.Sexp in
747 let start = get_start event in
748 let end_ = get_end event in
749 let format_ptime_iso p =
750 let dt = Date.ptime_to_timedesc p in
751 let y = Timedesc.year dt in
752 let m = Timedesc.month dt in
753 let d = Timedesc.day dt in
754 let h = Timedesc.hour dt in
755 let min = Timedesc.minute dt in
756 let s = Timedesc.second dt in
757 Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02d" y m d h min s
758 in
759 let entries =
760 [
761 Some (List [ Atom "id"; Atom (get_id event) ]);
762 (match get_summary event with
763 | Some s -> Some (List [ Atom "summary"; Atom s ])
764 | None -> None);
765 Some (List [ Atom "start"; Atom (format_ptime_iso start) ]);
766 (match end_ with
767 | Some e -> Some (List [ Atom "end"; Atom (format_ptime_iso e) ])
768 | None -> None);
769 (match get_location event with
770 | Some l -> Some (List [ Atom "location"; Atom l ])
771 | None -> None);
772 (match get_description event with
773 | Some d -> Some (List [ Atom "description"; Atom d ])
774 | None -> None);
775 Some (List [ Atom "file"; Atom (snd (get_file event)) ]);
776 Some (List [ Atom "calendar"; Atom (get_calendar_name event) ]);
777 ]
778 in
779 let filtered_entries = List.filter_map Fun.id entries in
780 List filtered_entries
781
782type filter = t -> bool
783
784let text_matches pattern text =
785 let re = Re.Pcre.regexp ~flags:[ `CASELESS ] (Re.Pcre.quote pattern) in
786 Re.Pcre.pmatch ~rex:re text
787
788let summary_contains text event =
789 match get_summary event with
790 | Some summary -> text_matches text summary
791 | None -> false
792
793let description_contains text event =
794 match get_description event with
795 | Some desc -> text_matches text desc
796 | None -> false
797
798let location_contains text event =
799 match get_location event with
800 | Some loc -> text_matches text loc
801 | None -> false
802
803let in_calendars ids event =
804 let id = get_calendar_name event in
805 List.exists (fun col -> col = id) ids
806
807let recurring_only () event = get_recurrence event <> None
808let non_recurring_only () event = get_recurrence event = None
809let with_id id event = get_id event = id
810let and_filter filters event = List.for_all (fun filter -> filter event) filters
811let or_filter filters event = List.exists (fun filter -> filter event) filters
812let not_filter filter event = not (filter event)
813let matches_filter event filter = filter event
814
815let take n list =
816 let rec aux n lst acc =
817 match (lst, n) with
818 | _, 0 -> List.rev acc
819 | [], _ -> List.rev acc
820 | x :: xs, n -> aux (n - 1) xs (x :: acc)
821 in
822 aux n list []
823
824let query_without_recurrence events ?filter ?(comparator = by_start) ?limit () =
825 let events =
826 match filter with Some f -> List.filter f events | None -> events
827 in
828 let events = List.sort comparator events in
829 match limit with Some n when n > 0 -> take n events | _ -> events
830
831let query events ?filter ~from ~to_ ?comparator ?limit () =
832 let events =
833 match filter with Some f -> List.filter f events | None -> events
834 in
835 let events =
836 List.concat_map (fun event -> expand_recurrences event ~from ~to_) events
837 in
838 let events =
839 match comparator with None -> events | Some c -> List.sort c events
840 in
841 match limit with Some n when n > 0 -> take n events | _ -> events