ical2rem/bin/utils.ml

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

(** Print a diagnostic message on stderr, but only when --verbose is active. *)
let warn fmt = if !Config.verbose then Printf.eprintf fmt else Printf.ifprintf stderr fmt

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 ->
            warn "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_triggers ev : Timedesc.Span.t list =
  let alarms = ev.Icalendar.alarms in
  let triggers =
    ListLabels.fold_left ~init:[] alarms ~f:(fun acc alarm ->
        let trigger =
          match alarm with
          | `Audio a -> Some a.Icalendar.trigger (* we keep audio triggers *)
          | `Display d -> Some d.Icalendar.trigger (* we keep display triggers *)
          | `Email _ -> None (* we ignore email triggers *)
          | `None _ -> None (* we ignore VAL=NONE triggers *)
        in
        match trigger with
        | Some trigger -> begin
            let _, trigger_duration_or_datetime = trigger in
            match trigger_duration_or_datetime with
            | `Duration dur -> Timedesc.Utils.span_of_ptime_span dur :: acc
            | `Datetime _ -> acc
          end
        | None -> acc)
  in
  triggers

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
    warn "Warning: RDATE with dates (%d entries) not supported, skipping (UID: %s)\n" (List.length dates) uid;
  if List.length datetimes > 0 then
    warn "Warning: RDATE with datetimes (%d entries) not supported, skipping (UID: %s)\n" (List.length datetimes) uid;
  if List.length periods > 0 then
    warn "Warning: RDATE with periods (%d entries) not supported, skipping (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 =
  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 ->
      warn "Warning: %d extra master events (no RECURRENCE-ID), only first used (UID: %s)\n" (List.length rest)
        (get_uid master);
      (master, recurrences)