Command-line and Emacs Calendar Client
ryan.freumh.org
1open Icalendar
2
3type event_id = string
4
5type t = {
6 collection : Collection.t;
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")
19
20let create ~(fs : Eio.Fs.dir_ty Eio.Path.t) ~calendar_dir_path ~summary ~start
21 ?end_ ?location ?description ?recurrence collection =
22 let uuid = generate_uuid () in
23 let uid = (Params.empty, uuid) in
24 let file_name = uuid ^ ".ics" in
25 let file =
26 Eio.Path.(
27 fs / calendar_dir_path
28 / (match collection with Collection.Col s -> s)
29 / file_name)
30 in
31 let dtstart = (Params.empty, start) in
32 let dtend_or_duration = end_ in
33 let rrule = Option.map (fun r -> (Params.empty, r)) recurrence in
34 let now = Ptime_clock.now () in
35 let props = [ `Summary (Params.empty, summary) ] in
36 let props =
37 match location with
38 | Some loc -> `Location (Params.empty, loc) :: props
39 | None -> props
40 in
41 let props =
42 match description with
43 | Some desc -> `Description (Params.empty, desc) :: props
44 | None -> props
45 in
46 let event =
47 {
48 dtstamp = (Params.empty, now);
49 uid;
50 dtstart;
51 dtend_or_duration;
52 rrule;
53 props;
54 alarms = [];
55 }
56 in
57 let calendar =
58 let props = [ default_prodid ] in
59 let components = [ `Event event ] in
60 (props, components)
61 in
62 { collection; file; event; calendar }
63
64let edit ?summary ?start ?end_ ?location ?description ?recurrence t =
65 let now = Ptime_clock.now () in
66 let uid = t.event.uid in
67 let dtstart =
68 match start with None -> t.event.dtstart | Some s -> (Params.empty, s)
69 in
70 let dtend_or_duration =
71 match end_ with None -> t.event.dtend_or_duration | Some _ -> end_
72 in
73 let rrule =
74 match recurrence with
75 | None -> t.event.rrule
76 | Some r -> Some (Params.empty, r)
77 in
78 let props =
79 List.filter
80 (function
81 | `Summary _ -> ( match summary with None -> true | Some _ -> false)
82 | `Location _ -> ( match location with None -> true | Some _ -> false)
83 | `Description _ -> (
84 match description with None -> true | Some _ -> false)
85 | _ -> true)
86 t.event.props
87 in
88 let props =
89 match summary with
90 | Some summary -> `Summary (Params.empty, summary) :: props
91 | None -> props
92 in
93 let props =
94 match location with
95 | Some loc -> `Location (Params.empty, loc) :: props
96 | None -> props
97 in
98 let props =
99 match description with
100 | Some desc -> `Description (Params.empty, desc) :: props
101 | None -> props
102 in
103 let alarms = t.event.alarms in
104 let event =
105 {
106 dtstamp = (Params.empty, now);
107 uid;
108 dtstart;
109 dtend_or_duration;
110 rrule;
111 props;
112 alarms;
113 }
114 in
115 let collection = t.collection in
116 let file = t.file in
117 let calendar = t.calendar in
118 { collection; file; event; calendar }
119
120let events_of_icalendar collection ~file calendar =
121 let remove_dup_ids lst =
122 let rec aux acc = function
123 | [] -> acc
124 | x :: xs ->
125 if List.exists (fun r -> r.uid = x.uid) acc then aux acc xs
126 else aux (x :: acc) xs
127 in
128 aux [] lst
129 in
130 let events =
131 List.filter_map
132 (function `Event event -> Some event | _ -> None)
133 (snd calendar)
134 in
135 let events = remove_dup_ids events in
136 List.map (function event -> { collection; file; event; calendar }) events
137
138let to_ical_event t = t.event
139let to_ical_calendar t = t.calendar
140let get_id t = snd t.event.uid
141
142let get_summary t =
143 match
144 List.filter_map
145 (function `Summary (_, s) when s <> "" -> Some s | _ -> None)
146 t.event.props
147 with
148 | s :: _ -> Some s
149 | _ -> None
150
151let get_ical_start event = Date.ptime_of_ical (snd event.dtstart)
152let get_start t = get_ical_start t.event
153
154let get_ical_end event =
155 match event.dtend_or_duration with
156 | Some (`Dtend (_, d)) -> Some (Date.ptime_of_ical d)
157 | Some (`Duration (_, span)) -> (
158 let start = get_ical_start event in
159 match Ptime.add_span start span with
160 | Some t -> Some t
161 | None ->
162 failwith
163 (Printf.sprintf "Invalid duration calculation: %s + %s"
164 (Ptime.to_rfc3339 start)
165 (Printf.sprintf "%.2fs" (Ptime.Span.to_float_s span))))
166 | None -> None
167
168let get_end t = get_ical_end t.event
169
170let get_start_timezone t =
171 match t.event.dtstart with
172 | _, `Datetime (`With_tzid (_, (_, tzid))) -> Some tzid
173 | _ -> None
174
175let get_end_timezone t =
176 match t.event.dtend_or_duration with
177 | Some (`Dtend (_, `Datetime (`With_tzid (_, (_, tzid))))) -> Some tzid
178 | _ -> None
179
180let get_duration t =
181 match t.event.dtend_or_duration with
182 | Some (`Duration (_, span)) -> Some span
183 | Some (`Dtend (_, e)) ->
184 let span = Ptime.diff (Date.ptime_of_ical e) (get_start t) in
185 Some span
186 | None -> None
187
188let is_date t =
189 match (t.event.dtstart, t.event.dtend_or_duration) with
190 | (_, `Date _), _ -> true
191 | _, Some (`Dtend (_, `Date _)) -> true
192 | _ -> false
193
194let get_location t =
195 match
196 List.filter_map
197 (function `Location (_, s) when s <> "" -> Some s | _ -> None)
198 t.event.props
199 with
200 | s :: _ -> Some s
201 | _ -> None
202
203let get_description t =
204 match
205 List.filter_map
206 (function `Description (_, s) when s <> "" -> Some s | _ -> None)
207 t.event.props
208 with
209 | s :: _ -> Some s
210 | _ -> None
211
212let get_recurrence t = Option.map (fun r -> snd r) t.event.rrule
213let get_collection t = t.collection
214let get_file t = t.file
215
216type comparator = t -> t -> int
217
218let by_start e1 e2 =
219 let t1 = get_start e1 in
220 let t2 = get_start e2 in
221 Ptime.compare t1 t2
222
223let by_end e1 e2 =
224 match (get_end e1, get_end e2) with
225 | Some t1, Some t2 -> Ptime.compare t1 t2
226 | Some _, None -> 1
227 | None, Some _ -> -1
228 | None, None -> 0
229
230let by_summary e1 e2 =
231 match (get_summary e1, get_summary e2) with
232 | Some s1, Some s2 -> String.compare s1 s2
233 | Some _, None -> 1
234 | None, Some _ -> -1
235 | None, None -> 0
236
237let by_location e1 e2 =
238 match (get_location e1, get_location e2) with
239 | Some l1, Some l2 -> String.compare l1 l2
240 | Some _, None -> 1
241 | None, Some _ -> -1
242 | None, None -> 0
243
244let by_collection e1 e2 =
245 match (get_collection e1, get_collection e2) with
246 | Collection.Col c1, Collection.Col c2 -> String.compare c1 c2
247
248let descending comp e1 e2 = -1 * comp e1 e2
249
250let chain comp1 comp2 e1 e2 =
251 let result = comp1 e1 e2 in
252 if result <> 0 then result else comp2 e1 e2
253
254let clone_with_event t event =
255 let collection = t.collection in
256 let file = t.file in
257 let calendar = t.calendar in
258 { collection; file; event; calendar }
259
260type format = [ `Text | `Entries | `Json | `Csv | `Ics | `Sexp ]
261
262let format_date ?tz date =
263 let dt = Date.ptime_to_timedesc ?tz date in
264 let y = Timedesc.year dt in
265 let m = Timedesc.month dt in
266 let d = Timedesc.day dt in
267 let weekday =
268 match Timedesc.weekday dt with
269 | `Mon -> "Mon"
270 | `Tue -> "Tue"
271 | `Wed -> "Wed"
272 | `Thu -> "Thu"
273 | `Fri -> "Fri"
274 | `Sat -> "Sat"
275 | `Sun -> "Sun"
276 in
277 Printf.sprintf "%04d-%02d-%02d %s" y m d weekday
278
279let format_time ?tz date =
280 let dt = Date.ptime_to_timedesc ?tz date in
281 let h = Timedesc.hour dt in
282 let m = Timedesc.minute dt in
283 Printf.sprintf "%02d:%02d" h m
284
285let format_datetime ?tz date =
286 let tz_str =
287 match tz with
288 | Some tz -> Printf.sprintf "(%s)" (Timedesc.Time_zone.name tz)
289 | None -> ""
290 in
291 Printf.sprintf "%s %s%s" (format_date ?tz date) (format_time ?tz date) tz_str
292
293let same_day day other =
294 let y1, m1, d1 = Ptime.to_date day in
295 let y2, m2, d2 = Ptime.to_date other in
296 y1 == y2 && m1 == m2 && d1 == d2
297
298let next_day day ~next =
299 let y1, m1, d1 = Ptime.to_date day in
300 let y2, m2, d2 = Ptime.to_date next in
301 y1 == y2 && m1 == m2 && d1 == d2 - 1
302
303(* exosed from icalendar *)
304
305let weekday_strings =
306 [
307 (`Monday, "MO");
308 (`Tuesday, "TU");
309 (`Wednesday, "WE");
310 (`Thursday, "TH");
311 (`Friday, "FR");
312 (`Saturday, "SA");
313 (`Sunday, "SU");
314 ]
315
316let freq_strings =
317 [
318 (`Daily, "DAILY");
319 (`Hourly, "HOURLY");
320 (`Minutely, "MINUTELY");
321 (`Monthly, "MONTHLY");
322 (`Secondly, "SECONDLY");
323 (`Weekly, "WEEKLY");
324 (`Yearly, "YEARLY");
325 ]
326
327let date_to_str (y, m, d) = Printf.sprintf "%04d%02d%02d" y m d
328
329let datetime_to_str ptime utc =
330 let date, ((hh, mm, ss), _) = Ptime.to_date_time ptime in
331 Printf.sprintf "%sT%02d%02d%02d%s" (date_to_str date) hh mm ss
332 (if utc then "Z" else "")
333
334let timestamp_to_ics ts buf =
335 Buffer.add_string buf
336 @@
337 match ts with
338 | `Utc ts -> datetime_to_str ts true
339 | `Local ts -> datetime_to_str ts false
340 | `With_tzid (ts, _str) -> (* TODO *) datetime_to_str ts false
341
342let recurs_to_ics (freq, count_or_until, interval, l) buf =
343 let write_rulepart key value =
344 Buffer.add_string buf key;
345 Buffer.add_char buf '=';
346 Buffer.add_string buf value
347 in
348 let int_list l = String.concat "," @@ List.map string_of_int l in
349 let recur_to_ics = function
350 | `Byminute byminlist -> write_rulepart "BYMINUTE" (int_list byminlist)
351 | `Byday bywdaylist ->
352 let wday (weeknumber, weekday) =
353 (if weeknumber = 0 then "" else string_of_int weeknumber)
354 ^ List.assoc weekday weekday_strings
355 in
356 write_rulepart "BYDAY" (String.concat "," @@ List.map wday bywdaylist)
357 | `Byhour byhrlist -> write_rulepart "BYHOUR" (int_list byhrlist)
358 | `Bymonth bymolist -> write_rulepart "BYMONTH" (int_list bymolist)
359 | `Bymonthday bymodaylist ->
360 write_rulepart "BYMONTHDAY" (int_list bymodaylist)
361 | `Bysecond byseclist -> write_rulepart "BYSECOND" (int_list byseclist)
362 | `Bysetposday bysplist -> write_rulepart "BYSETPOS" (int_list bysplist)
363 | `Byweek bywknolist -> write_rulepart "BYWEEKNO" (int_list bywknolist)
364 | `Byyearday byyrdaylist ->
365 write_rulepart "BYYEARDAY" (int_list byyrdaylist)
366 | `Weekday weekday ->
367 write_rulepart "WKST" (List.assoc weekday weekday_strings)
368 in
369 write_rulepart "FREQ" (List.assoc freq freq_strings);
370 (match count_or_until with
371 | None -> ()
372 | Some x -> (
373 Buffer.add_char buf ';';
374 match x with
375 | `Count c -> write_rulepart "COUNT" (string_of_int c)
376 | `Until enddate ->
377 (* TODO cleanup *)
378 Buffer.add_string buf "UNTIL=";
379 timestamp_to_ics enddate buf));
380 (match interval with
381 | None -> ()
382 | Some i ->
383 Buffer.add_char buf ';';
384 write_rulepart "INTERVAL" (string_of_int i));
385 List.iter
386 (fun recur ->
387 Buffer.add_char buf ';';
388 recur_to_ics recur)
389 l
390
391let format_event ?(format = `Text) ?tz event =
392 let start = get_start event in
393 let end_ = get_end event in
394 match format with
395 | `Text ->
396 let id = get_id event in
397 let start_date = " " ^ format_date ?tz start in
398 let start_time =
399 match is_date event with
400 | true -> ""
401 | false -> " " ^ format_time ?tz start
402 in
403 let end_date, end_time =
404 match end_ with
405 | None -> ("", "")
406 | Some end_ -> (
407 match is_date event with
408 | true -> (
409 match next_day start ~next:end_ with
410 | true -> ("", "")
411 | false -> (" - " ^ format_date ?tz end_, ""))
412 | false -> (
413 match same_day start end_ with
414 | true -> ("", " - " ^ format_time ?tz end_)
415 | false ->
416 (" - " ^ format_date ?tz end_, " " ^ format_time ?tz end_)))
417 in
418 let summary =
419 match get_summary event with
420 | Some summary when summary <> "" -> " " ^ summary
421 | _ -> ""
422 in
423 let location =
424 match get_location event with
425 | Some loc when loc <> "" -> " @" ^ loc
426 | _ -> ""
427 in
428 let collection = match get_collection event with Col s -> s in
429 Printf.sprintf "%-45s\t%s\t%s%s%s%s%s%s" id collection start_date
430 start_time end_date end_time summary location
431 | `Entries ->
432 let format_opt label f opt =
433 Option.map (fun x -> Printf.sprintf "%s: %s\n" label (f x)) opt
434 |> Option.value ~default:""
435 in
436 let format timezone datetime =
437 match is_date event with
438 | true -> format_date ?tz datetime
439 | false -> (
440 format_datetime ?tz datetime
441 ^ match timezone with None -> "" | Some t -> " (" ^ t ^ ")")
442 in
443 let start_str =
444 format_opt "Start" (format (get_start_timezone event)) (Some start)
445 in
446 let end_str = format_opt "End" (format (get_end_timezone event)) end_ in
447 let location_str = format_opt "Location" Fun.id (get_location event) in
448 let description_str =
449 format_opt "Description" Fun.id (get_description event)
450 in
451 let rrule_str =
452 Option.map
453 (fun r ->
454 let buf = Buffer.create 128 in
455 recurs_to_ics r buf;
456 Printf.sprintf "%s: %s\n" "Reccurence" (Buffer.contents buf))
457 (get_recurrence event)
458 |> Option.value ~default:""
459 in
460 let summary_str = format_opt "Summary" Fun.id (get_summary event) in
461 let file_str = format_opt "File" Fun.id (Some (snd (get_file event))) in
462 Printf.sprintf "%s%s%s%s%s%s%s" summary_str start_str end_str location_str
463 description_str rrule_str file_str
464 | `Json ->
465 let open Yojson.Safe in
466 let json =
467 `Assoc
468 [
469 ("id", `String (get_id event));
470 ( "summary",
471 match get_summary event with
472 | Some summary -> `String summary
473 | None -> `Null );
474 ("start", `String (format_datetime ?tz start));
475 ( "end",
476 match end_ with
477 | Some e -> `String (format_datetime ?tz e)
478 | None -> `Null );
479 ( "location",
480 match get_location event with
481 | Some loc -> `String loc
482 | None -> `Null );
483 ( "description",
484 match get_description event with
485 | Some desc -> `String desc
486 | None -> `Null );
487 ( "calendar",
488 match get_collection event with
489 | Collection.Col cal -> `String cal );
490 ]
491 in
492 to_string json
493 | `Csv ->
494 let summary =
495 match get_summary event with Some summary -> summary | None -> ""
496 in
497 let start = format_datetime ?tz start in
498 let end_str =
499 match end_ with Some e -> format_datetime ?tz e | None -> ""
500 in
501 let location =
502 match get_location event with Some loc -> loc | None -> ""
503 in
504 let cal_id =
505 match get_collection event with Collection.Col cal -> cal
506 in
507 Printf.sprintf "\"%s\",\"%s\",\"%s\",\"%s\",\"%s\"" summary start end_str
508 location cal_id
509 | `Ics ->
510 let calendar = to_ical_calendar event in
511 Icalendar.to_ics ~cr:true calendar
512 | `Sexp ->
513 let summary =
514 match get_summary event with Some summary -> summary | None -> ""
515 in
516 let start_date, start_time =
517 let dt = Date.ptime_to_timedesc ?tz start in
518 let y = Timedesc.year dt in
519 let m = Timedesc.month dt in
520 let d = Timedesc.day dt in
521 let h = Timedesc.hour dt in
522 let min = Timedesc.minute dt in
523 let s = Timedesc.second dt in
524 let dow =
525 match Timedesc.weekday dt with
526 | `Mon -> "monday"
527 | `Tue -> "tuesday"
528 | `Wed -> "wednesday"
529 | `Thu -> "thursday"
530 | `Fri -> "friday"
531 | `Sat -> "saturday"
532 | `Sun -> "sunday"
533 in
534 ( Printf.sprintf "(%04d %02d %02d %s)" y m d dow,
535 Printf.sprintf "(%02d %02d %02d)" h min s )
536 in
537 let end_str =
538 match end_ with
539 | Some end_date ->
540 let dt = Date.ptime_to_timedesc ?tz end_date in
541 let y = Timedesc.year dt in
542 let m = Timedesc.month dt in
543 let d = Timedesc.day dt in
544 let h = Timedesc.hour dt in
545 let min = Timedesc.minute dt in
546 let s = Timedesc.second dt in
547 let dow =
548 match Timedesc.weekday dt with
549 | `Mon -> "monday"
550 | `Tue -> "tuesday"
551 | `Wed -> "wednesday"
552 | `Thu -> "thursday"
553 | `Fri -> "friday"
554 | `Sat -> "saturday"
555 | `Sun -> "sunday"
556 in
557 Printf.sprintf "((%04d %02d %02d %s) (%02d %02d %02d))" y m d dow h
558 min s
559 | None -> "nil"
560 in
561 let location =
562 match get_location event with
563 | Some loc -> Printf.sprintf "\"%s\"" (String.escaped loc)
564 | None -> "nil"
565 in
566 let description =
567 match get_description event with
568 | Some desc -> Printf.sprintf "\"%s\"" (String.escaped desc)
569 | None -> "nil"
570 in
571 let calendar =
572 match get_collection event with
573 | Collection.Col cal -> Printf.sprintf "\"%s\"" (String.escaped cal)
574 in
575 let id = get_id event in
576 Printf.sprintf
577 "((:id \"%s\" :summary \"%s\" :start (%s %s) :end %s :location %s \
578 :description %s :calendar %s))"
579 (String.escaped id) (String.escaped summary) start_date start_time
580 end_str location description calendar
581
582let format_events ?(format = `Text) ?tz events =
583 match format with
584 | `Json ->
585 let json_events =
586 List.map
587 (fun e -> Yojson.Safe.from_string (format_event ~format:`Json ?tz e))
588 events
589 in
590 Yojson.Safe.to_string (`List json_events)
591 | `Csv ->
592 "\"Summary\",\"Start\",\"End\",\"Location\",\"Calendar\"\n"
593 ^ String.concat "\n" (List.map (format_event ~format:`Csv ?tz) events)
594 | `Sexp ->
595 "("
596 ^ String.concat "\n "
597 (List.map (fun e -> format_event ~format:`Sexp ?tz e) events)
598 ^ ")"
599 | _ ->
600 String.concat "\n" (List.map (fun e -> format_event ~format ?tz e) events)
601
602let expand_recurrences ~from ~to_ event =
603 let rule = get_recurrence event in
604 match rule with
605 (* If there's no recurrence we just return the original event. *)
606 | None ->
607 (* Include the original event instance only if it falls within the query range. *)
608 let start = get_start event in
609 let end_ = match get_end event with None -> start | Some e -> e in
610 if
611 Ptime.compare start to_ < 0
612 &&
613 (* end_ > f, meaning we don't include events that end at the exact start of our range.
614 This is handy to exclude date events that end at 00:00 the next day. *)
615 match from with Some f -> Ptime.compare end_ f > 0 | None -> true
616 then [ event ]
617 else []
618 | Some _ ->
619 let rec collect generator acc =
620 match generator () with
621 | None -> List.rev acc
622 | Some recur ->
623 let start = get_ical_start recur in
624 let end_ =
625 match get_ical_end recur with None -> start | Some e -> e
626 in
627 (* if start >= to then we're outside our (exclusive) date range and we terminate *)
628 if Ptime.compare start to_ >= 0 then List.rev acc
629 (* if end > from then, *)
630 else if
631 match from with
632 | Some f -> Ptime.compare end_ f > 0
633 | None -> true
634 (* we include the event *)
635 then collect generator (clone_with_event event recur :: acc)
636 (* otherwise we iterate till the event is in range *)
637 else collect generator acc
638 in
639 let generator =
640 let ical_event = to_ical_event event in
641 (* The first event is the non recurrence-id one *)
642 let _, other_events =
643 match
644 List.partition
645 (function `Event _ -> true | _ -> false)
646 (snd event.calendar)
647 with
648 | `Event hd :: tl, _ ->
649 (hd, List.map (function `Event e -> e | _ -> assert false) tl)
650 | _ -> assert false
651 in
652 recur_events ~recurrence_ids:other_events ical_event
653 in
654 collect generator []