From 83dfd0dfa971e6939ae8223004c94ce3a33d8fac Mon Sep 17 00:00:00 2001 From: Paolo Donadeo Date: Sun, 30 Nov 2025 19:33:35 +0100 Subject: [PATCH] feat: initial implementation of iCalendar to Remind converter - Add project scaffolding (dune, dune-project, opam, .ocamlformat) - Implement basic parsing and handling of iCalendar events - Add event predicates for common event types (all-day, timed, recurrence, exceptions) - Add transformation logic to map iCalendar events to Remind format (stub implementation) - Provide utilities for extracting event details and converting dates/times - Set up executable entrypoint and command-line interface using Cmdliner - Include Remind event type definitions and helpers --- .ocamlformat | 19 + bin/commandLine.ml | 17 + bin/dune | 13 + bin/eventPredicates.ml | 2301 +++++++++++++++++++++++++++++++++++++++ bin/eventTransformer.ml | 15 + bin/main.ml | 34 + bin/remind.ml | 119 ++ bin/utils.ml | 70 ++ dune | 1 + dune-project | 24 + lib/dune | 2 + remind_sync.opam | 30 + 12 files changed, 2645 insertions(+) create mode 100644 .ocamlformat create mode 100644 bin/commandLine.ml create mode 100644 bin/dune create mode 100644 bin/eventPredicates.ml create mode 100644 bin/eventTransformer.ml create mode 100644 bin/main.ml create mode 100644 bin/remind.ml create mode 100644 bin/utils.ml create mode 100644 dune create mode 100644 dune-project create mode 100644 lib/dune create mode 100644 remind_sync.opam diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..0443a92 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,19 @@ +version = 0.28.1 +profile = conventional + +break-cases = fit-or-vertical +break-infix = fit-or-vertical +break-separators = after +cases-exp-indent = 2 +exp-grouping = preserve +if-then-else = keyword-first +leading-nested-match-parens = false +let-and = sparse +margin = 120 +space-around-arrays = false +space-around-lists = false +space-around-records = false +space-around-records = true +space-around-variants = false +type-decl = sparse +wrap-fun-args = false diff --git a/bin/commandLine.ml b/bin/commandLine.ml new file mode 100644 index 0000000..a68b368 --- /dev/null +++ b/bin/commandLine.ml @@ -0,0 +1,17 @@ +open Cmdliner +open Cmdliner.Term.Syntax + +let ical_file = + let doc = "TODO" in + let docv = "ICAL" in + Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv ~doc) + +let main_command f = + let doc = "Convert iCalendar files to remind format" in + let man = [] in + Cmd.make (Cmd.info "ical2rem" ~version:"%%VERSION%%" ~doc ~man) + @@ + let+ ical_file = ical_file in + f ical_file + +let main f = Cmd.eval @@ main_command f diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..3f8c71e --- /dev/null +++ b/bin/dune @@ -0,0 +1,13 @@ +(executable + (public_name remind_sync) + (name main) + (modules main commandLine remind eventTransformer eventPredicates utils) + (preprocess + (pps ppx_deriving.show)) + (libraries + ;remind_sync + cmdliner + icalendar + timedesc-tzdb.full + timedesc-tzlocal.unix + timedesc)) diff --git a/bin/eventPredicates.ml b/bin/eventPredicates.ml new file mode 100644 index 0000000..9d3b239 --- /dev/null +++ b/bin/eventPredicates.ml @@ -0,0 +1,2301 @@ +open Icalendar +open Utils + +(* +FILE: icalendar.ml +-------------------- + +module Uri = struct + include Uri + let pp = pp_hum +end + +module Ptime = struct + include Ptime + let equal_date (y, m, d) (y', m', d') = y = y' && m = m' && d = d' + let pp_date fmt (y, m, d) = Fmt.pf fmt "%04d-%02d-%02d" y m d +end + +let positive = true + +type timestamp_utc = Ptime.t [@@deriving eq, show] +type timestamp_local = Ptime.t [@@deriving eq, show] + +type utc_or_timestamp_local = [ + | `Utc of timestamp_utc + | `Local of timestamp_local +] [@@deriving eq, show] + +type timestamp = [ + utc_or_timestamp_local + | `With_tzid of timestamp_local * (bool * string) +] [@@deriving eq, show] + +type date_or_datetime = [ `Datetime of timestamp | `Date of Ptime.date ] [@@deriving eq, show] + +type valuetype = [ + `Binary | `Boolean | `Caladdress | `Date | `Datetime | `Duration | `Float + | `Integer | `Period | `Recur | `Text | `Time | `Uri | `Utcoffset + | `Xname of (string * string) | `Ianatoken of string +] [@@deriving eq, show] + +type cutype = [ `Group | `Individual | `Resource | `Room | `Unknown + | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] + +type partstat = [ `Accepted | `Completed | `Declined | `Delegated + | `In_process | `Needs_action | `Tentative + | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] + +type relationship = + [ `Parent | `Child | `Sibling | + `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] + +type role = [ `Chair | `Nonparticipant | `Optparticipant | `Reqparticipant + | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] + +type fbtype = [ `Free | `Busy | `Busy_Unavailable | `Busy_Tentative | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] + +type param_value = [ `Quoted of string | `String of string ] [@@deriving eq, show] + +type _ icalparameter = + | Altrep : Uri.t icalparameter + | Cn : param_value icalparameter + | Cutype : cutype icalparameter + | Delegated_from : (Uri.t list) icalparameter + | Delegated_to : (Uri.t list) icalparameter + | Dir : Uri.t icalparameter + | Encoding : [ `Base64 ] icalparameter + | Media_type : (string * string) icalparameter + | Fbtype : fbtype icalparameter + | Language : string icalparameter + | Member : (Uri.t list) icalparameter + | Partstat : partstat icalparameter + | Range : [ `Thisandfuture ] icalparameter + | Related : [ `Start | `End ] icalparameter + | Reltype : relationship icalparameter + | Role : role icalparameter + | Rsvp : bool icalparameter + | Sentby : Uri.t icalparameter + | Tzid : (bool * string) icalparameter + | Valuetype : valuetype icalparameter + | Iana_param : string -> param_value list icalparameter + | Xparam : (string * string) -> param_value list icalparameter + +let equal_icalparameter : type a. a icalparameter -> a -> a -> bool + = fun k lhs_v rhs_v -> + match k with + | Altrep -> Uri.equal lhs_v rhs_v + | Cn -> equal_param_value lhs_v rhs_v + | Cutype -> equal_cutype lhs_v rhs_v + | Delegated_from -> List.for_all2 Uri.equal lhs_v rhs_v + | Delegated_to -> List.for_all2 Uri.equal lhs_v rhs_v + | Dir -> Uri.equal lhs_v rhs_v + | Encoding -> lhs_v = rhs_v + | Media_type -> String.equal (fst lhs_v) (fst rhs_v) && String.equal (snd lhs_v) (snd rhs_v) + | Fbtype -> equal_fbtype lhs_v rhs_v + | Language -> String.equal lhs_v rhs_v + | Member -> List.for_all2 Uri.equal lhs_v rhs_v + | Partstat -> equal_partstat lhs_v rhs_v + | Range -> lhs_v = rhs_v + | Related -> lhs_v = rhs_v + | Reltype -> equal_relationship lhs_v rhs_v + | Role -> equal_role lhs_v rhs_v + | Rsvp -> lhs_v = rhs_v + | Sentby -> Uri.equal lhs_v rhs_v + | Tzid -> fst lhs_v = fst rhs_v && String.equal (snd lhs_v) (snd rhs_v) + | Valuetype -> equal_valuetype lhs_v rhs_v + | Iana_param _ -> List.for_all2 equal_param_value lhs_v rhs_v + | Xparam _ -> List.for_all2 equal_param_value lhs_v rhs_v + +let pp_icalparameter : type a. Format.formatter -> a icalparameter -> a -> unit + = fun fmt k v -> + match k with + | Altrep -> Format.fprintf fmt "Altrep %a" Uri.pp v + | Cn -> Format.fprintf fmt "Cn %a" pp_param_value v + | Cutype -> Format.fprintf fmt "Cutype %a" pp_cutype v + | Delegated_from -> Format.fprintf fmt "Delegated_from %a" Fmt.(list Uri.pp) v + | Delegated_to -> Format.fprintf fmt "Delegated_to %a" Fmt.(list Uri.pp) v + | Dir -> Format.fprintf fmt "Dir %a" Uri.pp v + | Encoding -> Format.fprintf fmt "Encoding base64" + | Media_type -> Format.fprintf fmt "Media_type (%s/%s)" (fst v) (snd v) + | Fbtype -> Format.fprintf fmt "Fbtype %a" pp_fbtype v + | Language -> Format.fprintf fmt "Language %s" v + | Member -> Format.fprintf fmt "Member %a" Fmt.(list Uri.pp) v + | Partstat -> Format.fprintf fmt "Partstat %a" pp_partstat v + | Range -> Format.fprintf fmt "Range thisandfuture" + | Related -> Format.fprintf fmt "Related %s" (match v with `Start -> "start" | `End -> "end") + | Reltype -> Format.fprintf fmt "Reltype %a" pp_relationship v + | Role -> Format.fprintf fmt "Role %a" pp_role v + | Rsvp -> Format.fprintf fmt "Rsvp %b" v + | Sentby -> Format.fprintf fmt "Sentby %a" Uri.pp v + | Tzid -> Format.fprintf fmt "Tzid (%b, %s)" (fst v) (snd v) + | Valuetype -> Format.fprintf fmt "Valuetype %a" pp_valuetype v + | Iana_param a -> Format.fprintf fmt "Iana_param (%s, %a)" a Fmt.(list pp_param_value) v + | Xparam (a, b) -> Format.fprintf fmt "Xparam ((%s, %s), %a)" a b Fmt.(list pp_param_value) v + +module K = struct + type 'a t = 'a icalparameter + + let compare : type a b. a t -> b t -> (a, b) Gmap.Order.t = fun lhs rhs -> + let open Gmap.Order in + match (lhs, rhs) with + | (Altrep, Altrep) -> Eq + | (Cn, Cn) -> Eq + | (Cutype, Cutype) -> Eq + | (Delegated_from, Delegated_from) -> Eq + | (Delegated_to, Delegated_to) -> Eq + | (Dir, Dir) -> Eq + | (Encoding, Encoding) -> Eq + | (Media_type, Media_type) -> Eq + | (Fbtype, Fbtype) -> Eq + | (Language, Language) -> Eq + | (Member, Member) -> Eq + | (Partstat, Partstat) -> Eq + | (Range, Range) -> Eq + | (Related, Related) -> Eq + | (Reltype, Reltype) -> Eq + | (Role, Role) -> Eq + | (Rsvp, Rsvp) -> Eq + | (Sentby, Sentby) -> Eq + | (Tzid, Tzid) -> Eq + | (Valuetype, Valuetype) -> Eq + | (Iana_param a, Iana_param a') -> + begin match String.compare a a' with + | 0 -> Eq + | x when x < 0 -> Lt + | _ -> Gt + end + | (Xparam (a, b), Xparam (a', b')) -> + begin match String.compare a a' with + | 0 -> + begin match String.compare b b' with + | 0 -> Eq + | y when y < 0 -> Lt + | _ -> Gt + end + | x when x < 0 -> Lt + | _ -> Gt + end + | _ -> + let to_int : type a. a icalparameter -> int = + function + | Altrep -> 0 + | Cn -> 1 + | Cutype -> 2 + | Delegated_from -> 3 + | Delegated_to -> 4 + | Dir -> 5 + | Encoding -> 6 + | Media_type -> 7 + | Fbtype -> 8 + | Language -> 9 + | Member -> 10 + | Partstat -> 11 + | Range -> 12 + | Related -> 13 + | Reltype -> 14 + | Role -> 15 + | Rsvp -> 16 + | Sentby -> 17 + | Tzid -> 18 + | Valuetype -> 19 + | Iana_param _ -> 20 + | Xparam _ -> 21 in + if Stdlib.compare (to_int lhs) (to_int rhs) < 0 + then Lt else Gt +end + +module Params = Gmap.Make(K) + +type params = Params.t + +let equal_params m m' = + Params.equal { f = equal_icalparameter } m m' + +let pp_params ppf m = Params.iter + (fun (Params.B (k, v)) -> + pp_icalparameter ppf k v ; + Format.pp_print_space ppf ()) m + +type other_prop = + [ `Iana_prop of string * params * string + | `Xprop of (string * string) * params * string ] [@@deriving eq, show] + +type cal_prop = + [ `Prodid of params * string + | `Version of params * string + | `Calscale of params * string + | `Method of params * string + | other_prop + ] [@@deriving eq, show] + +type weekday = [ `Friday | `Monday | `Saturday | `Sunday | `Thursday | `Tuesday | `Wednesday ] [@@deriving eq, show] + +type recur = [ + | `Byminute of int list + | `Byday of (int * weekday) list + | `Byhour of int list + | `Bymonth of int list + | `Bymonthday of int list + | `Bysecond of int list + | `Bysetposday of int list + | `Byweek of int list + | `Byyearday of int list + | `Weekday of weekday +] [@@deriving eq, show] + +type freq = [ `Daily | `Hourly | `Minutely | `Monthly | `Secondly | `Weekly | `Yearly ] [@@deriving eq, show] + +type count_or_until = [ + | `Count of int + | `Until of utc_or_timestamp_local +] [@@deriving eq, show] + +type interval = int [@@deriving eq, show] + +type recurrence = freq * count_or_until option * interval option * recur list [@@deriving eq, show] + +type class_ = [ `Public | `Private | `Confidential | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] + +type status = [ `Draft | `Final | `Cancelled | + `Needs_action | `Completed | `In_process | `Tentative | `Confirmed ] [@@deriving eq, show] + +type period = timestamp * Ptime.Span.t * bool [@@deriving eq, show] +type period_utc = timestamp_utc * Ptime.Span.t * bool [@@deriving eq, show] + +type dates_or_datetimes = [ `Datetimes of timestamp list | `Dates of Ptime.date list ] [@@deriving eq, show] +type dates_or_datetimes_or_periods = [ dates_or_datetimes | `Periods of period list ] [@@deriving eq, show] + +type general_prop = [ + | `Dtstamp of params * timestamp_utc + | `Uid of params * string + | `Dtstart of params * date_or_datetime + | `Class of params * class_ + | `Created of params * timestamp_utc + | `Description of params * string + | `Geo of params * (float * float) + | `Lastmod of params * timestamp_utc + | `Location of params * string + | `Organizer of params * Uri.t + | `Priority of params * int + | `Seq of params * int + | `Status of params * status + | `Summary of params * string + | `Url of params * Uri.t + | `Recur_id of params * date_or_datetime + | `Rrule of params * recurrence + | `Duration of params * Ptime.Span.t + | `Attach of params * [ `Uri of Uri.t | `Binary of string ] + | `Attendee of params * Uri.t + | `Categories of params * string list + | `Comment of params * string + | `Contact of params * string + | `Exdate of params * dates_or_datetimes + | `Rstatus of params * ((int * int * int option) * string * string option) + | `Related of params * string + | `Resource of params * string list + | `Rdate of params * dates_or_datetimes_or_periods +] [@@deriving eq, show] + +type event_prop = [ + | general_prop + | `Transparency of params * [ `Transparent | `Opaque ] + | `Dtend of params * date_or_datetime + | other_prop +] [@@deriving eq, show] + +type 'a alarm_struct = { + trigger : params * [ `Duration of Ptime.Span.t | `Datetime of timestamp_utc ] ; + duration_repeat: ((params * Ptime.Span.t) * (params * int )) option ; + summary : (params * string) option ; + other: other_prop list ; + special: 'a ; +} [@@deriving eq, show] + +type audio_struct = { + attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; +} [@@deriving eq, show] + +type display_struct = { + description : (params * string) option ; +} [@@deriving eq, show] + +type email_struct = { + description : params * string ; + attendees : (params * Uri.t) list ; + attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; +} [@@deriving eq, show] + +type alarm = [ + | `Audio of audio_struct alarm_struct + | `Display of display_struct alarm_struct + | `Email of email_struct alarm_struct + | `None of unit alarm_struct +] [@@deriving eq, show] + +type tz_prop = [ + | `Dtstart_local of params * timestamp_local + | `Tzoffset_to of params * Ptime.Span.t + | `Tzoffset_from of params * Ptime.Span.t + | `Rrule of params * recurrence + | `Comment of params * string + | `Rdate of params * dates_or_datetimes_or_periods + | `Tzname of params * string + | other_prop +] [@@deriving eq, show] + +type timezone_prop = [ + | `Timezone_id of params * (bool * string) + | `Lastmod of params * timestamp_utc + | `Tzurl of params * Uri.t + | `Standard of tz_prop list + | `Daylight of tz_prop list + | other_prop +] [@@deriving eq, show] + +type todo_prop = [ + | general_prop + | `Completed of params * timestamp_utc + | `Percent of params * int + | `Due of params * date_or_datetime + | other_prop +] [@@deriving eq, show] + +type journal_prop = [ + | general_prop + | other_prop +] [@@deriving eq, show] + +type freebusy_prop = [ + | `Dtstamp of params * timestamp_utc + | `Uid of params * string + | `Contact of params * string + | `Dtstart_utc of params * timestamp_utc + | `Dtend_utc of params * timestamp_utc + | `Organizer of params * Uri.t + | `Url of params * Uri.t + | `Attendee of params * Uri.t + | `Comment of params * string + | `Freebusy of params * period_utc list + | `Rstatus of params * ((int * int * int option) * string * string option) + | other_prop +] [@@deriving eq, show] + +type event = { + dtstamp : params * timestamp_utc ; + uid : params * string ; + dtstart : params * date_or_datetime ; + dtend_or_duration : [ `Duration of params * Ptime.Span.t | `Dtend of params * date_or_datetime ] option ; + rrule : (params * recurrence) option ; + props : event_prop list ; + alarms : alarm list ; +} [@@deriving eq, show] + +END OF FILE: icalendar.ml +*) + +(* +FILE: icalendar.mli +-------------------- + +type timestamp_utc = Ptime.t [@@deriving eq, show] +type timestamp_local = Ptime.t [@@deriving eq, show] + +type utc_or_timestamp_local = [ + | `Utc of timestamp_utc + | `Local of timestamp_local +] [@@deriving eq, show] + +type timestamp = [ + utc_or_timestamp_local + | `With_tzid of timestamp_local * (bool * string) +] [@@deriving eq, show] + +type date_or_datetime = [ `Datetime of timestamp | `Date of Ptime.date ] + +type weekday = [ `Friday | `Monday | `Saturday | `Sunday | `Thursday | `Tuesday | `Wednesday ] [@@deriving eq, show] + +type recur = [ + | `Byminute of int list + | `Byday of (int * weekday) list + | `Byhour of int list + | `Bymonth of int list + | `Bymonthday of int list + | `Bysecond of int list + | `Bysetposday of int list + | `Byweek of int list + | `Byyearday of int list + | `Weekday of weekday +] [@@deriving eq, show] + +type freq = [ `Daily | `Hourly | `Minutely | `Monthly | `Secondly | `Weekly | `Yearly ] [@@deriving eq, show] + +type count_or_until = [ + | `Count of int + | `Until of utc_or_timestamp_local (* TODO date or datetime *) +] [@@deriving eq, show] + +type interval = int + +type recurrence = freq * count_or_until option * interval option * recur list [@@deriving eq, show] + +type valuetype = [ + `Binary | `Boolean | `Caladdress | `Date | `Datetime | `Duration | `Float + | `Integer | `Period | `Recur | `Text | `Time | `Uri | `Utcoffset + | `Xname of (string * string) | `Ianatoken of string +] + +type cutype = [ `Group | `Individual | `Resource | `Room | `Unknown + | `Ianatoken of string | `Xname of string * string ] + +type partstat = [ `Accepted | `Completed | `Declined | `Delegated + | `In_process | `Needs_action | `Tentative + | `Ianatoken of string | `Xname of string * string ] + +type role = [ `Chair | `Nonparticipant | `Optparticipant | `Reqparticipant + | `Ianatoken of string | `Xname of string * string ] + +type relationship = + [ `Parent | `Child | `Sibling | + `Ianatoken of string | `Xname of string * string ] + +type fbtype = [ `Free | `Busy | `Busy_Unavailable | `Busy_Tentative | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] + +type param_value = [ `Quoted of string | `String of string ] + +type _ icalparameter = + | Altrep : Uri.t icalparameter + | Cn : param_value icalparameter + | Cutype : cutype icalparameter + | Delegated_from : (Uri.t list) icalparameter + | Delegated_to : (Uri.t list) icalparameter + | Dir : Uri.t icalparameter + | Encoding : [ `Base64 ] icalparameter + | Media_type : (string * string) icalparameter + | Fbtype : fbtype icalparameter + | Language : string icalparameter + | Member : (Uri.t list) icalparameter + | Partstat : partstat icalparameter + | Range : [ `Thisandfuture ] icalparameter + | Related : [ `Start | `End ] icalparameter + | Reltype : relationship icalparameter + | Role : role icalparameter + | Rsvp : bool icalparameter + | Sentby : Uri.t icalparameter + | Tzid : (bool * string) icalparameter + | Valuetype : valuetype icalparameter + | Iana_param : string -> param_value list icalparameter + | Xparam : (string * string) -> param_value list icalparameter + +module Params : sig include Gmap.S with type 'a key = 'a icalparameter end + +type params = Params.t + +type other_prop = + [ `Iana_prop of string * params * string + | `Xprop of (string * string) * params * string ] [@@deriving eq, show] + +type cal_prop = + [ `Prodid of params * string + | `Version of params * string + | `Calscale of params * string + | `Method of params * string + | other_prop + ] + +type class_ = [ `Public | `Private | `Confidential | `Ianatoken of string | `Xname of string * string ] + +type status = [ `Draft | `Final | `Cancelled | + `Needs_action | `Completed | `In_process | (* `Cancelled *) + `Tentative | `Confirmed (* | `Cancelled *) ] + +type period = timestamp * Ptime.Span.t * bool +type period_utc = timestamp_utc * Ptime.Span.t * bool + +type dates_or_datetimes = [ `Datetimes of timestamp list | `Dates of Ptime.date list ] +type dates_or_datetimes_or_periods = [ dates_or_datetimes | `Periods of period list ] + +type general_prop = [ + | `Dtstamp of params * timestamp_utc + | `Uid of params * string + | `Dtstart of params * date_or_datetime + | `Class of params * class_ + | `Created of params * timestamp_utc + | `Description of params * string + | `Geo of params * (float * float) + | `Lastmod of params * timestamp_utc + | `Location of params * string + | `Organizer of params * Uri.t + | `Priority of params * int + | `Seq of params * int + | `Status of params * status + | `Summary of params * string + | `Url of params * Uri.t + | `Recur_id of params * date_or_datetime + (* TODO: Furthermore, this property MUST be specified + as a date with local time if and only if the "DTSTART" property + contained within the recurring component is specified as a date + with local time. *) + | `Rrule of params * recurrence + | `Duration of params * Ptime.Span.t + | `Attach of params * [ `Uri of Uri.t | `Binary of string ] + | `Attendee of params * Uri.t + | `Categories of params * string list + | `Comment of params * string + | `Contact of params * string + | `Exdate of params * dates_or_datetimes + | `Rstatus of params * ((int * int * int option) * string * string option) + | `Related of params * string + | `Resource of params * string list + | `Rdate of params * dates_or_datetimes_or_periods +] + +type event_prop = [ + | general_prop + | `Transparency of params * [ `Transparent | `Opaque ] + | `Dtend of params * date_or_datetime + (* TODO: valuetype same as DTSTART *) + | other_prop +] + +type 'a alarm_struct = { + trigger : params * [ `Duration of Ptime.Span.t | `Datetime of timestamp_utc ] ; + duration_repeat: ((params * Ptime.Span.t) * (params * int )) option ; + summary : (params * string) option ; + other: other_prop list ; + special: 'a ; +} + +type audio_struct = { + attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; +} + +type display_struct = { + description : (params * string) option ; +} + +type email_struct = { + description : params * string ; + attendees : (params * Uri.t) list ; + attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; +} + +type alarm = [ + | `Audio of audio_struct alarm_struct + | `Display of display_struct alarm_struct + | `Email of email_struct alarm_struct + | `None of unit alarm_struct +] + +type tz_prop = [ + | `Dtstart_local of params * timestamp_local + | `Tzoffset_to of params * Ptime.Span.t + | `Tzoffset_from of params * Ptime.Span.t + | `Rrule of params * recurrence + | `Comment of params * string + | `Rdate of params * dates_or_datetimes_or_periods + | `Tzname of params * string + | other_prop +] + +type timezone_prop = [ + | `Timezone_id of params * (bool * string) + | `Lastmod of params * timestamp_utc + | `Tzurl of params * Uri.t + | `Standard of tz_prop list + | `Daylight of tz_prop list + | other_prop +] + +type todo_prop = [ + | general_prop + | `Completed of params * timestamp_utc + | `Percent of params * int + | `Due of params * date_or_datetime + | other_prop +] + +type journal_prop = [ + | general_prop + | other_prop +] + +type freebusy_prop = [ + | `Dtstamp of params * timestamp_utc + | `Uid of params * string + | `Contact of params * string + | `Dtstart_utc of params * timestamp_utc + | `Dtend_utc of params * timestamp_utc + | `Organizer of params * Uri.t + | `Url of params * Uri.t + | `Attendee of params * Uri.t + | `Comment of params * string + | `Freebusy of params * period_utc list + | `Rstatus of params * ((int * int * int option) * string * string option) + | other_prop +] + +type event = { + dtstamp : params * timestamp_utc ; + uid : params * string ; + dtstart : params * date_or_datetime ; (* NOTE: optional if METHOD present according to RFC 5545 *) + dtend_or_duration : [ `Duration of params * Ptime.Span.t | `Dtend of params * date_or_datetime ] option ; + rrule : (params * recurrence) option ; (* NOTE: RFC says SHOULD NOT occur more than once *) + props : event_prop list ; + alarms : alarm list ; +} + +type timezone = timezone_prop list + +type component = [ + | `Event of event + | `Todo of todo_prop list * alarm list + | `Journal of journal_prop list + | `Freebusy of freebusy_prop list + | `Timezone of timezone +] [@@deriving show] + +(* +val in_timerange : component -> (Ptime.t * bool) * (Ptime.t * bool) -> bool +*) +val component_to_ics_key : component -> string + +type calendar = cal_prop list * component list + +val parse_datetime: string -> (timestamp, string) result +val parse : string -> (calendar, string) result +val pp : calendar Fmt.t +val equal_calendar : calendar -> calendar -> bool + +(* TODO this actually belongs to CalDAV! this is Webdav_xml module! *) +type comp = [ `Allcomp | `Comp of component_transform list ] +and prop = [ `Allprop | `Prop of (string * bool) list ] +and component_transform = string * prop * comp [@@deriving show, eq] + +val to_ics : ?cr:bool -> ?filter:component_transform option -> calendar -> string + +module Writer : sig + val duration_to_ics : Ptime.Span.t -> Buffer.t -> unit + val cal_prop_to_ics_key : cal_prop -> string +end + +val recur_dates : Ptime.t -> recurrence -> (unit -> Ptime.t option) + +val recur_events : ?recurrence_ids:event list -> event -> (unit -> event option) + +val normalize_timezone : Ptime.t -> bool * String.t -> + timezone_prop list list -> + Ptime.t option + + +END OF FILE: icalendar.mli +*) + +(* +FILE: ptime.ml +-------------------- +(*--------------------------------------------------------------------------- + Copyright (c) 2015 The ptime programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(* Julian day and proleptic Gregorian calendar date conversion. + + Formulae are from the calendar FAQ: + http://www.tondering.dk/claus/cal/julperiod.php#formula + + These formulae work for positive Julian days. They represent + Gegorian calendar BCE year `y` by `-(y-1)`, e.g. 2 BCE is -1, this + follows the convention of ISO 8601. + + All timestamps in Ptime's [min;max] range are represented by + positive Julian days and the formulae do not overflow on 32-bit + platforms in this restricted range. *) + +let jd_to_date jd = + let a = jd + 32044 in + let b = (4 * a + 3) / 146097 in + let c = a - ((146097 * b) / 4) in + let d = (4 * c + 3) / 1461 in + let e = c - ((1461 * d) / 4) in + let m = (5 * e + 2) / 153 in + let day = e - ((153 * m + 2) / 5) + 1 in + let month = m + 3 - (12 * (m / 10)) in + let year = 100 * b + d - 4800 + (m / 10) in + (year, month, day) + +let jd_to_year jd = (* Same as above but only for the year *) + let a = jd + 32044 in + let b = (4 * a + 3) / 146097 in + let c = a - ((146097 * b) / 4) in + let d = (4 * c + 3) / 1461 in + let e = c - ((1461 * d) / 4) in + let m = (5 * e + 2) / 153 in + 100 * b + d - 4800 + (m / 10) + +let jd_of_date (year, month, day) = + let a = (14 - month) / 12 in + let y = year + 4800 - a in + let m = month + 12 * a - 3 in + day + ((153 * m) + 2)/ 5 + 365 * y + + (y / 4) - (y / 100) + (y / 400) - 32045 + +let jd_posix_epoch = 2_440_588 (* the Julian day of the POSIX epoch *) +let jd_ptime_min = 1_721_060 (* the Julian day of Ptime.min *) +let jd_ptime_max = 5_373_484 (* the Julian day of Ptime.max *) + +(* Picosecond precision POSIX timestamps and time span representation. + + POSIX timestamps and spans are represented by int * int64 pairs + with the int64 in the range [0L;86_399_999_999_999_999L]. A pair + [(d, ps)] denotes the POSIX picosecond duration [d] * 86_400e12 + + [ps]. + + For a timestamp this can be seen as a POSIX day count from the + epoch paired with a picosecond precision POSIX time point in that + day starting from 00:00:00. + + By definition with a negative [d] the [ps] duration brings us + towards zero, *not* towards infinity: + + + (d * 86_400e12) (d * 86_400e12 + ps) 0 + ... -----+-----------------+-------------------+--------- ... + [---------------->| + ps + + [d] is largely sufficent to represent all the days in Ptime's + [min;max] range on both 32-bit and 64-bit platforms. *) + +type t = int * int64 + +let ps_count_in_ps = 1L +let ps_count_in_ns = 1_000L +let ps_count_in_100ns = 100_000L +let ps_count_in_us = 1_000_000L +let ps_count_in_100us = 100_000_000L +let ps_count_in_ms = 1_000_000_000L +let ps_count_in_100ms = 100_000_000_000L +let ps_count_in_s = 1_000_000_000_000L +let ps_count_in_min = 60_000_000_000_000L +let ps_count_in_hour = 3600_000_000_000_000L +let ps_count_in_day = 86_400_000_000_000_000L +let ps_day_max = 86_399_999_999_999_999L + +let day_min = jd_ptime_min - jd_posix_epoch +let day_max = jd_ptime_max - jd_posix_epoch + +let epoch = (0, 0L) (* 1970-01-01 00:00:00 UTC *) +let min = (day_min, 0L) (* 0000-01-01 00:00:00 UTC *) +let max = (day_max, ps_day_max) (* 9999-12-31 23:59:59 UTC *) + +(* POSIX time spans *) + +type span = t + +module Span = struct + + let stdlib_abs = abs + + (* Arithmetic *) + + let neg = function + | (d, 0L) -> (-d, 0L) + | (d, ps) -> (-(d + 1), Int64.sub ps_count_in_day ps) + + let add (d0, ps0) (d1, ps1) = + let d = d0 + d1 in + let ps = Int64.add ps0 ps1 in + let ps_clamp = Int64.rem ps ps_count_in_day in + let d = d + Int64.compare ps ps_clamp in + d, ps_clamp + + let sub s0 s1 = add s0 (neg s1) + let abs (d, _ as s) = if d < 0 then neg s else s + + (* POSIX time spans *) + + type t = span + + let zero = (0, 0L) + let v (d, ps as s) = + if ps < 0L || ps > ps_day_max + then invalid_arg (Format.sprintf "illegal ptime time span: (%d,%Ld)" d ps) + else s + + let of_d_ps (d, ps as s) = if ps < 0L || ps > ps_day_max then None else Some s + let unsafe_of_d_ps s = s + let unsafe_of_d_ps_option s = s + let to_d_ps s = s + + let of_int_s secs = + let d = stdlib_abs secs in + let s = (d / 86_400, Int64.(mul (of_int (d mod 86_400)) ps_count_in_s)) in + if secs < 0 then neg s else s + + let day_int_min = min_int / 86_400 + let day_int_max = max_int / 86_400 + let to_int_s (d, ps) = + if d < day_int_min || d > day_int_max then None else + let days_s = d * 86_400 in + let day_s = Int64.(to_int (div ps ps_count_in_s)) (* always positive *) in + let secs = days_s + day_s in + if secs < days_s (* positive overflow *) then None else Some secs + + let min_int_float = float min_int + let max_int_float = float max_int + let of_float_s secs = + if secs <> secs (* nan *) then None else + let days = floor (secs /. 86_400.) in + if days < min_int_float || days > max_int_float then None else + let rem_s = mod_float secs 86_400. in + let rem_s = if rem_s < 0. then 86_400. +. rem_s else rem_s in + if rem_s >= 86_400. then + (* Guard against a potential overflow in the computation of [rem_s] *) + let days = days +. 1. in + if days > max_int_float then None else + Some (int_of_float days, 0L) + else + let frac_s, rem_s = modf rem_s in + let rem_ps = Int64.(mul (of_float rem_s) ps_count_in_s) in + let frac_ps = Int64.(of_float (frac_s *. 1e12)) in + Some (int_of_float days, (Int64.add rem_ps frac_ps)) + + let to_float_s (d, ps) = + let days_s = (float d) *. 86_400. in + let day_s = Int64.(to_float (div ps ps_count_in_s)) in + let day_rem_ps = Int64.(to_float (rem ps ps_count_in_s)) in + days_s +. day_s +. (day_rem_ps *. 1e-12) + + (* Predicates *) + + let equal (d0, ps0) (d1, ps1) = + (compare : int -> int -> int) d0 d1 = 0 && + Int64.compare ps0 ps1 = 0 + + let compare (d0, ps0) (d1, ps1) = + let c = (compare : int -> int -> int) d0 d1 in + if c <> 0 then c else (compare : int64 -> int64 -> int) ps0 ps1 + + (* Rounding *) + + let round_div a b = (* a >= 0 and b > 0 *) + if a = 0L then 0L else + Int64.(div (add a (div b 2L)) b) + + let frac_div = [| 1_000_000_000_000L; + 100_000_000_000L; + 10_000_000_000L; + 1_000_000_000L; + 100_000_000L; + 10_000_000L; + 1_000_000L; + 100_000L; + 10_000L; + 1_000L; + 100L; + 10L; + 1L; |] + + let round ~frac_s:frac (sign, _ as t) = + let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in + let (d, ps) = if sign < 0 then neg t else t in + let rps = Int64.mul (round_div ps frac_div.(frac)) frac_div.(frac) in + let t = if rps > ps_day_max then (d + 1, 0L) else (d, rps) in + if sign < 0 then neg t else t + + let truncate ~frac_s:frac (sign, _ as t) = + let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in + let (d, ps) = if sign < 0 then neg t else t in + let tps = Int64.(sub ps (rem ps frac_div.(frac))) in + if sign < 0 then neg (d, tps) else (d, tps) + + let truncate_down ~frac_s:frac (d, ps) = + (d, Int64.(sub ps (rem ps frac_div.(frac )))) + + (* Pretty printing *) + + let dump ppf (d, ps) = Format.fprintf ppf "@[<1>(%d,@,%Ld)@]" d ps + + (* Warning laborious code follows. Is there a better way ? *) + + let divide_ps ~carry ps hi lo = + let hi_d = Int64.(to_int (div ps hi)) in + let rem_ps = Int64.rem ps hi in + let lo_d = Int64.to_int (round_div rem_ps lo) in + if lo_d = carry then hi_d + 1, 0 else hi_d, lo_d + + let pp_y_d ppf ~neg d ps = (* assert d >= 0 *) + let y, rem_d = + let max_d = max_int / 4 in + if d > max_d then (* d * 4 overflows *) d / 365, d mod 365 else + let y = (d * 4) / 1461 (* / 365.25 *) in + y, d - (y * 1461) / 4 + in + let days = rem_d + Int64.to_int (round_div ps ps_count_in_day) in + let y, days = if days = 366 then y + 1, 1 else y, days in + let y = if neg then -y else y in + Format.fprintf ppf "%dy" y; + if days <> 0 then Format.fprintf ppf "%dd" days; + () + + let pp_d_h ppf ~neg d ps = + let h, _ = divide_ps ~carry:1 ps ps_count_in_hour ps_count_in_hour in + let d, h = if h = 24 then d + 1, 0 else d, h in + if d = 366 then Format.fprintf ppf "%dy1d" (if neg then -1 else 1) else + if d = 365 && h >= 6 + then Format.fprintf ppf "%dy" (if neg then -1 else 1) else + let d = if neg then -d else d in + Format.fprintf ppf "%dd" d; + if h <> 0 then Format.fprintf ppf "%dh" h; + () + + let pp_h_m ppf ~neg ps = + let h, m = divide_ps ~carry:60 ps ps_count_in_hour ps_count_in_min in + if h = 24 then Format.fprintf ppf "%dd" (if neg then -1 else 1) else + let h = if neg then -h else h in + Format.fprintf ppf "%dh" h; + if m <> 0 then Format.fprintf ppf "%dmin" m; + () + + let pp_m_s ppf ~neg ps = + let m, s = divide_ps ~carry:60 ps ps_count_in_min ps_count_in_s in + if m = 60 then Format.fprintf ppf "%dh" (if neg then -1 else 1) else + let m = if neg then -m else m in + Format.fprintf ppf "%dmin" m; + if s <> 0 then Format.fprintf ppf "%ds" s; + () + + let pp_s ppf ~neg ps = + let s, ms = divide_ps ~carry:1000 ps ps_count_in_s ps_count_in_ms in + if s = 60 then Format.fprintf ppf "%dmin" (if neg then -1 else 1) else + let s = if neg then -s else s in + if ms <> 0 then Format.fprintf ppf "%d.%03ds" s ms else + Format.fprintf ppf "%ds" s + + let pp_unit higher_str hi hi_str frac_limit lo ppf ~neg ps = + let pp_unit_integral ppf ~neg h = + if h = 1000 + then Format.fprintf ppf "%d%s" (if neg then -1 else 1) higher_str + else Format.fprintf ppf "%d%s" (if neg then -h else h) hi_str + in + if ps < frac_limit then begin + let h, l = divide_ps ~carry:1000 ps hi lo in + if h >= 100 || l = 0 then pp_unit_integral ppf ~neg h else + let h = if neg then -h else h in + Format.fprintf ppf "%d.%03d%s" h l hi_str + end else begin + let ms, _ = divide_ps ~carry:1 ps hi hi in + pp_unit_integral ppf ~neg ms + end + + let pp_ms = + pp_unit "s" ps_count_in_ms "ms" ps_count_in_100ms ps_count_in_us + + let pp_us = + pp_unit "ms" ps_count_in_us "us" ps_count_in_100us ps_count_in_ns + + let pp_ns = + pp_unit "us" ps_count_in_ns "ns" ps_count_in_100ns ps_count_in_ps + + let pp_ps ppf ~neg ps = + let ps = Int64.to_int ps in + Format.fprintf ppf "%dps" (if neg then -ps else ps) + + let pp ppf (sign, _ as s) = + let neg = sign < 0 in + match (abs s) with + | (0, ps) -> + if ps >= ps_count_in_hour then pp_h_m ppf ~neg ps else + if ps >= ps_count_in_min then pp_m_s ppf ~neg ps else + if ps >= ps_count_in_s then pp_s ppf ~neg ps else + if ps >= ps_count_in_ms then pp_ms ppf ~neg ps else + if ps >= ps_count_in_us then pp_us ppf ~neg ps else + if ps >= ps_count_in_ns then pp_ns ppf ~neg ps else + pp_ps ppf ~neg ps + | (d, ps) -> + if d > 365 then pp_y_d ppf ~neg d ps else + pp_d_h ppf ~neg d ps +end + +(* POSIX timestamps *) + +let v (d, ps as s) = + if (ps < 0L || ps > ps_day_max || d < day_min || d > day_max) + then invalid_arg (Format.sprintf "illegal ptime timestamp: (%d,%Ld)" d ps) + else s + +let unsafe_of_d_ps s = s + +let of_span (d, _ as span) = + if d < day_min || d > day_max then None else Some span + +let to_span t = t + +let of_float_s secs = match Span.of_float_s secs with +| None -> None +| Some d -> of_span d + +let to_float_s = Span.to_float_s + +let truncate = Span.truncate_down + +let frac_s (_, ps) = (0, Int64.(rem ps ps_count_in_s)) + +(* Predicates *) + +let equal = Span.equal +let compare = Span.compare +let is_earlier t ~than = compare t than = -1 +let is_later t ~than = compare t than = 1 + +(* POSIX arithmetic *) + +let add_span t d = of_span (Span.add t d) +let sub_span t d = of_span (Span.sub t d) +let diff t1 t0 = Span.sub t1 t0 + +(* Time zone offsets between local and UTC timelines *) + +type tz_offset_s = int + +(* Date-time conversion + + POSIX time counts seconds since 1970-01-01 00:00:00 UTC without + counting leap seconds -- when a leap second occurs a POSIX second + can be two SI seconds or zero SI second. Hence 86400 POSIX seconds + always represent an UTC day and the translations below are accurate + without having to refer to a leap seconds table. *) + +type date = (int * int * int) +type time = (int * int * int) * tz_offset_s + +let max_month_day = (* max day number in a given year's month. *) + let is_leap_year y = (y mod 4 = 0) && (y mod 100 <> 0 || y mod 400 = 0) in + let mlen = [|31; 28 (* or not *); 31; 30; 31; 30; 31; 31; 30; 31; 30; 31|] in + fun y m -> if (m = 2 && is_leap_year y) then 29 else mlen.(m - 1) + +let is_date_valid (y, m, d) = + 0 <= y && y <= 9999 && + 1 <= m && m <= 12 && + 1 <= d && d <= max_month_day y m + +let is_time_valid ((hh, mm, ss), _) = + 0 <= hh && hh <= 23 && + 0 <= mm && mm <= 59 && + 0 <= ss && ss <= 60 + +let of_date_time (date, ((hh, mm, ss), tz_offset_s as t)) = + (* We first verify that the given date and time are Ptime-valid. + Once this has been established we find find the number of Julian + days since the epoch for the given proleptic Georgian calendar + date. This gives us the POSIX day component of the timestamp. The + remaining time fields are used to derive the picosecond precision + time in that day compensated by the time zone offset. The final + result is checked to be in Ptime's [min;max] range. + + By definition POSIX timestamps cannot represent leap seconds. + With the code below any date-time with a seconds value of 60 + (leap second addition) is mapped to the POSIX timestamp that + happens 1 second later which is what POSIX mktime would to. Any + formally non-existing UTC date-time with a seconds value of 59 + (leap second subtraction) is mapped on the POSIX timestamp that + represents this non existing instant. *) + if not (is_date_valid date && is_time_valid t) then None else + let d = jd_of_date date - jd_posix_epoch in + let hh_ps = Int64.(mul (of_int hh) ps_count_in_hour) in + let mm_ps = Int64.(mul (of_int mm) ps_count_in_min) in + let ss_ps = Int64.(mul (of_int ss) ps_count_in_s) in + let ps = Int64.(add hh_ps (add mm_ps ss_ps)) in + sub_span (d, ps) (Span.of_int_s tz_offset_s) + +let to_date_time ?(tz_offset_s = 0) t = + (* To render the timestamp in the given time zone offset we first + express the timestamp in local time and then compute the date + fields on that stamp as if it were UTC. If the local timestamp is + not in [min;max] then its date fields cannot be valid according + to the constraints guaranteed by Ptime and we fallback to UTC, + i.e. a time zone offset of 0. + + We then apply the following algorithm whose description makes + sense on a POSIX timestamp (i.e. UTC) but works equally well to + render the date-time fields of a local timestamp. + + We first take take the POSIX day count [d] (equivalent by + definition to an UTC day count) from the epoch, convert it to a + Julian day and use this to get the proleptic Gregorian calendar + date. The POSIX picoseconds [ps] in the day are are converted to + a daytime according to to its various units. + + By definition no POSIX timestamp can represent a date-time with a + seconds value of 60 (leap second addition) and thus the function + will never return a date-time with such a value. On the other + hand it will return an inexisting UTC date-time with a seconds + value of 59 whenever a leap second is subtracted since there is a + POSIX timestamp that represents this instant. *) + let (d, ps), tz_offset_s = match add_span t (Span.of_int_s tz_offset_s) with + | None -> t, 0 (* fallback to UTC *) + | Some local -> local, tz_offset_s + in + let jd = d + jd_posix_epoch in + let date = jd_to_date jd in + let hh = Int64.(to_int (div ps ps_count_in_hour)) in + let hh_rem = Int64.rem ps ps_count_in_hour in + let mm = Int64.(to_int (div hh_rem ps_count_in_min)) in + let mm_rem = Int64.rem hh_rem ps_count_in_min in + let ss = Int64.(to_int (div mm_rem ps_count_in_s)) in + date, ((hh, mm, ss), tz_offset_s) + +let of_date ?tz_offset_s:(tz = 0) date = of_date_time (date, ((00, 00, 00), tz)) +let to_date ?tz_offset_s t = fst (to_date_time ?tz_offset_s t) +let of_year ?tz_offset_s y = of_date ?tz_offset_s (y, 01, 01) +let to_year ?(tz_offset_s = 0) t = + let d = match add_span t (Span.of_int_s tz_offset_s) with + | None -> fst t (* fallback to UTC *) | Some (local_d, _) -> local_d + in + jd_to_year (d + jd_posix_epoch) + + +type weekday = [ `Sun | `Mon | `Tue | `Wed | `Thu | `Fri | `Sat ] + +let weekday_num ?(tz_offset_s = 0) t = + let (d, _) = Span.add t (Span.of_int_s tz_offset_s) in + (* N.B. in contrast to [to_date_time] we don't care if we fall outside + [min;max]. Even if it happens the result of the computation is still + correct *) + let i = (d + 4 (* Epoch, d = 0, was a thu, we want 4 for that day *)) mod 7 in + if i < 0 then 7 + i else i + +let weekday = + let wday = [| `Sun; `Mon; `Tue; `Wed; `Thu; `Fri; `Sat; |] in + fun ?tz_offset_s t -> wday.(weekday_num ?tz_offset_s t) + +(* RFC 3339 timestamp conversions *) + +(* RFC 3339 timestamp parser *) + +type error_range = int * int +type rfc3339_error = + [ `Invalid_stamp | `Eoi | `Exp_chars of char list | `Trailing_input ] + +let pp_rfc3339_error ppf = function +| `Invalid_stamp -> Format.fprintf ppf "@[invalid@ time@ stamp@]" +| `Eoi -> Format.fprintf ppf "@[unexpected@ end@ of@ input@]" +| `Trailing_input -> Format.fprintf ppf "@[trailing@ input@]" +| `Exp_chars cs -> + let rec pp_chars ppf = function + | c :: cs -> Format.fprintf ppf "@ %C" c; pp_chars ppf cs + | [] -> () + in + Format.fprintf ppf "@[expected@ a@ character@ in:%a@]" pp_chars cs + +let pp_range ppf (s, e) = + if s = e then Format.pp_print_int ppf s else Format.fprintf ppf "%d-%d" s e + +let _rfc3339_error_to_string (r, err) = + Format.asprintf "@[%a: %a@]" pp_range r pp_rfc3339_error err + +let rfc3339_string_error = function +| Ok _ as v -> v | Error (`RFC3339 e) -> Error (_rfc3339_error_to_string e) + +let rfc3339_error_to_msg = function +| Ok _ as v -> v | Error (`RFC3339 e) -> + Error (`Msg (_rfc3339_error_to_string e)) + +exception RFC3339 of (int * int) * rfc3339_error (* Internal *) + +let error r e = raise (RFC3339 (r, e)) +let error_pos p e = error (p, p) e +let error_exp_digit p = + error_pos p (`Exp_chars ['0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9']) + +let is_digit = function '0' .. '9' -> true | _ -> false + +let parse_digits ~count pos max s = + let stop = pos + count - 1 in + if stop > max then error_pos max `Eoi else + let rec loop k acc = + if k > stop then acc else + if is_digit s.[k] then loop (k+1) (acc * 10 + Char.code s.[k] - 0x30) else + error_exp_digit k + in + loop pos 0 + +let parse_char c pos max s = + if pos > max then error_pos max `Eoi else + if s.[pos] = c then () else error_pos pos (`Exp_chars [c]) + +let parse_dt_sep ~strict pos max s = + let is_dt_sep = function + | 'T' -> true + | 't' | ' ' when not strict -> true + | _ -> false + in + if pos > max then error_pos max `Eoi else + if is_dt_sep s.[pos] then () else + error_pos pos (`Exp_chars (['T'] @ if strict then [] else ['t'; ' '])) + +let decide_frac_or_tz ~strict pos max s = + if pos > max then error_pos max `Eoi else + match s.[pos] with + | '.' -> `Frac + | '+' | '-' | 'Z' -> `Tz + | 'z' when not strict -> `Tz + | c -> + let chars = ['.'; '+'; '-'; 'Z'] @ if strict then [] else ['z'] in + error_pos pos (`Exp_chars chars) + +let parse_frac_ps pos max s = + if pos > max then error_pos max `Eoi else + if not (is_digit s.[pos]) then error_exp_digit pos else + let rec loop k acc pow = + if k > max then error_pos max `Eoi else + if not (is_digit s.[k]) then (Some acc), k else + let count = k - pos + 1 in + if count > 12 then (* truncate *) loop (k + 1) acc pow else + let pow = Int64.div pow 10L in + let acc = Int64.(add acc (mul (of_int (Char.code s.[k] - 0x30)) pow)) in + loop (k + 1) acc pow + in + loop pos 0L ps_count_in_s + +let parse_tz_s ~strict pos max s = + let parse_tz_mag sign pos = + let hh_pos = pos in + let hh = parse_digits ~count:2 hh_pos max s in + let mm, mm_pos = match strict with + | true -> + let mm_pos = hh_pos + 3 in + parse_char ':' (mm_pos - 1) max s; + parse_digits ~count:2 mm_pos max s, mm_pos + | false -> + let next = hh_pos + 2 in + if next > max || not (s.[next] = ':' || is_digit s.[next]) + then (0, hh_pos (* end pos of parse - 1, one is added at the end *)) + else + let mm_pos = if s.[next] = ':' then hh_pos + 3 else hh_pos + 2 in + parse_digits ~count:2 mm_pos max s, mm_pos + in + if hh > 23 then error (hh_pos, hh_pos + 1) `Invalid_stamp else + if mm > 59 then error (mm_pos, mm_pos + 1) `Invalid_stamp else + let secs = hh * 3600 + mm * 60 in + let tz_s = match secs = 0 && sign = -1 with + | true -> None (* -00:00 convention *) + | false -> Some (sign * secs) + in + tz_s, mm_pos + 1 + in + if pos > max then error_pos max `Eoi else + match s.[pos] with + | 'Z' -> Some 0, pos + | 'z' when not strict -> Some 0, pos + | '+' -> parse_tz_mag ( 1) (pos + 1) + | '-' -> parse_tz_mag (-1) (pos + 1) + | c -> + let chars = ['+'; '-'; 'Z'] @ if strict then [] else ['z'] in + error_pos pos (`Exp_chars chars) + +let of_rfc3339 ?(strict = false) ?(sub = false) ?(start = 0) s = + try + let s_len = String.length s in + let max = s_len - 1 in + if s_len = 0 || start < 0 || start > max then error_pos start `Eoi else + let y_pos = start in + let m_pos = y_pos + 5 in + let d_pos = m_pos + 3 in + let hh_pos = d_pos + 3 in + let mm_pos = hh_pos + 3 in + let ss_pos = mm_pos + 3 in + let decide_pos = ss_pos + 2 in + let y = parse_digits ~count:4 y_pos max s in + parse_char '-' (m_pos - 1) max s; + let m = parse_digits ~count:2 m_pos max s in + parse_char '-' (d_pos - 1) max s; + let d = parse_digits ~count:2 d_pos max s in + parse_dt_sep ~strict (hh_pos - 1) max s; + let hh = parse_digits ~count:2 hh_pos max s in + parse_char ':' (mm_pos - 1) max s; + let mm = parse_digits ~count:2 mm_pos max s in + parse_char ':' (ss_pos - 1) max s; + let ss = parse_digits ~count:2 ss_pos max s in + let frac, tz_pos = match decide_frac_or_tz ~strict decide_pos max s with + | `Frac -> parse_frac_ps (decide_pos + 1) max s + | `Tz -> None, decide_pos + in + let tz_s_opt, last_pos = parse_tz_s ~strict tz_pos max s in + let tz_s = match tz_s_opt with None -> 0 | Some s -> s in + match of_date_time ((y, m, d), ((hh, mm, ss), tz_s)) with + | None -> error (start, last_pos) `Invalid_stamp + | Some t -> + let t, tz_s = match frac with + | None | Some 0L -> t, tz_s + | Some frac -> + match add_span t (0, frac) with + | None -> error (start, last_pos) `Invalid_stamp + | Some t -> t, tz_s + in + if not sub && last_pos <> max + then error_pos (last_pos + 1) `Trailing_input + else Ok (t, tz_s_opt, last_pos - start + 1) + with RFC3339 (r, e) -> Error (`RFC3339 (r, e)) + +(* RFC 3339 timestamp formatter *) + +let rfc3339_adjust_tz_offset tz_offset_s = + (* The RFC 3339 time zone offset field is limited in expression to + the bounds below with minute precision. If the requested time + zone offset exceeds these bounds or is not an *integral* number + of minutes we simply use UTC. An alternative would be to + compensate the offset *and* the timestamp but it's more + complicated to explain and maybe more surprising to the user. *) + let min = -86340 (* -23h59 in secs *) in + let max = +86340 (* +23h59 in secs *) in + if min <= tz_offset_s && tz_offset_s <= max && tz_offset_s mod 60 = 0 + then tz_offset_s, false + else 0 (* UTC *), true + +let s_frac_of_ps frac ps = + Int64.(div (rem ps ps_count_in_s) Span.frac_div.(frac)) + +let to_rfc3339 ?(space = false) ?frac_s:(frac = 0) ?tz_offset_s (_, ps as t) = + let buf = Buffer.create 255 in + let tz_offset_s, tz_unknown = match tz_offset_s with + | Some tz -> rfc3339_adjust_tz_offset tz + | None -> 0, true + in + let (y, m, d), ((hh, ss, mm), tz_offset_s) = to_date_time ~tz_offset_s t in + let dt_sep = if space then ' ' else 'T' in + Printf.bprintf buf "%04d-%02d-%02d%c%02d:%02d:%02d" y m d dt_sep hh ss mm; + let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in + if frac <> 0 then Printf.bprintf buf ".%0*Ld" frac (s_frac_of_ps frac ps); + if tz_offset_s = 0 && not tz_unknown then Printf.bprintf buf "Z" else + begin + let tz_sign = if tz_offset_s < 0 || tz_unknown then '-' else '+' in + let tz_min = abs (tz_offset_s / 60) in + let tz_hh = tz_min / 60 in + let tz_mm = tz_min mod 60 in + Printf.bprintf buf "%c%02d:%02d" tz_sign tz_hh tz_mm; + end; + Buffer.contents buf + +let pp_rfc3339 ?space ?frac_s ?tz_offset_s () ppf t = + Format.fprintf ppf "%s" (to_rfc3339 ?space ?frac_s ?tz_offset_s t) + +(* Pretty printing *) + +let pp_human ?frac_s:(frac = 0) ?tz_offset_s () ppf (_, ps as t) = + let tz_offset_s, tz_unknown = match tz_offset_s with + | Some tz -> rfc3339_adjust_tz_offset tz + | None -> 0, true + in + let (y, m, d), ((hh, ss, mm), tz_offset_s) = to_date_time ~tz_offset_s t in + Format.fprintf ppf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh ss mm; + let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in + if frac <> 0 then Format.fprintf ppf ".%0*Ld" frac (s_frac_of_ps frac ps); + let tz_sign = if tz_offset_s < 0 || tz_unknown then '-' else '+' in + let tz_min = abs (tz_offset_s / 60) in + let tz_hh = tz_min / 60 in + let tz_mm = tz_min mod 60 in + Format.fprintf ppf " %c%02d:%02d" tz_sign tz_hh tz_mm; + () + +let pp = pp_human ~tz_offset_s:0 () +let dump = Span.dump + + +END OF FILE: ptime.ml +*) + +(* +FILE: ptime.mli +-------------------- +(*--------------------------------------------------------------------------- + Copyright (c) 2015 The ptime programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** POSIX time values. + + Consult the {{!basics}basics} and a few {{!notes}notes + and limitations}. + + {b References} + {ul + {- The Open Group. {{:http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap04.html#tag_04_15}The Open Group Base Specifications Issue 7, section 4.15 Seconds Since the Epoch}. 2013} + {- G. Klyne et al. + {{:http://tools.ietf.org/html/rfc3339} + {e Date and Time on the Internet: Timestamps}}. RFC 3339, 2002.}} *) + +(** {1:timespans POSIX time spans} *) + +type span +(** The type for signed picosecond precision POSIX time spans. A value + of this type represent the POSIX duration between two POSIX + timestamps. *) + +(** POSIX time spans. + + {b WARNING.} A POSIX time span is not equal to an SI second based time + span see the {{!basics}basics}. *) +module Span : sig + + (** {1:spans POSIX time spans} *) + + type t = span + (** The type for signed, picosecond precision, POSIX time spans. *) + + val v : int * int64 -> span + (** [v s] is like {!of_d_ps}[ s] but raises [Invalid_argument] if + [s] is not in the right range. Use {!of_d_ps} to deal with + untrusted input. *) + + val zero : span + (** [zero] is the neutral element of {!add}. *) + + val of_d_ps : int * int64 -> span option + (** [of_d_ps (d, ps)] is a span for the signed POSIX picosecond + span [d] * 86_400e12 + [ps]. [d] is a signed number of POSIX + days and [ps] a number of picoseconds in the range + \[[0];[86_399_999_999_999_999L]\]. [None] is returned if + [ps] is not in the right range. *) + + (**/**) + val unsafe_of_d_ps : int * int64 -> span + val unsafe_of_d_ps_option : (int * int64) option -> span option + (**/**) + + val to_d_ps : span -> int * int64 + (** [to_d_ps d] is the span [d] as a pair [(d, ps)] expressing the + POSIX picosecond span [d] * 86_400e12 + [ps] with + [ps] in the range \[[0];[86_399_999_999_999_999L]\] *) + + val of_int_s : int -> span + (** [of_int_s secs] is a span from the signed integer POSIX second + span [secs]. *) + + val to_int_s : span -> int option + (** [to_int_s d] is the span [d] as a signed integer POSIX second + span, if [int]'s range can represent it (note that this + depends on {!Sys.word_size}). Subsecond precision numbers are + truncated. *) + + val of_float_s : float -> span option + (** [of_float_s secs] is a span from the signed floating point POSIX + second span [d]. Subpicosecond precision numbers are truncated. + + [None] is returned if [secs] cannot be represented as a span. + This occurs on {!Stdlib.nan} or if the duration in POSIX + days cannot fit on an [int] (on 32-bit platforms this means the + absolute magnitude of the duration is greater than ~2'941'758 + years). *) + + val to_float_s : span -> float + (** [to_float_s s] is the span [d] as floating point POSIX seconds. + + {b Warning.} The magnitude of [s] may not be represented exactly + by the floating point value. *) + + (** {1:predicates Predicates} *) + + val equal : span -> span -> bool + (** [equal d d'] is [true] iff [d] and [d'] are the same time span. *) + + val compare : span -> span -> int + (** [compare d d'] is a total order on durations that is compatible + with signed time span order. *) + + (** {1:arith Arithmetic} + + {b Note.} The following functions rollover on overflows. *) + + val neg : span -> span + (** [neg d] is the span [d] negated. *) + + val add : span -> span -> span + (** [add d d'] is [d] + [d']. *) + + val sub : span -> span -> span + (** [sub d d'] is [d] - [d']. *) + + val abs : span -> span + (** [abs d] is the absolute value of span [d]. *) + + (** {1:rounding Rounding} *) + + val round : frac_s:int -> span -> span + (** [round ~frac_s t] is [t] rounded to the [frac_s] decimal + fractional second. Ties are rounded away from zero. [frac_s] is + clipped to the range \[[0];[12]\]. *) + + val truncate : frac_s:int -> span -> span + (** [truncate ~frac_s t] is [t] truncated to the [frac_s] decimal + fractional second. [frac_s] is clipped to the range + \[[0];[12]\]. *) + + (** {1:print Pretty printing} *) + + val pp : Format.formatter -> span -> unit + (** [pp ppf d] prints an unspecified, approximative, representation of [d] + on [ppf]. + + The representation is not fixed-width, depends on the magnitude of [d] + and uses locale independent + {{:http://www.bipm.org/en/publications/si-brochure/chapter3.html}SI + prefixes} on seconds and + {{:http://www.bipm.org/en/publications/si-brochure/table6.html}accepted + non-SI units}. Years are counted in Julian years (365.25 + SI-accepted days) as + {{:http://www.iau.org/publications/proceedings_rules/units/}defined} + by the International Astronomical Union (IUA). + + The representation is approximative. In particular beyond 60 + seconds it only keeps the two most significant time units and + rounds towards the infinity. The latter means that case arising, + it always {e over} approximates durations. + + {b Warning} Becomes unprecise (but does not overflow) if the + absolute number of POSIX days in the time span is greater than [max_int / + 4] (on 32-bit platforms this is ~735'439 years) *) + + val dump : Format.formatter -> span -> unit + (** [dump ppf s] prints an unspecified raw representation of [d] + on [ppf]. *) +end + +(** {1:timestamps POSIX timestamps} *) + +type t +(** The type for picosecond precision POSIX timestamps in the range + \[{!min};{!max}\]. Note that POSIX timestamps, and hence values of + this type, are by definition always on the UTC timeline. *) + +val v : int * int64 -> t +(** [v s] is [of_span (Span.v s)] but raise [Invalid_argument] if [s] + is not in the right range. Use {!Span.of_d_ps} and {!of_span} + to deal with untrusted input. *) + +val epoch : t +(** [epoch] is 1970-01-01 00:00:00 UTC. *) + +val min : t +(** [min] is 0000-01-01 00:00:00 UTC, the earliest timestamp + representable by {!Ptime}. *) + +val max : t +(** [max] is 9999-12-31 23:59:59.999999999999 UTC, the latest timestamp + representable by {!Ptime}. *) + +val of_span : span -> t option +(** [of_span d] is the POSIX time stamp that: + {ul + {- Happens at the POSIX span [d] {e after} {!epoch} + if [d] is positive.} + {- Happens at the POSIX span [d] {e before} {!epoch} + if [d] is negative.}} + [None] is returned if the timestamp is not in the range + \[{!min};{!max}\]. *) + +val to_span : t -> span +(** [to_span t] is the signed POSIX span that happen between [t] + and {!epoch}: + {ul + {- If the number is positive [t] happens {e after} {!epoch}.} + {- If the number is negative [t] happens {e before} {!epoch}.}} *) + +(**/**) +val unsafe_of_d_ps : int * int64 -> t +(**/**) + +val of_float_s : float -> t option +(** [of_float_s d] is like {!of_span} but with [d] as a floating point + second POSIX span [d]. This function is compatible with the result + of {!Unix.gettimeofday}. Decimal fractional seconds beyond [1e-12] + are truncated. *) + +val to_float_s : t -> float +(** [to_float_s t] is like {!to_span} but returns a floating point second + POSIX span. + + {b Warning.} Due to floating point inaccuracies do not expect the + function to round trip with {!of_float_s}; especially near + {!Ptime.min} and {!Ptime.max}. *) + +val truncate : frac_s:int -> t -> t +(** [truncate ~frac_s t] is [t] truncated to the [frac_s] decimal + fractional second. Effectively this reduces precision without + rounding, the timestamp remains in the second it is in. [frac_s] + is clipped to the range \[[0];[12]\]. *) + +val frac_s : t -> span +(** [frac_s t] is the (positive) fractional second duration in [t]. *) + +(** {1:predicates Predicates} *) + +val equal : t -> t -> bool +(** [equal t t'] is [true] iff [t] and [t'] are the same timestamps. *) + +val compare : t -> t -> int +(** [compare t t'] is a total order on timestamps that is compatible + with timeline order. *) + +val is_earlier : t -> than:t -> bool +(** [is_earlier t ~than] is [true] iff [compare t than = -1]. *) + +val is_later : t -> than:t -> bool +(** [is_later t than] is [true] iff [compare t than = 1]. *) + +(** {1:posix_arithmetic POSIX arithmetic} + + {b WARNING.} A POSIX time span is not equal to an SI second based + time span, see the {{!basics}basics}. Do not use these functions + to perform calendar arithmetic or measure wall-clock durations, + you will fail. *) + +val add_span : t -> span -> t option +(** [add_span t d] is timestamp [t + d], that is [t] with the signed + POSIX span [d] added. [None] is returned if the result is not + in the range \[{!min};{!max}\]. *) + +val sub_span : t -> span -> t option +(** [sub_span t d] is the timestamp [t - d], that is [t] with the + signed POSIX span [d] subtracted. [None] is returned if the result + is not in the range \[{!min};{!max}\]. *) + +val diff : t -> t -> span +(** [diff t t'] is the signed POSIX span [t - t'] that happens between + the timestamps [t] and [t']. *) + +(** {1:tz_offset Time zone offsets between local and UTC timelines} *) + +type tz_offset_s = int +(** The type for time zone offsets between local and UTC timelines + in seconds. This is the signed difference in seconds between the local + timeline and the UTC timeline: +{[ + tz_offset_s = local - UTC +]} + {ul + {- A value of [-3600] means that the local timeline is sixty minutes + {e behind} the UTC timeline.} + {- A value of [3600] means that the local timeline is sixty + minutes {e ahead} the UTC timeline.}} *) + +(** {1:date_time Date-time value conversions} + + A {e date-time} represents a point on the UTC timeline by pairing + a date in the proleptic Gregorian calendar and a second precision + daytime in a local timeline with stated relationship to the UTC + timeline. *) + +type date = int * int * int +(** The type for big-endian proleptic Gregorian dates. A triple + [(y, m, d)] with: + {ul + {- [y] the year from [0] to [9999]. [0] denotes -1 BCE + (this follows the + {{:http://www.iso.org/iso/home/standards/iso8601.htm}ISO 8601} + convention).} + {- [m] is the month from [1] to [12]} + {- [d] is the day from [1] to [28], [29], [30] or [31] + depending on [m] and [y]}} + + A date is said to be {e valid} iff the values [(y, m, d)] are + in the range mentioned above and represent an existing date in the + proleptic Gregorian calendar. *) + +type time = (int * int * int) * tz_offset_s +(** The type for daytimes on a local timeline. Pairs a triple [(hh, + mm, ss)] denoting the time on the local timeline and a [tz_offset] + stating the {{!tz_offset_s}relationship} of the local timeline to + the UTC timeline. + + The [(hh, mm, ss)] components are understood and constrainted as + follows: + {ul + {- [hh] is the hour from [0] to [23].} + {- [mm] is the minute from [0] to [59].} + {- [ss] is the seconds from [0] to [60]. [60] may happen whenever + a leap second is added.}} + A [time] value is said to be {e valid} iff the values [(hh, mm, ss)] + are in the ranges mentioned above. *) + +(** {2:datetimes Date and time} *) + +val of_date_time : date * time -> t option +(** [of_date_time dt] is the POSIX timestamp corresponding to + date-time [dt] or [None] if [dt] has an {{!date}invalid date}, + {{!time}invalid time} or the date-time is not in the range + \[{!min};{!max}\]. + + {b Leap seconds.} Any date-time with a seconds value of [60], hence + representing a leap second addition, is mapped to the date-time + that happens 1 second later. Any date-time with a seconds value of + [59] is mapped to the POSIX timestamp that represents this + instant, if a leap second was subtracted at that point, this is + the POSIX timestamp that represents this inexisting instant. See + the {{!basics}basics}. *) + +val to_date_time : ?tz_offset_s:tz_offset_s -> t -> date * time +(** [to_date_time ~tz_offset_s t] is the date-time of the timestamp [t]. + + [tz_offset_s] hints the time zone offset used for the resulting + daytime component (defaults to [0], i.e. UTC). The offset is not + honoured and fallbacks to [0] in case the resulting date-time + rendering of the timestamp would yield an {{!date}invalid + date}. This means that you should always interpret the resulting + time component with the time zone offset it is paired with in the + result and not assume it will be the one you gave to the + function. Note that for real-world time zone offsets the fallback + to [0] will only happen around {!Ptime.min} and {!Ptime.max}. + Formally the fallback occurs whenever [add_span t (Span.of_int_s + tz_offset_s)] is [None]. + + {b Leap seconds.} No POSIX timestamp can represent a date-time + with a leap second added, hence this function will never return a + date-time with a [60] seconds value. This function does return + inexisting UTC date-times with [59] seconds whenever a leap second is + subtracted since POSIX timestamps do represent them. See the + {{!basics}basics}. + + {b Subsecond precision.} POSIX timestamps with subsecond precision + are floored, i.e. the date-time always has the second mentioned in + the timestamp. *) + +(** {2:dates Date} *) + +val of_date : ?tz_offset_s:tz_offset_s -> date -> t option +(** [of_date d] is + [of_date_time (d, ((00, 00, 00), tz_offset_s))]. [tz_offset_s] + defaults to 0, i.e. UTC. *) + +val to_date : ?tz_offset_s:tz_offset_s -> t -> date +(** [to_date t] is [fst (to_date_time ?tz_offset_s t)]. *) + +(** {2:years Year} *) + +val of_year : ?tz_offset_s:tz_offset_s -> int -> t option +(** [of_year y] is [of_date ?tz_offset_s (y, 01, 01)]. *) + +val to_year : ?tz_offset_s:tz_offset_s -> t -> int +(** [to_year t] is the first component of [(to_date ?tz_offset_s t))] but + more efficient. *) + +(** {2:weekdays Week days} *) + +type weekday = [ `Sun | `Mon | `Tue | `Wed | `Thu | `Fri | `Sat ] +(** The type for the days of the 7-day week. *) + +val weekday : ?tz_offset_s:tz_offset_s -> t -> weekday +(** [weekday ~tz_offset_s t] is the day in the 7-day week of timestamp [t] + expressed in the time zone offset [ts_offset_s] (defaults to [0]). *) + +val weekday_num : ?tz_offset_s:tz_offset_s -> t -> int +(** [weekday_num] is like {!weekday} but returns a weekday number, 0 + is sunday, 1 is monday, …, 6 is saturday etc. *) + +(** {1:rfc3339 RFC 3339 timestamp conversions} *) + +type error_range = int * int +(** The type for error ranges, starting and ending position. *) + +type rfc3339_error = + [ `Invalid_stamp + | `Eoi + | `Exp_chars of char list + | `Trailing_input ] +(** The type for RFC 3339 timestamp parsing errors. [`Invalid_stamp] + means that either the time stamp is not in the range + \[{!min};{!max}\], or the date is invalid, or one of the fields is + not in the right range. *) + +val pp_rfc3339_error : Format.formatter -> rfc3339_error -> unit +(** [pp_rfc3339_error ppf e] prints an unspecified representation of + [e] on [ppf]. *) + +val rfc3339_error_to_msg : ('a, [`RFC3339 of error_range * rfc3339_error]) + result -> ('a, [> `Msg of string]) result +(** [rfc3339_error_to_msg r] converts RFC 3339 parse errors to error + messages. *) + +val rfc3339_string_error : + ('a, [`RFC3339 of error_range * rfc3339_error]) result -> ('a, string) result +(** [rfc3339_string_error r] converts RFC 3339 parse errors errors to + string errors. *) + +val of_rfc3339 : ?strict:bool -> ?sub:bool -> ?start:int -> string -> + ((t * tz_offset_s option * int), + [> `RFC3339 of error_range * rfc3339_error]) result +(** [of_rfc3339 ~strict ~sub ~start s] parses an RFC 3339 + {{:https://tools.ietf.org/html/rfc3339#section-5.6}[date-time]} + starting at [start] (defaults to [0]) in [s] to a triple [(t, tz, count)] + with: + {ul + {- [t] the POSIX timestamp (hence on the UTC timeline).} + {- [tz], the optional {{!tz_offset_s}time zone offset} found in the + timestamp. [None] is returned iff the date-time satisfies the + {{:https://tools.ietf.org/html/rfc3339#section-4.3}unknown local + offset convention}.} + {- [count] the number of bytes read starting at [start] to parse the + timestamp. If [sub] is [false] (default) this is always + [String.length s - start] and [Error `Trailing_input] is returned + if there are still bytes in [s] after the date-time was parsed. Use + [~sub:true] for allowing trailing input to exist.} + {- [strict] if [false] (default) the pasring function does + not error on timestamp with lowercase ['T'] or ['Z'] characters, or + space separated date and times, and `hhmm` and `hh` timezone + offsets (strict mandates [hh:mm]). This allows to parse a slightly + larger subset of ISO 8601 than what RFC 3339 allows}} + + {b Notes and limitations.} + {ul + {- If [start] is not an index of [s], [Error ((start, start), `Eoi)] is + returned.} + {- RFC 3339 allows a few degenerate (I say) timestamps with + non-zero time zone offsets to be parsed at the boundaries that + correspond to timestamps that cannot be expressed in UTC in RFC + 3339 itself (e.g. [0000-01-01T00:00:00+00:01]). The function + errors on these timestamps with [`Invalid_stamp] as they cannot + be represented in the range \[{!min};{!max}\].} + {- Leap seconds are allowed on any date-time and handled as in + {!of_date_time}} + {- Fractional parts beyond the picosecond ([1e-12]) are truncated.}} *) + +val to_rfc3339 : ?space:bool -> ?frac_s:int -> ?tz_offset_s:tz_offset_s -> + t -> string +(** [to_rfc3339_tz ~space ~frac_s ~tz_offset_s t] formats the timestamp + [t] according to a RFC 3339 + {{:https://tools.ietf.org/html/rfc3339#section-5.6}[date-time]} + production with: + {ul + {- [tz_offset_s] hints the time zone offset to use, use [0] for UTC. + The hint is ignored in the following cases: if [tz_offset_s] is not an + integral number of minutes and its magnitude not in the range permitted + by the standard, if [add_span t (Span.of_int_s tz_offset_s)] is [None] + (the resulting timestamp rendering would not be RFC 3339 compliant). + If either the hint is ignored or [tz_offset_s] is unspecified then + the + {{:https://tools.ietf.org/html/rfc3339#section-4.3}unknown local offset + convention} is used to render the time zone component.} + {- [frac_s], clipped to the range \[[0];[12]\] specifies that exactly + [frac_s] decimal digits of the fractional second of [t] are + rendered (defaults to [0]).} + {- [space] if [true] the date and time separator is a space + rather than a ['T'] (not recommended but may be allowed by the + protocol you are dealing with, defaults to [false]).}} *) + +val pp_rfc3339 : ?space:bool -> ?frac_s:int -> ?tz_offset_s:tz_offset_s -> + unit -> Format.formatter -> t -> unit +(** [pp_rfc3339 ?space ?frac_s ?tz_offset_s () ppf t] is + [Format.fprintf ppf "%s" (to_rfc3339 ?space ?frac_s ?tz_offset_s t)]. *) + +(** {1:print Pretty printing} *) + +val pp_human : ?frac_s:int -> ?tz_offset_s:tz_offset_s -> unit -> + Format.formatter -> t -> unit +(** [pp_human ~frac_s ~tz_offset_s () ppf t] prints an unspecified, human + readable, locale-independent, representation of [t] with: + {ul + {- [tz_offset_s] hints the time zone offset to use. The hint is ignored + in the following cases: if [tz_offset_s] is not an integral number of + minutes and its magnitude not in the range permitted by the standard, + if [add_span t (Span.of_int_s tz_offset_s)] is [None]. + If either the hint is ignored or [tz_offset_s] is unspecified then + RFC 3339's + {{:https://tools.ietf.org/html/rfc3339#section-4.3}unknown local offset + convention} is used to render the time zone component.} + {- [frac_s] clipped to the range \[[0];[12]\] specifies that exactly + [frac_s] decimal digits of the fractional second of [t] are + rendered (defaults to [0]).}} + + {b Note.} The output of this function is similar to but {b not} + compliant with RFC 3339, it should only be used for presentation, + not as a serialization format. *) + +val pp : Format.formatter -> t -> unit +(** [pp] is [pp_human ~tz_offset_s:0]. *) + +val dump : Format.formatter -> t -> unit +(** [dump ppf t] prints an unspecified raw representation of [t] + on [ppf]. *) + +(** {1:basics Basics} + + POSIX time counts POSIX seconds since the epoch 1970-01-01 + 00:00:00 UTC. As such a POSIX timestamp is {b always} on the UTC + timeline. + + POSIX time doesn't count leap seconds, so by definition it cannot + represent them. One way of viewing this is that whenever a leap + second is added a POSIX second lasts two SI seconds and whenever a + leap second is subtracted a POSIX second lasts zero SI second. + + {!Ptime} does not provide any mean to convert the duration between + two POSIX timestamps to SI seconds. The reason is that in order to + accurately find this number, a + {{:http://www.ietf.org/timezones/data/leap-seconds.list}leap + second table} is needed. However since this table may change every + six months, {!Ptime} decides not to include it so as not to + potentially become incorrect every six months. + + This decision has the following implications. First it should be + realised that the durations mentioned by the {!add_span}, + {!sub_span} and {!diff} functions are expressed in {e + POSIX seconds} which may represent zero, one, or two SI + seconds. For example if we add 1 second with + {!add_span} to the POSIX timestamp for 1998-12-31 23:59:59 UTC, + what we get is the timestamp for 1999-01-01 00:00:00 UTC: +{[ +let get = function None -> assert false | Some v -> v +let utc d t = get @@ Ptime.of_date_time (d, (t, 0)) +let t0 = utc (1998, 12, 31) (23, 59, 59) +let t1 = utc (1999, 01, 01) (00, 00, 00) +let one_s = Ptime.Span.of_int_s 1 +let () = assert (Ptime.equal (get @@ Ptime.add_span t0 one_s) t1) +]} + However since the leap second 1998-12-31 23:59:60 UTC exists, + {e two} actual SI seconds elapsed between [t0] and [t1]. Now if we use + {!diff} to find the POSIX duration that elapsed between + [t0] and [t1] we get one POSIX second: +{[ +let () = assert (Ptime.Span.equal (Ptime.diff t1 t0) one_s) +]} + But still, two SI seconds elapsed between these two points in + time. Note also that no value of type {!t} can represent the UTC + timetamp 1998-12-31 23:59:60 and hence {!Ptime.to_date_time} + will never return a date-time with a seconds value of [60]. In + fact both 1998-12-31 23:59:60 UTC and 1999-01-01 00:00:00 UTC are + represented by the same timestamp: +{[ +let t2 = utc (1998, 12, 31) (23, 59, 60) +let () = assert (Ptime.equal t1 t2) +]} + This is true of any added leap second, we map it on the first second + of the next minute, thus matching the behaviour + of POSIX's + {{:http://pubs.opengroup.org/onlinepubs/9699919799/functions/mktime.html} + mktime} function. + + If a leap second is subtracted on a day the following occurs – + 2015, as of writing this never happened. Let YYYY-06-30 23:59:58 + be the instant a leap second is subtracted, this means that the + next UTC date-time, one SI second later, is YYYY-07-01 + 00:00:00. However if we diff the two instants: +{[ +let y = 9999 (* hypothetical year were this happens *) +let t0 = utc (y, 06, 30) (23, 59, 58) +let t1 = utc (y, 07, 01) (00, 00, 00) +let two_s = Ptime.Span.of_int_s 2 +let () = assert (Ptime.Span.equal (Ptime.diff t1 t0) two_s) +]} + We get two POSIX seconds, but only one SI second + elapsed between these two points in time. It should also + be noted that POSIX time will represent a point that never + existed in time namely YYYY-06-30 23:59:59, the POSIX second + with 0 SI second duration and that {!Ptime.to_date_time} + will return a date-time value for this timestamp even though + it never existed: +{[ +let t2 = utc (y, 06, 30) (23, 59, 59) +let () = assert (Ptime.equal (get @@ Ptime.add_span t0 one_s) t2) +]} + + {1:notes Notes and limitations} + + The following points should be taken into account + {ul + {- {!Ptime} is not a calendar library and will never be.} + {- {!Ptime} can only represent picosecond precision timestamps in + the range \[{!Ptime.min};{!Ptime.max}\]. It is however able to + convert {e any} of these timestamps to a valid date-time or RFC + 3339 timestamp.} + {- POSIX time in general is ill-suited to measure wall-clock + time spans for the following reasons. + {ul + {- POSIX time counts time in POSIX seconds. POSIX + seconds can represent 2, 1 or 0 SI seconds. [Ptime] + offers no mechanism to determine the SI duration between + two timestamps, see the {{!basics}basics}.} + {- The POSIX timestamps returned by your platform are not + monotonic: they are subject to operating system time + adjustements and can even go back in time. If you need to + measure time spans in a single program run use a monotonic + time source (e.g. {!Mtime}).}}}} +*) + +END OF FILE: ptime.mli +*) + +(* CASE ANALYSIS PREDICATES + - id: P01 + pattern: All-day singolo + ics: "DTSTART;VALUE=DATE, opzionale DTEND=giorno+1" + remind_support: nativo + strategia: "REM MSG " + snippet: 'REM 2025-12-25 MSG Natale' + priorita: Subito + + - id: P02 + pattern: All-day multi-giorno + ics: "DTSTART;VALUE=DATE + DTEND;VALUE=DATE esclusivo" + remind_support: nativo+accorgimenti + strategia: "espandi in eventi giornalieri; stesso SUMMARY" + snippet: 'REM 2025-08-10 THROUGH 2025-08-15 MSG Ferie # oppure espansione per-giorno' + priorita: Subito + + - id: P03 + pattern: Evento a orario locale + ics: "DTSTART;TZID=… + DTEND oppure DURATION" + remind_support: nativo + strategia: "REM AT [DURATION] MSG …" + snippet: 'REM 2025-10-05 AT 09:00 DURATION 1:00 MSG Riunione' + priorita: Subito + + - id: P04 + pattern: Evento a orario in UTC + ics: "DTSTART/DTEND con suffisso Z" + remind_support: nativo+accorgimenti + strategia: "converti a fuso locale prima di emettere AT" + snippet: 'REM 2025-09-03 AT 06:45 MSG Treno' + priorita: Subito + + - id: P05 + pattern: Ricorrenza settimanale semplice + ics: "RRULE:FREQ=WEEKLY;BYDAY=…;[UNTIL|COUNT]" + remind_support: nativo + strategia: "REM FROM [UNTIL ] AT MSG …" + snippet: 'REM Mon Wed FROM 2025-09-01 UNTIL 2025-10-31 AT 09:00 MSG Standup' + priorita: Subito + + - id: P06 + pattern: Ricorrenza giornaliera semplice + ics: "RRULE:FREQ=DAILY;[UNTIL|COUNT]" + remind_support: nativo + strategia: "REM FROM UNTIL AT EVERY 1 MSG …" + snippet: 'REM FROM 2025-10-01 UNTIL 2025-10-10 AT 08:30 MSG Daily' + priorita: Subito + + - id: P07 + pattern: Ricorrenza mensile per giorno fisso + ics: "RRULE:FREQ=MONTHLY;BYMONTHDAY=…" + remind_support: nativo + strategia: "REM AT FROM/UNTIL" + snippet: 'REM 15 AT 10:00 FROM 2025-01-01 MSG Fatture' + priorita: Dopo + + - id: P08 + pattern: Ricorrenza “n-esimo weekday” del mese + ics: "RRULE:FREQ=MONTHLY;BYDAY=MO;BYSETPOS=3" + remind_support: espansione + strategia: "materializza occorrenze in singoli REM o calcola in codice" + snippet: '# genera REM per ciascuna data calcolata' + priorita: Dopo + + - id: P09 + pattern: Ricorrenza annuale semplice + ics: "RRULE:FREQ=YEARLY;[BYMONTH][BYMONTHDAY]" + remind_support: nativo + strategia: "REM MSG …" + snippet: 'REM Jul 29 MSG Compleanno' + priorita: Dopo + + - id: P10 + pattern: Eccezioni + ics: "EXDATE (una o più), RDATE aggiuntive" + remind_support: nativo+accorgimenti + strategia: "usa OMIT per rimuovere date; aggiungi REM singoli per RDATE" + snippet: 'REM Mon AT 09:00 FROM 2025-09-01 UNTIL 2025-10-31 MSG Standup\nOMIT 2025-10-13' + priorita: Subito + + - id: P11 + pattern: Override/cancellazioni per istanza + ics: "RECURRENCE-ID con contenuto modificato o STATUS:CANCELLED" + remind_support: espansione + strategia: "OMIT la data dalla serie; aggiungi REM singolo con i campi override" + snippet: '# serie + REM specifico per l’istanza' + priorita: Subito + + - id: P12 + pattern: DURATION al posto di DTEND + ics: "DURATION:PT…" + remind_support: nativo + strategia: "mappa su DURATION in REM" + snippet: 'REM 2025-10-05 AT 14:00 DURATION 2:30 MSG Workshop' + priorita: Subito + + - id: P13 + pattern: Allarmi + ics: "VALARM DISPLAY/AUDIO/EMAIL; TRIGGER relativo" + remind_support: parziale + strategia: "mappa 1 allarme principale su WARN; multipli opzionali come REM duplicati HIDE" + snippet: 'REM 2025-10-05 AT 09:00 WARN 15 MSG Riunione' + priorita: Dopo + + - id: P14 + pattern: Fusi orari dichiarati (VTIMEZONE, TZID diversi) + ics: "VTIMEZONE + DTSTART;TZID=…" + remind_support: nativo+accorgimenti + strategia: "normalizza tutto al fuso locale del sistema prima dell’output" + snippet: '# conversione in pre-processing' + priorita: Subito + + - id: P15 + pattern: Partecipanti/organizzatore + ics: "ORGANIZER, ATTENDEE*, PARTSTAT…" + remind_support: non previsto + strategia: "appendi a DESCRIPTION/MSG come testo" + snippet: '# nessuna semantica in Remind' + priorita: Quando serve + + - id: P16 + pattern: Allegati/URL esterni + ics: "ATTACH, URL" + remind_support: non previsto + strategia: "conserva URL in coda al MSG" + snippet: '# link nel testo' + priorita: Quando serve + + - id: P17 + pattern: Meeting online (Google/Teams metadati) + ics: "X-GOOGLE-CONFERENCE, X-MICROSOFT-*" + remind_support: non previsto + strategia: "estrai solo URL di join nel MSG" + snippet: '# riduci al link' + priorita: Quando serve + + - id: P18 + pattern: Visibilità/trasparenza + ics: "CLASS, TRANSP" + remind_support: non previsto + strategia: "ignora o aggiungi prefisso [FREE]/[BUSY] nel MSG" + snippet: '# opzionale' + priorita: Ignora + + - id: P19 + pattern: Stato/versioning + ics: "STATUS, SEQUENCE, CREATED, LAST-MODIFIED" + remind_support: non previsto + strategia: "ignora; usa solo STATUS:CANCELLED per soppressioni" + snippet: '# già coperto in P11' + priorita: Ignora + + - id: P20 + pattern: Categorie/etichette + ics: "CATEGORIES:…" + remind_support: parziale + strategia: "prefisso nel MSG o uso TAG se ti serve filtrare" + snippet: 'REM 2025-10-05 AT 09:00 TAG Work MSG [Work] Riunione' + priorita: Dopo +*) + +type event_description = + [ `All_day_event_single (* P01 *) + | `All_day_event_multi (* P02 *) + | `Timed_event (* P03 and P04 *) + | `Weekly_simple_recurrence (* P05 *) + | `Daily_simple_recurrence (* P06 *) + | `Exception_events (* P10 *) ] +[@@deriving show] + +type predicate = Icalendar.event -> bool + +let all_day_event_single ev : bool = + (* P01 *) + let _, dtstart = ev.dtstart in + match dtstart with + | `Date d -> begin + match ev.dtend_or_duration with + | None -> true + | Some (`Dtend (_, `Date end_)) -> begin + let start_dt = Ptime.of_date d |> Option.get in + let end_dt = Ptime.of_date end_ |> Option.get in + if Ptime.diff end_dt start_dt = Ptime.Span.of_int_s 86400 then true else false + end + | _ -> false + end + | _ -> begin false end + +let all_day_event_multi ev : bool = + (* P02 *) + let _, dtstart = ev.dtstart in + match dtstart with + | `Date d -> begin + match ev.dtend_or_duration with + | None -> false + | Some (`Dtend (_, `Date end_)) -> begin + let start_dt = Ptime.of_date d |> Option.get in + let end_dt = Ptime.of_date end_ |> Option.get in + if Ptime.diff end_dt start_dt > Ptime.Span.of_int_s 86400 then true else false + end + | _ -> false + end + | _ -> begin false end + +let timed_event ev : bool = + (* P03 and P04 *) + let _, dtstart = ev.dtstart in + let start_td = get_start ev in + let uid = get_uid ev in + match dtstart with + | `Datetime (`Local _) -> begin + Printf.printf "Local time event: %s\n" uid; + Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); + true + end + | `Datetime (`Utc ts) -> begin + Printf.printf "UTC time event: %s, time: %s\n" uid (Ptime.to_rfc3339 ts); + Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); + true + end + | `Datetime (`With_tzid (ts, (b, tz_name))) -> begin + Printf.printf "With TZID event: %s, TZID: (%b, %s), time: %s\n" uid b tz_name (Ptime.to_rfc3339 ts); + Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); + true + end + | `Date (y, m, d) -> begin + Printf.printf "All-day event (date): %s, date: %04d-%02d-%02d\n" uid y m d; + Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); + false + end + +let weekly_simple_recurrence ev : bool = + (* P05 *) + let rrules = ev.rrule in + match rrules with + | None -> false + | Some (_, (`Weekly, _, _, _)) -> begin + Printf.printf " Weekly simple recurrence event\n"; + true + end + | _ -> false + +let daily_simple_recurrence ev : bool = + (* P06 *) + let rrules = ev.rrule in + match rrules with + | None -> false + | Some (_, (`Daily, _, _, _)) -> begin + Printf.printf " Daily simple recurrence event\n"; + true + end + | _ -> false + +let exception_events ev : bool = + (* P10 *) + let exdates = get_exdates ev in + let rdates = get_rdates ev in + if exdates <> [] || rdates <> [] + then begin + Printf.printf " Exception event: %s\n" (get_uid ev); + true + end + else false + +let all_predicates : (predicate * event_description) list = + [ + (all_day_event_single, `All_day_event_single); + (all_day_event_multi, `All_day_event_multi); + (timed_event, `Timed_event); + (weekly_simple_recurrence, `Weekly_simple_recurrence); + (daily_simple_recurrence, `Daily_simple_recurrence); + (exception_events, `Exception_events); + ] diff --git a/bin/eventTransformer.ml b/bin/eventTransformer.ml new file mode 100644 index 0000000..9645638 --- /dev/null +++ b/bin/eventTransformer.ml @@ -0,0 +1,15 @@ +let default_implementation = Remind.Omit (Ptime.epoch |> Ptime.to_date) + +let remind_of_event (ev : Icalendar.event) : Remind.event = + let found = + ListLabels.fold_left ~init:[] EventPredicates.all_predicates ~f:(fun acc (pred, desc) -> + if pred ev then desc :: acc else acc) + |> List.rev + in + if List.length found > 0 + then begin + Printf.printf " 󰧓 ⇒ matches these predicates:\n"; + List.iter (fun d -> Printf.printf " - %s\n" (EventPredicates.show_event_description d)) found; + Printf.printf "\n" + end; + default_implementation diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000..40994a2 --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,34 @@ +let ical2rem ical_file = + let ic = open_in ical_file in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n; + close_in ic; + let cal_or_error = Icalendar.parse (Bytes.unsafe_to_string s) in + match cal_or_error with + | Error e -> prerr_endline ("Error parsing iCalendar file: " ^ e) + | Ok (_, components) -> begin + let events = ref 0 in + List.iter + (fun comp -> + match comp with + | `Event event -> + events := !events + 1; + let uid = Utils.get_uid event in + Printf.printf "󰧓 ⇒ UID: %s\n" uid; + Printf.printf "%s\n\n\n" (Icalendar.show_component comp) + | _ -> () (* Ignore non-event components *)) + components; + Printf.printf "\nEvents: %d\n" !events; + let events = + List.filter_map + (function + | `Event ev -> Some ev + | _ -> None) + components + in + let _reminders = List.map EventTransformer.remind_of_event events in + () + end + +let () = if !Sys.interactive then () else exit (CommandLine.main ical2rem) diff --git a/bin/remind.ml b/bin/remind.ml new file mode 100644 index 0000000..772d1cd --- /dev/null +++ b/bin/remind.ml @@ -0,0 +1,119 @@ +(* Alias esplicito per chiarezza *) +type date = Ptime.date + +let pp_date fmt (y, m, d) = Format.fprintf fmt "%04d-%02d-%02d" y m d + +let show_date (d : date) : string = + let y, m, day = d in + Printf.sprintf "%04d-%02d-%02d" y m day + +type tod = Ptime.Span.t (* secondi da mezzanotte locale *) + +let pp_tod = Ptime.Span.pp +let span_min (m : int) : tod = Ptime.Span.of_int_s (m * 60) +let span_hm ~(h : int) ~(m : int) : tod = Ptime.Span.of_int_s ((h * 3600) + (m * 60)) + +let hm_of_tod (t : tod) : int * int = + match Ptime.Span.to_int_s t with + | None -> invalid_arg "tod out of range" + | Some s -> (s / 3600, s mod 3600 / 60) + +type weekday = + | Mon + | Tue + | Wed + | Thu + | Fri + | Sat + | Sun + +type time_spec = + | All_day + | Timed of { + at : tod; + duration : Ptime.Span.t option; + } + +type range = { + from_ : date; + until : date option; +} +(* UNTIL inclusivo *) + +type recurrence = + | No_recur + | Daily of { + interval : int; + span : range; + } + | Weekly of { + interval : int; + days : weekday list; + span : range; + } + | Monthly_dom of { + interval : int; + day : int; + span : range; + } + | Monthly_nth_weekday of { + interval : int; + n : int; + wday : weekday; + span : range; + } + | Yearly of { + month : int; + day : int; + } + +type alarm = { warn_before : Ptime.Span.t } + +type meta = { + location : string option; + url : string option; + categories : string list; + attendees : string list; +} + +type instance_override = { + on : date; + cancel : bool; + summary : string option; + time_spec : time_spec option; + notes : string option; + alarm : alarm option; + meta : meta option; +} + +type series = { + summary : string; + start : date; (* DTSTART locale *) + time_spec : time_spec; + recur : recurrence; + exdates : date list; + overrides : instance_override list; + alarm : alarm option; + notes : string option; + meta : meta; +} + +type info_header = string [@@deriving show] +type info_value = string [@@deriving show] + +type event = + | Rem of { + date_expr : string; + at : tod option; + duration : Ptime.Span.t option; + warn : Ptime.Span.t option; + msg : string; + exdates : date list; + infos : (info_header * info_value) list; + } + | Omit of date +[@@deriving show] + +let string_of_date (d : date) : string = + let y, m, day = d in + Printf.sprintf "%04d-%02d-%02d" y m day diff --git a/bin/utils.ml b/bin/utils.ml new file mode 100644 index 0000000..85bda98 --- /dev/null +++ b/bin/utils.ml @@ -0,0 +1,70 @@ +open Icalendar + +let get_uid ev = + let _, uid = ev.uid in + uid + +let timedesc_of_date_or_datetime (t : date_or_datetime) : Timedesc.t = + match t with + | `Datetime (`Local _ptime_ts) -> + (* TODO: this case is not present in my current dataset… *) + failwith "Unhandled case: `Local datetime" + | `Datetime (`Utc ts) -> + Timedesc.Utils.timestamp_of_ptime ts |> Timedesc.of_timestamp_exn ~tz_of_date_time:(Timedesc.Time_zone.local_exn ()) + | `Datetime (`With_tzid (ts, (_b, tz_name))) -> + (* Qui il timestamp è SCRITTO come se fosse UTC (+00:00) ma in realtà va interpretato con + il fuso orario indicato da tz_name. *) + let tz = Timedesc.Time_zone.make_exn tz_name 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 + Timedesc.make_exn ~year ~month ~day ~hour ~minute ~second ~tz () + | `Date (year, month, day) -> + Timedesc.make_exn ~year ~month ~day ~hour:0 ~minute:0 ~second:0 ~tz:(Timedesc.Time_zone.local_exn ()) () + +let get_start ev = + let _, start = ev.dtstart in + timedesc_of_date_or_datetime start + +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 + ListLabels.fold_left ~init:[] dates_or_datetimes ~f:(fun acc dates -> + let added = + match dates with + | `Datetimes ts_list -> List.map (fun ts -> `Datetime ts) ts_list + | `Dates date_list -> List.map (fun date -> `Date date) date_list + in + added @ acc) + |> List.map timedesc_of_date_or_datetime + +let get_rdates ev = + let event_props = ev.props in + let dates_or_datetimes = + List.filter_map + (fun prop -> + match prop with + | `Rdate (_, dates) -> Some dates + | _ -> None) + event_props + in + ListLabels.fold_left ~init:[] dates_or_datetimes ~f:(fun acc dates -> + let added = + match dates with + | `Datetimes ts_list -> List.map (fun ts -> `Datetime ts) ts_list + | `Dates date_list -> List.map (fun date -> `Date date) date_list + | `Periods _ -> + (* TODO: Ignored for now, does not appear in my current dataset *) + failwith "Unhandled case: `Periods in RDATE" + in + added @ acc) + |> List.map timedesc_of_date_or_datetime diff --git a/dune b/dune new file mode 100644 index 0000000..f8837a3 --- /dev/null +++ b/dune @@ -0,0 +1 @@ +(data_only_dirs contrib) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..3f269bb --- /dev/null +++ b/dune-project @@ -0,0 +1,24 @@ +(lang dune 3.20) + +(name remind_sync) + +(generate_opam_files true) + +(source + (uri https://git.donadeo.net/pdonadeo/remind-sync)) + +(authors "Paolo Donadeo ") + +(maintainers "Maintainer Name ") + +(license MIT) + +(documentation https://git.donadeo.net/pdonadeo/remind-sync) + +(package + (name remind_sync) + (synopsis "A short synopsis") + (description "A longer description") + (depends ocaml) + (tags + ("add topics" "to describe" your project))) diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..53fe938 --- /dev/null +++ b/lib/dune @@ -0,0 +1,2 @@ +(library + (name remind_sync)) diff --git a/remind_sync.opam b/remind_sync.opam new file mode 100644 index 0000000..a3dc098 --- /dev/null +++ b/remind_sync.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "A short synopsis" +description: "A longer description" +maintainer: ["Maintainer Name "] +authors: ["Paolo Donadeo "] +license: "MIT" +tags: ["add topics" "to describe" "your" "project"] +doc: "https://git.donadeo.net/pdonadeo/remind-sync" +depends: [ + "dune" {>= "3.20"} + "ocaml" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "https://git.donadeo.net/pdonadeo/remind-sync" +x-maintenance-intent: ["(latest)"]