open Icalendar open Utils type error = Invalid_date of string | Skip let invalid_date s e = Error (Invalid_date (spf "Invalid date: %s, error: %s" s (show_error e))) let skip = Error Skip type collector = Remind.rem -> event -> (Remind.rem, error) result let collect_uuid rem ev : (Remind.rem, error) result = let uid = Utils.get_uid ev in Ok { rem with Remind.original_uuid = uid } let collect_summary rem ev : (Remind.rem, error) result = let summary_opt = List.find_map (function | `Summary (_, s) -> Some s | _ -> None) ev.props in match summary_opt with | Some s -> Ok { rem with Remind.summary = s } | None -> Ok { rem with Remind.summary = "" } let collect_location rem ev : (Remind.rem, error) result = let location_opt = Utils.get_location ev in match location_opt with | Some loc -> Ok { rem with Remind.location = Some loc } | None -> Ok rem let collect_description rem ev : (Remind.rem, error) result = let description_opt = Utils.get_description ev in match description_opt with | Some desc -> Ok { rem with Remind.description = Some desc } | None -> Ok rem let collect_conference_url rem ev : (Remind.rem, error) result = let conference_url_opt = Utils.get_conference_url ev in match conference_url_opt with | Some url -> Ok { rem with Remind.conference_url = Some url } | None -> Ok rem let collect_start_end_duration rem ev : (Remind.rem, error) result = let _, dtstart = ev.dtstart in match dtstart with | `Date (year, month, day) -> ( match Timedesc.Date.Ymd.make ~year ~month ~day with | Error e -> invalid_date "DTSTART" e | Ok day_start -> begin match ev.dtend_or_duration with | None -> { rem with Remind.date = day_start } |> Result.ok | Some (`Dtend (_, `Datetime _)) -> Utils.warn "Warning: DTSTART is DATE but DTEND is DATETIME, skipping (UID: %s)\n" rem.Remind.original_uuid; skip | Some (`Dtend (_, `Date (year, month, day))) -> begin match Timedesc.Date.Ymd.make ~year ~month ~day with | Error e -> invalid_date "DTEND" e | Ok day_end -> let day_end = if Timedesc.Date.lt day_start day_end then Timedesc.Date.add ~days:(-1) day_end else day_end in if Timedesc.Date.diff_days day_end day_start = 0 then Ok { rem with Remind.date = day_start; Remind.end_date = None } else Ok { rem with Remind.date = day_start; Remind.end_date = Some day_end } end | Some (`Duration (_, duration)) -> (* DATE + DURATION: compute end_date as start + duration_in_days - 1 *) let days, _ = Ptime.Span.to_d_ps duration in if days <= 1 then Ok { rem with Remind.date = day_start; Remind.end_date = None } else let day_end = Timedesc.Date.add ~days:(days - 1) day_start in Ok { rem with Remind.date = day_start; Remind.end_date = Some day_end } end) | `Datetime datetime -> begin let start_td = Utils.timedesc_of_timestamp datetime in let rem = { rem with Remind.date = Timedesc.date start_td; Remind.time = Some (Timedesc.time start_td); Remind.tz = Some (Timedesc.tz start_td); } in match ev.dtend_or_duration with | None -> Ok rem | Some (`Dtend (_, date_or_datetime)) -> begin match date_or_datetime with | `Datetime datetime -> begin let end_td = Utils.timedesc_of_timestamp datetime in let duration = Timedesc.Span.sub (Timedesc.to_timestamp_single end_td) (Timedesc.to_timestamp_single start_td) in let rem = { rem with Remind.duration = Some duration } in Ok rem end | `Date (_year, _month, _day) -> Utils.warn "Warning: DTSTART is DATETIME but DTEND is DATE, skipping (UID: %s)\n" rem.Remind.original_uuid; skip end | Some (`Duration (_, duration)) -> let span = Timedesc.Utils.span_of_ptime_span duration in let rem = { rem with Remind.duration = Some span } in Ok rem end let collect_exdates rem ev : (Remind.rem, error) result = let exdates = Utils.get_exdates ev in Ok { rem with Remind.exdate = exdates } let collect_triggers rem ev : (Remind.rem, error) result = let triggers = Utils.get_triggers ev in Ok { rem with Remind.triggers } let yearly_simple_date rem ev : (Remind.rem, error) result = match ev.rrule with | Some (_, (`Yearly, None, None, [])) -> let month, day = (Timedesc.Date.month rem.Remind.date, Timedesc.Date.day rem.Remind.date) in Ok { rem with Remind.yearly = Some (month, day) } | Some _ -> Ok rem | None -> Ok rem let simple_recurrence rem ev : (Remind.rem, error) result = match ev.rrule with | Some (_, (`Yearly, None, None, [])) -> Ok rem (* handled in yearly_simple_date *) | Some (_, ((`Weekly as freq), count_or_until, interval, recurs)) | Some (_, ((`Daily as freq), count_or_until, interval, recurs)) -> begin let days = ListLabels.filter_map recurs ~f:(function | `Byday days -> begin List.map (fun (_n, weekday) -> weekday) days |> Option.some end | _ -> None) |> List.flatten in let week_start = ListLabels.find_map recurs ~f:(function | `Weekday `Sunday -> Some `Sunday | `Weekday `Monday -> Some `Monday | _ -> None) in match freq with | `Daily -> Ok { rem with Remind.weekly = None; Remind.daily = Some { count_or_until; interval; week_start } } | `Weekly -> let days = if days = [] then [ timedesc_wd_to_ical (Timedesc.Date.weekday rem.date) ] else days in Ok { rem with Remind.daily = None; Remind.weekly = Some { count_or_until; interval; byday = days; week_start }; } end | Some (_, (`Monthly, count_or_until, interval, recurs)) -> begin match interval with | Some n when n > 1 -> Utils.warn "Warning: MONTHLY INTERVAL=%d not supported, skipping (UID: %s)\n" n (Utils.get_uid ev); skip | _ -> ( let bymonthday = List.find_map (function | `Bymonthday (d :: _) -> Some d | _ -> None) recurs in let byday = List.find_map (function | `Byday pairs -> List.find_map (fun (n, wd) -> if n <> 0 then Some (n, wd) else None) pairs | _ -> None) recurs in let pattern = match (bymonthday, byday) with | _, Some (n, wd) -> Some (Remind.By_nth_weekday (n, wd)) (* BYDAY takes precedence *) | Some day, None -> Some (Remind.By_month_day day) | None, None -> Some (Remind.By_month_day (Timedesc.Date.day rem.Remind.date)) in match pattern with | None -> Utils.warn "Warning: MONTHLY with unsupported BYDAY, skipping (UID: %s)\n" (Utils.get_uid ev); skip | Some p -> Ok { rem with Remind.monthly = Some { count_or_until; interval; pattern = p } }) end | Some (_, recurs) -> Utils.warn "Warning: unsupported recurrence rule, skipping (UID: %s)\n" (Utils.get_uid ev); skip | None -> Ok rem let is_cancelled (ev : Icalendar.event) : bool = List.exists (function | `Status (_, `Cancelled) -> true | _ -> false) ev.props let build_override_rem (source : string) (override_ev : Icalendar.event) : (Remind.rem, error) result = let rem = { Remind.empty with Remind.source } in let collectors = [ collect_uuid; collect_summary; collect_start_end_duration ] in ListLabels.fold_left ~init:(Ok rem) collectors ~f:(fun rem_or_error pred -> match rem_or_error with | Error e -> Error e | Ok rem -> pred rem override_ev) let collect_overrides rem _ev : (Remind.rem, error) result = (* Process each RECURRENCE-ID override event stored in rem.recurring: - add its RECURRENCE-ID date to rem.exdate (feeds the OMIT mechanism) - for non-cancelled overrides, build a single REM and add to rem.overrides *) let new_exdates, new_overrides = ListLabels.fold_left ~init:([], []) rem.Remind.recurring ~f:(fun (exdates, overrides) override_ev -> let recur_id_opt = Utils.get_recurrence_id override_ev in let exdates = match recur_id_opt with | None -> Utils.warn "Warning: override event has no RECURRENCE-ID, skipping (UID: %s)\n" (Utils.get_uid override_ev); exdates | Some date_or_dt -> date_or_dt :: exdates in let overrides = if is_cancelled override_ev then overrides else match build_override_rem rem.Remind.source override_ev with | Error _ -> Utils.warn "Warning: could not build override REM, skipping (UID: %s)\n" (Utils.get_uid override_ev); overrides | Ok override_rem -> override_rem :: overrides in (exdates, overrides)) in Ok { rem with Remind.exdate = rem.Remind.exdate @ List.rev new_exdates; Remind.overrides = List.rev new_overrides; Remind.recurring = []; } let all_collectors : collector list = [ collect_uuid; collect_summary; collect_location; collect_description; collect_conference_url; collect_start_end_duration; collect_exdates; collect_triggers; collect_overrides; yearly_simple_date; simple_recurrence; ] let remind_of_event (source : string) (ev : Icalendar.event list) : (Remind.rem, error) result = let () = if List.length ev = 0 then failwith "No events provided" in let master, recurrence = if List.length ev > 1 then begin separate_master_and_recurrence ev end else begin let ev = List.hd ev in (ev, []) end in let rem = { Remind.empty with Remind.source; Remind.original_event = Some master; Remind.recurring = recurrence } in ListLabels.fold_left ~init:(Ok rem) all_collectors ~f:(fun rem_or_error pred -> match rem_or_error with | Error e -> Error e | Ok rem -> pred rem master)