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
6module Keyword = struct
7 (* RFC 8621 Standard Keywords *)
8 let draft = "$draft"
9 let seen = "$seen"
10 let flagged = "$flagged"
11 let answered = "$answered"
12 let forwarded = "$forwarded"
13 let phishing = "$phishing"
14 let junk = "$junk"
15 let not_junk = "$notjunk"
16
17 (* draft-ietf-mailmaint Extended Keywords *)
18 let notify = "$notify"
19 let muted = "$muted"
20 let followed = "$followed"
21 let memo = "$memo"
22 let has_memo = "$hasmemo"
23 let has_attachment = "$hasattachment"
24 let has_no_attachment = "$hasnoattachment"
25 let auto_sent = "$autosent"
26 let unsubscribed = "$unsubscribed"
27 let can_unsubscribe = "$canunsubscribe"
28 let imported = "$imported"
29 let is_trusted = "$istrusted"
30 let masked_email = "$maskedemail"
31 let new_ = "$new"
32
33 (* Apple Mail Flag Color Keywords *)
34 let mail_flag_bit0 = "$MailFlagBit0"
35 let mail_flag_bit1 = "$MailFlagBit1"
36 let mail_flag_bit2 = "$MailFlagBit2"
37
38 type flag_color = [
39 | `Red
40 | `Orange
41 | `Yellow
42 | `Green
43 | `Blue
44 | `Purple
45 | `Gray
46 ]
47
48 let flag_color_to_keywords = function
49 | `Red -> []
50 | `Orange -> [mail_flag_bit0]
51 | `Yellow -> [mail_flag_bit1]
52 | `Green -> [mail_flag_bit0; mail_flag_bit1; mail_flag_bit2]
53 | `Blue -> [mail_flag_bit2]
54 | `Purple -> [mail_flag_bit0; mail_flag_bit2]
55 | `Gray -> [mail_flag_bit1; mail_flag_bit2]
56
57 let flag_color_of_keywords keywords =
58 let has k = List.mem k keywords in
59 let bit0 = has mail_flag_bit0 in
60 let bit1 = has mail_flag_bit1 in
61 let bit2 = has mail_flag_bit2 in
62 match (bit0, bit1, bit2) with
63 | (false, false, false) -> Some `Red
64 | (true, false, false) -> Some `Orange
65 | (false, true, false) -> Some `Yellow
66 | (true, true, true) -> Some `Green
67 | (false, false, true) -> Some `Blue
68 | (true, false, true) -> Some `Purple
69 | (false, true, true) -> Some `Gray
70 | (true, true, false) -> None
71end
72
73(* Email property types *)
74
75type metadata_property = [
76 | `Id
77 | `Blob_id
78 | `Thread_id
79 | `Mailbox_ids
80 | `Keywords
81 | `Size
82 | `Received_at
83]
84
85type header_convenience_property = [
86 | `Message_id
87 | `In_reply_to
88 | `References
89 | `Sender
90 | `From
91 | `To
92 | `Cc
93 | `Bcc
94 | `Reply_to
95 | `Subject
96 | `Sent_at
97 | `Headers
98]
99
100type body_property = [
101 | `Body_structure
102 | `Body_values
103 | `Text_body
104 | `Html_body
105 | `Attachments
106 | `Has_attachment
107 | `Preview
108]
109
110type standard_property = [
111 | metadata_property
112 | header_convenience_property
113 | body_property
114]
115
116type header_property = [ `Header of Mail_header.header_property ]
117
118type property = [ standard_property | header_property ]
119
120let standard_property_to_string : [< standard_property ] -> string = function
121 | `Id -> "id"
122 | `Blob_id -> "blobId"
123 | `Thread_id -> "threadId"
124 | `Mailbox_ids -> "mailboxIds"
125 | `Keywords -> "keywords"
126 | `Size -> "size"
127 | `Received_at -> "receivedAt"
128 | `Message_id -> "messageId"
129 | `In_reply_to -> "inReplyTo"
130 | `References -> "references"
131 | `Sender -> "sender"
132 | `From -> "from"
133 | `To -> "to"
134 | `Cc -> "cc"
135 | `Bcc -> "bcc"
136 | `Reply_to -> "replyTo"
137 | `Subject -> "subject"
138 | `Sent_at -> "sentAt"
139 | `Headers -> "headers"
140 | `Body_structure -> "bodyStructure"
141 | `Body_values -> "bodyValues"
142 | `Text_body -> "textBody"
143 | `Html_body -> "htmlBody"
144 | `Attachments -> "attachments"
145 | `Has_attachment -> "hasAttachment"
146 | `Preview -> "preview"
147
148let property_to_string : [< property ] -> string = function
149 | `Header hp -> Mail_header.header_property_to_string hp
150 | #standard_property as p -> standard_property_to_string p
151
152let standard_property_of_string s : standard_property option =
153 match s with
154 | "id" -> Some `Id
155 | "blobId" -> Some `Blob_id
156 | "threadId" -> Some `Thread_id
157 | "mailboxIds" -> Some `Mailbox_ids
158 | "keywords" -> Some `Keywords
159 | "size" -> Some `Size
160 | "receivedAt" -> Some `Received_at
161 | "messageId" -> Some `Message_id
162 | "inReplyTo" -> Some `In_reply_to
163 | "references" -> Some `References
164 | "sender" -> Some `Sender
165 | "from" -> Some `From
166 | "to" -> Some `To
167 | "cc" -> Some `Cc
168 | "bcc" -> Some `Bcc
169 | "replyTo" -> Some `Reply_to
170 | "subject" -> Some `Subject
171 | "sentAt" -> Some `Sent_at
172 | "headers" -> Some `Headers
173 | "bodyStructure" -> Some `Body_structure
174 | "bodyValues" -> Some `Body_values
175 | "textBody" -> Some `Text_body
176 | "htmlBody" -> Some `Html_body
177 | "attachments" -> Some `Attachments
178 | "hasAttachment" -> Some `Has_attachment
179 | "preview" -> Some `Preview
180 | _ -> None
181
182let property_of_string s : property option =
183 match standard_property_of_string s with
184 | Some p -> Some (p :> property)
185 | None ->
186 match Mail_header.header_property_of_string s with
187 | Some hp -> Some (`Header hp)
188 | None -> None
189
190(* Body part properties *)
191
192type body_part_property = [
193 | `Part_id
194 | `Blob_id
195 | `Size
196 | `Part_headers
197 | `Name
198 | `Type
199 | `Charset
200 | `Disposition
201 | `Cid
202 | `Language
203 | `Location
204 | `Sub_parts
205]
206
207let body_part_property_to_string : [< body_part_property ] -> string = function
208 | `Part_id -> "partId"
209 | `Blob_id -> "blobId"
210 | `Size -> "size"
211 | `Part_headers -> "headers"
212 | `Name -> "name"
213 | `Type -> "type"
214 | `Charset -> "charset"
215 | `Disposition -> "disposition"
216 | `Cid -> "cid"
217 | `Language -> "language"
218 | `Location -> "location"
219 | `Sub_parts -> "subParts"
220
221let body_part_property_of_string s : body_part_property option =
222 match s with
223 | "partId" -> Some `Part_id
224 | "blobId" -> Some `Blob_id
225 | "size" -> Some `Size
226 | "headers" -> Some `Part_headers
227 | "name" -> Some `Name
228 | "type" -> Some `Type
229 | "charset" -> Some `Charset
230 | "disposition" -> Some `Disposition
231 | "cid" -> Some `Cid
232 | "language" -> Some `Language
233 | "location" -> Some `Location
234 | "subParts" -> Some `Sub_parts
235 | _ -> None
236
237(* Email type with optional fields *)
238
239type t = {
240 id : Proto_id.t option;
241 blob_id : Proto_id.t option;
242 thread_id : Proto_id.t option;
243 size : int64 option;
244 received_at : Ptime.t option;
245 mailbox_ids : (Proto_id.t * bool) list option;
246 keywords : (string * bool) list option;
247 message_id : string list option;
248 in_reply_to : string list option;
249 references : string list option;
250 sender : Mail_address.t list option;
251 from : Mail_address.t list option;
252 to_ : Mail_address.t list option;
253 cc : Mail_address.t list option;
254 bcc : Mail_address.t list option;
255 reply_to : Mail_address.t list option;
256 subject : string option;
257 sent_at : Ptime.t option;
258 headers : Mail_header.t list option;
259 body_structure : Mail_body.Part.t option;
260 body_values : (string * Mail_body.Value.t) list option;
261 text_body : Mail_body.Part.t list option;
262 html_body : Mail_body.Part.t list option;
263 attachments : Mail_body.Part.t list option;
264 has_attachment : bool option;
265 preview : string option;
266 dynamic_headers : (string * Jsont.json) list;
267}
268
269let id t = t.id
270let blob_id t = t.blob_id
271let thread_id t = t.thread_id
272let size t = t.size
273let received_at t = t.received_at
274let mailbox_ids t = t.mailbox_ids
275let keywords t = t.keywords
276let message_id t = t.message_id
277let in_reply_to t = t.in_reply_to
278let references t = t.references
279let sender t = t.sender
280let from t = t.from
281let to_ t = t.to_
282let cc t = t.cc
283let bcc t = t.bcc
284let reply_to t = t.reply_to
285let subject t = t.subject
286let sent_at t = t.sent_at
287let headers t = t.headers
288let body_structure t = t.body_structure
289let body_values t = t.body_values
290let text_body t = t.text_body
291let html_body t = t.html_body
292let attachments t = t.attachments
293let has_attachment t = t.has_attachment
294let preview t = t.preview
295let dynamic_headers_raw t = t.dynamic_headers
296
297(* Parse header property name to determine form and :all flag *)
298let parse_header_prop name =
299 if not (String.length name > 7 && String.sub name 0 7 = "header:") then
300 None
301 else
302 let rest = String.sub name 7 (String.length name - 7) in
303 let parts = String.split_on_char ':' rest in
304 match parts with
305 | [] -> None
306 | [_name] -> Some (`Raw, false)
307 | [_name; second] ->
308 if second = "all" then Some (`Raw, true)
309 else (
310 match Mail_header.form_of_string second with
311 | Some form -> Some (form, false)
312 | None -> None
313 )
314 | [_name; form_str; "all"] ->
315 (match Mail_header.form_of_string form_str with
316 | Some form -> Some (form, true)
317 | None -> None)
318 | _ -> None
319
320(* Decode a raw JSON header value into typed header_value *)
321let decode_header_value prop_name json =
322 match parse_header_prop prop_name with
323 | None -> None
324 | Some (form, all) ->
325 let jsont = Mail_header.header_value_jsont ~form ~all in
326 match Jsont.Json.decode' jsont json with
327 | Ok v -> Some v
328 | Error _ -> None
329
330let get_header t key =
331 match List.assoc_opt key t.dynamic_headers with
332 | None -> None
333 | Some json -> decode_header_value key json
334
335let get_header_string t key =
336 match get_header t key with
337 | Some (Mail_header.String_single s) -> s
338 | _ -> None
339
340let get_header_addresses t key =
341 match get_header t key with
342 | Some (Mail_header.Addresses_single addrs) -> addrs
343 | _ -> None
344
345let make id blob_id thread_id size received_at mailbox_ids keywords
346 message_id in_reply_to references sender from to_ cc bcc reply_to
347 subject sent_at headers body_structure body_values text_body html_body
348 attachments has_attachment preview dynamic_headers =
349 { id; blob_id; thread_id; size; received_at; mailbox_ids; keywords;
350 message_id; in_reply_to; references; sender; from; to_; cc; bcc;
351 reply_to; subject; sent_at; headers; body_structure; body_values;
352 text_body; html_body; attachments; has_attachment; preview; dynamic_headers }
353
354(* Use centralized null_safe_list from Proto_json_map *)
355
356module String_map = Map.Make(String)
357
358(* Filter unknown members to only keep header:* properties *)
359let filter_header_props (unknown : Jsont.json String_map.t) : (string * Jsont.json) list =
360 String_map.to_seq unknown
361 |> Seq.filter (fun (k, _) -> String.length k > 7 && String.sub k 0 7 = "header:")
362 |> List.of_seq
363
364let jsont =
365 let kind = "Email" in
366 let body_values_jsont = Proto_json_map.of_string Mail_body.Value.jsont in
367 (* Use null_safe_list for address fields that can be null *)
368 let addr_list = Proto_json_map.null_safe_list Mail_address.jsont in
369 let str_list = Proto_json_map.null_safe_list Jsont.string in
370 let part_list = Proto_json_map.null_safe_list Mail_body.Part.jsont in
371 let hdr_list = Proto_json_map.null_safe_list Mail_header.jsont in
372 Jsont.Object.map ~kind (fun id blob_id thread_id size received_at mailbox_ids keywords
373 message_id in_reply_to references sender from to_ cc bcc reply_to
374 subject sent_at headers body_structure body_values text_body html_body
375 attachments has_attachment preview unknown ->
376 let dynamic_headers = filter_header_props unknown in
377 make id blob_id thread_id size received_at mailbox_ids keywords
378 message_id in_reply_to references sender from to_ cc bcc reply_to
379 subject sent_at headers body_structure body_values text_body html_body
380 attachments has_attachment preview dynamic_headers)
381 |> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
382 |> Jsont.Object.opt_mem "blobId" Proto_id.jsont ~enc:blob_id
383 |> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id
384 |> Jsont.Object.opt_mem "size" Proto_int53.Unsigned.jsont ~enc:size
385 |> Jsont.Object.opt_mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at
386 |> Jsont.Object.opt_mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids
387 |> Jsont.Object.opt_mem "keywords" Proto_json_map.string_to_bool ~enc:keywords
388 |> Jsont.Object.opt_mem "messageId" str_list ~enc:message_id
389 |> Jsont.Object.opt_mem "inReplyTo" str_list ~enc:in_reply_to
390 |> Jsont.Object.opt_mem "references" str_list ~enc:references
391 |> Jsont.Object.opt_mem "sender" addr_list ~enc:sender
392 |> Jsont.Object.opt_mem "from" addr_list ~enc:from
393 |> Jsont.Object.opt_mem "to" addr_list ~enc:to_
394 |> Jsont.Object.opt_mem "cc" addr_list ~enc:cc
395 |> Jsont.Object.opt_mem "bcc" addr_list ~enc:bcc
396 |> Jsont.Object.opt_mem "replyTo" addr_list ~enc:reply_to
397 |> Jsont.Object.opt_mem "subject" Jsont.string ~enc:subject
398 |> Jsont.Object.opt_mem "sentAt" Proto_date.Rfc3339.jsont ~enc:sent_at
399 |> Jsont.Object.opt_mem "headers" hdr_list ~enc:headers
400 |> Jsont.Object.opt_mem "bodyStructure" Mail_body.Part.jsont ~enc:body_structure
401 |> Jsont.Object.opt_mem "bodyValues" body_values_jsont ~enc:body_values
402 |> Jsont.Object.opt_mem "textBody" part_list ~enc:text_body
403 |> Jsont.Object.opt_mem "htmlBody" part_list ~enc:html_body
404 |> Jsont.Object.opt_mem "attachments" part_list ~enc:attachments
405 |> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:has_attachment
406 |> Jsont.Object.opt_mem "preview" Jsont.string ~enc:preview
407 |> Jsont.Object.keep_unknown
408 (Jsont.Object.Mems.string_map Jsont.json)
409 ~enc:(fun t -> String_map.of_list t.dynamic_headers)
410 |> Jsont.Object.finish
411
412module Filter_condition = struct
413 type t = {
414 in_mailbox : Proto_id.t option;
415 in_mailbox_other_than : Proto_id.t list option;
416 before : Ptime.t option;
417 after : Ptime.t option;
418 min_size : int64 option;
419 max_size : int64 option;
420 all_in_thread_have_keyword : string option;
421 some_in_thread_have_keyword : string option;
422 none_in_thread_have_keyword : string option;
423 has_keyword : string option;
424 not_keyword : string option;
425 has_attachment : bool option;
426 text : string option;
427 from : string option;
428 to_ : string option;
429 cc : string option;
430 bcc : string option;
431 subject : string option;
432 body : string option;
433 header : (string * string option) option;
434 }
435
436 let make in_mailbox in_mailbox_other_than before after min_size max_size
437 all_in_thread_have_keyword some_in_thread_have_keyword
438 none_in_thread_have_keyword has_keyword not_keyword has_attachment
439 text from to_ cc bcc subject body header =
440 { in_mailbox; in_mailbox_other_than; before; after; min_size; max_size;
441 all_in_thread_have_keyword; some_in_thread_have_keyword;
442 none_in_thread_have_keyword; has_keyword; not_keyword; has_attachment;
443 text; from; to_; cc; bcc; subject; body; header }
444
445 let header_jsont =
446 let kind = "HeaderFilter" in
447 let dec json =
448 match json with
449 | Jsont.Array ([Jsont.String (name, _)], _) ->
450 (name, None)
451 | Jsont.Array ([Jsont.String (name, _); Jsont.String (value, _)], _) ->
452 (name, Some value)
453 | _ ->
454 Jsont.Error.msgf Jsont.Meta.none "%s: expected [name] or [name, value]" kind
455 in
456 let enc (name, value) =
457 match value with
458 | None -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none)], Jsont.Meta.none)
459 | Some v -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none); Jsont.String (v, Jsont.Meta.none)], Jsont.Meta.none)
460 in
461 Jsont.map ~kind ~dec ~enc Jsont.json
462
463 let jsont =
464 let kind = "EmailFilterCondition" in
465 Jsont.Object.map ~kind make
466 |> Jsont.Object.opt_mem "inMailbox" Proto_id.jsont ~enc:(fun f -> f.in_mailbox)
467 |> Jsont.Object.opt_mem "inMailboxOtherThan" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.in_mailbox_other_than)
468 |> Jsont.Object.opt_mem "before" Proto_date.Utc.jsont ~enc:(fun f -> f.before)
469 |> Jsont.Object.opt_mem "after" Proto_date.Utc.jsont ~enc:(fun f -> f.after)
470 |> Jsont.Object.opt_mem "minSize" Proto_int53.Unsigned.jsont ~enc:(fun f -> f.min_size)
471 |> Jsont.Object.opt_mem "maxSize" Proto_int53.Unsigned.jsont ~enc:(fun f -> f.max_size)
472 |> Jsont.Object.opt_mem "allInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.all_in_thread_have_keyword)
473 |> Jsont.Object.opt_mem "someInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.some_in_thread_have_keyword)
474 |> Jsont.Object.opt_mem "noneInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.none_in_thread_have_keyword)
475 |> Jsont.Object.opt_mem "hasKeyword" Jsont.string ~enc:(fun f -> f.has_keyword)
476 |> Jsont.Object.opt_mem "notKeyword" Jsont.string ~enc:(fun f -> f.not_keyword)
477 |> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:(fun f -> f.has_attachment)
478 |> Jsont.Object.opt_mem "text" Jsont.string ~enc:(fun f -> f.text)
479 |> Jsont.Object.opt_mem "from" Jsont.string ~enc:(fun f -> f.from)
480 |> Jsont.Object.opt_mem "to" Jsont.string ~enc:(fun f -> f.to_)
481 |> Jsont.Object.opt_mem "cc" Jsont.string ~enc:(fun f -> f.cc)
482 |> Jsont.Object.opt_mem "bcc" Jsont.string ~enc:(fun f -> f.bcc)
483 |> Jsont.Object.opt_mem "subject" Jsont.string ~enc:(fun f -> f.subject)
484 |> Jsont.Object.opt_mem "body" Jsont.string ~enc:(fun f -> f.body)
485 |> Jsont.Object.opt_mem "header" header_jsont ~enc:(fun f -> f.header)
486 |> Jsont.Object.finish
487end
488
489type get_args_extra = {
490 body_properties : body_part_property list option;
491 fetch_text_body_values : bool;
492 fetch_html_body_values : bool;
493 fetch_all_body_values : bool;
494 max_body_value_bytes : int64 option;
495}
496
497let get_args_extra ?body_properties ?(fetch_text_body_values=false)
498 ?(fetch_html_body_values=false) ?(fetch_all_body_values=false)
499 ?max_body_value_bytes () =
500 { body_properties; fetch_text_body_values; fetch_html_body_values;
501 fetch_all_body_values; max_body_value_bytes }
502
503let body_part_property_list_jsont =
504 Jsont.list (Jsont.map ~kind:"body_part_property"
505 ~dec:(fun s -> match body_part_property_of_string s with
506 | Some p -> p
507 | None -> Jsont.Error.msgf Jsont.Meta.none "Unknown body property: %s" s)
508 ~enc:body_part_property_to_string
509 Jsont.string)
510
511let get_args_extra_jsont =
512 let kind = "Email/get extra args" in
513 Jsont.Object.map ~kind (fun body_properties fetch_text_body_values
514 fetch_html_body_values fetch_all_body_values max_body_value_bytes ->
515 { body_properties; fetch_text_body_values; fetch_html_body_values;
516 fetch_all_body_values; max_body_value_bytes })
517 |> Jsont.Object.opt_mem "bodyProperties" body_part_property_list_jsont
518 ~enc:(fun a -> a.body_properties)
519 |> Jsont.Object.mem "fetchTextBodyValues" Jsont.bool ~dec_absent:false
520 ~enc:(fun a -> a.fetch_text_body_values) ~enc_omit:(fun b -> not b)
521 |> Jsont.Object.mem "fetchHTMLBodyValues" Jsont.bool ~dec_absent:false
522 ~enc:(fun a -> a.fetch_html_body_values) ~enc_omit:(fun b -> not b)
523 |> Jsont.Object.mem "fetchAllBodyValues" Jsont.bool ~dec_absent:false
524 ~enc:(fun a -> a.fetch_all_body_values) ~enc_omit:(fun b -> not b)
525 |> Jsont.Object.opt_mem "maxBodyValueBytes" Proto_int53.Unsigned.jsont
526 ~enc:(fun a -> a.max_body_value_bytes)
527 |> Jsont.Object.finish
528
529(* Conversion to/from mail-flag keywords *)
530
531let keywords_to_assoc keywords =
532 List.map (fun k -> (Mail_flag.Keyword.to_string k, true)) keywords
533
534let keywords_of_assoc assoc =
535 List.filter_map (fun (s, v) ->
536 if v then Some (Mail_flag.Keyword.of_string s) else None
537 ) assoc