Paolo Donadeo
dc11e077bf
Add a `Windows_tz` module containing a CLDR-sourced mapping table from Windows timezone names to canonical IANA names. Update `timedesc_of_timestamp` to resolve Windows-style timezone identifiers (e.g. `"W. Europe Standard Time"`) via this table before constructing a `Timedesc.Time_zone.t`, falling back to the local timezone with a warning if resolution fails entirely.
257 lines
9.4 KiB
OCaml
257 lines
9.4 KiB
OCaml
open Icalendar
|
|
|
|
(** Target timezone for all timestamp conversions. Defaults to local timezone; overridden by --timezone CLI option
|
|
before any processing begins. *)
|
|
let target_tz : Timedesc.Time_zone.t ref = ref Timedesc.Time_zone.utc
|
|
|
|
let init_target_tz (tz_opt : string option) : unit =
|
|
match tz_opt with
|
|
| None -> target_tz := Timedesc.Time_zone.local_exn ()
|
|
| Some name -> target_tz := Timedesc.Time_zone.make_exn name
|
|
|
|
type months = Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec
|
|
|
|
let timedesc_wd_to_ical (wd : Timedesc.weekday) : Icalendar.weekday =
|
|
match wd with
|
|
| `Mon -> `Monday
|
|
| `Tue -> `Tuesday
|
|
| `Wed -> `Wednesday
|
|
| `Thu -> `Thursday
|
|
| `Fri -> `Friday
|
|
| `Sat -> `Saturday
|
|
| `Sun -> `Sunday
|
|
|
|
let show_error (e : Timedesc.Date.Ymd.error) : string =
|
|
match e with
|
|
| `Does_not_exist -> "Date does not exist"
|
|
| `Invalid_year y -> Printf.sprintf "Invalid year: %d" y
|
|
| `Invalid_month m -> Printf.sprintf "Invalid month: %d" m
|
|
| `Invalid_day d -> Printf.sprintf "Invalid day: %d" d
|
|
|
|
let string_of_weekday = function
|
|
| `Monday -> "Mon"
|
|
| `Tuesday -> "Tue"
|
|
| `Wednesday -> "Wed"
|
|
| `Thursday -> "Thu"
|
|
| `Friday -> "Fri"
|
|
| `Saturday -> "Sat"
|
|
| `Sunday -> "Sun"
|
|
|
|
let month_of_int = function
|
|
| 1 -> Jan
|
|
| 2 -> Feb
|
|
| 3 -> Mar
|
|
| 4 -> Apr
|
|
| 5 -> May
|
|
| 6 -> Jun
|
|
| 7 -> Jul
|
|
| 8 -> Aug
|
|
| 9 -> Sep
|
|
| 10 -> Oct
|
|
| 11 -> Nov
|
|
| 12 -> Dec
|
|
| _ -> failwith "Invalid month number"
|
|
|
|
let string_of_month = function
|
|
| Jan -> "Jan"
|
|
| Feb -> "Feb"
|
|
| Mar -> "Mar"
|
|
| Apr -> "Apr"
|
|
| May -> "May"
|
|
| Jun -> "Jun"
|
|
| Jul -> "Jul"
|
|
| Aug -> "Aug"
|
|
| Sep -> "Sep"
|
|
| Oct -> "Oct"
|
|
| Nov -> "Nov"
|
|
| Dec -> "Dec"
|
|
|
|
let spf = Printf.sprintf
|
|
|
|
let get_uid ev =
|
|
let _, uid = ev.uid in
|
|
uid
|
|
|
|
(* Questa funzione serve solo da esempio per copia e incolla *)
|
|
let unpack_date_or_datetime (d_or_dt : Icalendar.date_or_datetime) =
|
|
match d_or_dt with
|
|
| `Datetime (`Local _ptime_ts) -> ()
|
|
| `Datetime (`Utc _ts) -> ()
|
|
| `Datetime (`With_tzid (_ts, (_b, _tz_name))) -> ()
|
|
| `Date (_year, _month, _day) -> ()
|
|
|
|
(* Questa funzione serve solo da esempio per copia e incolla *)
|
|
let unpack_dtend_or_duration dtend_or_dur =
|
|
match dtend_or_dur with
|
|
| None -> ()
|
|
| Some (`Dtend (_, date_or_datetime)) -> unpack_date_or_datetime date_or_datetime
|
|
| Some (`Duration (_, _duration)) -> ()
|
|
|
|
let string_of_time (t : Timedesc.Time.t) : string =
|
|
let view = Timedesc.Time.view t in
|
|
let hour, minute = (view.Timedesc.Time.hour, view.Timedesc.Time.minute) in
|
|
spf "%02d:%02d" hour minute
|
|
|
|
let string_of_span (sp : Timedesc.Span.t) : string =
|
|
let view = Timedesc.Span.For_human.view sp in
|
|
let hours, minutes = (view.Timedesc.Span.For_human.hours, view.Timedesc.Span.For_human.minutes) in
|
|
spf "%02d:%02d" hours minutes
|
|
|
|
let timedesc_of_timestamp (ts : timestamp) : Timedesc.t =
|
|
match ts with
|
|
| `Local t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:!target_tz
|
|
(* this case is not present in my current dataset… *)
|
|
| `Utc t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:!target_tz
|
|
| `With_tzid (ts, (_b, tz_name)) ->
|
|
(* The timestamp is stored as if it were UTC but must be interpreted in tz_name.
|
|
We reconstruct the wall-clock time in tz_name, then convert to target_tz. *)
|
|
(* Resolve the timezone name: Windows names (e.g. "W. Europe Standard Time") are
|
|
mapped to IANA via the CLDR table; otherwise the name is used as-is (assumed
|
|
to already be a valid IANA name). If resolution fails entirely, fall back to
|
|
target_tz with a warning. *)
|
|
let tz =
|
|
let candidate = Option.value ~default:tz_name (Windows_tz.to_iana tz_name) in
|
|
match Timedesc.Time_zone.make candidate with
|
|
| Some tz -> tz
|
|
| None ->
|
|
Printf.eprintf "Warning: unresolvable timezone %S, falling back to local timezone\n" tz_name;
|
|
!target_tz
|
|
in
|
|
let wrong_ts = Timedesc.Utils.timestamp_of_ptime ts in
|
|
let date = Timedesc.date (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in
|
|
let year, month, day = (Timedesc.Date.year date, Timedesc.Date.month date, Timedesc.Date.day date) in
|
|
let time = Timedesc.time_view (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in
|
|
let hour, minute, second = (time.Timedesc.Time.hour, time.Timedesc.Time.minute, time.Timedesc.Time.second) in
|
|
let t_in_named_tz = Timedesc.make_exn ~year ~month ~day ~hour ~minute ~second ~tz () in
|
|
(* Convert from tz_name to target_tz *)
|
|
Timedesc.of_timestamp_exn ~tz_of_date_time:!target_tz (Timedesc.to_timestamp_single t_in_named_tz)
|
|
|
|
let timedesc_of_utc_or_timestamp_local (ts : utc_or_timestamp_local) : Timedesc.t =
|
|
match ts with
|
|
| `Local t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:!target_tz
|
|
(* this case is not present in my current dataset… *)
|
|
| `Utc t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:!target_tz
|
|
|
|
(** Convert a UTC-or-local timestamp to a Timedesc.t in the given timezone. Use this (instead of
|
|
[timedesc_of_utc_or_timestamp_local]) when the event has a known TZID, so that UNTIL comparisons are independent of
|
|
the process locale. *)
|
|
let timedesc_of_utc_or_timestamp_tz (tz : Timedesc.Time_zone.t) (ts : utc_or_timestamp_local) : Timedesc.t =
|
|
match ts with
|
|
| `Local t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:tz
|
|
| `Utc t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:tz
|
|
|
|
let get_exdates ev =
|
|
let event_props = ev.props in
|
|
let dates_or_datetimes =
|
|
List.filter_map
|
|
(fun prop ->
|
|
match prop with
|
|
| `Exdate (_, dates) -> Some dates
|
|
| _ -> None)
|
|
event_props
|
|
in
|
|
|
|
let datetimes, dates =
|
|
ListLabels.fold_left ~init:([], []) dates_or_datetimes ~f:(fun (acc_datetimes, acc_dates) dates ->
|
|
match dates with
|
|
| `Dates date_list -> (acc_datetimes, acc_dates @ date_list)
|
|
| `Datetimes ts_list -> (acc_datetimes @ ts_list, acc_dates))
|
|
in
|
|
|
|
List.map (fun d -> `Date d) dates @ List.map (fun dt -> `Datetime dt) datetimes
|
|
|
|
let get_rdates ev =
|
|
let uid = get_uid ev in
|
|
let event_props = ev.props in
|
|
let dates_or_datetimes_or_periods =
|
|
List.filter_map
|
|
(fun prop ->
|
|
match prop with
|
|
| `Rdate (_, x) -> Some x
|
|
| _ -> None)
|
|
event_props
|
|
in
|
|
|
|
let datetimes, dates, periods =
|
|
ListLabels.fold_left ~init:([], [], []) dates_or_datetimes_or_periods
|
|
~f:(fun (acc_datetimes, acc_dates, acc_periods) dates ->
|
|
match dates with
|
|
| `Dates date_list -> (acc_datetimes, acc_dates @ date_list, acc_periods)
|
|
| `Datetimes ts_list -> (acc_datetimes @ ts_list, acc_dates, acc_periods)
|
|
| `Periods period_list -> (acc_datetimes, acc_dates, acc_periods @ period_list))
|
|
in
|
|
|
|
if List.length dates > 0 then Printf.eprintf "Found RDATE with dates: %d entries; UID: %s\n" (List.length dates) uid;
|
|
if List.length datetimes > 0 then
|
|
Printf.eprintf "Found RDATE with datetimes: %d entries; UID: %s\n" (List.length datetimes) uid;
|
|
if List.length periods > 0 then
|
|
Printf.eprintf "Found RDATE with periods: %d entries; UID: %s\n" (List.length periods) uid;
|
|
[]
|
|
|
|
let add_months (date : Timedesc.Date.t) (n : int) : Timedesc.Date.t =
|
|
let year = Timedesc.Date.year date in
|
|
let month = Timedesc.Date.month date in
|
|
let day = Timedesc.Date.day date in
|
|
let total_months = (year * 12) + (month - 1) + n in
|
|
let new_year = total_months / 12 in
|
|
let new_month = (total_months mod 12) + 1 in
|
|
let rec try_day d =
|
|
match Timedesc.Date.Ymd.make ~year:new_year ~month:new_month ~day:d with
|
|
| Ok date -> date
|
|
| Error _ -> try_day (d - 1)
|
|
in
|
|
try_day day
|
|
|
|
let get_recurrence_id ev =
|
|
List.find_map
|
|
(fun prop ->
|
|
match prop with
|
|
| `Recur_id (_, date_or_datetime) -> Some date_or_datetime
|
|
| _ -> None)
|
|
ev.props
|
|
|
|
let get_location ev =
|
|
List.find_map
|
|
(fun prop ->
|
|
match prop with
|
|
| `Location (_, loc) -> Some loc
|
|
| _ -> None)
|
|
ev.props
|
|
|
|
let get_description ev =
|
|
List.find_map
|
|
(fun prop ->
|
|
match prop with
|
|
| `Description (_, desc) -> Some desc
|
|
| _ -> None)
|
|
ev.props
|
|
|
|
let get_conference_url ev =
|
|
List.find_map
|
|
(fun prop ->
|
|
match prop with
|
|
| `Xprop (("", "GOOGLE-CONFERENCE"), _, url) -> Some url
|
|
| `Xprop (("", "MICROSOFT-SKYPETEAMSMEETINGURL"), _, url) -> Some url
|
|
| _ -> None)
|
|
ev.props
|
|
|
|
let separate_master_and_recurrence (events : Icalendar.event list) : Icalendar.event * Icalendar.event list =
|
|
(* List.iteri (fun i e -> Printf.eprintf "%02d: %s\n" (i + 1) (Icalendar.show_component (`Event e))) events; *)
|
|
let recur_ids = List.map (fun ev -> (ev, get_recurrence_id ev)) events in
|
|
|
|
let master_and_recurrences =
|
|
List.partition_map
|
|
(fun (ev, recur_id_opt) ->
|
|
match recur_id_opt with
|
|
| None -> Left ev (* no RECURRENCE-ID → master *)
|
|
| Some _ -> Right ev (* has RECURRENCE-ID → override *))
|
|
recur_ids
|
|
in
|
|
match master_and_recurrences with
|
|
| [], _ -> failwith "No master event found"
|
|
| [ master ], recurrences -> (master, recurrences)
|
|
| master :: rest, recurrences ->
|
|
Printf.eprintf "Warning: %d extra master events (no RECURRENCE-ID) for UID: %s — only first used\n"
|
|
(List.length rest) (get_uid master);
|
|
(master, recurrences)
|