My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** Email object implementation.
2
3 This module implements the main Email object type and operations as specified in
4 RFC 8621 Section 4.1. It provides comprehensive email handling with property-based
5 access, JSON serialization, and patch operations for modifications.
6
7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1> RFC 8621, Section 4.1
8*)
9
10[@@@warning "-32"] (* Suppress unused value warnings for interface-required functions *)
11
12(** Email field validation functions according to RFC 8621 *)
13module Validation = struct
14 (** Validate Message-ID format according to RFC 5322.
15 Message-ID must be enclosed in angle brackets and follow addr-spec rules
16 with restrictions: only dot-atom-text on left side, no CFWS allowed. *)
17 let is_valid_message_id (msg_id : string) : bool =
18 let len = String.length msg_id in
19 if len < 3 then false else
20 if msg_id.[0] != '<' || msg_id.[len-1] != '>' then false else
21 let content = String.sub msg_id 1 (len - 2) in
22 (* Check for required @ symbol *)
23 match String.index_opt content '@' with
24 | None -> false
25 | Some at_pos ->
26 if at_pos = 0 || at_pos = String.length content - 1 then false else
27 let local_part = String.sub content 0 at_pos in
28 let domain_part = String.sub content (at_pos + 1) (String.length content - at_pos - 1) in
29 (* Validate local part: only dot-atom-text allowed *)
30 let is_valid_dot_atom_char c =
31 (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') ||
32 c = '!' || c = '#' || c = '$' || c = '%' || c = '&' || c = '\'' ||
33 c = '*' || c = '+' || c = '-' || c = '/' || c = '=' || c = '?' ||
34 c = '^' || c = '_' || c = '`' || c = '{' || c = '|' || c = '}' || c = '~'
35 in
36 let is_valid_local_part s =
37 if String.length s = 0 || s.[0] = '.' || s.[String.length s - 1] = '.' then false else
38 let has_consecutive_dots = ref false in
39 for i = 0 to String.length s - 2 do
40 if s.[i] = '.' && s.[i+1] = '.' then has_consecutive_dots := true
41 done;
42 if !has_consecutive_dots then false else
43 String.for_all (fun c -> c = '.' || is_valid_dot_atom_char c) s
44 in
45 let is_valid_domain s =
46 String.length s > 0 && String.for_all (fun c ->
47 (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') ||
48 (c >= '0' && c <= '9') || c = '.' || c = '-'
49 ) s && not (s.[0] = '.' || s.[String.length s - 1] = '.')
50 in
51 is_valid_local_part local_part && is_valid_domain domain_part
52
53 (** Validate keyword format according to RFC 8621 *)
54 let is_valid_keyword (keyword : string) : bool =
55 let len = String.length keyword in
56 if len = 0 || len > 255 then false else
57 let is_forbidden_char c =
58 c = '(' || c = ')' || c = '{' || c = ']' || c = '%' ||
59 c = '*' || c = '"' || c = '\\' || c <= ' ' || c > '~'
60 in
61 not (String.exists is_forbidden_char keyword) &&
62 String.for_all (fun c -> c >= '!' && c <= '~') keyword
63
64 (** Validate that all mailbox ID values are true according to RFC 8621 *)
65 let validate_mailbox_ids (mailbox_ids : (Jmap.Id.t, bool) Hashtbl.t) : (unit, string) result =
66 let all_true = Hashtbl.fold (fun _id value acc -> acc && value) mailbox_ids true in
67 if all_true then Ok () else Error "All mailboxIds values must be true"
68
69 (** Validate keywords hashtable according to RFC 8621 *)
70 let validate_keywords (keywords : (string, bool) Hashtbl.t) : (unit, string) result =
71 let errors = ref [] in
72 Hashtbl.iter (fun keyword value ->
73 if not value then
74 errors := (Printf.sprintf "Keyword '%s' value must be true" keyword) :: !errors;
75 if not (is_valid_keyword keyword) then
76 errors := (Printf.sprintf "Invalid keyword format: '%s'" keyword) :: !errors
77 ) keywords;
78 match !errors with
79 | [] -> Ok ()
80 | errs -> Error (String.concat "; " errs)
81
82 (** Validate message ID list with Message-ID format checking *)
83 let validate_message_id_list (msg_ids : string list option) : (unit, string) result =
84 match msg_ids with
85 | None -> Ok ()
86 | Some ids ->
87 let invalid_ids = List.filter (fun id -> not (is_valid_message_id id)) ids in
88 if invalid_ids = [] then Ok ()
89 else Error (Printf.sprintf "Invalid Message-ID format: %s" (String.concat ", " invalid_ids))
90
91 (** Validate email size constraints *)
92 let validate_size (size : Jmap.UInt.t option) : (unit, string) result =
93 match size with
94 | None -> Ok ()
95 | Some s ->
96 let size_val = Jmap.UInt.to_int s in
97 if size_val >= 0 then Ok ()
98 else Error "Email size must be non-negative"
99end
100
101(** JSON parsing combinators for cleaner field extraction *)
102module Json = struct
103 (** Extract a field from JSON object fields list *)
104 let field (name : string) (fields : (string * Yojson.Safe.t) list) : Yojson.Safe.t option =
105 List.assoc_opt name fields
106
107 (** Parse string field *)
108 let string (name : string) (fields : (string * Yojson.Safe.t) list) : string option =
109 match field name fields with
110 | Some (`String s) -> Some s
111 | _ -> None
112
113 (** Parse integer field *)
114 let int (name : string) (fields : (string * Yojson.Safe.t) list) : int option =
115 match field name fields with
116 | Some (`Int i) -> Some i
117 | _ -> None
118
119 (** Parse boolean field *)
120 let bool (name : string) (fields : (string * Yojson.Safe.t) list) : bool option =
121 match field name fields with
122 | Some (`Bool b) -> Some b
123 | _ -> None
124
125 (** Parse list field with element parser *)
126 let list (element_parser : Yojson.Safe.t -> 'a option) (name : string) (fields : (string * Yojson.Safe.t) list) : 'a list option =
127 match field name fields with
128 | Some (`List items) ->
129 let parsed = List.filter_map element_parser items in
130 if parsed <> [] then Some parsed else None
131 | _ -> None
132
133 (** Parse string list field *)
134 let string_list (name : string) (fields : (string * Yojson.Safe.t) list) : string list option =
135 list (function `String s -> Some s | _ -> None) name fields
136
137 (** Parse ISO 8601 Jmap.Date.t field to Unix timestamp *)
138 let iso_date (name : string) (fields : (string * Yojson.Safe.t) list) : float option =
139 match string name fields with
140 | Some s ->
141 (try
142 let tm = Scanf.sscanf s "%04d-%02d-%02dT%02d:%02d:%02dZ"
143 (fun y m d h min sec ->
144 {Unix.tm_year = y - 1900; tm_mon = m - 1; tm_mday = d;
145 tm_hour = h; tm_min = min; tm_sec = sec; tm_wday = 0;
146 tm_yday = 0; tm_isdst = false}) in
147 Some (fst (Unix.mktime tm))
148 with _ -> None)
149 | None -> None
150
151 (** Parse email address from JSON object *)
152 let email_address (json : Yojson.Safe.t) : Address.t option =
153 match json with
154 | `Assoc addr_fields ->
155 let email = string "email" addr_fields in
156 let name = string "name" addr_fields in
157 (match email with
158 | Some e when e <> "" -> Some (Address.create_unsafe ~email:e ?name ())
159 | _ -> None)
160 | _ -> None
161
162 (** Parse email address list field *)
163 let email_address_list (name : string) (fields : (string * Yojson.Safe.t) list) : Address.t list option =
164 list email_address name fields
165
166 (** Parse object field as hashtable *)
167 let object_map (value_parser : Yojson.Safe.t -> 'a option) (name : string) (fields : (string * Yojson.Safe.t) list) : (string, 'a) Hashtbl.t option =
168 match field name fields with
169 | Some (`Assoc obj_fields) ->
170 let tbl = Hashtbl.create (List.length obj_fields) in
171 let success = List.for_all (fun (key, value) ->
172 match value_parser value with
173 | Some parsed_value ->
174 Hashtbl.add tbl key parsed_value;
175 true
176 | None -> false
177 ) obj_fields in
178 if success && Hashtbl.length tbl > 0 then Some tbl else None
179 | _ -> None
180
181 (** Parse string-to-string map *)
182 let string_map (name : string) (fields : (string * Yojson.Safe.t) list) : (string, string) Hashtbl.t option =
183 object_map (function `String s -> Some s | _ -> None) name fields
184
185 (** Parse string-to-bool map (for mailboxIds) *)
186 let bool_map (name : string) (fields : (string * Yojson.Safe.t) list) : (string, bool) Hashtbl.t option =
187 object_map (function `Bool b -> Some b | _ -> None) name fields
188end
189
190type t = {
191 id : Jmap.Id.t option;
192 blob_id : Jmap.Id.t option;
193 thread_id : Jmap.Id.t option;
194 mailbox_ids : (Jmap.Id.t, bool) Hashtbl.t option;
195 keywords : Keywords.t option;
196 size : Jmap.UInt.t option;
197 received_at : Jmap.Date.t option;
198 message_id : string list option;
199 in_reply_to : string list option;
200 references : string list option;
201 sender : Address.t option;
202 from : Address.t list option;
203 to_ : Address.t list option;
204 cc : Address.t list option;
205 bcc : Address.t list option;
206 reply_to : Address.t list option;
207 subject : string option;
208 sent_at : Jmap.Date.t option;
209 has_attachment : bool option;
210 preview : string option;
211 body_structure : Body.t option;
212 body_values : (string, Body.Value.t) Hashtbl.t option;
213 text_body : Body.t list option;
214 html_body : Body.t list option;
215 attachments : Body.t list option;
216 headers : (string, string) Hashtbl.t option;
217 other_properties : (string, Yojson.Safe.t) Hashtbl.t;
218}
219
220(* Accessor functions *)
221let id t = t.id
222let blob_id t = t.blob_id
223let thread_id t = t.thread_id
224let mailbox_ids t = t.mailbox_ids
225let keywords t = t.keywords
226let size t = t.size
227let received_at t = t.received_at
228let message_id t = t.message_id
229let in_reply_to t = t.in_reply_to
230let references t = t.references
231let sender t = t.sender
232let from t = t.from
233let to_ t = t.to_
234let cc t = t.cc
235let bcc t = t.bcc
236let reply_to t = t.reply_to
237let subject t = t.subject
238let sent_at t = t.sent_at
239let has_attachment t = t.has_attachment
240let preview t = t.preview
241let body_structure t = t.body_structure
242let body_values t = t.body_values
243let text_body t = t.text_body
244let html_body t = t.html_body
245let attachments t = t.attachments
246
247let header t name =
248 match t.headers with
249 | Some headers -> Hashtbl.find_opt headers name
250 | None -> None
251
252(** Enhanced header access functions using structured parsing **)
253
254(** Get header as structured Header.t objects *)
255let headers_as_structured t : Header.t list =
256 match t.headers with
257 | Some headers ->
258 Hashtbl.fold (fun name value acc ->
259 let header = Header.create_unsafe ~name ~value () in
260 header :: acc
261 ) headers []
262 | None -> []
263
264(** Get specific header field as structured Header.t *)
265let get_header_field t name : Header.t option =
266 match t.headers with
267 | Some headers ->
268 (match Hashtbl.find_opt headers name with
269 | Some value -> Some (Header.create_unsafe ~name ~value ())
270 | None -> None)
271 | None -> None
272
273(** Get header using JMAP access patterns *)
274let get_header_as_text t name : string option =
275 match get_header_field t name with
276 | Some header -> Header.find_and_parse_as_text [header] name
277 | None -> None
278
279let get_header_as_addresses t name : Address.t list option =
280 match get_header_field t name with
281 | Some header -> Header.find_and_parse_as_addresses [header] name
282 | None -> None
283
284let get_header_as_message_ids t name : string list option =
285 match get_header_field t name with
286 | Some header -> Header.find_and_parse_as_message_ids [header] name
287 | None -> None
288
289let get_header_as_date t name : Jmap.Date.t option =
290 match get_header_field t name with
291 | Some header -> Header.find_and_parse_as_date [header] name
292 | None -> None
293
294(** Convenience functions for common header access patterns *)
295
296(** Get From header addresses using structured parsing *)
297let get_from_addresses t : Address.t list =
298 match get_header_as_addresses t "from" with
299 | Some addrs -> addrs
300 | None -> match t.from with Some addrs -> addrs | None -> []
301
302(** Get To header addresses using structured parsing *)
303let get_to_addresses t : Address.t list =
304 match get_header_as_addresses t "to" with
305 | Some addrs -> addrs
306 | None -> match t.to_ with Some addrs -> addrs | None -> []
307
308(** Get Subject header text using structured parsing *)
309let get_subject_text t : string option =
310 match get_header_as_text t "subject" with
311 | Some text -> Some text
312 | None -> t.subject
313
314(** Get Message-ID header *)
315let get_message_id t : string list =
316 match get_header_as_message_ids t "message-id" with
317 | Some ids -> ids
318 | None -> match t.message_id with Some ids -> ids | None -> []
319
320(** Get In-Reply-To header *)
321let get_in_reply_to t : string list =
322 match get_header_as_message_ids t "in-reply-to" with
323 | Some ids -> ids
324 | None -> match t.in_reply_to with Some ids -> ids | None -> []
325
326(** Get References header *)
327let get_references t : string list =
328 match get_header_as_message_ids t "references" with
329 | Some ids -> ids
330 | None -> match t.references with Some ids -> ids | None -> []
331
332(** Get Date header using structured parsing *)
333let get_date t : Jmap.Date.t option =
334 match get_header_as_date t "date" with
335 | Some date -> Some date
336 | None -> t.sent_at
337
338let other_properties t = t.other_properties
339
340(* JMAP_OBJECT signature implementations *)
341
342(* Create a minimal valid email object with only required fields *)
343let create ?id () =
344 {
345 id; blob_id = None; thread_id = None; mailbox_ids = None; keywords = None;
346 size = None; received_at = None; message_id = None; in_reply_to = None;
347 references = None; sender = None; from = None; to_ = None; cc = None;
348 bcc = None; reply_to = None; subject = None; sent_at = None;
349 has_attachment = None; preview = None; body_structure = None;
350 body_values = None; text_body = None; html_body = None; attachments = None;
351 headers = None; other_properties = Hashtbl.create 0;
352 }
353
354(* Get list of all valid property names for Email objects *)
355let valid_properties () = [
356 "id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; "size"; "receivedAt";
357 "messageId"; "inReplyTo"; "references"; "sender"; "from"; "to"; "cc"; "bcc";
358 "replyTo"; "subject"; "sentAt"; "hasAttachment"; "preview"; "bodyStructure";
359 "bodyValues"; "textBody"; "htmlBody"; "attachments"; "headers"
360]
361
362(** Enhanced validation function for complete Email objects *)
363let validate (email : t) : (unit, string) result =
364 let errors = ref [] in
365
366 (* Validate mailbox_ids *)
367 (match email.mailbox_ids with
368 | Some mids ->
369 (match Validation.validate_mailbox_ids mids with
370 | Ok () -> ()
371 | Error msg -> errors := msg :: !errors)
372 | None -> ());
373
374 (* Validate size *)
375 (match Validation.validate_size email.size with
376 | Ok () -> ()
377 | Error msg -> errors := msg :: !errors);
378
379 (* Validate message ID fields *)
380 (match Validation.validate_message_id_list email.message_id with
381 | Ok () -> ()
382 | Error msg -> errors := ("messageId: " ^ msg) :: !errors);
383 (match Validation.validate_message_id_list email.in_reply_to with
384 | Ok () -> ()
385 | Error msg -> errors := ("inReplyTo: " ^ msg) :: !errors);
386 (match Validation.validate_message_id_list email.references with
387 | Ok () -> ()
388 | Error msg -> errors := ("references: " ^ msg) :: !errors);
389
390 match !errors with
391 | [] -> Ok ()
392 | errs -> Error (String.concat "; " errs)
393
394(* Serialize to JSON with only specified properties *)
395let to_json_with_properties ~properties t =
396 let all_fields = [
397 ("id", (match t.id with Some id_t -> `String (Jmap.Id.to_string id_t) | None -> `Null));
398 ("blobId", (match t.blob_id with Some id_t -> `String (Jmap.Id.to_string id_t) | None -> `Null));
399 ("threadId", (match t.thread_id with Some id_t -> `String (Jmap.Id.to_string id_t) | None -> `Null));
400 ("subject", (match t.subject with Some s -> `String s | None -> `Null));
401 ("size", (match t.size with Some i -> `Int i | None -> `Null));
402 (* Add more fields as needed - this is a simplified implementation *)
403 ] in
404 let filtered_fields = List.filter (fun (name, _) ->
405 List.mem name properties
406 ) all_fields in
407 let non_null_fields = List.filter (fun (_, value) ->
408 value <> `Null
409 ) filtered_fields in
410 `Assoc non_null_fields
411
412(* Extended create function with all properties *)
413let create_full ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at
414 ?message_id ?in_reply_to ?references ?sender ?from ?to_ ?cc ?bcc
415 ?reply_to ?subject ?sent_at ?has_attachment ?preview ?body_structure
416 ?body_values ?text_body ?html_body ?attachments ?headers
417 ?(other_properties = Hashtbl.create 0) () =
418 {
419 id; blob_id; thread_id; mailbox_ids; keywords; size; received_at;
420 message_id; in_reply_to; references; sender; from; to_; cc; bcc;
421 reply_to; subject; sent_at; has_attachment; preview; body_structure;
422 body_values; text_body; html_body; attachments; headers; other_properties;
423 }
424
425(** Get email ID with validation *)
426let get_id t =
427 match t.id with
428 | Some id -> Ok id
429 | None -> Error "Email object has no ID"
430
431(** Create email with validation *)
432let create_validated ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at
433 ?message_id ?in_reply_to ?references ?sender ?from ?to_ ?cc ?bcc
434 ?reply_to ?subject ?sent_at ?has_attachment ?preview ?body_structure
435 ?body_values ?text_body ?html_body ?attachments ?headers
436 ?(other_properties = Hashtbl.create 0) () =
437 let email = create_full ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at
438 ?message_id ?in_reply_to ?references ?sender ?from ?to_ ?cc ?bcc
439 ?reply_to ?subject ?sent_at ?has_attachment ?preview ?body_structure
440 ?body_values ?text_body ?html_body ?attachments ?headers
441 ~other_properties () in
442 match validate email with
443 | Ok () -> Ok email
444 | Error msg -> Error ("Email validation failed: " ^ msg)
445
446let take_id t =
447 match t.id with
448 | Some id -> id
449 | None -> failwith "Email object has no ID"
450
451let is_unread t =
452 match t.keywords with
453 | Some keywords ->
454 not (Keywords.is_draft keywords) &&
455 not (Keywords.is_seen keywords)
456 | None -> false (* Cannot determine without keywords *)
457
458let is_draft t =
459 match t.keywords with
460 | Some keywords -> Keywords.is_draft keywords
461 | None -> false
462
463let is_flagged t =
464 match t.keywords with
465 | Some keywords -> Keywords.is_flagged keywords
466 | None -> false
467
468let primary_sender t =
469 match t.from with
470 | Some (addr :: _) -> Some addr
471 | Some [] | None ->
472 t.sender
473
474let all_recipients t =
475 let to_list = match t.to_ with Some l -> l | None -> [] in
476 let cc_list = match t.cc with Some l -> l | None -> [] in
477 let bcc_list = match t.bcc with Some l -> l | None -> [] in
478 to_list @ cc_list @ bcc_list
479
480let display_summary t =
481 let sender_str = match primary_sender t with
482 | Some addr ->
483 (match Address.name addr with
484 | Some name -> name
485 | None -> Address.email addr)
486 | None -> "Unknown sender"
487 in
488 let subject_str = match t.subject with
489 | Some subj when subj <> "" -> subj
490 | _ -> "(No subject)"
491 in
492 let date_str = match t.received_at with
493 | Some date -> Printf.sprintf "%.0f" (Jmap.Date.to_timestamp date)
494 | None -> match t.sent_at with
495 | Some date -> Printf.sprintf "%.0f" (Jmap.Date.to_timestamp date)
496 | None -> "Unknown Jmap.Date.t"
497 in
498 Printf.sprintf "%s: %s (%s)" sender_str subject_str date_str
499
500(* PRINTABLE interface implementation *)
501let pp ppf t =
502 let id_str = match t.id with Some id -> Jmap.Id.to_string id | None -> "no-id" in
503 let subject_str = match t.subject with Some s -> s | None -> "(no subject)" in
504 Format.fprintf ppf "Email{id=%s; subject=%s}" id_str subject_str
505
506let pp_hum = pp
507
508(* JSON helper functions *)
509
510(* Complete JSON serialization for Email objects *)
511let to_json t =
512 let fields = [] in
513 let add_opt_string fields name str_opt = match str_opt with
514 | Some s -> (name, `String s) :: fields
515 | None -> fields
516 in
517 let add_opt_int fields name int_opt = match int_opt with
518 | Some i -> (name, `Int i) :: fields
519 | None -> fields
520 in
521 let add_opt_bool fields name bool_opt = match bool_opt with
522 | Some b -> (name, `Bool b) :: fields
523 | None -> fields
524 in
525 let add_opt_date fields name float_opt = match float_opt with
526 | Some f ->
527 let tm = Unix.gmtime f in
528 let iso_string = Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
529 (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
530 tm.tm_hour tm.tm_min tm.tm_sec in
531 (name, `String iso_string) :: fields
532 | None -> fields
533 in
534 let add_opt_string_list fields name list_opt = match list_opt with
535 | Some lst -> (name, `List (List.map (fun s -> `String s) lst)) :: fields
536 | None -> fields
537 in
538 let add_opt_address_list fields name addr_list_opt = match addr_list_opt with
539 | Some addrs -> (name, `List (List.map Address.to_json addrs)) :: fields
540 | None -> fields
541 in
542 let add_opt_body_part_list fields name body_list_opt = match body_list_opt with
543 | Some body_parts -> (name, `List (List.map Body.to_json body_parts)) :: fields
544 | None -> fields
545 in
546 let add_opt_string_map fields name map_opt = match map_opt with
547 | Some map ->
548 let assoc_list = Hashtbl.fold (fun k v acc -> (k, `String v) :: acc) map [] in
549 (name, `Assoc assoc_list) :: fields
550 | None -> fields
551 in
552 let add_opt_bool_map fields name map_opt = match map_opt with
553 | Some map ->
554 let assoc_list = Hashtbl.fold (fun k v acc -> (Jmap.Id.to_string k, `Bool v) :: acc) map [] in
555 (name, `Assoc assoc_list) :: fields
556 | None -> fields
557 in
558 let add_opt_body_values fields name body_values_opt = match body_values_opt with
559 | Some body_values ->
560 let assoc_list = Hashtbl.fold (fun k v acc -> (k, Body.Value.to_json v) :: acc) body_values [] in
561 (name, `Assoc assoc_list) :: fields
562 | None -> fields
563 in
564
565 (* Add all email fields *)
566 let fields = add_opt_string fields "id" (Option.map Jmap.Id.to_string t.id) in
567 let fields = add_opt_string fields "blobId" (Option.map Jmap.Id.to_string t.blob_id) in
568 let fields = add_opt_string fields "threadId" (Option.map Jmap.Id.to_string t.thread_id) in
569 let fields = add_opt_bool_map fields "mailboxIds" t.mailbox_ids in
570 let fields = match t.keywords with
571 | Some kw -> ("keywords", Keywords.to_json kw) :: fields
572 | None -> fields
573 in
574 let fields = add_opt_int fields "size" (Option.map Jmap.UInt.to_int t.size) in
575 let fields = add_opt_date fields "receivedAt" (Option.map Jmap.Date.to_timestamp t.received_at) in
576 let fields = add_opt_string_list fields "messageId" t.message_id in
577 let fields = add_opt_string_list fields "inReplyTo" t.in_reply_to in
578 let fields = add_opt_string_list fields "references" t.references in
579 let fields = match t.sender with
580 | Some addr -> ("sender", `List [Address.to_json addr]) :: fields
581 | None -> fields
582 in
583 let fields = add_opt_address_list fields "from" t.from in
584 let fields = add_opt_address_list fields "to" t.to_ in
585 let fields = add_opt_address_list fields "cc" t.cc in
586 let fields = add_opt_address_list fields "bcc" t.bcc in
587 let fields = add_opt_address_list fields "replyTo" t.reply_to in
588 let fields = add_opt_string fields "subject" t.subject in
589 let fields = add_opt_date fields "sentAt" (Option.map Jmap.Date.to_timestamp t.sent_at) in
590 let fields = add_opt_bool fields "hasAttachment" t.has_attachment in
591 let fields = add_opt_string fields "preview" t.preview in
592 let fields = match t.body_structure with
593 | Some body -> ("bodyStructure", Body.to_json body) :: fields
594 | None -> fields
595 in
596 let fields = add_opt_body_values fields "bodyValues" t.body_values in
597 let fields = add_opt_body_part_list fields "textBody" t.text_body in
598 let fields = add_opt_body_part_list fields "htmlBody" t.html_body in
599 let fields = add_opt_body_part_list fields "attachments" t.attachments in
600 let fields = add_opt_string_map fields "headers" t.headers in
601
602 (* Add any other properties *)
603 let fields = if Hashtbl.length t.other_properties > 0 then
604 let other_fields = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.other_properties [] in
605 other_fields @ fields
606 else fields
607 in
608 `Assoc fields
609
610
611(** Enhanced JSON parsing with comprehensive validation *)
612let of_json_with_validation = function
613 | `Assoc fields ->
614 (try
615 (* Parse all email fields using combinators *)
616 let id = match Json.string "id" fields with
617 | Some id_str -> (match Jmap.Id.of_string id_str with
618 | Ok jmap_id -> Some jmap_id
619 | Error _ -> None)
620 | None -> None in
621 let blob_id = match Json.string "blobId" fields with
622 | Some blob_id_str -> (match Jmap.Id.of_string blob_id_str with
623 | Ok jmap_id -> Some jmap_id
624 | Error _ -> None)
625 | None -> None in
626 let thread_id = match Json.string "threadId" fields with
627 | Some thread_id_str -> (match Jmap.Id.of_string thread_id_str with
628 | Ok jmap_id -> Some jmap_id
629 | Error _ -> None)
630 | None -> None in
631 let mailbox_ids = match Json.bool_map "mailboxIds" fields with
632 | Some string_map ->
633 let id_map = Hashtbl.create (Hashtbl.length string_map) in
634 Hashtbl.iter (fun str_key bool_val ->
635 match Jmap.Id.of_string str_key with
636 | Ok id_key -> Hashtbl.add id_map id_key bool_val
637 | Error _ -> () (* Skip invalid ids *)
638 ) string_map;
639 if Hashtbl.length id_map > 0 then Some id_map else None
640 | None -> None in
641
642 (* Validate mailbox_ids if present *)
643 (match mailbox_ids with
644 | Some mids ->
645 (match Validation.validate_mailbox_ids mids with
646 | Ok () -> ()
647 | Error msg -> failwith ("Mailbox validation error: " ^ msg))
648 | None -> ());
649
650 (* Parse keywords with validation *)
651 let keywords = match Json.field "keywords" fields with
652 | Some json ->
653 (match Keywords.of_json json with
654 | Ok kw -> Some kw
655 | Error _msg -> None (* Parse failed *))
656 | None -> None
657 in
658 let size = match Json.int "size" fields with
659 | Some int_val -> (match Jmap.UInt.of_int int_val with
660 | Ok uint_val -> Some uint_val
661 | Error _ -> None)
662 | None -> None in
663
664 (* Validate size if present *)
665 (match Validation.validate_size size with
666 | Ok () -> ()
667 | Error msg -> failwith ("Size validation error: " ^ msg));
668
669 let received_at = match Json.iso_date "receivedAt" fields with
670 | Some float_val -> Some (Jmap.Date.of_timestamp float_val)
671 | None -> None in
672 let message_id = Json.string_list "messageId" fields in
673 let in_reply_to = Json.string_list "inReplyTo" fields in
674 let references = Json.string_list "references" fields in
675
676 (* Enhanced validation for message ID fields *)
677 (match Validation.validate_message_id_list message_id with
678 | Ok () -> ()
679 | Error msg -> failwith ("Message-ID validation error in messageId: " ^ msg));
680 (match Validation.validate_message_id_list in_reply_to with
681 | Ok () -> ()
682 | Error msg -> failwith ("Message-ID validation error in inReplyTo: " ^ msg));
683 (match Validation.validate_message_id_list references with
684 | Ok () -> ()
685 | Error msg -> failwith ("Message-ID validation error in references: " ^ msg));
686
687 let sender = match Json.email_address_list "sender" fields with
688 | Some [addr] -> Some addr
689 | _ -> None
690 in
691 let from = Json.email_address_list "from" fields in
692 let to_ = Json.email_address_list "to" fields in
693 let cc = Json.email_address_list "cc" fields in
694 let bcc = Json.email_address_list "bcc" fields in
695 let reply_to = Json.email_address_list "replyTo" fields in
696 let subject = Json.string "subject" fields in
697 let sent_at = match Json.iso_date "sentAt" fields with
698 | Some float_val -> Some (Jmap.Date.of_timestamp float_val)
699 | None -> None in
700 let has_attachment = Json.bool "hasAttachment" fields in
701 let preview = Json.string "preview" fields in
702 (* Parse body structure using the Body module *)
703 let body_structure = match Json.field "bodyStructure" fields with
704 | Some json ->
705 (match Body.of_json json with
706 | Ok body -> Some body
707 | Error _msg -> None (* Ignore parse errors for now *))
708 | None -> None
709 in
710 (* Parse body values map using Body.Value module *)
711 let body_values = match Json.field "bodyValues" fields with
712 | Some (`Assoc body_value_fields) ->
713 let parsed_values = Hashtbl.create (List.length body_value_fields) in
714 let parse_success = List.for_all (fun (part_id, body_value_json) ->
715 match Body.Value.of_json body_value_json with
716 | Ok body_value ->
717 Hashtbl.add parsed_values part_id body_value;
718 true
719 | Error _msg -> false (* Ignore individual parse errors for now *)
720 ) body_value_fields in
721 if parse_success && Hashtbl.length parsed_values > 0 then Some parsed_values else None
722 | Some _non_object -> None (* Invalid bodyValues format *)
723 | None -> None
724 in
725 (* Parse textBody, htmlBody, and attachments arrays using Body module *)
726 let text_body = match Json.field "textBody" fields with
727 | Some (`List body_part_jsons) ->
728 let parsed_parts = List.filter_map (fun json ->
729 match Body.of_json json with
730 | Ok body_part -> Some body_part
731 | Error _msg -> None (* Skip invalid parts for now *)
732 ) body_part_jsons in
733 if parsed_parts <> [] then Some parsed_parts else None
734 | Some _non_list -> None (* Invalid textBody format *)
735 | None -> None
736 in
737 let html_body = match Json.field "htmlBody" fields with
738 | Some (`List body_part_jsons) ->
739 let parsed_parts = List.filter_map (fun json ->
740 match Body.of_json json with
741 | Ok body_part -> Some body_part
742 | Error _msg -> None (* Skip invalid parts for now *)
743 ) body_part_jsons in
744 if parsed_parts <> [] then Some parsed_parts else None
745 | Some _non_list -> None (* Invalid htmlBody format *)
746 | None -> None
747 in
748 let attachments = match Json.field "attachments" fields with
749 | Some (`List body_part_jsons) ->
750 let parsed_parts = List.filter_map (fun json ->
751 match Body.of_json json with
752 | Ok body_part -> Some body_part
753 | Error _msg -> None (* Skip invalid parts for now *)
754 ) body_part_jsons in
755 if parsed_parts <> [] then Some parsed_parts else None
756 | Some _non_list -> None (* Invalid attachments format *)
757 | None -> None
758 in
759 let headers = Json.string_map "headers" fields in
760
761 (* Collect any unrecognized fields into other_properties *)
762 let known_fields = [
763 "id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; "size"; "receivedAt";
764 "messageId"; "inReplyTo"; "references"; "sender"; "from"; "to"; "cc"; "bcc";
765 "replyTo"; "subject"; "sentAt"; "hasAttachment"; "preview"; "bodyStructure";
766 "bodyValues"; "textBody"; "htmlBody"; "attachments"; "headers"
767 ] in
768 let other_properties = Hashtbl.create 16 in
769 List.iter (fun (field_name, field_value) ->
770 if not (List.mem field_name known_fields) then
771 Hashtbl.add other_properties field_name field_value
772 ) fields;
773
774 Ok (create_full
775 ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at
776 ?message_id ?in_reply_to ?references ?sender ?from ?to_ ?cc ?bcc
777 ?reply_to ?subject ?sent_at ?has_attachment ?preview ?body_structure
778 ?body_values ?text_body ?html_body ?attachments ?headers
779 ~other_properties ())
780 with
781 | exn -> Error (Printf.sprintf "Email JSON parsing error: %s" (Printexc.to_string exn)))
782 | _ ->
783 Error "Email JSON must be an object"
784
785(* Complete JSON parsing implementation for Email objects using combinators *)
786let of_json = function
787 | `Assoc fields ->
788 (try
789 (* Parse all email fields using combinators *)
790 let id = match Json.string "id" fields with
791 | Some id_str -> (match Jmap.Id.of_string id_str with
792 | Ok jmap_id -> Some jmap_id
793 | Error _ -> None)
794 | None -> None in
795 let blob_id = match Json.string "blobId" fields with
796 | Some blob_id_str -> (match Jmap.Id.of_string blob_id_str with
797 | Ok jmap_id -> Some jmap_id
798 | Error _ -> None)
799 | None -> None in
800 let thread_id = match Json.string "threadId" fields with
801 | Some thread_id_str -> (match Jmap.Id.of_string thread_id_str with
802 | Ok jmap_id -> Some jmap_id
803 | Error _ -> None)
804 | None -> None in
805 let mailbox_ids = match Json.bool_map "mailboxIds" fields with
806 | Some string_map ->
807 let id_map = Hashtbl.create (Hashtbl.length string_map) in
808 Hashtbl.iter (fun str_key bool_val ->
809 match Jmap.Id.of_string str_key with
810 | Ok id_key -> Hashtbl.add id_map id_key bool_val
811 | Error _ -> () (* Skip invalid ids *)
812 ) string_map;
813 Some id_map
814 | None -> None in
815 (* Parse keywords using the Keywords module *)
816 let keywords = match Json.field "keywords" fields with
817 | Some json ->
818 (match Keywords.of_json json with
819 | Ok kw -> Some kw
820 | Error _msg -> None (* Ignore parse errors for now *))
821 | None -> None
822 in
823 let size = match Json.int "size" fields with
824 | Some int_val -> (match Jmap.UInt.of_int int_val with
825 | Ok uint_val -> Some uint_val
826 | Error _ -> None)
827 | None -> None in
828 let received_at = match Json.iso_date "receivedAt" fields with
829 | Some float_val -> Some (Jmap.Date.of_timestamp float_val)
830 | None -> None in
831 let message_id = Json.string_list "messageId" fields in
832 let in_reply_to = Json.string_list "inReplyTo" fields in
833 let references = Json.string_list "references" fields in
834 let sender = match Json.email_address_list "sender" fields with
835 | Some [addr] -> Some addr
836 | _ -> None
837 in
838 let from = Json.email_address_list "from" fields in
839 let to_ = Json.email_address_list "to" fields in
840 let cc = Json.email_address_list "cc" fields in
841 let bcc = Json.email_address_list "bcc" fields in
842 let reply_to = Json.email_address_list "replyTo" fields in
843 let subject = Json.string "subject" fields in
844 let sent_at = match Json.iso_date "sentAt" fields with
845 | Some float_val -> Some (Jmap.Date.of_timestamp float_val)
846 | None -> None in
847 let has_attachment = Json.bool "hasAttachment" fields in
848 let preview = Json.string "preview" fields in
849 (* Parse body structure using the Body module *)
850 let body_structure = match Json.field "bodyStructure" fields with
851 | Some json ->
852 (match Body.of_json json with
853 | Ok body -> Some body
854 | Error _msg -> None (* Ignore parse errors for now *))
855 | None -> None
856 in
857 (* Parse body values map using Body.Value module *)
858 let body_values = match Json.field "bodyValues" fields with
859 | Some (`Assoc body_value_fields) ->
860 let parsed_values = Hashtbl.create (List.length body_value_fields) in
861 let parse_success = List.for_all (fun (part_id, body_value_json) ->
862 match Body.Value.of_json body_value_json with
863 | Ok body_value ->
864 Hashtbl.add parsed_values part_id body_value;
865 true
866 | Error _msg -> false (* Ignore individual parse errors for now *)
867 ) body_value_fields in
868 if parse_success && Hashtbl.length parsed_values > 0 then Some parsed_values else None
869 | Some _non_object -> None (* Invalid bodyValues format *)
870 | None -> None
871 in
872 (* Parse textBody, htmlBody, and attachments arrays using Body module *)
873 let text_body = match Json.field "textBody" fields with
874 | Some (`List body_part_jsons) ->
875 let parsed_parts = List.filter_map (fun json ->
876 match Body.of_json json with
877 | Ok body_part -> Some body_part
878 | Error _msg -> None (* Skip invalid parts for now *)
879 ) body_part_jsons in
880 if parsed_parts <> [] then Some parsed_parts else None
881 | Some _non_list -> None (* Invalid textBody format *)
882 | None -> None
883 in
884 let html_body = match Json.field "htmlBody" fields with
885 | Some (`List body_part_jsons) ->
886 let parsed_parts = List.filter_map (fun json ->
887 match Body.of_json json with
888 | Ok body_part -> Some body_part
889 | Error _msg -> None (* Skip invalid parts for now *)
890 ) body_part_jsons in
891 if parsed_parts <> [] then Some parsed_parts else None
892 | Some _non_list -> None (* Invalid htmlBody format *)
893 | None -> None
894 in
895 let attachments = match Json.field "attachments" fields with
896 | Some (`List body_part_jsons) ->
897 let parsed_parts = List.filter_map (fun json ->
898 match Body.of_json json with
899 | Ok body_part -> Some body_part
900 | Error _msg -> None (* Skip invalid parts for now *)
901 ) body_part_jsons in
902 if parsed_parts <> [] then Some parsed_parts else None
903 | Some _non_list -> None (* Invalid attachments format *)
904 | None -> None
905 in
906 let headers = Json.string_map "headers" fields in
907
908 (* Collect any unrecognized fields into other_properties *)
909 let known_fields = [
910 "id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; "size"; "receivedAt";
911 "messageId"; "inReplyTo"; "references"; "sender"; "from"; "to"; "cc"; "bcc";
912 "replyTo"; "subject"; "sentAt"; "hasAttachment"; "preview"; "bodyStructure";
913 "bodyValues"; "textBody"; "htmlBody"; "attachments"; "headers"
914 ] in
915 let other_properties = Hashtbl.create 16 in
916 List.iter (fun (field_name, field_value) ->
917 if not (List.mem field_name known_fields) then
918 Hashtbl.add other_properties field_name field_value
919 ) fields;
920
921 Ok (create_full
922 ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at
923 ?message_id ?in_reply_to ?references ?sender ?from ?to_ ?cc ?bcc
924 ?reply_to ?subject ?sent_at ?has_attachment ?preview ?body_structure
925 ?body_values ?text_body ?html_body ?attachments ?headers
926 ~other_properties ())
927 with
928 | exn -> Error (Printf.sprintf "Email JSON parsing error: %s" (Printexc.to_string exn)))
929 | _ ->
930 Error "Email JSON must be an object"
931
932(* Pretty printing implementation for PRINTABLE signature *)
933let pp ppf t =
934 let id_str = match t.id with
935 | Some id -> Jmap.Id.to_string id
936 | None -> "<no-id>"
937 in
938 let subject_str = match t.subject with
939 | Some subj -> subj
940 | None -> "<no-subject>"
941 in
942 let sender_str = match primary_sender t with
943 | Some addr -> Address.email addr
944 | None -> "<unknown-sender>"
945 in
946 Format.fprintf ppf "Email{Jmap.Id.t=%s; from=%s; subject=%s}"
947 id_str sender_str subject_str
948
949(* Alias for pp following Fmt conventions *)
950let pp_hum ppf t = pp ppf t
951
952
953(** Enhanced patch operations with validation *)
954module Patch = struct
955 let create ?add_keywords ?remove_keywords ?add_mailboxes ?remove_mailboxes () =
956 let _add_keywords = add_keywords in (* Acknowledge unused parameter *)
957 let _remove_keywords = remove_keywords in (* Acknowledge unused parameter *)
958 let _add_mailboxes = add_mailboxes in (* Acknowledge unused parameter *)
959 let _remove_mailboxes = remove_mailboxes in (* Acknowledge unused parameter *)
960 let patches = [] in
961
962 (* Validate keywords if provided *)
963 (match add_keywords with
964 | Some keywords ->
965 let keyword_list = Keywords.items keywords in
966 List.iter (fun kw ->
967 let kw_str = Keywords.keyword_to_string kw in
968 if not (Validation.is_valid_keyword kw_str) then
969 failwith (Printf.sprintf "Invalid keyword format: %s" kw_str)
970 ) keyword_list
971 | None -> ());
972
973 (* Simplified implementation - would build proper JSON patches *)
974 (`List patches : Yojson.Safe.t)
975
976 let mark_read () =
977 let keywords = Keywords.add (Keywords.empty ()) Keywords.Seen in
978 create ~add_keywords:keywords ()
979
980 let mark_unread () =
981 let keywords = Keywords.add (Keywords.empty ()) Keywords.Seen in
982 create ~remove_keywords:keywords ()
983
984 let flag () =
985 let keywords = Keywords.add (Keywords.empty ()) Keywords.Flagged in
986 create ~add_keywords:keywords ()
987
988 let unflag () =
989 let keywords = Keywords.add (Keywords.empty ()) Keywords.Flagged in
990 create ~remove_keywords:keywords ()
991
992 let move_to_mailboxes _mailbox_ids =
993 `List [] (* Simplified implementation *)
994end
995
996(* Module aliases for external access *)
997module Email_address = Address
998module Email_keywords = Keywords
999module Email_header = Header
1000module Email_body = Body
1001module Apple_mail = Apple
1002module Thread = Thread
1003module Identity = Identity
1004module Query = Query
1005module Email_response = Response
1006module Email_set = Set
1007module Email_changes = Changes
1008
1009(* Legacy aliases for compatibility *)
1010module Types = struct
1011 module Keywords = Keywords
1012 module Email_address = Address
1013 module Email = struct
1014 type nonrec t = t (* Alias the main email type *)
1015 let id t = t.id
1016 let received_at = received_at
1017 let subject = subject
1018 let from = from
1019 let keywords = keywords
1020 end
1021end