this repo has no description
anil.recoil.org
1(** Implementation of the JMAP Mail extension, as defined in RFC8621 *)
2
3(** Module for managing JMAP Mail-specific capability URIs *)
4module Capability = struct
5 (** Mail capability URI *)
6 let mail_uri = "urn:ietf:params:jmap:mail"
7
8 (** Submission capability URI *)
9 let submission_uri = "urn:ietf:params:jmap:submission"
10
11 (** Vacation response capability URI *)
12 let vacation_response_uri = "urn:ietf:params:jmap:vacationresponse"
13
14 (** All mail extension capability types *)
15 type t =
16 | Mail (** Mail capability *)
17 | Submission (** Submission capability *)
18 | VacationResponse (** Vacation response capability *)
19 | Extension of string (** Custom extension *)
20
21 (** Convert capability to URI string *)
22 let to_string = function
23 | Mail -> mail_uri
24 | Submission -> submission_uri
25 | VacationResponse -> vacation_response_uri
26 | Extension s -> s
27
28 (** Parse a string to a capability *)
29 let of_string s =
30 if s = mail_uri then Mail
31 else if s = submission_uri then Submission
32 else if s = vacation_response_uri then VacationResponse
33 else Extension s
34
35 (** Check if a capability is a standard mail capability *)
36 let is_standard = function
37 | Mail | Submission | VacationResponse -> true
38 | Extension _ -> false
39
40 (** Check if a capability string is a standard mail capability *)
41 let is_standard_string s =
42 s = mail_uri || s = submission_uri || s = vacation_response_uri
43
44 (** Create a list of capability strings *)
45 let strings_of_capabilities capabilities =
46 List.map to_string capabilities
47end
48
49module Types = struct
50 open Jmap.Types
51
52 (** {1 Mail capabilities} *)
53
54 (** Capability URI for JMAP Mail*)
55 let capability_mail = Capability.mail_uri
56
57 (** Capability URI for JMAP Submission *)
58 let capability_submission = Capability.submission_uri
59
60 (** Capability URI for JMAP Vacation Response *)
61 let capability_vacation_response = Capability.vacation_response_uri
62
63 (** {1:mailbox Mailbox objects} *)
64
65 (** A role for a mailbox. See RFC8621 Section 2. *)
66 type mailbox_role =
67 | All (** All mail *)
68 | Archive (** Archived mail *)
69 | Drafts (** Draft messages *)
70 | Flagged (** Starred/flagged mail *)
71 | Important (** Important mail *)
72 | Inbox (** Inbox *)
73 | Junk (** Spam/Junk mail *)
74 | Sent (** Sent mail *)
75 | Trash (** Deleted/Trash mail *)
76 | Unknown of string (** Server-specific roles *)
77
78 (** A mailbox (folder) in a mail account. See RFC8621 Section 2. *)
79 type mailbox = {
80 id : id;
81 name : string;
82 parent_id : id option;
83 role : mailbox_role option;
84 sort_order : unsigned_int;
85 total_emails : unsigned_int;
86 unread_emails : unsigned_int;
87 total_threads : unsigned_int;
88 unread_threads : unsigned_int;
89 is_subscribed : bool;
90 my_rights : mailbox_rights;
91 }
92
93 (** Rights for a mailbox. See RFC8621 Section 2. *)
94 and mailbox_rights = {
95 may_read_items : bool;
96 may_add_items : bool;
97 may_remove_items : bool;
98 may_set_seen : bool;
99 may_set_keywords : bool;
100 may_create_child : bool;
101 may_rename : bool;
102 may_delete : bool;
103 may_submit : bool;
104 }
105
106 (** Filter condition for mailbox queries. See RFC8621 Section 2.3. *)
107 type mailbox_filter_condition = {
108 parent_id : id option;
109 name : string option;
110 role : string option;
111 has_any_role : bool option;
112 is_subscribed : bool option;
113 }
114
115 type mailbox_query_filter = [
116 | `And of mailbox_query_filter list
117 | `Or of mailbox_query_filter list
118 | `Not of mailbox_query_filter
119 | `Condition of mailbox_filter_condition
120 ]
121
122 (** Mailbox/get request arguments. See RFC8621 Section 2.1. *)
123 type mailbox_get_arguments = {
124 account_id : id;
125 ids : id list option;
126 properties : string list option;
127 }
128
129 (** Mailbox/get response. See RFC8621 Section 2.1. *)
130 type mailbox_get_response = {
131 account_id : id;
132 state : string;
133 list : mailbox list;
134 not_found : id list;
135 }
136
137 (** Mailbox/changes request arguments. See RFC8621 Section 2.2. *)
138 type mailbox_changes_arguments = {
139 account_id : id;
140 since_state : string;
141 max_changes : unsigned_int option;
142 }
143
144 (** Mailbox/changes response. See RFC8621 Section 2.2. *)
145 type mailbox_changes_response = {
146 account_id : id;
147 old_state : string;
148 new_state : string;
149 has_more_changes : bool;
150 created : id list;
151 updated : id list;
152 destroyed : id list;
153 }
154
155 (** Mailbox/query request arguments. See RFC8621 Section 2.3. *)
156 type mailbox_query_arguments = {
157 account_id : id;
158 filter : mailbox_query_filter option;
159 sort : [ `name | `role | `sort_order ] list option;
160 limit : unsigned_int option;
161 }
162
163 (** Mailbox/query response. See RFC8621 Section 2.3. *)
164 type mailbox_query_response = {
165 account_id : id;
166 query_state : string;
167 can_calculate_changes : bool;
168 position : unsigned_int;
169 ids : id list;
170 total : unsigned_int option;
171 }
172
173 (** Mailbox/queryChanges request arguments. See RFC8621 Section 2.4. *)
174 type mailbox_query_changes_arguments = {
175 account_id : id;
176 filter : mailbox_query_filter option;
177 sort : [ `name | `role | `sort_order ] list option;
178 since_query_state : string;
179 max_changes : unsigned_int option;
180 up_to_id : id option;
181 }
182
183 (** Mailbox/queryChanges response. See RFC8621 Section 2.4. *)
184 type mailbox_query_changes_response = {
185 account_id : id;
186 old_query_state : string;
187 new_query_state : string;
188 total : unsigned_int option;
189 removed : id list;
190 added : mailbox_query_changes_added list;
191 }
192
193 and mailbox_query_changes_added = {
194 id : id;
195 index : unsigned_int;
196 }
197
198 (** Mailbox/set request arguments. See RFC8621 Section 2.5. *)
199 type mailbox_set_arguments = {
200 account_id : id;
201 if_in_state : string option;
202 create : (id * mailbox_creation) list option;
203 update : (id * mailbox_update) list option;
204 destroy : id list option;
205 }
206
207 and mailbox_creation = {
208 name : string;
209 parent_id : id option;
210 role : string option;
211 sort_order : unsigned_int option;
212 is_subscribed : bool option;
213 }
214
215 and mailbox_update = {
216 name : string option;
217 parent_id : id option;
218 role : string option;
219 sort_order : unsigned_int option;
220 is_subscribed : bool option;
221 }
222
223 (** Mailbox/set response. See RFC8621 Section 2.5. *)
224 type mailbox_set_response = {
225 account_id : id;
226 old_state : string option;
227 new_state : string;
228 created : (id * mailbox) list option;
229 updated : id list option;
230 destroyed : id list option;
231 not_created : (id * set_error) list option;
232 not_updated : (id * set_error) list option;
233 not_destroyed : (id * set_error) list option;
234 }
235
236 (** {1:thread Thread objects} *)
237
238 (** A thread in a mail account. See RFC8621 Section 3. *)
239 type thread = {
240 id : id;
241 email_ids : id list;
242 }
243
244 (** Thread/get request arguments. See RFC8621 Section 3.1. *)
245 type thread_get_arguments = {
246 account_id : id;
247 ids : id list option;
248 properties : string list option;
249 }
250
251 (** Thread/get response. See RFC8621 Section 3.1. *)
252 type thread_get_response = {
253 account_id : id;
254 state : string;
255 list : thread list;
256 not_found : id list;
257 }
258
259 (** Thread/changes request arguments. See RFC8621 Section 3.2. *)
260 type thread_changes_arguments = {
261 account_id : id;
262 since_state : string;
263 max_changes : unsigned_int option;
264 }
265
266 (** Thread/changes response. See RFC8621 Section 3.2. *)
267 type thread_changes_response = {
268 account_id : id;
269 old_state : string;
270 new_state : string;
271 has_more_changes : bool;
272 created : id list;
273 updated : id list;
274 destroyed : id list;
275 }
276
277 (** {1:email Email objects} *)
278
279 (** Addressing (mailbox) information. See RFC8621 Section 4.1.1. *)
280 type email_address = {
281 name : string option;
282 email : string;
283 parameters : (string * string) list;
284 }
285
286 (** Message header field. See RFC8621 Section 4.1.2. *)
287 type header = {
288 name : string;
289 value : string;
290 }
291
292 (** Email keyword (flag). See RFC8621 Section 4.3. *)
293 type keyword =
294 | Flagged
295 | Answered
296 | Draft
297 | Forwarded
298 | Phishing
299 | Junk
300 | NotJunk
301 | Seen
302 | Unread
303 | Custom of string
304
305 (** Email message. See RFC8621 Section 4. *)
306 type email = {
307 id : id;
308 blob_id : id;
309 thread_id : id;
310 mailbox_ids : (id * bool) list;
311 keywords : (keyword * bool) list;
312 size : unsigned_int;
313 received_at : utc_date;
314 message_id : string list;
315 in_reply_to : string list option;
316 references : string list option;
317 sender : email_address list option;
318 from : email_address list option;
319 to_ : email_address list option;
320 cc : email_address list option;
321 bcc : email_address list option;
322 reply_to : email_address list option;
323 subject : string option;
324 sent_at : utc_date option;
325 has_attachment : bool option;
326 preview : string option;
327 body_values : (string * string) list option;
328 text_body : email_body_part list option;
329 html_body : email_body_part list option;
330 attachments : email_body_part list option;
331 headers : header list option;
332 }
333
334 (** Email body part. See RFC8621 Section 4.1.4. *)
335 and email_body_part = {
336 part_id : string option;
337 blob_id : id option;
338 size : unsigned_int option;
339 headers : header list option;
340 name : string option;
341 type_ : string option;
342 charset : string option;
343 disposition : string option;
344 cid : string option;
345 language : string list option;
346 location : string option;
347 sub_parts : email_body_part list option;
348 header_parameter_name : string option;
349 header_parameter_value : string option;
350 }
351
352 (** Email query filter condition. See RFC8621 Section 4.4. *)
353 type email_filter_condition = {
354 in_mailbox : id option;
355 in_mailbox_other_than : id list option;
356 min_size : unsigned_int option;
357 max_size : unsigned_int option;
358 before : utc_date option;
359 after : utc_date option;
360 header : (string * string) option;
361 from : string option;
362 to_ : string option;
363 cc : string option;
364 bcc : string option;
365 subject : string option;
366 body : string option;
367 has_keyword : string option;
368 not_keyword : string option;
369 has_attachment : bool option;
370 text : string option;
371 }
372
373 type email_query_filter = [
374 | `And of email_query_filter list
375 | `Or of email_query_filter list
376 | `Not of email_query_filter
377 | `Condition of email_filter_condition
378 ]
379
380 (** Email/get request arguments. See RFC8621 Section 4.5. *)
381 type email_get_arguments = {
382 account_id : id;
383 ids : id list option;
384 properties : string list option;
385 body_properties : string list option;
386 fetch_text_body_values : bool option;
387 fetch_html_body_values : bool option;
388 fetch_all_body_values : bool option;
389 max_body_value_bytes : unsigned_int option;
390 }
391
392 (** Email/get response. See RFC8621 Section 4.5. *)
393 type email_get_response = {
394 account_id : id;
395 state : string;
396 list : email list;
397 not_found : id list;
398 }
399
400 (** Email/changes request arguments. See RFC8621 Section 4.6. *)
401 type email_changes_arguments = {
402 account_id : id;
403 since_state : string;
404 max_changes : unsigned_int option;
405 }
406
407 (** Email/changes response. See RFC8621 Section 4.6. *)
408 type email_changes_response = {
409 account_id : id;
410 old_state : string;
411 new_state : string;
412 has_more_changes : bool;
413 created : id list;
414 updated : id list;
415 destroyed : id list;
416 }
417
418 (** Email/query request arguments. See RFC8621 Section 4.4. *)
419 type email_query_arguments = {
420 account_id : id;
421 filter : email_query_filter option;
422 sort : comparator list option;
423 collapse_threads : bool option;
424 position : unsigned_int option;
425 anchor : id option;
426 anchor_offset : int_t option;
427 limit : unsigned_int option;
428 calculate_total : bool option;
429 }
430
431 (** Email/query response. See RFC8621 Section 4.4. *)
432 type email_query_response = {
433 account_id : id;
434 query_state : string;
435 can_calculate_changes : bool;
436 position : unsigned_int;
437 ids : id list;
438 total : unsigned_int option;
439 thread_ids : id list option;
440 }
441
442 (** Email/queryChanges request arguments. See RFC8621 Section 4.7. *)
443 type email_query_changes_arguments = {
444 account_id : id;
445 filter : email_query_filter option;
446 sort : comparator list option;
447 collapse_threads : bool option;
448 since_query_state : string;
449 max_changes : unsigned_int option;
450 up_to_id : id option;
451 }
452
453 (** Email/queryChanges response. See RFC8621 Section 4.7. *)
454 type email_query_changes_response = {
455 account_id : id;
456 old_query_state : string;
457 new_query_state : string;
458 total : unsigned_int option;
459 removed : id list;
460 added : email_query_changes_added list;
461 }
462
463 and email_query_changes_added = {
464 id : id;
465 index : unsigned_int;
466 }
467
468 (** Email/set request arguments. See RFC8621 Section 4.8. *)
469 type email_set_arguments = {
470 account_id : id;
471 if_in_state : string option;
472 create : (id * email_creation) list option;
473 update : (id * email_update) list option;
474 destroy : id list option;
475 }
476
477 and email_creation = {
478 mailbox_ids : (id * bool) list;
479 keywords : (keyword * bool) list option;
480 received_at : utc_date option;
481 message_id : string list option;
482 in_reply_to : string list option;
483 references : string list option;
484 sender : email_address list option;
485 from : email_address list option;
486 to_ : email_address list option;
487 cc : email_address list option;
488 bcc : email_address list option;
489 reply_to : email_address list option;
490 subject : string option;
491 body_values : (string * string) list option;
492 text_body : email_body_part list option;
493 html_body : email_body_part list option;
494 attachments : email_body_part list option;
495 headers : header list option;
496 }
497
498 and email_update = {
499 keywords : (keyword * bool) list option;
500 mailbox_ids : (id * bool) list option;
501 }
502
503 (** Email/set response. See RFC8621 Section 4.8. *)
504 type email_set_response = {
505 account_id : id;
506 old_state : string option;
507 new_state : string;
508 created : (id * email) list option;
509 updated : id list option;
510 destroyed : id list option;
511 not_created : (id * set_error) list option;
512 not_updated : (id * set_error) list option;
513 not_destroyed : (id * set_error) list option;
514 }
515
516 (** Email/copy request arguments. See RFC8621 Section 4.9. *)
517 type email_copy_arguments = {
518 from_account_id : id;
519 account_id : id;
520 create : (id * email_creation) list;
521 on_success_destroy_original : bool option;
522 }
523
524 (** Email/copy response. See RFC8621 Section 4.9. *)
525 type email_copy_response = {
526 from_account_id : id;
527 account_id : id;
528 created : (id * email) list option;
529 not_created : (id * set_error) list option;
530 }
531
532 (** Email/import request arguments. See RFC8621 Section 4.10. *)
533 type email_import_arguments = {
534 account_id : id;
535 emails : (id * email_import) list;
536 }
537
538 and email_import = {
539 blob_id : id;
540 mailbox_ids : (id * bool) list;
541 keywords : (keyword * bool) list option;
542 received_at : utc_date option;
543 }
544
545 (** Email/import response. See RFC8621 Section 4.10. *)
546 type email_import_response = {
547 account_id : id;
548 created : (id * email) list option;
549 not_created : (id * set_error) list option;
550 }
551
552 (** {1:search_snippet Search snippets} *)
553
554 (** SearchSnippet/get request arguments. See RFC8621 Section 4.11. *)
555 type search_snippet_get_arguments = {
556 account_id : id;
557 email_ids : id list;
558 filter : email_filter_condition;
559 }
560
561 (** SearchSnippet/get response. See RFC8621 Section 4.11. *)
562 type search_snippet_get_response = {
563 account_id : id;
564 list : (id * search_snippet) list;
565 not_found : id list;
566 }
567
568 and search_snippet = {
569 subject : string option;
570 preview : string option;
571 }
572
573 (** {1:submission EmailSubmission objects} *)
574
575 (** EmailSubmission address. See RFC8621 Section 5.1. *)
576 type submission_address = {
577 email : string;
578 parameters : (string * string) list option;
579 }
580
581 (** Email submission object. See RFC8621 Section 5.1. *)
582 type email_submission = {
583 id : id;
584 identity_id : id;
585 email_id : id;
586 thread_id : id;
587 envelope : envelope option;
588 send_at : utc_date option;
589 undo_status : [
590 | `pending
591 | `final
592 | `canceled
593 ] option;
594 delivery_status : (string * submission_status) list option;
595 dsn_blob_ids : (string * id) list option;
596 mdn_blob_ids : (string * id) list option;
597 }
598
599 (** Envelope for mail submission. See RFC8621 Section 5.1. *)
600 and envelope = {
601 mail_from : submission_address;
602 rcpt_to : submission_address list;
603 }
604
605 (** Delivery status for submitted email. See RFC8621 Section 5.1. *)
606 and submission_status = {
607 smtp_reply : string;
608 delivered : string option;
609 }
610
611 (** EmailSubmission/get request arguments. See RFC8621 Section 5.3. *)
612 type email_submission_get_arguments = {
613 account_id : id;
614 ids : id list option;
615 properties : string list option;
616 }
617
618 (** EmailSubmission/get response. See RFC8621 Section 5.3. *)
619 type email_submission_get_response = {
620 account_id : id;
621 state : string;
622 list : email_submission list;
623 not_found : id list;
624 }
625
626 (** EmailSubmission/changes request arguments. See RFC8621 Section 5.4. *)
627 type email_submission_changes_arguments = {
628 account_id : id;
629 since_state : string;
630 max_changes : unsigned_int option;
631 }
632
633 (** EmailSubmission/changes response. See RFC8621 Section 5.4. *)
634 type email_submission_changes_response = {
635 account_id : id;
636 old_state : string;
637 new_state : string;
638 has_more_changes : bool;
639 created : id list;
640 updated : id list;
641 destroyed : id list;
642 }
643
644 (** EmailSubmission/query filter condition. See RFC8621 Section 5.5. *)
645 type email_submission_filter_condition = {
646 identity_id : id option;
647 email_id : id option;
648 thread_id : id option;
649 before : utc_date option;
650 after : utc_date option;
651 subject : string option;
652 }
653
654 type email_submission_query_filter = [
655 | `And of email_submission_query_filter list
656 | `Or of email_submission_query_filter list
657 | `Not of email_submission_query_filter
658 | `Condition of email_submission_filter_condition
659 ]
660
661 (** EmailSubmission/query request arguments. See RFC8621 Section 5.5. *)
662 type email_submission_query_arguments = {
663 account_id : id;
664 filter : email_submission_query_filter option;
665 sort : comparator list option;
666 position : unsigned_int option;
667 anchor : id option;
668 anchor_offset : int_t option;
669 limit : unsigned_int option;
670 calculate_total : bool option;
671 }
672
673 (** EmailSubmission/query response. See RFC8621 Section 5.5. *)
674 type email_submission_query_response = {
675 account_id : id;
676 query_state : string;
677 can_calculate_changes : bool;
678 position : unsigned_int;
679 ids : id list;
680 total : unsigned_int option;
681 }
682
683 (** EmailSubmission/set request arguments. See RFC8621 Section 5.6. *)
684 type email_submission_set_arguments = {
685 account_id : id;
686 if_in_state : string option;
687 create : (id * email_submission_creation) list option;
688 update : (id * email_submission_update) list option;
689 destroy : id list option;
690 on_success_update_email : (id * email_update) list option;
691 }
692
693 and email_submission_creation = {
694 email_id : id;
695 identity_id : id;
696 envelope : envelope option;
697 send_at : utc_date option;
698 }
699
700 and email_submission_update = {
701 email_id : id option;
702 identity_id : id option;
703 envelope : envelope option;
704 undo_status : [`canceled] option;
705 }
706
707 (** EmailSubmission/set response. See RFC8621 Section 5.6. *)
708 type email_submission_set_response = {
709 account_id : id;
710 old_state : string option;
711 new_state : string;
712 created : (id * email_submission) list option;
713 updated : id list option;
714 destroyed : id list option;
715 not_created : (id * set_error) list option;
716 not_updated : (id * set_error) list option;
717 not_destroyed : (id * set_error) list option;
718 }
719
720 (** {1:identity Identity objects} *)
721
722 (** Identity for sending mail. See RFC8621 Section 6. *)
723 type identity = {
724 id : id;
725 name : string;
726 email : string;
727 reply_to : email_address list option;
728 bcc : email_address list option;
729 text_signature : string option;
730 html_signature : string option;
731 may_delete : bool;
732 }
733
734 (** Identity/get request arguments. See RFC8621 Section 6.1. *)
735 type identity_get_arguments = {
736 account_id : id;
737 ids : id list option;
738 properties : string list option;
739 }
740
741 (** Identity/get response. See RFC8621 Section 6.1. *)
742 type identity_get_response = {
743 account_id : id;
744 state : string;
745 list : identity list;
746 not_found : id list;
747 }
748
749 (** Identity/changes request arguments. See RFC8621 Section 6.2. *)
750 type identity_changes_arguments = {
751 account_id : id;
752 since_state : string;
753 max_changes : unsigned_int option;
754 }
755
756 (** Identity/changes response. See RFC8621 Section 6.2. *)
757 type identity_changes_response = {
758 account_id : id;
759 old_state : string;
760 new_state : string;
761 has_more_changes : bool;
762 created : id list;
763 updated : id list;
764 destroyed : id list;
765 }
766
767 (** Identity/set request arguments. See RFC8621 Section 6.3. *)
768 type identity_set_arguments = {
769 account_id : id;
770 if_in_state : string option;
771 create : (id * identity_creation) list option;
772 update : (id * identity_update) list option;
773 destroy : id list option;
774 }
775
776 and identity_creation = {
777 name : string;
778 email : string;
779 reply_to : email_address list option;
780 bcc : email_address list option;
781 text_signature : string option;
782 html_signature : string option;
783 }
784
785 and identity_update = {
786 name : string option;
787 email : string option;
788 reply_to : email_address list option;
789 bcc : email_address list option;
790 text_signature : string option;
791 html_signature : string option;
792 }
793
794 (** Identity/set response. See RFC8621 Section 6.3. *)
795 type identity_set_response = {
796 account_id : id;
797 old_state : string option;
798 new_state : string;
799 created : (id * identity) list option;
800 updated : id list option;
801 destroyed : id list option;
802 not_created : (id * set_error) list option;
803 not_updated : (id * set_error) list option;
804 not_destroyed : (id * set_error) list option;
805 }
806
807 (** {1:vacation_response VacationResponse objects} *)
808
809 (** Vacation auto-reply setting. See RFC8621 Section 7. *)
810 type vacation_response = {
811 id : id;
812 is_enabled : bool;
813 from_date : utc_date option;
814 to_date : utc_date option;
815 subject : string option;
816 text_body : string option;
817 html_body : string option;
818 }
819
820 (** VacationResponse/get request arguments. See RFC8621 Section 7.2. *)
821 type vacation_response_get_arguments = {
822 account_id : id;
823 ids : id list option;
824 properties : string list option;
825 }
826
827 (** VacationResponse/get response. See RFC8621 Section 7.2. *)
828 type vacation_response_get_response = {
829 account_id : id;
830 state : string;
831 list : vacation_response list;
832 not_found : id list;
833 }
834
835 (** VacationResponse/set request arguments. See RFC8621 Section 7.3. *)
836 type vacation_response_set_arguments = {
837 account_id : id;
838 if_in_state : string option;
839 update : (id * vacation_response_update) list;
840 }
841
842 and vacation_response_update = {
843 is_enabled : bool option;
844 from_date : utc_date option;
845 to_date : utc_date option;
846 subject : string option;
847 text_body : string option;
848 html_body : string option;
849 }
850
851 (** VacationResponse/set response. See RFC8621 Section 7.3. *)
852 type vacation_response_set_response = {
853 account_id : id;
854 old_state : string option;
855 new_state : string;
856 updated : id list option;
857 not_updated : (id * set_error) list option;
858 }
859
860 (** {1:message_flags Message Flags and Mailbox Attributes} *)
861
862 (** Flag color defined by the combination of MailFlagBit0, MailFlagBit1, and MailFlagBit2 keywords *)
863 type flag_color =
864 | Red (** Bit pattern 000 *)
865 | Orange (** Bit pattern 100 *)
866 | Yellow (** Bit pattern 010 *)
867 | Green (** Bit pattern 111 *)
868 | Blue (** Bit pattern 001 *)
869 | Purple (** Bit pattern 101 *)
870 | Gray (** Bit pattern 011 *)
871
872 (** Standard message keywords as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02 *)
873 type message_keyword =
874 | Notify (** Indicate a notification should be shown for this message *)
875 | Muted (** User is not interested in future replies to this thread *)
876 | Followed (** User is particularly interested in future replies to this thread *)
877 | Memo (** Message is a note-to-self about another message in the same thread *)
878 | HasMemo (** Message has an associated memo with the $memo keyword *)
879 | HasAttachment (** Message has an attachment *)
880 | HasNoAttachment (** Message does not have an attachment *)
881 | AutoSent (** Message was sent automatically as a response due to a user rule *)
882 | Unsubscribed (** User has unsubscribed from the thread this message is in *)
883 | CanUnsubscribe (** Message has an RFC8058-compliant List-Unsubscribe header *)
884 | Imported (** Message was imported from another mailbox *)
885 | IsTrusted (** Server has verified authenticity of the from name and email *)
886 | MaskedEmail (** Message was received via an alias created for an individual sender *)
887 | New (** Message should be made more prominent due to a recent action *)
888 | MailFlagBit0 (** Bit 0 of the 3-bit flag color pattern *)
889 | MailFlagBit1 (** Bit 1 of the 3-bit flag color pattern *)
890 | MailFlagBit2 (** Bit 2 of the 3-bit flag color pattern *)
891 | OtherKeyword of string (** Other non-standard keywords *)
892
893 (** Special mailbox attribute names as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02 *)
894 type mailbox_attribute =
895 | Snoozed (** Mailbox containing messages that have been snoozed *)
896 | Scheduled (** Mailbox containing messages scheduled to be sent later *)
897 | Memos (** Mailbox containing messages with the $memo keyword *)
898 | OtherAttribute of string (** Other non-standard mailbox attributes *)
899
900 (** Functions for working with flag colors based on the specification in
901 draft-ietf-mailmaint-messageflag-mailboxattribute-02, section 3.1. *)
902
903 (** Convert bit pattern to flag color *)
904 let flag_color_of_bits bit0 bit1 bit2 =
905 match (bit0, bit1, bit2) with
906 | (false, false, false) -> Red (* 000 *)
907 | (true, false, false) -> Orange (* 100 *)
908 | (false, true, false) -> Yellow (* 010 *)
909 | (true, true, true) -> Green (* 111 *)
910 | (false, false, true) -> Blue (* 001 *)
911 | (true, false, true) -> Purple (* 101 *)
912 | (false, true, true) -> Gray (* 011 *)
913 | (true, true, false) -> Green (* 110 - not in spec, defaulting to green *)
914
915 (** Get bits for a flag color *)
916 let bits_of_flag_color = function
917 | Red -> (false, false, false)
918 | Orange -> (true, false, false)
919 | Yellow -> (false, true, false)
920 | Green -> (true, true, true)
921 | Blue -> (false, false, true)
922 | Purple -> (true, false, true)
923 | Gray -> (false, true, true)
924
925 (** Check if a keyword list contains a flag color *)
926 let has_flag_color keywords =
927 let has_bit0 = List.exists (function
928 | (Custom s, true) when s = "$MailFlagBit0" -> true
929 | _ -> false
930 ) keywords in
931
932 let has_bit1 = List.exists (function
933 | (Custom s, true) when s = "$MailFlagBit1" -> true
934 | _ -> false
935 ) keywords in
936
937 let has_bit2 = List.exists (function
938 | (Custom s, true) when s = "$MailFlagBit2" -> true
939 | _ -> false
940 ) keywords in
941
942 has_bit0 || has_bit1 || has_bit2
943
944 (** Extract flag color from keywords if present *)
945 let get_flag_color keywords =
946 (* First check if the message has the \Flagged system flag *)
947 let is_flagged = List.exists (function
948 | (Flagged, true) -> true
949 | _ -> false
950 ) keywords in
951
952 if not is_flagged then
953 None
954 else
955 (* Get values of each bit flag *)
956 let bit0 = List.exists (function
957 | (Custom s, true) when s = "$MailFlagBit0" -> true
958 | _ -> false
959 ) keywords in
960
961 let bit1 = List.exists (function
962 | (Custom s, true) when s = "$MailFlagBit1" -> true
963 | _ -> false
964 ) keywords in
965
966 let bit2 = List.exists (function
967 | (Custom s, true) when s = "$MailFlagBit2" -> true
968 | _ -> false
969 ) keywords in
970
971 Some (flag_color_of_bits bit0 bit1 bit2)
972
973 (** Convert a message keyword to its string representation *)
974 let string_of_message_keyword = function
975 | Notify -> "$notify"
976 | Muted -> "$muted"
977 | Followed -> "$followed"
978 | Memo -> "$memo"
979 | HasMemo -> "$hasmemo"
980 | HasAttachment -> "$hasattachment"
981 | HasNoAttachment -> "$hasnoattachment"
982 | AutoSent -> "$autosent"
983 | Unsubscribed -> "$unsubscribed"
984 | CanUnsubscribe -> "$canunsubscribe"
985 | Imported -> "$imported"
986 | IsTrusted -> "$istrusted"
987 | MaskedEmail -> "$maskedemail"
988 | New -> "$new"
989 | MailFlagBit0 -> "$MailFlagBit0"
990 | MailFlagBit1 -> "$MailFlagBit1"
991 | MailFlagBit2 -> "$MailFlagBit2"
992 | OtherKeyword s -> s
993
994 (** Parse a string into a message keyword *)
995 let message_keyword_of_string = function
996 | "$notify" -> Notify
997 | "$muted" -> Muted
998 | "$followed" -> Followed
999 | "$memo" -> Memo
1000 | "$hasmemo" -> HasMemo
1001 | "$hasattachment" -> HasAttachment
1002 | "$hasnoattachment" -> HasNoAttachment
1003 | "$autosent" -> AutoSent
1004 | "$unsubscribed" -> Unsubscribed
1005 | "$canunsubscribe" -> CanUnsubscribe
1006 | "$imported" -> Imported
1007 | "$istrusted" -> IsTrusted
1008 | "$maskedemail" -> MaskedEmail
1009 | "$new" -> New
1010 | "$MailFlagBit0" -> MailFlagBit0
1011 | "$MailFlagBit1" -> MailFlagBit1
1012 | "$MailFlagBit2" -> MailFlagBit2
1013 | s -> OtherKeyword s
1014
1015 (** Convert a mailbox attribute to its string representation *)
1016 let string_of_mailbox_attribute = function
1017 | Snoozed -> "Snoozed"
1018 | Scheduled -> "Scheduled"
1019 | Memos -> "Memos"
1020 | OtherAttribute s -> s
1021
1022 (** Parse a string into a mailbox attribute *)
1023 let mailbox_attribute_of_string = function
1024 | "Snoozed" -> Snoozed
1025 | "Scheduled" -> Scheduled
1026 | "Memos" -> Memos
1027 | s -> OtherAttribute s
1028
1029 (** Get a human-readable representation of a flag color *)
1030 let human_readable_flag_color = function
1031 | Red -> "Red"
1032 | Orange -> "Orange"
1033 | Yellow -> "Yellow"
1034 | Green -> "Green"
1035 | Blue -> "Blue"
1036 | Purple -> "Purple"
1037 | Gray -> "Gray"
1038
1039 (** Get a human-readable representation of a message keyword *)
1040 let human_readable_message_keyword = function
1041 | Notify -> "Notify"
1042 | Muted -> "Muted"
1043 | Followed -> "Followed"
1044 | Memo -> "Memo"
1045 | HasMemo -> "Has Memo"
1046 | HasAttachment -> "Has Attachment"
1047 | HasNoAttachment -> "No Attachment"
1048 | AutoSent -> "Auto Sent"
1049 | Unsubscribed -> "Unsubscribed"
1050 | CanUnsubscribe -> "Can Unsubscribe"
1051 | Imported -> "Imported"
1052 | IsTrusted -> "Trusted"
1053 | MaskedEmail -> "Masked Email"
1054 | New -> "New"
1055 | MailFlagBit0 | MailFlagBit1 | MailFlagBit2 -> "Flag Bit"
1056 | OtherKeyword s -> s
1057
1058 (** Format email keywords into a human-readable string representation *)
1059 let format_email_keywords keywords =
1060 (* Get flag color if present *)
1061 let color_str =
1062 match get_flag_color keywords with
1063 | Some color -> human_readable_flag_color color
1064 | None -> ""
1065 in
1066
1067 (* Get standard JMAP keywords *)
1068 let standard_keywords = List.filter_map (fun (kw, active) ->
1069 if not active then None
1070 else match kw with
1071 | Flagged -> Some "Flagged"
1072 | Answered -> Some "Answered"
1073 | Draft -> Some "Draft"
1074 | Forwarded -> Some "Forwarded"
1075 | Phishing -> Some "Phishing"
1076 | Junk -> Some "Junk"
1077 | NotJunk -> Some "Not Junk"
1078 | Seen -> Some "Seen"
1079 | Unread -> Some "Unread"
1080 | _ -> None
1081 ) keywords in
1082
1083 (* Get message keywords *)
1084 let message_keywords = List.filter_map (fun (kw, active) ->
1085 if not active then None
1086 else match kw with
1087 | Custom s ->
1088 (* Try to parse as message keyword *)
1089 let message_kw = message_keyword_of_string s in
1090 (match message_kw with
1091 | OtherKeyword _ -> None
1092 | MailFlagBit0 | MailFlagBit1 | MailFlagBit2 -> None
1093 | kw -> Some (human_readable_message_keyword kw))
1094 | _ -> None
1095 ) keywords in
1096
1097 (* Combine all human-readable labels *)
1098 let all_parts =
1099 (if color_str <> "" then [color_str] else []) @
1100 standard_keywords @
1101 message_keywords
1102 in
1103
1104 String.concat ", " all_parts
1105end
1106
1107(** {1 JSON serialization} *)
1108
1109module Json = struct
1110 open Types
1111
1112 (** {2 Helper functions for serialization} *)
1113
1114 let string_of_mailbox_role = function
1115 | All -> "all"
1116 | Archive -> "archive"
1117 | Drafts -> "drafts"
1118 | Flagged -> "flagged"
1119 | Important -> "important"
1120 | Inbox -> "inbox"
1121 | Junk -> "junk"
1122 | Sent -> "sent"
1123 | Trash -> "trash"
1124 | Unknown s -> s
1125
1126 let mailbox_role_of_string = function
1127 | "all" -> All
1128 | "archive" -> Archive
1129 | "drafts" -> Drafts
1130 | "flagged" -> Flagged
1131 | "important" -> Important
1132 | "inbox" -> Inbox
1133 | "junk" -> Junk
1134 | "sent" -> Sent
1135 | "trash" -> Trash
1136 | s -> Unknown s
1137
1138 let string_of_keyword = function
1139 | Flagged -> "$flagged"
1140 | Answered -> "$answered"
1141 | Draft -> "$draft"
1142 | Forwarded -> "$forwarded"
1143 | Phishing -> "$phishing"
1144 | Junk -> "$junk"
1145 | NotJunk -> "$notjunk"
1146 | Seen -> "$seen"
1147 | Unread -> "$unread"
1148 | Custom s -> s
1149
1150 let keyword_of_string = function
1151 | "$flagged" -> Flagged
1152 | "$answered" -> Answered
1153 | "$draft" -> Draft
1154 | "$forwarded" -> Forwarded
1155 | "$phishing" -> Phishing
1156 | "$junk" -> Junk
1157 | "$notjunk" -> NotJunk
1158 | "$seen" -> Seen
1159 | "$unread" -> Unread
1160 | s -> Custom s
1161
1162 (** {2 Mailbox serialization} *)
1163
1164 (** TODO:claude - Need to implement all JSON serialization functions
1165 for each type we've defined. This would be a substantial amount of
1166 code and likely require additional understanding of the ezjsonm API.
1167
1168 For a full implementation, we would need functions to convert between
1169 OCaml types and JSON for each of:
1170 - mailbox, mailbox_rights, mailbox query/update operations
1171 - thread operations
1172 - email, email_address, header, email_body_part
1173 - email query/update operations
1174 - submission operations
1175 - identity operations
1176 - vacation response operations
1177 *)
1178end
1179
1180(** {1 API functions} *)
1181
1182open Lwt.Syntax
1183open Jmap.Api
1184open Jmap.Types
1185
1186(** Authentication credentials for a JMAP server *)
1187type credentials = {
1188 username: string;
1189 password: string;
1190}
1191
1192(** Connection to a JMAP mail server *)
1193type connection = {
1194 session: Jmap.Types.session;
1195 config: Jmap.Api.config;
1196}
1197
1198(** Convert JSON mail object to OCaml type *)
1199let mailbox_of_json json =
1200 try
1201 let open Ezjsonm in
1202 let id = get_string (find json ["id"]) in
1203 let name = get_string (find json ["name"]) in
1204 (* Handle parentId which can be null *)
1205 let parent_id =
1206 match find_opt json ["parentId"] with
1207 | Some (`Null) -> None
1208 | Some (`String s) -> Some s
1209 | None -> None
1210 | _ -> None
1211 in
1212 (* Handle role which might be null *)
1213 let role =
1214 match find_opt json ["role"] with
1215 | Some (`Null) -> None
1216 | Some (`String s) -> Some (Json.mailbox_role_of_string s)
1217 | None -> None
1218 | _ -> None
1219 in
1220 let sort_order = get_int (find json ["sortOrder"]) in
1221 let total_emails = get_int (find json ["totalEmails"]) in
1222 let unread_emails = get_int (find json ["unreadEmails"]) in
1223 let total_threads = get_int (find json ["totalThreads"]) in
1224 let unread_threads = get_int (find json ["unreadThreads"]) in
1225 let is_subscribed = get_bool (find json ["isSubscribed"]) in
1226 let rights_json = find json ["myRights"] in
1227 let my_rights = {
1228 Types.may_read_items = get_bool (find rights_json ["mayReadItems"]);
1229 may_add_items = get_bool (find rights_json ["mayAddItems"]);
1230 may_remove_items = get_bool (find rights_json ["mayRemoveItems"]);
1231 may_set_seen = get_bool (find rights_json ["maySetSeen"]);
1232 may_set_keywords = get_bool (find rights_json ["maySetKeywords"]);
1233 may_create_child = get_bool (find rights_json ["mayCreateChild"]);
1234 may_rename = get_bool (find rights_json ["mayRename"]);
1235 may_delete = get_bool (find rights_json ["mayDelete"]);
1236 may_submit = get_bool (find rights_json ["maySubmit"]);
1237 } in
1238 let result = {
1239 Types.id;
1240 name;
1241 parent_id;
1242 role;
1243 sort_order;
1244 total_emails;
1245 unread_emails;
1246 total_threads;
1247 unread_threads;
1248 is_subscribed;
1249 my_rights;
1250 } in
1251 Ok (result)
1252 with
1253 | Not_found ->
1254 Error (Parse_error "Required field not found in mailbox object")
1255 | Invalid_argument msg ->
1256 Error (Parse_error msg)
1257 | e ->
1258 Error (Parse_error (Printexc.to_string e))
1259
1260(** Convert JSON email object to OCaml type *)
1261let email_of_json json =
1262 try
1263 let open Ezjsonm in
1264
1265 let id = get_string (find json ["id"]) in
1266 let blob_id = get_string (find json ["blobId"]) in
1267 let thread_id = get_string (find json ["threadId"]) in
1268
1269 (* Process mailboxIds map *)
1270 let mailbox_ids_json = find json ["mailboxIds"] in
1271 let mailbox_ids = match mailbox_ids_json with
1272 | `O items -> List.map (fun (id, v) -> (id, get_bool v)) items
1273 | _ -> raise (Invalid_argument "mailboxIds is not an object")
1274 in
1275
1276 (* Process keywords map *)
1277 let keywords_json = find json ["keywords"] in
1278 let keywords = match keywords_json with
1279 | `O items -> List.map (fun (k, v) ->
1280 (Json.keyword_of_string k, get_bool v)) items
1281 | _ -> raise (Invalid_argument "keywords is not an object")
1282 in
1283
1284 let size = get_int (find json ["size"]) in
1285 let received_at = get_string (find json ["receivedAt"]) in
1286
1287 (* Handle messageId which might be an array or missing *)
1288 let message_id =
1289 match find_opt json ["messageId"] with
1290 | Some (`A ids) -> List.map (fun id ->
1291 match id with
1292 | `String s -> s
1293 | _ -> raise (Invalid_argument "messageId item is not a string")
1294 ) ids
1295 | Some (`String s) -> [s] (* Handle single string case *)
1296 | None -> [] (* Handle missing case *)
1297 | _ -> raise (Invalid_argument "messageId has unexpected type")
1298 in
1299
1300 (* Parse optional fields *)
1301 let parse_email_addresses opt_json =
1302 match opt_json with
1303 | Some (`A items) ->
1304 Some (List.map (fun addr_json ->
1305 let name =
1306 match find_opt addr_json ["name"] with
1307 | Some (`String s) -> Some s
1308 | Some (`Null) -> None
1309 | None -> None
1310 | _ -> None
1311 in
1312 let email = get_string (find addr_json ["email"]) in
1313 let parameters =
1314 match find_opt addr_json ["parameters"] with
1315 | Some (`O items) -> List.map (fun (k, v) ->
1316 match v with
1317 | `String s -> (k, s)
1318 | _ -> (k, "")
1319 ) items
1320 | _ -> []
1321 in
1322 { Types.name; email; parameters }
1323 ) items)
1324 | _ -> None
1325 in
1326
1327 (* Handle optional string arrays with null handling *)
1328 let parse_string_array_opt field_name =
1329 match find_opt json [field_name] with
1330 | Some (`A ids) ->
1331 Some (List.filter_map (function
1332 | `String s -> Some s
1333 | _ -> None
1334 ) ids)
1335 | Some (`Null) -> None
1336 | None -> None
1337 | _ -> None
1338 in
1339
1340 let in_reply_to = parse_string_array_opt "inReplyTo" in
1341 let references = parse_string_array_opt "references" in
1342
1343 let sender = parse_email_addresses (find_opt json ["sender"]) in
1344 let from = parse_email_addresses (find_opt json ["from"]) in
1345 let to_ = parse_email_addresses (find_opt json ["to"]) in
1346 let cc = parse_email_addresses (find_opt json ["cc"]) in
1347 let bcc = parse_email_addresses (find_opt json ["bcc"]) in
1348 let reply_to = parse_email_addresses (find_opt json ["replyTo"]) in
1349
1350 (* Handle optional string fields with null handling *)
1351 let parse_string_opt field_name =
1352 match find_opt json [field_name] with
1353 | Some (`String s) -> Some s
1354 | Some (`Null) -> None
1355 | None -> None
1356 | _ -> None
1357 in
1358
1359 let subject = parse_string_opt "subject" in
1360 let sent_at = parse_string_opt "sentAt" in
1361
1362 (* Handle optional boolean fields with null handling *)
1363 let parse_bool_opt field_name =
1364 match find_opt json [field_name] with
1365 | Some (`Bool b) -> Some b
1366 | Some (`Null) -> None
1367 | None -> None
1368 | _ -> None
1369 in
1370
1371 let has_attachment = parse_bool_opt "hasAttachment" in
1372 let preview = parse_string_opt "preview" in
1373
1374 (* TODO Body parts parsing would go here - omitting for brevity *)
1375 Ok ({
1376 Types.id;
1377 blob_id;
1378 thread_id;
1379 mailbox_ids;
1380 keywords;
1381 size;
1382 received_at;
1383 message_id;
1384 in_reply_to;
1385 references;
1386 sender;
1387 from;
1388 to_;
1389 cc;
1390 bcc;
1391 reply_to;
1392 subject;
1393 sent_at;
1394 has_attachment;
1395 preview;
1396 body_values = None;
1397 text_body = None;
1398 html_body = None;
1399 attachments = None;
1400 headers = None;
1401 })
1402 with
1403 | Not_found ->
1404 Error (Parse_error "Required field not found in email object")
1405 | Invalid_argument msg ->
1406 Error (Parse_error msg)
1407 | e ->
1408 Error (Parse_error (Printexc.to_string e))
1409
1410(** Login to a JMAP server and establish a connection
1411 @param uri The URI of the JMAP server
1412 @param credentials Authentication credentials
1413 @return A connection object if successful
1414
1415 TODO:claude *)
1416let login ~uri ~credentials =
1417 let* session_result = get_session (Uri.of_string uri)
1418 ~username:credentials.username
1419 ~authentication_token:credentials.password
1420 () in
1421 match session_result with
1422 | Ok session ->
1423 let api_uri = Uri.of_string session.api_url in
1424 let config = {
1425 api_uri;
1426 username = credentials.username;
1427 authentication_token = credentials.password;
1428 } in
1429 Lwt.return (Ok { session; config })
1430 | Error e -> Lwt.return (Error e)
1431
1432(** Login to a JMAP server using an API token
1433 @param uri The URI of the JMAP server
1434 @param api_token The API token for authentication
1435 @return A connection object if successful
1436
1437 TODO:claude *)
1438let login_with_token ~uri ~api_token =
1439 let* session_result = get_session (Uri.of_string uri)
1440 ~api_token
1441 () in
1442 match session_result with
1443 | Ok session ->
1444 let api_uri = Uri.of_string session.api_url in
1445 let config = {
1446 api_uri;
1447 username = ""; (* Empty username indicates we're using token auth *)
1448 authentication_token = api_token;
1449 } in
1450 Lwt.return (Ok { session; config })
1451 | Error e -> Lwt.return (Error e)
1452
1453(** Get all mailboxes for an account
1454 @param conn The JMAP connection
1455 @param account_id The account ID to get mailboxes for
1456 @return A list of mailboxes if successful
1457
1458 TODO:claude *)
1459let get_mailboxes conn ~account_id =
1460 let request = {
1461 using = [
1462 Jmap.Capability.to_string Jmap.Capability.Core;
1463 Capability.to_string Capability.Mail
1464 ];
1465 method_calls = [
1466 {
1467 name = "Mailbox/get";
1468 arguments = `O [
1469 ("accountId", `String account_id);
1470 ];
1471 method_call_id = "m1";
1472 }
1473 ];
1474 created_ids = None;
1475 } in
1476
1477 let* response_result = make_request conn.config request in
1478 match response_result with
1479 | Ok response ->
1480 let result =
1481 try
1482 let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1483 inv.name = "Mailbox/get") response.method_responses in
1484 let args = method_response.arguments in
1485 match Ezjsonm.find_opt args ["list"] with
1486 | Some (`A mailbox_list) ->
1487 let parse_results = List.map mailbox_of_json mailbox_list in
1488 let (successes, failures) = List.partition Result.is_ok parse_results in
1489 if List.length failures > 0 then
1490 Error (Parse_error "Failed to parse some mailboxes")
1491 else
1492 Ok (List.map Result.get_ok successes)
1493 | _ -> Error (Parse_error "Mailbox list not found in response")
1494 with
1495 | Not_found -> Error (Parse_error "Mailbox/get method response not found")
1496 | e -> Error (Parse_error (Printexc.to_string e))
1497 in
1498 Lwt.return result
1499 | Error e -> Lwt.return (Error e)
1500
1501(** Get a specific mailbox by ID
1502 @param conn The JMAP connection
1503 @param account_id The account ID
1504 @param mailbox_id The mailbox ID to retrieve
1505 @return The mailbox if found
1506
1507 TODO:claude *)
1508let get_mailbox conn ~account_id ~mailbox_id =
1509 let request = {
1510 using = [
1511 Jmap.Capability.to_string Jmap.Capability.Core;
1512 Capability.to_string Capability.Mail
1513 ];
1514 method_calls = [
1515 {
1516 name = "Mailbox/get";
1517 arguments = `O [
1518 ("accountId", `String account_id);
1519 ("ids", `A [`String mailbox_id]);
1520 ];
1521 method_call_id = "m1";
1522 }
1523 ];
1524 created_ids = None;
1525 } in
1526
1527 let* response_result = make_request conn.config request in
1528 match response_result with
1529 | Ok response ->
1530 let result =
1531 try
1532 let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1533 inv.name = "Mailbox/get") response.method_responses in
1534 let args = method_response.arguments in
1535 match Ezjsonm.find_opt args ["list"] with
1536 | Some (`A [mailbox]) -> mailbox_of_json mailbox
1537 | Some (`A []) -> Error (Parse_error ("Mailbox not found: " ^ mailbox_id))
1538 | _ -> Error (Parse_error "Expected single mailbox in response")
1539 with
1540 | Not_found -> Error (Parse_error "Mailbox/get method response not found")
1541 | e -> Error (Parse_error (Printexc.to_string e))
1542 in
1543 Lwt.return result
1544 | Error e -> Lwt.return (Error e)
1545
1546(** Get messages in a mailbox
1547 @param conn The JMAP connection
1548 @param account_id The account ID
1549 @param mailbox_id The mailbox ID to get messages from
1550 @param limit Optional limit on number of messages to return
1551 @return The list of email messages if successful
1552
1553 TODO:claude *)
1554let get_messages_in_mailbox conn ~account_id ~mailbox_id ?limit () =
1555 (* First query the emails in the mailbox *)
1556 let query_request = {
1557 using = [
1558 Jmap.Capability.to_string Jmap.Capability.Core;
1559 Capability.to_string Capability.Mail
1560 ];
1561 method_calls = [
1562 {
1563 name = "Email/query";
1564 arguments = `O ([
1565 ("accountId", `String account_id);
1566 ("filter", `O [("inMailbox", `String mailbox_id)]);
1567 ("sort", `A [`O [("property", `String "receivedAt"); ("isAscending", `Bool false)]]);
1568 ] @ (match limit with
1569 | Some l -> [("limit", `Float (float_of_int l))]
1570 | None -> []
1571 ));
1572 method_call_id = "q1";
1573 }
1574 ];
1575 created_ids = None;
1576 } in
1577
1578 let* query_result = make_request conn.config query_request in
1579 match query_result with
1580 | Ok query_response ->
1581 (try
1582 let query_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1583 inv.name = "Email/query") query_response.method_responses in
1584 let args = query_method.arguments in
1585 match Ezjsonm.find_opt args ["ids"] with
1586 | Some (`A ids) ->
1587 let email_ids = List.map (function
1588 | `String id -> id
1589 | _ -> raise (Invalid_argument "Email ID is not a string")
1590 ) ids in
1591
1592 (* If we have IDs, fetch the actual email objects *)
1593 if List.length email_ids > 0 then
1594 let get_request = {
1595 using = [
1596 Jmap.Capability.to_string Jmap.Capability.Core;
1597 Capability.to_string Capability.Mail
1598 ];
1599 method_calls = [
1600 {
1601 name = "Email/get";
1602 arguments = `O [
1603 ("accountId", `String account_id);
1604 ("ids", `A (List.map (fun id -> `String id) email_ids));
1605 ];
1606 method_call_id = "g1";
1607 }
1608 ];
1609 created_ids = None;
1610 } in
1611
1612 let* get_result = make_request conn.config get_request in
1613 match get_result with
1614 | Ok get_response ->
1615 (try
1616 let get_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1617 inv.name = "Email/get") get_response.method_responses in
1618 let args = get_method.arguments in
1619 match Ezjsonm.find_opt args ["list"] with
1620 | Some (`A email_list) ->
1621 let parse_results = List.map email_of_json email_list in
1622 let (successes, failures) = List.partition Result.is_ok parse_results in
1623 if List.length failures > 0 then
1624 Lwt.return (Error (Parse_error "Failed to parse some emails"))
1625 else
1626 Lwt.return (Ok (List.map Result.get_ok successes))
1627 | _ -> Lwt.return (Error (Parse_error "Email list not found in response"))
1628 with
1629 | Not_found -> Lwt.return (Error (Parse_error "Email/get method response not found"))
1630 | e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1631 | Error e -> Lwt.return (Error e)
1632 else
1633 (* No emails in mailbox *)
1634 Lwt.return (Ok [])
1635
1636 | _ -> Lwt.return (Error (Parse_error "Email IDs not found in query response"))
1637 with
1638 | Not_found -> Lwt.return (Error (Parse_error "Email/query method response not found"))
1639 | Invalid_argument msg -> Lwt.return (Error (Parse_error msg))
1640 | e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1641 | Error e -> Lwt.return (Error e)
1642
1643(** Get a single email message by ID
1644 @param conn The JMAP connection
1645 @param account_id The account ID
1646 @param email_id The email ID to retrieve
1647 @return The email message if found
1648
1649 TODO:claude *)
1650let get_email conn ~account_id ~email_id =
1651 let request = {
1652 using = [
1653 Jmap.Capability.to_string Jmap.Capability.Core;
1654 Capability.to_string Capability.Mail
1655 ];
1656 method_calls = [
1657 {
1658 name = "Email/get";
1659 arguments = `O [
1660 ("accountId", `String account_id);
1661 ("ids", `A [`String email_id]);
1662 ];
1663 method_call_id = "m1";
1664 }
1665 ];
1666 created_ids = None;
1667 } in
1668
1669 let* response_result = make_request conn.config request in
1670 match response_result with
1671 | Ok response ->
1672 let result =
1673 try
1674 let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1675 inv.name = "Email/get") response.method_responses in
1676 let args = method_response.arguments in
1677 match Ezjsonm.find_opt args ["list"] with
1678 | Some (`A [email]) -> email_of_json email
1679 | Some (`A []) -> Error (Parse_error ("Email not found: " ^ email_id))
1680 | _ -> Error (Parse_error "Expected single email in response")
1681 with
1682 | Not_found -> Error (Parse_error "Email/get method response not found")
1683 | e -> Error (Parse_error (Printexc.to_string e))
1684 in
1685 Lwt.return result
1686 | Error e -> Lwt.return (Error e)
1687
1688(** Helper functions for working with message flags and mailbox attributes *)
1689
1690(** Check if an email has a specific message keyword
1691 @param email The email to check
1692 @param keyword The message keyword to look for
1693 @return true if the email has the keyword, false otherwise
1694
1695 TODO:claude *)
1696let has_message_keyword (email:Types.email) keyword =
1697 let open Types in
1698 let keyword_string = string_of_message_keyword keyword in
1699 List.exists (function
1700 | (Custom s, true) when s = keyword_string -> true
1701 | _ -> false
1702 ) email.keywords
1703
1704(** Add a message keyword to an email
1705 @param conn The JMAP connection
1706 @param account_id The account ID
1707 @param email_id The email ID
1708 @param keyword The message keyword to add
1709 @return Success or error
1710
1711 TODO:claude *)
1712let add_message_keyword conn ~account_id ~email_id ~keyword =
1713 let keyword_string = Types.string_of_message_keyword keyword in
1714
1715 let request = {
1716 using = [
1717 Jmap.Capability.to_string Jmap.Capability.Core;
1718 Capability.to_string Capability.Mail
1719 ];
1720 method_calls = [
1721 {
1722 name = "Email/set";
1723 arguments = `O [
1724 ("accountId", `String account_id);
1725 ("update", `O [
1726 (email_id, `O [
1727 ("keywords", `O [
1728 (keyword_string, `Bool true)
1729 ])
1730 ])
1731 ]);
1732 ];
1733 method_call_id = "m1";
1734 }
1735 ];
1736 created_ids = None;
1737 } in
1738
1739 let* response_result = make_request conn.config request in
1740 match response_result with
1741 | Ok response ->
1742 let result =
1743 try
1744 let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1745 inv.name = "Email/set") response.method_responses in
1746 let args = method_response.arguments in
1747 match Ezjsonm.find_opt args ["updated"] with
1748 | Some (`A _ids) -> Ok ()
1749 | _ ->
1750 match Ezjsonm.find_opt args ["notUpdated"] with
1751 | Some (`O _errors) ->
1752 Error (Parse_error ("Failed to update email: " ^ email_id))
1753 | _ -> Error (Parse_error "Unexpected response format")
1754 with
1755 | Not_found -> Error (Parse_error "Email/set method response not found")
1756 | e -> Error (Parse_error (Printexc.to_string e))
1757 in
1758 Lwt.return result
1759 | Error e -> Lwt.return (Error e)
1760
1761(** Set a flag color for an email
1762 @param conn The JMAP connection
1763 @param account_id The account ID
1764 @param email_id The email ID
1765 @param color The flag color to set
1766 @return Success or error
1767
1768 TODO:claude *)
1769let set_flag_color conn ~account_id ~email_id ~color =
1770 (* Get the bit pattern for the color *)
1771 let (bit0, bit1, bit2) = Types.bits_of_flag_color color in
1772
1773 (* Build the keywords update object *)
1774 let keywords = [
1775 ("$flagged", `Bool true);
1776 ("$MailFlagBit0", `Bool bit0);
1777 ("$MailFlagBit1", `Bool bit1);
1778 ("$MailFlagBit2", `Bool bit2);
1779 ] in
1780
1781 let request = {
1782 using = [
1783 Jmap.Capability.to_string Jmap.Capability.Core;
1784 Capability.to_string Capability.Mail
1785 ];
1786 method_calls = [
1787 {
1788 name = "Email/set";
1789 arguments = `O [
1790 ("accountId", `String account_id);
1791 ("update", `O [
1792 (email_id, `O [
1793 ("keywords", `O keywords)
1794 ])
1795 ]);
1796 ];
1797 method_call_id = "m1";
1798 }
1799 ];
1800 created_ids = None;
1801 } in
1802
1803 let* response_result = make_request conn.config request in
1804 match response_result with
1805 | Ok response ->
1806 let result =
1807 try
1808 let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1809 inv.name = "Email/set") response.method_responses in
1810 let args = method_response.arguments in
1811 match Ezjsonm.find_opt args ["updated"] with
1812 | Some (`A _ids) -> Ok ()
1813 | _ ->
1814 match Ezjsonm.find_opt args ["notUpdated"] with
1815 | Some (`O _errors) ->
1816 Error (Parse_error ("Failed to update email: " ^ email_id))
1817 | _ -> Error (Parse_error "Unexpected response format")
1818 with
1819 | Not_found -> Error (Parse_error "Email/set method response not found")
1820 | e -> Error (Parse_error (Printexc.to_string e))
1821 in
1822 Lwt.return result
1823 | Error e -> Lwt.return (Error e)
1824
1825(** Convert an email's keywords to typed message_keyword list
1826 @param email The email to analyze
1827 @return List of message keywords
1828
1829 TODO:claude *)
1830let get_message_keywords (email:Types.email) =
1831 let open Types in
1832 List.filter_map (function
1833 | (Custom s, true) -> Some (message_keyword_of_string s)
1834 | _ -> None
1835 ) email.keywords
1836
1837(** Get emails with a specific message keyword
1838 @param conn The JMAP connection
1839 @param account_id The account ID
1840 @param keyword The message keyword to search for
1841 @param limit Optional limit on number of emails to return
1842 @return List of emails with the keyword if successful
1843
1844 TODO:claude *)
1845let get_emails_with_keyword conn ~account_id ~keyword ?limit () =
1846 let keyword_string = Types.string_of_message_keyword keyword in
1847
1848 (* Query for emails with the specified keyword *)
1849 let query_request = {
1850 using = [
1851 Jmap.Capability.to_string Jmap.Capability.Core;
1852 Capability.to_string Capability.Mail
1853 ];
1854 method_calls = [
1855 {
1856 name = "Email/query";
1857 arguments = `O ([
1858 ("accountId", `String account_id);
1859 ("filter", `O [("hasKeyword", `String keyword_string)]);
1860 ("sort", `A [`O [("property", `String "receivedAt"); ("isAscending", `Bool false)]]);
1861 ] @ (match limit with
1862 | Some l -> [("limit", `Float (float_of_int l))]
1863 | None -> []
1864 ));
1865 method_call_id = "q1";
1866 }
1867 ];
1868 created_ids = None;
1869 } in
1870
1871 let* query_result = make_request conn.config query_request in
1872 match query_result with
1873 | Ok query_response ->
1874 (try
1875 let query_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1876 inv.name = "Email/query") query_response.method_responses in
1877 let args = query_method.arguments in
1878 match Ezjsonm.find_opt args ["ids"] with
1879 | Some (`A ids) ->
1880 let email_ids = List.map (function
1881 | `String id -> id
1882 | _ -> raise (Invalid_argument "Email ID is not a string")
1883 ) ids in
1884
1885 (* If we have IDs, fetch the actual email objects *)
1886 if List.length email_ids > 0 then
1887 let get_request = {
1888 using = [
1889 Jmap.Capability.to_string Jmap.Capability.Core;
1890 Capability.to_string Capability.Mail
1891 ];
1892 method_calls = [
1893 {
1894 name = "Email/get";
1895 arguments = `O [
1896 ("accountId", `String account_id);
1897 ("ids", `A (List.map (fun id -> `String id) email_ids));
1898 ];
1899 method_call_id = "g1";
1900 }
1901 ];
1902 created_ids = None;
1903 } in
1904
1905 let* get_result = make_request conn.config get_request in
1906 match get_result with
1907 | Ok get_response ->
1908 (try
1909 let get_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1910 inv.name = "Email/get") get_response.method_responses in
1911 let args = get_method.arguments in
1912 match Ezjsonm.find_opt args ["list"] with
1913 | Some (`A email_list) ->
1914 let parse_results = List.map email_of_json email_list in
1915 let (successes, failures) = List.partition Result.is_ok parse_results in
1916 if List.length failures > 0 then
1917 Lwt.return (Error (Parse_error "Failed to parse some emails"))
1918 else
1919 Lwt.return (Ok (List.map Result.get_ok successes))
1920 | _ -> Lwt.return (Error (Parse_error "Email list not found in response"))
1921 with
1922 | Not_found -> Lwt.return (Error (Parse_error "Email/get method response not found"))
1923 | e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1924 | Error e -> Lwt.return (Error e)
1925 else
1926 (* No emails with the keyword *)
1927 Lwt.return (Ok [])
1928
1929 | _ -> Lwt.return (Error (Parse_error "Email IDs not found in query response"))
1930 with
1931 | Not_found -> Lwt.return (Error (Parse_error "Email/query method response not found"))
1932 | Invalid_argument msg -> Lwt.return (Error (Parse_error msg))
1933 | e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1934 | Error e -> Lwt.return (Error e)
1935
1936(** {1 Email Address Utilities} *)
1937
1938(** Custom implementation of substring matching *)
1939let contains_substring str sub =
1940 try
1941 let _ = Str.search_forward (Str.regexp_string sub) str 0 in
1942 true
1943 with Not_found -> false
1944
1945(** Checks if a pattern with wildcards matches a string
1946 @param pattern Pattern string with * and ? wildcards
1947 @param str String to match against
1948 Based on simple recursive wildcard matching algorithm
1949*)
1950let matches_wildcard pattern str =
1951 let pattern_len = String.length pattern in
1952 let str_len = String.length str in
1953
1954 (* Convert both to lowercase for case-insensitive matching *)
1955 let pattern = String.lowercase_ascii pattern in
1956 let str = String.lowercase_ascii str in
1957
1958 (* If there are no wildcards, do a simple substring check *)
1959 if not (String.contains pattern '*' || String.contains pattern '?') then
1960 contains_substring str pattern
1961 else
1962 (* Classic recursive matching algorithm *)
1963 let rec match_from p_pos s_pos =
1964 (* Pattern matched to the end *)
1965 if p_pos = pattern_len then
1966 s_pos = str_len
1967 (* Star matches zero or more chars *)
1968 else if pattern.[p_pos] = '*' then
1969 match_from (p_pos + 1) s_pos || (* Match empty string *)
1970 (s_pos < str_len && match_from p_pos (s_pos + 1)) (* Match one more char *)
1971 (* If both have more chars and they match or ? wildcard *)
1972 else if s_pos < str_len &&
1973 (pattern.[p_pos] = '?' || pattern.[p_pos] = str.[s_pos]) then
1974 match_from (p_pos + 1) (s_pos + 1)
1975 else
1976 false
1977 in
1978
1979 match_from 0 0
1980
1981(** Check if an email address matches a filter string
1982 @param email The email address to check
1983 @param pattern The filter pattern to match against
1984 @return True if the email address matches the filter
1985*)
1986let email_address_matches email pattern =
1987 matches_wildcard pattern email
1988
1989(** Check if an email matches a sender filter
1990 @param email The email object to check
1991 @param pattern The sender filter pattern
1992 @return True if any sender address matches the filter
1993*)
1994let email_matches_sender (email : Types.email) pattern =
1995 (* Helper to extract emails from address list *)
1996 let addresses_match addrs =
1997 List.exists (fun (addr : Types.email_address) ->
1998 email_address_matches addr.email pattern
1999 ) addrs
2000 in
2001
2002 (* Check From addresses first *)
2003 let from_match =
2004 match email.Types.from with
2005 | Some addrs -> addresses_match addrs
2006 | None -> false
2007 in
2008
2009 (* If no match in From, check Sender field *)
2010 if from_match then true
2011 else
2012 match email.Types.sender with
2013 | Some addrs -> addresses_match addrs
2014 | None -> false