283 lines
10 KiB
OCaml
283 lines
10 KiB
OCaml
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_location;
|
|
collect_description;
|
|
collect_conference_url;
|
|
collect_start_end_duration;
|
|
collect_triggers;
|
|
]
|
|
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)
|