jon.recoil.org
forked from
anil.recoil.org/ocaml-jmap
this repo has no description
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6type t = {
7 name : string;
8 value : string;
9}
10
11let create ~name ~value = { name; value }
12
13let name t = t.name
14let value t = t.value
15
16let make name value = { name; value }
17
18let jsont =
19 let kind = "EmailHeader" in
20 Jsont.Object.map ~kind make
21 |> Jsont.Object.mem "name" Jsont.string ~enc:name
22 |> Jsont.Object.mem "value" Jsont.string ~enc:value
23 |> Jsont.Object.finish
24
25(* Header categories *)
26
27type address_header = [
28 | `From
29 | `Sender
30 | `Reply_to
31 | `To
32 | `Cc
33 | `Bcc
34 | `Resent_from
35 | `Resent_sender
36 | `Resent_reply_to
37 | `Resent_to
38 | `Resent_cc
39 | `Resent_bcc
40]
41
42type message_id_header = [
43 | `Message_id
44 | `In_reply_to
45 | `References
46 | `Resent_message_id
47]
48
49type date_header = [
50 | `Date
51 | `Resent_date
52]
53
54type url_header = [
55 | `List_help
56 | `List_unsubscribe
57 | `List_subscribe
58 | `List_post
59 | `List_owner
60 | `List_archive
61]
62
63type text_header = [
64 | `Subject
65 | `Comments
66 | `Keywords
67 | `List_id
68]
69
70type standard_header = [
71 | address_header
72 | message_id_header
73 | date_header
74 | url_header
75 | text_header
76]
77
78type custom_header = [ `Custom of string ]
79
80type any_header = [ standard_header | custom_header ]
81
82let standard_header_to_string : [< standard_header ] -> string = function
83 | `From -> "From"
84 | `Sender -> "Sender"
85 | `Reply_to -> "Reply-To"
86 | `To -> "To"
87 | `Cc -> "Cc"
88 | `Bcc -> "Bcc"
89 | `Resent_from -> "Resent-From"
90 | `Resent_sender -> "Resent-Sender"
91 | `Resent_reply_to -> "Resent-Reply-To"
92 | `Resent_to -> "Resent-To"
93 | `Resent_cc -> "Resent-Cc"
94 | `Resent_bcc -> "Resent-Bcc"
95 | `Message_id -> "Message-ID"
96 | `In_reply_to -> "In-Reply-To"
97 | `References -> "References"
98 | `Resent_message_id -> "Resent-Message-ID"
99 | `Date -> "Date"
100 | `Resent_date -> "Resent-Date"
101 | `List_help -> "List-Help"
102 | `List_unsubscribe -> "List-Unsubscribe"
103 | `List_subscribe -> "List-Subscribe"
104 | `List_post -> "List-Post"
105 | `List_owner -> "List-Owner"
106 | `List_archive -> "List-Archive"
107 | `Subject -> "Subject"
108 | `Comments -> "Comments"
109 | `Keywords -> "Keywords"
110 | `List_id -> "List-Id"
111
112let standard_header_of_string s : standard_header option =
113 match String.lowercase_ascii s with
114 | "from" -> Some `From
115 | "sender" -> Some `Sender
116 | "reply-to" -> Some `Reply_to
117 | "to" -> Some `To
118 | "cc" -> Some `Cc
119 | "bcc" -> Some `Bcc
120 | "resent-from" -> Some `Resent_from
121 | "resent-sender" -> Some `Resent_sender
122 | "resent-reply-to" -> Some `Resent_reply_to
123 | "resent-to" -> Some `Resent_to
124 | "resent-cc" -> Some `Resent_cc
125 | "resent-bcc" -> Some `Resent_bcc
126 | "message-id" -> Some `Message_id
127 | "in-reply-to" -> Some `In_reply_to
128 | "references" -> Some `References
129 | "resent-message-id" -> Some `Resent_message_id
130 | "date" -> Some `Date
131 | "resent-date" -> Some `Resent_date
132 | "list-help" -> Some `List_help
133 | "list-unsubscribe" -> Some `List_unsubscribe
134 | "list-subscribe" -> Some `List_subscribe
135 | "list-post" -> Some `List_post
136 | "list-owner" -> Some `List_owner
137 | "list-archive" -> Some `List_archive
138 | "subject" -> Some `Subject
139 | "comments" -> Some `Comments
140 | "keywords" -> Some `Keywords
141 | "list-id" -> Some `List_id
142 | _ -> None
143
144let any_header_to_string : [< any_header ] -> string = function
145 | `Custom s -> s
146 | #standard_header as h -> standard_header_to_string h
147
148(* Header parsed forms *)
149
150type form = [
151 | `Raw
152 | `Text
153 | `Addresses
154 | `Grouped_addresses
155 | `Message_ids
156 | `Date
157 | `Urls
158]
159
160let form_to_string : [< form ] -> string = function
161 | `Raw -> ""
162 | `Text -> "asText"
163 | `Addresses -> "asAddresses"
164 | `Grouped_addresses -> "asGroupedAddresses"
165 | `Message_ids -> "asMessageIds"
166 | `Date -> "asDate"
167 | `Urls -> "asURLs"
168
169let form_of_string s : form option =
170 match s with
171 | "" -> Some `Raw
172 | "asText" -> Some `Text
173 | "asAddresses" -> Some `Addresses
174 | "asGroupedAddresses" -> Some `Grouped_addresses
175 | "asMessageIds" -> Some `Message_ids
176 | "asDate" -> Some `Date
177 | "asURLs" -> Some `Urls
178 | _ -> None
179
180(* Header property requests *)
181
182type header_property =
183 | Raw of { name : string; all : bool }
184 | Text of { header : [ text_header | custom_header ]; all : bool }
185 | Addresses of { header : [ address_header | custom_header ]; all : bool }
186 | Grouped_addresses of { header : [ address_header | custom_header ]; all : bool }
187 | Message_ids of { header : [ message_id_header | custom_header ]; all : bool }
188 | Date of { header : [ date_header | custom_header ]; all : bool }
189 | Urls of { header : [ url_header | custom_header ]; all : bool }
190
191let header_name_of_property : header_property -> string = function
192 | Raw { name; _ } -> name
193 | Text { header; _ } -> any_header_to_string (header :> any_header)
194 | Addresses { header; _ } -> any_header_to_string (header :> any_header)
195 | Grouped_addresses { header; _ } -> any_header_to_string (header :> any_header)
196 | Message_ids { header; _ } -> any_header_to_string (header :> any_header)
197 | Date { header; _ } -> any_header_to_string (header :> any_header)
198 | Urls { header; _ } -> any_header_to_string (header :> any_header)
199
200let header_property_all : header_property -> bool = function
201 | Raw { all; _ } -> all
202 | Text { all; _ } -> all
203 | Addresses { all; _ } -> all
204 | Grouped_addresses { all; _ } -> all
205 | Message_ids { all; _ } -> all
206 | Date { all; _ } -> all
207 | Urls { all; _ } -> all
208
209let header_property_form : header_property -> form = function
210 | Raw _ -> `Raw
211 | Text _ -> `Text
212 | Addresses _ -> `Addresses
213 | Grouped_addresses _ -> `Grouped_addresses
214 | Message_ids _ -> `Message_ids
215 | Date _ -> `Date
216 | Urls _ -> `Urls
217
218let header_property_to_string prop =
219 let name = header_name_of_property prop in
220 let form = form_to_string (header_property_form prop) in
221 let all_suffix = if header_property_all prop then ":all" else "" in
222 let form_suffix = if form = "" then "" else ":" ^ form in
223 "header:" ^ name ^ form_suffix ^ all_suffix
224
225let header_property_of_string s : header_property option =
226 if not (String.length s > 7 && String.sub s 0 7 = "header:") then
227 None
228 else
229 let rest = String.sub s 7 (String.length s - 7) in
230 (* Parse the parts: name[:form][:all] *)
231 let parts = String.split_on_char ':' rest in
232 match parts with
233 | [] -> None
234 | [name] ->
235 Some (Raw { name; all = false })
236 | [name; second] ->
237 if second = "all" then
238 Some (Raw { name; all = true })
239 else begin
240 match form_of_string second with
241 | None -> None
242 | Some `Raw -> Some (Raw { name; all = false })
243 | Some `Text -> Some (Text { header = `Custom name; all = false })
244 | Some `Addresses -> Some (Addresses { header = `Custom name; all = false })
245 | Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = false })
246 | Some `Message_ids -> Some (Message_ids { header = `Custom name; all = false })
247 | Some `Date -> Some (Date { header = `Custom name; all = false })
248 | Some `Urls -> Some (Urls { header = `Custom name; all = false })
249 end
250 | [name; form_str; "all"] ->
251 begin match form_of_string form_str with
252 | None -> None
253 | Some `Raw -> Some (Raw { name; all = true })
254 | Some `Text -> Some (Text { header = `Custom name; all = true })
255 | Some `Addresses -> Some (Addresses { header = `Custom name; all = true })
256 | Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = true })
257 | Some `Message_ids -> Some (Message_ids { header = `Custom name; all = true })
258 | Some `Date -> Some (Date { header = `Custom name; all = true })
259 | Some `Urls -> Some (Urls { header = `Custom name; all = true })
260 end
261 | _ -> None
262
263(* Convenience constructors *)
264
265let raw ?(all=false) name = Raw { name; all }
266
267let text ?(all=false) header = Text { header; all }
268
269let addresses ?(all=false) header = Addresses { header; all }
270
271let grouped_addresses ?(all=false) header = Grouped_addresses { header; all }
272
273let message_ids ?(all=false) header = Message_ids { header; all }
274
275let date ?(all=false) header = Date { header; all }
276
277let urls ?(all=false) header = Urls { header; all }
278
279(* Header values in responses *)
280
281type header_value =
282 | String_single of string option
283 | String_all of string list
284 | Addresses_single of Mail_address.t list option
285 | Addresses_all of Mail_address.t list list
286 | Grouped_single of Mail_address.Group.t list option
287 | Grouped_all of Mail_address.Group.t list list
288 | Date_single of Ptime.t option
289 | Date_all of Ptime.t option list
290 | Strings_single of string list option
291 | Strings_all of string list option list
292
293let header_value_jsont ~form ~all : header_value Jsont.t =
294 match form, all with
295 | (`Raw | `Text), false ->
296 Jsont.map
297 ~dec:(fun s -> String_single s)
298 ~enc:(function String_single s -> s | _ -> None)
299 (Jsont.option Jsont.string)
300 | (`Raw | `Text), true ->
301 Jsont.map
302 ~dec:(fun l -> String_all l)
303 ~enc:(function String_all l -> l | _ -> [])
304 (Jsont.list Jsont.string)
305 | `Addresses, false ->
306 Jsont.map
307 ~dec:(fun l -> Addresses_single l)
308 ~enc:(function Addresses_single l -> l | _ -> None)
309 (Jsont.option (Jsont.list Mail_address.jsont))
310 | `Addresses, true ->
311 Jsont.map
312 ~dec:(fun l -> Addresses_all l)
313 ~enc:(function Addresses_all l -> l | _ -> [])
314 (Jsont.list (Jsont.list Mail_address.jsont))
315 | `Grouped_addresses, false ->
316 Jsont.map
317 ~dec:(fun l -> Grouped_single l)
318 ~enc:(function Grouped_single l -> l | _ -> None)
319 (Jsont.option (Jsont.list Mail_address.Group.jsont))
320 | `Grouped_addresses, true ->
321 Jsont.map
322 ~dec:(fun l -> Grouped_all l)
323 ~enc:(function Grouped_all l -> l | _ -> [])
324 (Jsont.list (Jsont.list Mail_address.Group.jsont))
325 | `Message_ids, false ->
326 Jsont.map
327 ~dec:(fun l -> Strings_single l)
328 ~enc:(function Strings_single l -> l | _ -> None)
329 (Jsont.option (Jsont.list Jsont.string))
330 | `Message_ids, true ->
331 Jsont.map
332 ~dec:(fun l -> Strings_all l)
333 ~enc:(function Strings_all l -> l | _ -> [])
334 (Jsont.list (Jsont.option (Jsont.list Jsont.string)))
335 | `Date, false ->
336 Jsont.map
337 ~dec:(fun t -> Date_single t)
338 ~enc:(function Date_single t -> t | _ -> None)
339 (Jsont.option Proto_date.Rfc3339.jsont)
340 | `Date, true ->
341 Jsont.map
342 ~dec:(fun l -> Date_all l)
343 ~enc:(function Date_all l -> l | _ -> [])
344 (Jsont.list (Jsont.option Proto_date.Rfc3339.jsont))
345 | `Urls, false ->
346 Jsont.map
347 ~dec:(fun l -> Strings_single l)
348 ~enc:(function Strings_single l -> l | _ -> None)
349 (Jsont.option (Jsont.list Jsont.string))
350 | `Urls, true ->
351 Jsont.map
352 ~dec:(fun l -> Strings_all l)
353 ~enc:(function Strings_all l -> l | _ -> [])
354 (Jsont.list (Jsont.option (Jsont.list Jsont.string)))
355
356(* Low-level JSON codecs *)
357
358let raw_jsont = Jsont.string
359
360let text_jsont = Jsont.string
361
362let addresses_jsont = Jsont.list Mail_address.jsont
363
364let grouped_addresses_jsont = Jsont.list Mail_address.Group.jsont
365
366let message_ids_jsont = Jsont.list Jsont.string
367
368let date_jsont = Proto_date.Rfc3339.jsont
369
370let urls_jsont = Jsont.list Jsont.string