My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** Apple Mail Color Flag Support Implementation
2
3 Provides support for Apple Mail's color flag system using the three-bit
4 flag encoding defined in draft-ietf-mailmaint-messageflag.
5*)
6
7
8(** Apple Mail color flag enumeration *)
9type color =
10 | Red (** $MailFlagBit0 *)
11 | Orange (** $MailFlagBit1 *)
12 | Yellow (** $MailFlagBit2 *)
13 | Green (** $MailFlagBit0 + $MailFlagBit1 *)
14 | Blue (** $MailFlagBit0 + $MailFlagBit2 *)
15 | Purple (** $MailFlagBit1 + $MailFlagBit2 *)
16 | Gray (** $MailFlagBit0 + $MailFlagBit1 + $MailFlagBit2 *)
17 | None (** No color flags set *)
18
19(** Get the JMAP keyword list for a specific color *)
20let color_keywords = function
21 | Red -> [Keywords.MailFlagBit0]
22 | Orange -> [Keywords.MailFlagBit1]
23 | Yellow -> [Keywords.MailFlagBit2]
24 | Green -> [Keywords.MailFlagBit0; Keywords.MailFlagBit1]
25 | Blue -> [Keywords.MailFlagBit0; Keywords.MailFlagBit2]
26 | Purple -> [Keywords.MailFlagBit1; Keywords.MailFlagBit2]
27 | Gray -> [Keywords.MailFlagBit0; Keywords.MailFlagBit1; Keywords.MailFlagBit2]
28 | None -> []
29
30(** Convert keywords to color by analyzing flag bit presence *)
31let keywords_to_color keywords =
32 let has_bit0 = List.mem Keywords.MailFlagBit0 keywords in
33 let has_bit1 = List.mem Keywords.MailFlagBit1 keywords in
34 let has_bit2 = List.mem Keywords.MailFlagBit2 keywords in
35 match has_bit0, has_bit1, has_bit2 with
36 | true, false, false -> Red
37 | false, true, false -> Orange
38 | false, false, true -> Yellow
39 | true, true, false -> Green
40 | true, false, true -> Blue
41 | false, true, true -> Purple
42 | true, true, true -> Gray
43 | false, false, false -> None
44
45(** Get human-readable color name *)
46let color_name = function
47 | Red -> "Red"
48 | Orange -> "Orange"
49 | Yellow -> "Yellow"
50 | Green -> "Green"
51 | Blue -> "Blue"
52 | Purple -> "Purple"
53 | Gray -> "Gray"
54 | None -> "None"
55
56(** Create JMAP filter for a specific color *)
57let color_filter color =
58 let keywords = color_keywords color in
59 match keywords with
60 | [] ->
61 (* No color flags - create a filter that matches emails without any color flags *)
62 let bit0_filter = Jmap.Methods.Filter.operator `NOT
63 [Jmap.Methods.Filter.condition (`Assoc [("hasKeyword", `String "$MailFlagBit0")])] in
64 let bit1_filter = Jmap.Methods.Filter.operator `NOT
65 [Jmap.Methods.Filter.condition (`Assoc [("hasKeyword", `String "$MailFlagBit1")])] in
66 let bit2_filter = Jmap.Methods.Filter.operator `NOT
67 [Jmap.Methods.Filter.condition (`Assoc [("hasKeyword", `String "$MailFlagBit2")])] in
68 Jmap.Methods.Filter.operator `AND [bit0_filter; bit1_filter; bit2_filter]
69 | [single_keyword] ->
70 (* Single keyword filter *)
71 let keyword_str = Keywords.keyword_to_string single_keyword in
72 Jmap.Methods.Filter.condition (`Assoc [("hasKeyword", `String keyword_str)])
73 | multiple_keywords ->
74 (* Multiple keywords - create AND filter *)
75 let keyword_filters = List.map (fun kw ->
76 let keyword_str = Keywords.keyword_to_string kw in
77 Jmap.Methods.Filter.condition (`Assoc [("hasKeyword", `String keyword_str)])
78 ) multiple_keywords in
79 Jmap.Methods.Filter.operator `AND keyword_filters
80
81(** Generate patch operations to set a color *)
82let color_patch color =
83 let clear_patches = [
84 ("keywords/$MailFlagBit0", `Null);
85 ("keywords/$MailFlagBit1", `Null);
86 ("keywords/$MailFlagBit2", `Null);
87 ] in
88 let color_keywords = color_keywords color in
89 let set_patches = List.map (fun kw ->
90 let keyword_str = Keywords.keyword_to_string kw in
91 ("keywords/" ^ keyword_str, `Bool true)
92 ) color_keywords in
93 clear_patches @ set_patches
94
95(** Generate patch operations to clear all color flags *)
96let clear_color_patch () = [
97 ("keywords/$MailFlagBit0", `Null);
98 ("keywords/$MailFlagBit1", `Null);
99 ("keywords/$MailFlagBit2", `Null);
100]
101
102(* JSON serialization functions for JSONABLE interface *)
103let to_json = function
104 | Red -> `String "red"
105 | Orange -> `String "orange"
106 | Yellow -> `String "yellow"
107 | Green -> `String "green"
108 | Blue -> `String "blue"
109 | Purple -> `String "purple"
110 | Gray -> `String "gray"
111 | None -> `String "none"
112
113let of_json = function
114 | `String "red" -> Ok Red
115 | `String "orange" -> Ok Orange
116 | `String "yellow" -> Ok Yellow
117 | `String "green" -> Ok Green
118 | `String "blue" -> Ok Blue
119 | `String "purple" -> Ok Purple
120 | `String "gray" -> Ok Gray
121 | `String "none" -> Ok None
122 | `String other -> Error ("Unknown Apple Mail color: " ^ other)
123 | _ -> Error "Apple Mail color must be a JSON string"
124
125(* Pretty-printing functions for PRINTABLE interface *)
126let pp ppf color = Format.fprintf ppf "%s" (color_name color)
127
128let pp_hum = pp
129
130(* Vendor extension functions for VENDOR_EXTENSION interface *)
131let vendor () = "com.apple.mail"
132
133let extension_name () = "Color Flags"
134
135let capability_uri () = Some "urn:ietf:params:jmap:mail:apple:flags"
136
137let is_experimental () = false