1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
type name = { family : string; given : string; additional : string; prefix : string; suffix : string }
type phone = { number : string; kinds : string list }
type email = { address : string; kinds : string list }
type address = {
street : string;
locality : string;
region : string;
code : string;
country : string;
kinds : string list;
}
type card = {
uid : string;
name : name;
full_name : string;
org : string;
title : string;
phones : phone list;
emails : email list;
addresses : address list;
birthday : Civil.date option;
note : string;
}
let no_name = { family = ""; given = ""; additional = ""; prefix = ""; suffix = "" }
let make (full_name : string) : card =
{ uid = ""; name = no_name; full_name; org = ""; title = ""; phones = []; emails = []; addresses = [];
birthday = None; note = "" }
let structured (v : string) : string list =
let n = String.length v in
let rec go i start acc =
if i >= n then List.rev (String.sub v start (n - start) :: acc)
else if v.[i] = '\\' then go (i + 2) start acc
else if v.[i] = ';' then go (i + 1) (i + 1) (String.sub v start (i - start) :: acc)
else go (i + 1) start acc
in
go 0 0 [] |> List.map (fun s -> String.trim (Ics.unescape s))
let part (parts : string list) (i : int) : string = Option.value ~default:"" (List.nth_opt parts i)
let kinds (params : (string * string) list) : string list =
List.concat_map
(fun (p, v) -> if p = "TYPE" then String.split_on_char ',' v |> List.map String.lowercase_ascii else [])
params
let birthday (v : string) : Civil.date option =
let v = match String.index_opt v 'T' with Some i -> String.sub v 0 i | None -> v in
let digits = String.concat "" (String.split_on_char '-' v) in
if String.length digits <> 8 then None
else
match
(int_of_string_opt (String.sub digits 0 4), int_of_string_opt (String.sub digits 4 2),
int_of_string_opt (String.sub digits 6 2))
with
| Some year, Some month, Some day ->
let d : Civil.date = { year; month; day } in
if Civil.is_valid d then Some d else None
| _ -> None
let property (c : card) ((name, params, v) : string * (string * string) list * string) : card =
match name with
| "UID" -> { c with uid = Ics.unescape v }
| "FN" -> { c with full_name = Ics.unescape v }
| "N" ->
let p = structured v in
{ c with name = { family = part p 0; given = part p 1; additional = part p 2; prefix = part p 3; suffix = part p 4 } }
| "ORG" -> { c with org = String.concat ", " (List.filter (fun s -> s <> "") (structured v)) }
| "TITLE" -> { c with title = Ics.unescape v }
| "TEL" -> { c with phones = c.phones @ [ { number = Ics.unescape v; kinds = kinds params } ] }
| "EMAIL" -> { c with emails = c.emails @ [ { address = Ics.unescape v; kinds = kinds params } ] }
| "ADR" ->
let p = structured v in
{ c with
addresses =
c.addresses
@ [ { street = part p 2; locality = part p 3; region = part p 4; code = part p 5; country = part p 6;
kinds = kinds params } ] }
| "BDAY" -> { c with birthday = birthday v }
| "NOTE" -> { c with note = Ics.unescape v }
| _ -> c
let of_string (s : string) : card list =
let lines = Ics.unfold s |> List.filter_map Ics.content_line in
let is name want v = name = want && String.uppercase_ascii v = "VCARD" in
List.fold_left
(fun (cards, inside) ((name, _, v) as p) ->
match inside with
| None -> if is name "BEGIN" v then (cards, Some (make "")) else (cards, None)
| Some c -> if is name "END" v then (c :: cards, None) else (cards, Some (property c p)))
([], None) lines
|> fst |> List.rev
let to_string (cards : card list) : string =
let line name value = [ name ^ ":" ^ value ] in
let text name s = if s = "" then [] else line name (Ics.escape s) in
let typed name (ks : string list) value =
line (if ks = [] then name else name ^ ";TYPE=" ^ String.concat "," ks) value
in
let parts l = String.concat ";" (List.map Ics.escape l) in
let card (c : card) =
List.concat
[ line "BEGIN" "VCARD"; line "VERSION" "3.0"; text "UID" c.uid;
line "N" (parts [ c.name.family; c.name.given; c.name.additional; c.name.prefix; c.name.suffix ]);
line "FN" (Ics.escape (if c.full_name = "" then String.trim (c.name.given ^ " " ^ c.name.family) else c.full_name));
text "ORG" c.org; text "TITLE" c.title;
List.concat_map (fun (p : phone) -> typed "TEL" p.kinds (Ics.escape p.number)) c.phones;
List.concat_map (fun (e : email) -> typed "EMAIL" e.kinds (Ics.escape e.address)) c.emails;
List.concat_map
(fun (a : address) -> typed "ADR" a.kinds (parts [ ""; ""; a.street; a.locality; a.region; a.code; a.country ]))
c.addresses;
(match c.birthday with Some d -> line "BDAY" (Civil.to_string d) | None -> []);
text "NOTE" c.note; line "END" "VCARD" ]
in
List.concat_map card cards |> List.map Ics.fold |> List.map (fun l -> l ^ "\r\n") |> String.concat ""
let display_name (c : card) : string =
if c.full_name <> "" then c.full_name else String.trim (c.name.given ^ " " ^ c.name.family)
let compare_by_name (a : card) (b : card) : int =
let key (c : card) =
String.lowercase_ascii (if c.name.family <> "" then c.name.family ^ "\000" ^ c.name.given else display_name c)
in
compare (key a) (key b)