Initial commit
This commit is contained in:
316
lib/icalendar_augmented.ml
Normal file
316
lib/icalendar_augmented.ml
Normal file
@@ -0,0 +1,316 @@
|
||||
module Params = struct
|
||||
include Icalendar.Params
|
||||
|
||||
let pp ppf _m = Format.pp_print_string ppf "<params>"
|
||||
end
|
||||
|
||||
type params = Params.t [@@deriving show]
|
||||
|
||||
module Ptime = struct
|
||||
include Ptime_augmented
|
||||
end
|
||||
|
||||
(* TODO: tag these with `Utc | `Local *)
|
||||
type timestamp_utc = Ptime.t [@@deriving show]
|
||||
type timestamp_local = Ptime.t [@@deriving show]
|
||||
type utc_or_timestamp_local = [ `Utc of timestamp_utc | `Local of timestamp_local ] [@@deriving show]
|
||||
type timestamp = [ utc_or_timestamp_local | `With_tzid of timestamp_local * (bool * string) ] [@@deriving show]
|
||||
type date_or_datetime = [ `Datetime of timestamp | `Date of Ptime.date ] [@@deriving show]
|
||||
type weekday = [ `Friday | `Monday | `Saturday | `Sunday | `Thursday | `Tuesday | `Wednesday ] [@@deriving 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 show]
|
||||
|
||||
type freq = [ `Daily | `Hourly | `Minutely | `Monthly | `Secondly | `Weekly | `Yearly ] [@@deriving show]
|
||||
type count_or_until = [ `Count of int | `Until of utc_or_timestamp_local (* TODO date or datetime *) ] [@@deriving show]
|
||||
type interval = int [@@deriving show]
|
||||
type recurrence = freq * count_or_until option * interval option * recur list [@@deriving 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 ]
|
||||
[@@deriving show]
|
||||
|
||||
type partstat =
|
||||
[ `Accepted
|
||||
| `Completed
|
||||
| `Declined
|
||||
| `Delegated
|
||||
| `In_process
|
||||
| `Needs_action
|
||||
| `Tentative
|
||||
| `Ianatoken of string
|
||||
| `Xname of string * string ]
|
||||
[@@deriving show]
|
||||
|
||||
type role =
|
||||
[ `Chair | `Nonparticipant | `Optparticipant | `Reqparticipant | `Ianatoken of string | `Xname of string * string ]
|
||||
[@@deriving show]
|
||||
|
||||
type relationship = [ `Parent | `Child | `Sibling | `Ianatoken of string | `Xname of string * string ] [@@deriving show]
|
||||
|
||||
type fbtype = [ `Free | `Busy | `Busy_Unavailable | `Busy_Tentative | `Ianatoken of string | `Xname of string * string ]
|
||||
[@@deriving show]
|
||||
|
||||
type param_value = [ `Quoted of string | `String of string ] [@@deriving 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
|
||||
[@@deriving show]
|
||||
|
||||
type other_prop = [ `Iana_prop of string * params * string | `Xprop of (string * string) * params * string ]
|
||||
[@@deriving show]
|
||||
|
||||
type cal_prop =
|
||||
[ `Prodid of params * string
|
||||
| `Version of params * string
|
||||
| `Calscale of params * string
|
||||
| `Method of params * string
|
||||
| other_prop ]
|
||||
[@@deriving show]
|
||||
|
||||
type class_ = [ `Public | `Private | `Confidential | `Ianatoken of string | `Xname of string * string ]
|
||||
[@@deriving show]
|
||||
|
||||
type status =
|
||||
[ `Draft
|
||||
| `Final
|
||||
| `Cancelled
|
||||
| `Needs_action
|
||||
| `Completed
|
||||
| `In_process
|
||||
| (* `Cancelled *)
|
||||
`Tentative
|
||||
| `Confirmed (* | `Cancelled *) ]
|
||||
[@@deriving show]
|
||||
|
||||
type period = timestamp * Ptime.Span.t * bool [@@deriving show]
|
||||
type period_utc = timestamp_utc * Ptime.Span.t * bool [@@deriving show]
|
||||
type dates_or_datetimes = [ `Datetimes of timestamp list | `Dates of Ptime.date list ] [@@deriving show]
|
||||
type dates_or_datetimes_or_periods = [ dates_or_datetimes | `Periods of period list ] [@@deriving 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
|
||||
| (* 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 ]
|
||||
[@@deriving show]
|
||||
|
||||
type event_prop =
|
||||
[ general_prop
|
||||
| `Transparency of params * [ `Transparent | `Opaque ]
|
||||
| `Dtend of params * date_or_datetime
|
||||
| (* TODO: valuetype same as DTSTART *)
|
||||
other_prop ]
|
||||
[@@deriving 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 show]
|
||||
|
||||
type audio_struct = { attach : (params * [ `Uri of Uri.t | `Binary of string ]) option } [@@deriving show]
|
||||
type display_struct = { description : (params * string) option } [@@deriving show]
|
||||
|
||||
type email_struct = {
|
||||
description : params * string;
|
||||
attendees : (params * Uri.t) list;
|
||||
attach : (params * [ `Uri of Uri.t | `Binary of string ]) option;
|
||||
}
|
||||
[@@deriving 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 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 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 show]
|
||||
|
||||
type todo_prop =
|
||||
[ general_prop
|
||||
| `Completed of params * timestamp_utc
|
||||
| `Percent of params * int
|
||||
| `Due of params * date_or_datetime
|
||||
| other_prop ]
|
||||
[@@deriving show]
|
||||
|
||||
type journal_prop = [ general_prop | other_prop ] [@@deriving 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 show]
|
||||
|
||||
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;
|
||||
}
|
||||
[@@deriving show]
|
||||
|
||||
type timezone = timezone_prop list [@@deriving show]
|
||||
|
||||
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]
|
||||
|
||||
let conv_alarm_struct (f : 'a -> 'b) (s : 'a Icalendar.alarm_struct) : 'b alarm_struct =
|
||||
{
|
||||
trigger = s.trigger;
|
||||
duration_repeat = s.duration_repeat;
|
||||
summary = s.summary;
|
||||
other = s.other;
|
||||
special = f s.special;
|
||||
}
|
||||
|
||||
let conv_audio_struct (s : Icalendar.audio_struct) : audio_struct = { attach = s.attach }
|
||||
let conv_display_struct (s : Icalendar.display_struct) : display_struct = { description = s.description }
|
||||
|
||||
let conv_email_struct (s : Icalendar.email_struct) : email_struct =
|
||||
{ description = s.description; attendees = s.attendees; attach = s.attach }
|
||||
|
||||
let conv_alarm (a : Icalendar.alarm) : alarm =
|
||||
match a with
|
||||
| `Audio s -> `Audio (conv_alarm_struct conv_audio_struct s)
|
||||
| `Display s -> `Display (conv_alarm_struct conv_display_struct s)
|
||||
| `Email s -> `Email (conv_alarm_struct conv_email_struct s)
|
||||
| `None s -> `None (conv_alarm_struct Fun.id s)
|
||||
|
||||
let conv_event (e : Icalendar.event) : event =
|
||||
{
|
||||
dtstamp = e.dtstamp;
|
||||
uid = e.uid;
|
||||
dtstart = e.dtstart;
|
||||
dtend_or_duration = e.dtend_or_duration;
|
||||
rrule = e.rrule;
|
||||
props = e.props;
|
||||
alarms = List.map conv_alarm e.alarms;
|
||||
}
|
||||
|
||||
let conv_component (c : Icalendar.component) : component =
|
||||
match c with
|
||||
| `Event e -> `Event (conv_event e)
|
||||
| `Todo (props, alms) -> `Todo (props, List.map conv_alarm alms)
|
||||
| `Journal props -> `Journal props
|
||||
| `Freebusy props -> `Freebusy props
|
||||
| `Timezone tz -> `Timezone tz
|
||||
|
||||
let parse s =
|
||||
Result.map (fun (cal_props, components) -> (cal_props, List.map conv_component components)) (Icalendar.parse s)
|
||||
Reference in New Issue
Block a user