My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** JMAP Email Submission Implementation.
2
3 This module implements the JMAP EmailSubmission data type for tracking
4 email sending operations, including SMTP envelope handling, delivery
5 status tracking, and undo capabilities.
6
7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7: EmailSubmission
8*)
9
10
11(** {1 Internal Type Representations} *)
12
13(** Internal EmailSubmission representation *)
14type submission_data = {
15 id : Jmap.Id.t;
16 identity_id : Jmap.Id.t;
17 email_id : Jmap.Id.t;
18 thread_id : Jmap.Id.t;
19 envelope : envelope_data option;
20 send_at : Jmap.Date.t;
21 undo_status : [`Pending | `Final | `Canceled];
22 delivery_status : (string, delivery_status_data) Hashtbl.t option;
23 dsn_blob_ids : Jmap.Id.t list;
24 mdn_blob_ids : Jmap.Id.t list;
25}
26
27(** Internal envelope representation *)
28and envelope_data = {
29 mail_from : envelope_address_data;
30 rcpt_to : envelope_address_data list;
31}
32
33(** Internal envelope address representation *)
34and envelope_address_data = {
35 email : string;
36 parameters : (string, Yojson.Safe.t) Hashtbl.t option;
37}
38
39(** Internal delivery status representation *)
40and delivery_status_data = {
41 smtp_reply : string;
42 delivered : [`Queued | `Yes | `No | `Unknown];
43 displayed : [`Yes | `Unknown];
44}
45
46(** {1 Main EmailSubmission Type} *)
47
48(** Main EmailSubmission type *)
49type t = submission_data
50
51(** Alias for use in submodules *)
52type email_submission_t = t
53
54(** {1 JSON Serialization} *)
55
56(** Helper functions for JSON conversion *)
57let delivered_to_string = function
58 | `Queued -> "queued"
59 | `Yes -> "yes"
60 | `No -> "no"
61 | `Unknown -> "unknown"
62
63let delivered_of_string = function
64 | "queued" -> `Queued
65 | "yes" -> `Yes
66 | "no" -> `No
67 | "unknown" -> `Unknown
68 | s -> failwith ("Invalid delivered status: " ^ s)
69
70let displayed_to_string = function
71 | `Yes -> "yes"
72 | `Unknown -> "unknown"
73
74let displayed_of_string = function
75 | "yes" -> `Yes
76 | "unknown" -> `Unknown
77 | s -> failwith ("Invalid displayed status: " ^ s)
78
79let undo_status_to_string = function
80 | `Pending -> "pending"
81 | `Final -> "final"
82 | `Canceled -> "canceled"
83
84let undo_status_of_string = function
85 | "pending" -> `Pending
86 | "final" -> `Final
87 | "canceled" -> `Canceled
88 | s -> failwith ("Invalid undo status: " ^ s)
89
90(** {1 Status Types} *)
91
92module DeliveryStatus = struct
93
94 (** DeliveryStatus constructor wrapper *)
95 type t = DeliveryStatus of delivery_status_data
96
97 let to_json (DeliveryStatus status) =
98 `Assoc [
99 ("smtpReply", `String status.smtp_reply);
100 ("delivered", `String (delivered_to_string status.delivered));
101 ("displayed", `String (displayed_to_string status.displayed));
102 ]
103
104 let of_json json =
105 try
106 match json with
107 | `Assoc fields ->
108 let get_field name = List.assoc name fields in
109 let smtp_reply = match get_field "smtpReply" with
110 | `String s -> s
111 | _ -> failwith "Expected string for smtpReply"
112 in
113 let delivered = match get_field "delivered" with
114 | `String s -> delivered_of_string s
115 | _ -> failwith "Expected string for delivered"
116 in
117 let displayed = match get_field "displayed" with
118 | `String s -> displayed_of_string s
119 | _ -> failwith "Expected string for displayed"
120 in
121 Ok (DeliveryStatus { smtp_reply; delivered; displayed })
122 | _ -> Error "Expected object for DeliveryStatus"
123 with
124 | Failure msg -> Error msg
125 | exn -> Error ("Failed to parse DeliveryStatus: " ^ Printexc.to_string exn)
126
127 let smtp_reply (DeliveryStatus status) = status.smtp_reply
128 let delivered (DeliveryStatus status) = status.delivered
129 let displayed (DeliveryStatus status) = status.displayed
130
131 let create ~smtp_reply ~delivered ~displayed =
132 Ok (DeliveryStatus { smtp_reply; delivered; displayed })
133end
134
135(** {1 SMTP Envelope Support} *)
136
137module EnvelopeAddress = struct
138
139 (** EnvelopeAddress constructor wrapper *)
140 type t = EnvelopeAddress of envelope_address_data
141
142 let to_json (EnvelopeAddress addr) =
143 let base = [("email", `String addr.email)] in
144 let fields = match addr.parameters with
145 | Some params ->
146 let param_list = Hashtbl.fold (fun k v acc -> (k, v) :: acc) params [] in
147 ("parameters", `Assoc param_list) :: base
148 | None -> base
149 in
150 `Assoc fields
151
152 let of_json json =
153 try
154 match json with
155 | `Assoc fields ->
156 let get_field name = List.assoc name fields in
157 let get_optional_field name = try Some (get_field name) with Not_found -> None in
158 let email = match get_field "email" with
159 | `String s -> s
160 | _ -> failwith "Expected string for email"
161 in
162 let parameters = match get_optional_field "parameters" with
163 | Some (`Assoc param_list) ->
164 let param_map = Hashtbl.create (List.length param_list) in
165 List.iter (fun (k, v) -> Hashtbl.replace param_map k v) param_list;
166 Some param_map
167 | Some _ -> failwith "Expected object for parameters"
168 | None -> None
169 in
170 Ok (EnvelopeAddress { email; parameters })
171 | _ -> Error "Expected object for EnvelopeAddress"
172 with
173 | Failure msg -> Error msg
174 | exn -> Error ("Failed to parse EnvelopeAddress: " ^ Printexc.to_string exn)
175
176 let email (EnvelopeAddress addr) = addr.email
177 let parameters (EnvelopeAddress addr) = addr.parameters
178
179 let create ~email ?parameters () =
180 Ok (EnvelopeAddress { email; parameters })
181end
182
183module Envelope = struct
184
185 (** Envelope constructor wrapper *)
186 type t = Envelope of envelope_data
187
188 let to_json (Envelope envelope) =
189 `Assoc [
190 ("mailFrom", EnvelopeAddress.to_json (EnvelopeAddress.EnvelopeAddress envelope.mail_from));
191 ("rcptTo", `List (List.map (fun addr -> EnvelopeAddress.to_json (EnvelopeAddress.EnvelopeAddress addr)) envelope.rcpt_to));
192 ]
193
194 let of_json json =
195 try
196 match json with
197 | `Assoc fields ->
198 let get_field name = List.assoc name fields in
199 let mail_from = match EnvelopeAddress.of_json (get_field "mailFrom") with
200 | Ok (EnvelopeAddress.EnvelopeAddress a) -> a
201 | Error msg -> failwith ("Failed to parse mailFrom: " ^ msg)
202 in
203 let rcpt_to = match get_field "rcptTo" with
204 | `List addrs -> List.map (fun addr_json ->
205 match EnvelopeAddress.of_json addr_json with
206 | Ok (EnvelopeAddress.EnvelopeAddress a) -> a
207 | Error msg -> failwith ("Failed to parse rcptTo address: " ^ msg)
208 ) addrs
209 | _ -> failwith "Expected list for rcptTo"
210 in
211 Ok (Envelope { mail_from; rcpt_to })
212 | _ -> Error "Expected object for Envelope"
213 with
214 | Failure msg -> Error msg
215 | exn -> Error ("Failed to parse Envelope: " ^ Printexc.to_string exn)
216
217 let mail_from (Envelope envelope) = EnvelopeAddress.EnvelopeAddress envelope.mail_from
218 let rcpt_to (Envelope envelope) = List.map (fun a -> EnvelopeAddress.EnvelopeAddress a) envelope.rcpt_to
219
220 let create ~mail_from ~rcpt_to =
221 let mail_from_data = match mail_from with EnvelopeAddress.EnvelopeAddress a -> a in
222 let rcpt_to_data = List.map (function EnvelopeAddress.EnvelopeAddress a -> a) rcpt_to in
223 Ok (Envelope { mail_from = mail_from_data; rcpt_to = rcpt_to_data })
224end
225
226(** Convert submission to JSON *)
227let to_json submission =
228 let base = [
229 ("id", `String (Jmap.Id.to_string submission.id));
230 ("identityId", `String (Jmap.Id.to_string submission.identity_id));
231 ("emailId", `String (Jmap.Id.to_string submission.email_id));
232 ("threadId", `String (Jmap.Id.to_string submission.thread_id));
233 ("sendAt", `Float (Jmap.Date.to_timestamp submission.send_at));
234 ("undoStatus", `String (undo_status_to_string submission.undo_status));
235 ("dsnBlobIds", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) submission.dsn_blob_ids));
236 ("mdnBlobIds", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) submission.mdn_blob_ids));
237 ] in
238 let fields = match submission.envelope with
239 | Some env -> ("envelope", Envelope.to_json (Envelope.Envelope env)) :: base
240 | None -> base
241 in
242 let fields = match submission.delivery_status with
243 | Some status_map ->
244 let status_assoc = Hashtbl.fold (fun email status acc ->
245 (email, DeliveryStatus.to_json (DeliveryStatus.DeliveryStatus status)) :: acc
246 ) status_map [] in
247 ("deliveryStatus", `Assoc status_assoc) :: fields
248 | None -> fields
249 in
250 `Assoc fields
251
252(** {1 Printable Formatting} *)
253
254(** Format EmailSubmission for debugging *)
255let pp ppf submission =
256 let send_at_str = Printf.sprintf "%.0f" (Jmap.Date.to_timestamp submission.send_at) in
257 let undo_status_str = undo_status_to_string submission.undo_status in
258 Format.fprintf ppf "EmailSubmission{Id.t=%s; email_id=%s; thread_id=%s; identity_id=%s; send_at=%s; undo_status=%s}"
259 (Jmap.Id.to_string submission.id)
260 (Jmap.Id.to_string submission.email_id)
261 (Jmap.Id.to_string submission.thread_id)
262 (Jmap.Id.to_string submission.identity_id)
263 send_at_str
264 undo_status_str
265
266(** Format EmailSubmission for human reading *)
267let pp_hum ppf submission =
268 let send_at_str = Printf.sprintf "%.0f" (Jmap.Date.to_timestamp submission.send_at) in
269 let undo_status_str = undo_status_to_string submission.undo_status in
270 let envelope_str = match submission.envelope with
271 | None -> "none"
272 | Some _ -> "present"
273 in
274 let delivery_status_str = match submission.delivery_status with
275 | None -> "none"
276 | Some tbl -> Printf.sprintf "%d recipients" (Hashtbl.length tbl)
277 in
278 Format.fprintf ppf "EmailSubmission {\n Id.t: %s\n email_id: %s\n thread_id: %s\n identity_id: %s\n send_at: %s\n undo_status: %s\n envelope: %s\n delivery_status: %s\n dsn_blob_ids: %d\n mdn_blob_ids: %d\n}"
279 (Jmap.Id.to_string submission.id)
280 (Jmap.Id.to_string submission.email_id)
281 (Jmap.Id.to_string submission.thread_id)
282 (Jmap.Id.to_string submission.identity_id)
283 send_at_str
284 undo_status_str
285 envelope_str
286 delivery_status_str
287 (List.length submission.dsn_blob_ids)
288 (List.length submission.mdn_blob_ids)
289
290(** Parse submission from JSON *)
291let of_json json =
292 try
293 match json with
294 | `Assoc fields ->
295 let get_field name = List.assoc name fields in
296 let get_string_field name = match get_field name with
297 | `String s -> s
298 | _ -> failwith ("Expected string for " ^ name)
299 in
300 let get_float_field name = match get_field name with
301 | `Float f -> f
302 | _ -> failwith ("Expected float for " ^ name)
303 in
304 let get_list_field name = match get_field name with
305 | `List l -> l
306 | _ -> failwith ("Expected list for " ^ name)
307 in
308 let get_optional_field name = try Some (get_field name) with Not_found -> None in
309
310 let id = match Jmap.Id.of_string (get_string_field "id") with
311 | Ok id -> id | Error err -> failwith ("Invalid id: " ^ err) in
312 let identity_id = match Jmap.Id.of_string (get_string_field "identityId") with
313 | Ok id -> id | Error err -> failwith ("Invalid identityId: " ^ err) in
314 let email_id = match Jmap.Id.of_string (get_string_field "emailId") with
315 | Ok id -> id | Error err -> failwith ("Invalid emailId: " ^ err) in
316 let thread_id = match Jmap.Id.of_string (get_string_field "threadId") with
317 | Ok id -> id | Error err -> failwith ("Invalid threadId: " ^ err) in
318 let send_at = Jmap.Date.of_timestamp (get_float_field "sendAt") in
319 let undo_status = undo_status_of_string (get_string_field "undoStatus") in
320 let dsn_blob_ids = List.map (function
321 | `String s -> (match Jmap.Id.of_string s with Ok id -> id | Error err -> failwith ("Invalid dsnBlobId: " ^ err))
322 | _ -> failwith "Expected string in dsnBlobIds"
323 ) (get_list_field "dsnBlobIds") in
324 let mdn_blob_ids = List.map (function
325 | `String s -> (match Jmap.Id.of_string s with Ok id -> id | Error err -> failwith ("Invalid mdnBlobId: " ^ err))
326 | _ -> failwith "Expected string in mdnBlobIds"
327 ) (get_list_field "mdnBlobIds") in
328
329 let envelope = match get_optional_field "envelope" with
330 | Some env_json ->
331 (match Envelope.of_json env_json with
332 | Ok (Envelope.Envelope env) -> Some env
333 | Error _ -> None) (* Skip malformed envelope rather than failing *)
334 | None -> None
335 in
336
337 let delivery_status = match get_optional_field "deliveryStatus" with
338 | Some (`Assoc status_list) ->
339 let status_map = Hashtbl.create (List.length status_list) in
340 List.iter (fun (k, v) ->
341 let status_obj = match DeliveryStatus.of_json v with
342 | Ok (DeliveryStatus.DeliveryStatus s) -> s
343 | Error msg -> failwith ("Failed to parse delivery status for " ^ k ^ ": " ^ msg)
344 in
345 Hashtbl.replace status_map k status_obj
346 ) status_list;
347 Some status_map
348 | Some _ -> failwith "Expected object for deliveryStatus"
349 | None -> None
350 in
351
352 Ok {
353 id; identity_id; email_id; thread_id; envelope; send_at; undo_status;
354 delivery_status; dsn_blob_ids; mdn_blob_ids;
355 }
356 | _ -> Error "Expected JSON object for EmailSubmission"
357 with
358 | Not_found -> Error "Missing required field in EmailSubmission JSON"
359 | Failure msg -> Error ("EmailSubmission JSON parsing error: " ^ msg)
360 | exn -> Error ("EmailSubmission JSON parsing exception: " ^ Printexc.to_string exn)
361
362(** {1 Property Accessors} *)
363
364(** {1 JMAP_OBJECT Implementation} *)
365
366(** Get the object ID (always present for EmailSubmission) *)
367let id submission = Some submission.id
368
369
370(** Serialize to JSON with only specified properties *)
371let to_json_with_properties ~properties submission =
372 let all_fields = [
373 ("id", `String (Jmap.Id.to_string submission.id));
374 ("identityId", `String (Jmap.Id.to_string submission.identity_id));
375 ("emailId", `String (Jmap.Id.to_string submission.email_id));
376 ("threadId", `String (Jmap.Id.to_string submission.thread_id));
377 ("sendAt", `Float (Jmap.Date.to_timestamp submission.send_at));
378 ("undoStatus", `String (undo_status_to_string submission.undo_status));
379 ("dsnBlobIds", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) submission.dsn_blob_ids));
380 ("mdnBlobIds", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) submission.mdn_blob_ids));
381 ("envelope", match submission.envelope with
382 | Some env -> Envelope.to_json (Envelope.Envelope env)
383 | None -> `Null);
384 ("deliveryStatus", match submission.delivery_status with
385 | Some status_map ->
386 let status_assoc = Hashtbl.fold (fun email status acc ->
387 (email, DeliveryStatus.to_json (DeliveryStatus.DeliveryStatus status)) :: acc
388 ) status_map [] in
389 `Assoc status_assoc
390 | None -> `Null);
391 ] in
392 let filtered_fields = List.filter (fun (key, _) -> List.mem key properties) all_fields in
393 `Assoc filtered_fields
394
395(** Get list of all valid property names *)
396let valid_properties () = [
397 "id"; "identityId"; "emailId"; "threadId"; "envelope";
398 "sendAt"; "undoStatus"; "deliveryStatus"; "dsnBlobIds"; "mdnBlobIds"
399] (* TODO: Use Property.to_string_list Property.all_properties when module ordering is fixed *)
400
401(** {1 Property Accessors} *)
402
403let identity_id submission = submission.identity_id
404let email_id submission = submission.email_id
405let thread_id submission = submission.thread_id
406let envelope submission = Option.map (fun e -> Envelope.Envelope e) submission.envelope
407let send_at submission = submission.send_at
408let undo_status submission = submission.undo_status
409let delivery_status submission =
410 Option.map (fun tbl ->
411 let new_tbl = Hashtbl.create (Hashtbl.length tbl) in
412 Hashtbl.iter (fun k v -> Hashtbl.add new_tbl k (DeliveryStatus.DeliveryStatus v)) tbl;
413 new_tbl
414 ) submission.delivery_status
415let dsn_blob_ids submission = submission.dsn_blob_ids
416let mdn_blob_ids submission = submission.mdn_blob_ids
417
418(** {1 Smart Constructors} *)
419
420let create ~id ~identity_id ~email_id ~thread_id ?envelope ~send_at ~undo_status ?delivery_status ?(dsn_blob_ids=[]) ?(mdn_blob_ids=[]) () =
421 let envelope_data = Option.map (function Envelope.Envelope e -> e) envelope in
422 let delivery_status_data = Option.map (fun tbl ->
423 let new_tbl = Hashtbl.create (Hashtbl.length tbl) in
424 Hashtbl.iter (fun k v -> match v with DeliveryStatus.DeliveryStatus s -> Hashtbl.add new_tbl k s) tbl;
425 new_tbl
426 ) delivery_status in
427 Ok {
428 id; identity_id; email_id; thread_id; envelope = envelope_data; send_at; undo_status;
429 delivery_status = delivery_status_data; dsn_blob_ids; mdn_blob_ids;
430 }
431
432(** {1 JMAP Method Operations} *)
433
434module Create = struct
435
436 type create_data = {
437 identity_id : Jmap.Id.t;
438 email_id : Jmap.Id.t;
439 envelope : envelope_data option;
440 }
441
442 type t = create_data
443
444 let to_json create =
445 let base = [
446 ("identityId", `String (Jmap.Id.to_string create.identity_id));
447 ("emailId", `String (Jmap.Id.to_string create.email_id));
448 ] in
449 let fields = match create.envelope with
450 | Some env -> ("envelope", Envelope.to_json (Envelope.Envelope env)) :: base
451 | None -> base
452 in
453 `Assoc fields
454
455 let of_json json =
456 try
457 match json with
458 | `Assoc fields ->
459 let get_field name = List.assoc name fields in
460 let get_optional_field name = try Some (get_field name) with Not_found -> None in
461 let identity_id = match get_field "identityId" with
462 | `String s -> (match Jmap.Id.of_string s with
463 | Ok id -> id
464 | Error _ -> failwith ("Invalid identityId: " ^ s))
465 | _ -> failwith "Expected string for identityId"
466 in
467 let email_id = match get_field "emailId" with
468 | `String s -> (match Jmap.Id.of_string s with
469 | Ok id -> id
470 | Error _ -> failwith ("Invalid emailId: " ^ s))
471 | _ -> failwith "Expected string for emailId"
472 in
473 let envelope = match get_optional_field "envelope" with
474 | Some env_json ->
475 (match Envelope.of_json env_json with
476 | Ok (Envelope.Envelope env) -> Some env
477 | Error _ -> None) (* Skip malformed envelope rather than failing *)
478 | None -> None
479 in
480 Ok { identity_id; email_id; envelope }
481 | _ -> Error "Expected JSON object for Create"
482 with
483 | Not_found -> Error "Missing required field in Create JSON"
484 | Failure msg -> Error ("Create JSON parsing error: " ^ msg)
485 | exn -> Error ("Create JSON parsing exception: " ^ Printexc.to_string exn)
486
487 let identity_id create = create.identity_id
488 let email_id create = create.email_id
489 let envelope create = Option.map (fun e -> Envelope.Envelope e) create.envelope
490
491 let create ~identity_id ~email_id ?envelope () =
492 let envelope_data = Option.map (function Envelope.Envelope e -> e) envelope in
493 Ok { identity_id; email_id; envelope = envelope_data }
494
495 module Response = struct
496
497 type response_data = {
498 id : Jmap.Id.t;
499 thread_id : Jmap.Id.t;
500 send_at : Jmap.Date.t;
501 }
502
503 type t = response_data
504
505 let to_json response =
506 `Assoc [
507 ("id", `String (Jmap.Id.to_string response.id));
508 ("threadId", `String (Jmap.Id.to_string response.thread_id));
509 ("sendAt", `Float (Jmap.Date.to_timestamp response.send_at));
510 ]
511
512 let of_json json =
513 try
514 match json with
515 | `Assoc fields ->
516 let get_field name = List.assoc name fields in
517 let id = match get_field "id" with
518 | `String s -> (match Jmap.Id.of_string s with
519 | Ok id -> id
520 | Error _ -> failwith ("Invalid id: " ^ s))
521 | _ -> failwith "Expected string for id"
522 in
523 let thread_id = match get_field "threadId" with
524 | `String s -> (match Jmap.Id.of_string s with
525 | Ok id -> id
526 | Error _ -> failwith ("Invalid threadId: " ^ s))
527 | _ -> failwith "Expected string for threadId"
528 in
529 let send_at = match get_field "sendAt" with
530 | `Float f -> Jmap.Date.of_timestamp f
531 | _ -> failwith "Expected float for sendAt"
532 in
533 Ok { id; thread_id; send_at }
534 | _ -> Error "Expected JSON object for Create.Response"
535 with
536 | Not_found -> Error "Missing required field in Create.Response JSON"
537 | Failure msg -> Error ("Create.Response JSON parsing error: " ^ msg)
538 | exn -> Error ("Create.Response JSON parsing exception: " ^ Printexc.to_string exn)
539
540 let id response = response.id
541 let thread_id response = response.thread_id
542 let send_at response = response.send_at
543
544 let create ~id ~thread_id ~send_at =
545 Ok { id; thread_id; send_at }
546 end
547end
548
549module Update = struct
550
551 (** Update is a patch object - for EmailSubmission, only undo status can be updated *)
552 type t = Yojson.Safe.t
553
554 let to_json update = update
555 let of_json json = Ok json
556
557 let cancel = Ok (`Assoc [("undoStatus", `String "canceled")])
558
559 module Response = struct
560
561 (** Update response contains the full updated submission *)
562 type t = email_submission_t
563
564 (* For Set_response, we need to return an empty object or the updated properties *)
565 let to_json _response = `Assoc [] (* EmailSubmission updates only return empty object *)
566
567 let of_json _json =
568 (* Update responses for EmailSubmission are typically empty objects
569 Since we can't construct a full submission from an empty response,
570 we return a dummy submission *)
571 match Jmap.Id.of_string "update-response-placeholder" with
572 | Ok id ->
573 create ~id ~identity_id:id ~email_id:id ~thread_id:id
574 ~send_at:(Jmap.Date.of_timestamp 0.0)
575 ~undo_status:`Canceled ()
576 | Error err -> Error err
577
578 let submission response = response
579
580 let create ~submission =
581 Ok submission
582 end
583end
584
585module Get_args = struct
586
587 type get_args_data = {
588 account_id : Jmap.Id.t;
589 ids : Jmap.Id.t list option;
590 properties : string list option;
591 }
592
593 type t = get_args_data
594
595 let to_json args =
596 let base = [("accountId", `String (Jmap.Id.to_string args.account_id))] in
597 let fields = match args.ids with
598 | Some ids -> ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: base
599 | None -> base
600 in
601 let fields = match args.properties with
602 | Some props -> ("properties", `List (List.map (fun p -> `String p) props)) :: fields
603 | None -> fields
604 in
605 `Assoc fields
606
607 let of_json json =
608 try
609 match json with
610 | `Assoc fields ->
611 let get_field name = List.assoc name fields in
612 let get_optional_field name = try Some (get_field name) with Not_found -> None in
613 let account_id = match get_field "accountId" with
614 | `String s -> (match Jmap.Id.of_string s with
615 | Ok id -> id
616 | Error _ -> failwith ("Invalid accountId: " ^ s))
617 | _ -> failwith "Expected string for accountId"
618 in
619 let ids = match get_optional_field "ids" with
620 | Some (`List id_list) -> Some (List.map (function
621 | `String s -> (match Jmap.Id.of_string s with
622 | Ok id -> id
623 | Error _ -> failwith ("Invalid id: " ^ s))
624 | _ -> failwith "Expected string in ids"
625 ) id_list)
626 | Some _ -> failwith "Expected list for ids"
627 | None -> None
628 in
629 let properties = match get_optional_field "properties" with
630 | Some (`List prop_list) -> Some (List.map (function
631 | `String s -> s
632 | _ -> failwith "Expected string in properties"
633 ) prop_list)
634 | Some _ -> failwith "Expected list for properties"
635 | None -> None
636 in
637 Ok { account_id; ids; properties }
638 | _ -> Error "Expected JSON object for Get_args"
639 with
640 | Not_found -> Error "Missing required field in Get_args JSON"
641 | Failure msg -> Error ("Get_args JSON parsing error: " ^ msg)
642 | exn -> Error ("Get_args JSON parsing exception: " ^ Printexc.to_string exn)
643
644 let create ~account_id ?ids ?properties () =
645 Ok { account_id; ids; properties }
646end
647
648module Get_response = struct
649
650 type get_response_data = {
651 account_id : Jmap.Id.t;
652 state : string;
653 list : email_submission_t list;
654 not_found : Jmap.Id.t list;
655 }
656
657 type t = get_response_data
658
659 let to_json response =
660 `Assoc [
661 ("accountId", `String (Jmap.Id.to_string response.account_id));
662 ("state", `String response.state);
663 ("list", `List (List.map (fun submission -> to_json submission) response.list));
664 ("notFound", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) response.not_found));
665 ]
666
667 let of_json json =
668 try
669 match json with
670 | `Assoc fields ->
671 let get_field name = List.assoc name fields in
672 let account_id = match get_field "accountId" with
673 | `String s -> (match Jmap.Id.of_string s with
674 | Ok id -> id
675 | Error _ -> failwith ("Invalid accountId: " ^ s))
676 | _ -> failwith "Expected string for accountId"
677 in
678 let state = match get_field "state" with
679 | `String s -> s
680 | _ -> failwith "Expected string for state"
681 in
682 let list = match get_field "list" with
683 | `List submission_list ->
684 List.filter_map (fun item ->
685 match (of_json : Yojson.Safe.t -> (email_submission_t, string) result) item with
686 | Ok submission -> Some submission
687 | Error _ -> None (* Skip entries that fail to parse *)
688 ) submission_list
689 | _ -> failwith "Expected list for list"
690 in
691 let not_found = match get_field "notFound" with
692 | `List id_list -> List.filter_map (function
693 | `String s -> (match Jmap.Id.of_string s with
694 | Ok id -> Some id
695 | Error _ -> None)
696 | _ -> None
697 ) id_list
698 | _ -> failwith "Expected list for notFound"
699 in
700 Ok { account_id; state; list; not_found }
701 | _ -> Error "Expected JSON object for Get_response"
702 with
703 | Not_found -> Error "Missing required field in Get_response JSON"
704 | Failure msg -> Error ("Get_response JSON parsing error: " ^ msg)
705 | exn -> Error ("Get_response JSON parsing exception: " ^ Printexc.to_string exn)
706
707 let account_id response = response.account_id
708 let state response = response.state
709 let list response = response.list
710 let not_found response = response.not_found
711end
712
713(** {1 Additional JMAP Method Modules} *)
714
715(* Changes, Query, Set modules would be implemented similarly following the same pattern *)
716(* For brevity, I'm providing a simplified version that maintains the interface *)
717
718module Changes_args = struct
719 type changes_args_data = {
720 account_id : Jmap.Id.t;
721 since_state : string;
722 max_changes : Jmap.UInt.t option;
723 }
724
725 type t = changes_args_data
726
727 let to_json args =
728 let base = [
729 ("accountId", `String (Jmap.Id.to_string args.account_id));
730 ("sinceState", `String args.since_state);
731 ] in
732 let fields = match args.max_changes with
733 | Some max -> ("maxChanges", `Int (Jmap.UInt.to_int max)) :: base
734 | None -> base
735 in
736 `Assoc fields
737
738 let of_json json =
739 try
740 match json with
741 | `Assoc fields ->
742 let get_field name = List.assoc name fields in
743 let get_optional_field name = try Some (get_field name) with Not_found -> None in
744 let account_id = match get_field "accountId" with
745 | `String s -> (match Jmap.Id.of_string s with
746 | Ok id -> id
747 | Error _ -> failwith ("Invalid accountId: " ^ s))
748 | _ -> failwith "Expected string for accountId"
749 in
750 let since_state = match get_field "sinceState" with
751 | `String s -> s
752 | _ -> failwith "Expected string for sinceState"
753 in
754 let max_changes = match get_optional_field "maxChanges" with
755 | Some (`Int i) -> (match Jmap.UInt.of_int i with
756 | Ok v -> Some v
757 | Error _ -> None)
758 | _ -> None
759 in
760 Ok { account_id; since_state; max_changes }
761 | _ -> Error "Expected JSON object for Changes_args"
762 with
763 | Not_found -> Error "Missing required field in Changes_args JSON"
764 | Failure msg -> Error ("Changes_args JSON parsing error: " ^ msg)
765 | exn -> Error ("Changes_args JSON parsing exception: " ^ Printexc.to_string exn)
766
767 let create ~account_id ~since_state ?max_changes () =
768 Ok { account_id; since_state; max_changes }
769end
770
771module Changes_response = struct
772 type changes_response_data = {
773 account_id : Jmap.Id.t;
774 old_state : string;
775 new_state : string;
776 has_more_changes : bool;
777 created : Jmap.Id.t list;
778 updated : Jmap.Id.t list;
779 destroyed : Jmap.Id.t list;
780 }
781
782 type t = changes_response_data
783
784 let to_json response =
785 `Assoc [
786 ("accountId", `String (Jmap.Id.to_string response.account_id));
787 ("oldState", `String response.old_state);
788 ("newState", `String response.new_state);
789 ("hasMoreChanges", `Bool response.has_more_changes);
790 ("created", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) response.created));
791 ("updated", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) response.updated));
792 ("destroyed", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) response.destroyed));
793 ]
794
795 let of_json json =
796 try
797 match json with
798 | `Assoc fields ->
799 let get_field name = List.assoc name fields in
800 let account_id = match get_field "accountId" with
801 | `String s -> (match Jmap.Id.of_string s with
802 | Ok id -> id
803 | Error _ -> failwith ("Invalid accountId: " ^ s))
804 | _ -> failwith "Expected string for accountId"
805 in
806 let old_state = match get_field "oldState" with
807 | `String s -> s
808 | _ -> failwith "Expected string for oldState"
809 in
810 let new_state = match get_field "newState" with
811 | `String s -> s
812 | _ -> failwith "Expected string for newState"
813 in
814 let has_more_changes = match get_field "hasMoreChanges" with
815 | `Bool b -> b
816 | _ -> failwith "Expected bool for hasMoreChanges"
817 in
818 let parse_id_list field_name =
819 match get_field field_name with
820 | `List ids -> List.filter_map (function
821 | `String s -> (match Jmap.Id.of_string s with
822 | Ok id -> Some id
823 | Error _ -> None)
824 | _ -> None) ids
825 | _ -> []
826 in
827 let created = parse_id_list "created" in
828 let updated = parse_id_list "updated" in
829 let destroyed = parse_id_list "destroyed" in
830 Ok { account_id; old_state; new_state; has_more_changes; created; updated; destroyed }
831 | _ -> Error "Expected JSON object for Changes_response"
832 with
833 | Not_found -> Error "Missing required field in Changes_response JSON"
834 | Failure msg -> Error ("Changes_response JSON parsing error: " ^ msg)
835 | exn -> Error ("Changes_response JSON parsing exception: " ^ Printexc.to_string exn)
836
837 let account_id response = response.account_id
838 let old_state response = response.old_state
839 let new_state response = response.new_state
840 let has_more_changes response = response.has_more_changes
841 let created response = response.created
842 let updated response = response.updated
843 let destroyed response = response.destroyed
844end
845
846module Query_args = struct
847 type query_args_data = {
848 account_id : Jmap.Id.t;
849 filter : Jmap.Methods.Filter.t option;
850 sort : Jmap.Methods.Comparator.t list option;
851 position : Jmap.UInt.t option;
852 anchor : Jmap.Id.t option;
853 anchor_offset : int option;
854 limit : Jmap.UInt.t option;
855 calculate_total : bool option;
856 }
857
858 type t = query_args_data
859
860 let to_json args =
861 let base = [("accountId", `String (Jmap.Id.to_string args.account_id))] in
862 let fields = match args.filter with
863 | Some f -> ("filter", Jmap.Methods.Filter.to_json f) :: base
864 | None -> base
865 in
866 let fields = match args.sort with
867 | Some s -> ("sort", `List (List.map Jmap.Methods.Comparator.to_json s)) :: fields
868 | None -> fields
869 in
870 let fields = match args.position with
871 | Some p -> ("position", `Int (Jmap.UInt.to_int p)) :: fields
872 | None -> fields
873 in
874 let fields = match args.anchor with
875 | Some a -> ("anchor", `String (Jmap.Id.to_string a)) :: fields
876 | None -> fields
877 in
878 let fields = match args.anchor_offset with
879 | Some o -> ("anchorOffset", `Int o) :: fields
880 | None -> fields
881 in
882 let fields = match args.limit with
883 | Some l -> ("limit", `Int (Jmap.UInt.to_int l)) :: fields
884 | None -> fields
885 in
886 let fields = match args.calculate_total with
887 | Some b -> ("calculateTotal", `Bool b) :: fields
888 | None -> fields
889 in
890 `Assoc fields
891
892 let of_json json =
893 try
894 match json with
895 | `Assoc fields ->
896 let get_field name = List.assoc name fields in
897 let get_optional_field name = try Some (get_field name) with Not_found -> None in
898 let account_id = match get_field "accountId" with
899 | `String s -> (match Jmap.Id.of_string s with
900 | Ok id -> id
901 | Error _ -> failwith ("Invalid accountId: " ^ s))
902 | _ -> failwith "Expected string for accountId"
903 in
904 let filter = match get_optional_field "filter" with
905 | Some f -> Some (Jmap.Methods.Filter.condition f)
906 | None -> None
907 in
908 let sort = match get_optional_field "sort" with
909 | Some (`List s) -> Some (List.filter_map (fun item ->
910 match Jmap.Methods.Comparator.of_json item with
911 | Ok comp -> Some comp
912 | Error _ -> None) s)
913 | _ -> None
914 in
915 let position = match get_optional_field "position" with
916 | Some (`Int i) -> (match Jmap.UInt.of_int i with
917 | Ok v -> Some v
918 | Error _ -> None)
919 | _ -> None
920 in
921 let anchor = match get_optional_field "anchor" with
922 | Some (`String s) -> (match Jmap.Id.of_string s with
923 | Ok id -> Some id
924 | Error _ -> None)
925 | _ -> None
926 in
927 let anchor_offset = match get_optional_field "anchorOffset" with
928 | Some (`Int i) -> Some i
929 | _ -> None
930 in
931 let limit = match get_optional_field "limit" with
932 | Some (`Int i) -> (match Jmap.UInt.of_int i with
933 | Ok v -> Some v
934 | Error _ -> None)
935 | _ -> None
936 in
937 let calculate_total = match get_optional_field "calculateTotal" with
938 | Some (`Bool b) -> Some b
939 | _ -> None
940 in
941 Ok { account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
942 | _ -> Error "Expected JSON object for Query_args"
943 with
944 | Not_found -> Error "Missing required field in Query_args JSON"
945 | Failure msg -> Error ("Query_args JSON parsing error: " ^ msg)
946 | exn -> Error ("Query_args JSON parsing exception: " ^ Printexc.to_string exn)
947
948 let create ~account_id ?filter ?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () =
949 Ok { account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
950end
951
952module Query_response = struct
953 type query_response_data = {
954 account_id : Jmap.Id.t;
955 query_state : string;
956 can_calculate_changes : bool;
957 position : Jmap.UInt.t;
958 total : Jmap.UInt.t option;
959 ids : Jmap.Id.t list;
960 }
961
962 type t = query_response_data
963
964 let to_json response =
965 let base = [
966 ("accountId", `String (Jmap.Id.to_string response.account_id));
967 ("queryState", `String response.query_state);
968 ("canCalculateChanges", `Bool response.can_calculate_changes);
969 ("position", `Int (Jmap.UInt.to_int response.position));
970 ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) response.ids));
971 ] in
972 let fields = match response.total with
973 | Some t -> ("total", `Int (Jmap.UInt.to_int t)) :: base
974 | None -> base
975 in
976 `Assoc fields
977
978 let of_json json =
979 try
980 match json with
981 | `Assoc fields ->
982 let get_field name = List.assoc name fields in
983 let get_optional_field name = try Some (get_field name) with Not_found -> None in
984 let account_id = match get_field "accountId" with
985 | `String s -> (match Jmap.Id.of_string s with
986 | Ok id -> id
987 | Error _ -> failwith ("Invalid accountId: " ^ s))
988 | _ -> failwith "Expected string for accountId"
989 in
990 let query_state = match get_field "queryState" with
991 | `String s -> s
992 | _ -> failwith "Expected string for queryState"
993 in
994 let can_calculate_changes = match get_field "canCalculateChanges" with
995 | `Bool b -> b
996 | _ -> failwith "Expected bool for canCalculateChanges"
997 in
998 let position = match get_field "position" with
999 | `Int i -> (match Jmap.UInt.of_int i with
1000 | Ok v -> v
1001 | Error _ -> failwith "Invalid position")
1002 | _ -> failwith "Expected int for position"
1003 in
1004 let total = match get_optional_field "total" with
1005 | Some (`Int i) -> (match Jmap.UInt.of_int i with
1006 | Ok v -> Some v
1007 | Error _ -> None)
1008 | _ -> None
1009 in
1010 let ids = match get_field "ids" with
1011 | `List id_list -> List.filter_map (function
1012 | `String s -> (match Jmap.Id.of_string s with
1013 | Ok id -> Some id
1014 | Error _ -> None)
1015 | _ -> None) id_list
1016 | _ -> []
1017 in
1018 Ok { account_id; query_state; can_calculate_changes; position; total; ids }
1019 | _ -> Error "Expected JSON object for Query_response"
1020 with
1021 | Not_found -> Error "Missing required field in Query_response JSON"
1022 | Failure msg -> Error ("Query_response JSON parsing error: " ^ msg)
1023 | exn -> Error ("Query_response JSON parsing exception: " ^ Printexc.to_string exn)
1024
1025 let account_id response = response.account_id
1026 let query_state response = response.query_state
1027 let can_calculate_changes response = response.can_calculate_changes
1028 let position response = response.position
1029 let total response = response.total
1030 let ids response = response.ids
1031end
1032
1033module Set_args = struct
1034 type set_args_data = {
1035 account_id : Jmap.Id.t;
1036 if_in_state : string option;
1037 create : (Jmap.Id.t * Create.t) list option;
1038 update : (Jmap.Id.t * Update.t) list option;
1039 destroy : Jmap.Id.t list option;
1040 on_success_destroy_email : Jmap.Id.t list option;
1041 }
1042
1043 type t = set_args_data
1044
1045 let to_json args =
1046 let base = [("accountId", `String (Jmap.Id.to_string args.account_id))] in
1047 let fields = match args.if_in_state with
1048 | Some s -> ("ifInState", `String s) :: base
1049 | None -> base
1050 in
1051 let fields = match args.create with
1052 | Some creates ->
1053 let create_assoc = List.map (fun (id, create_obj) ->
1054 (Jmap.Id.to_string id, Create.to_json create_obj)
1055 ) creates in
1056 ("create", `Assoc create_assoc) :: fields
1057 | None -> fields
1058 in
1059 let fields = match args.update with
1060 | Some updates ->
1061 let update_assoc = List.map (fun (id, update_obj) ->
1062 (Jmap.Id.to_string id, Update.to_json update_obj)
1063 ) updates in
1064 ("update", `Assoc update_assoc) :: fields
1065 | None -> fields
1066 in
1067 let fields = match args.destroy with
1068 | Some ids ->
1069 ("destroy", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: fields
1070 | None -> fields
1071 in
1072 let fields = match args.on_success_destroy_email with
1073 | Some ids ->
1074 ("onSuccessDestroyEmail", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: fields
1075 | None -> fields
1076 in
1077 `Assoc fields
1078
1079 let of_json json =
1080 try
1081 match json with
1082 | `Assoc fields ->
1083 let get_field name = List.assoc name fields in
1084 let get_optional_field name = try Some (get_field name) with Not_found -> None in
1085 let account_id = match get_field "accountId" with
1086 | `String s -> (match Jmap.Id.of_string s with
1087 | Ok id -> id
1088 | Error _ -> failwith ("Invalid accountId: " ^ s))
1089 | _ -> failwith "Expected string for accountId"
1090 in
1091 let if_in_state = match get_optional_field "ifInState" with
1092 | Some (`String s) -> Some s
1093 | _ -> None
1094 in
1095 let create = match get_optional_field "create" with
1096 | Some (`Assoc create_list) ->
1097 Some (List.filter_map (fun (id_str, create_json) ->
1098 match Jmap.Id.of_string id_str, Create.of_json create_json with
1099 | Ok id, Ok create_obj -> Some (id, create_obj)
1100 | _ -> None
1101 ) create_list)
1102 | _ -> None
1103 in
1104 let update = match get_optional_field "update" with
1105 | Some (`Assoc update_list) ->
1106 Some (List.filter_map (fun (id_str, update_json) ->
1107 match Jmap.Id.of_string id_str, Update.of_json update_json with
1108 | Ok id, Ok update_obj -> Some (id, update_obj)
1109 | _ -> None
1110 ) update_list)
1111 | _ -> None
1112 in
1113 let destroy = match get_optional_field "destroy" with
1114 | Some (`List id_list) ->
1115 Some (List.filter_map (function
1116 | `String s -> (match Jmap.Id.of_string s with
1117 | Ok id -> Some id
1118 | Error _ -> None)
1119 | _ -> None) id_list)
1120 | _ -> None
1121 in
1122 let on_success_destroy_email = match get_optional_field "onSuccessDestroyEmail" with
1123 | Some (`List id_list) ->
1124 Some (List.filter_map (function
1125 | `String s -> (match Jmap.Id.of_string s with
1126 | Ok id -> Some id
1127 | Error _ -> None)
1128 | _ -> None) id_list)
1129 | _ -> None
1130 in
1131 Ok { account_id; if_in_state; create; update; destroy; on_success_destroy_email }
1132 | _ -> Error "Expected JSON object for Set_args"
1133 with
1134 | Not_found -> Error "Missing required field in Set_args JSON"
1135 | Failure msg -> Error ("Set_args JSON parsing error: " ^ msg)
1136 | exn -> Error ("Set_args JSON parsing exception: " ^ Printexc.to_string exn)
1137
1138 let create ~account_id ?if_in_state ?create ?update ?destroy ?on_success_destroy_email () =
1139 Ok { account_id; if_in_state; create; update; destroy; on_success_destroy_email }
1140end
1141
1142module Set_response = struct
1143 type set_response_data = {
1144 account_id : Jmap.Id.t;
1145 old_state : string option;
1146 new_state : string;
1147 created : (string, Create.Response.t) Hashtbl.t;
1148 updated : (string, Update.Response.t) Hashtbl.t option;
1149 destroyed : Jmap.Id.t list option;
1150 not_created : (string, Jmap.Error.Set_error.t) Hashtbl.t option;
1151 not_updated : (string, Jmap.Error.Set_error.t) Hashtbl.t option;
1152 not_destroyed : (string, Jmap.Error.Set_error.t) Hashtbl.t option;
1153 }
1154
1155 type t = set_response_data
1156
1157 let to_json response =
1158 let base = [
1159 ("accountId", `String (Jmap.Id.to_string response.account_id));
1160 ("newState", `String response.new_state);
1161 ] in
1162 let fields = match response.old_state with
1163 | Some s -> ("oldState", `String s) :: base
1164 | None -> base
1165 in
1166 let fields =
1167 let created_assoc = Hashtbl.fold (fun k v acc ->
1168 (k, Create.Response.to_json v) :: acc
1169 ) response.created [] in
1170 if created_assoc <> [] then
1171 ("created", `Assoc created_assoc) :: fields
1172 else fields
1173 in
1174 let fields = match response.updated with
1175 | Some updated_tbl ->
1176 let updated_assoc = Hashtbl.fold (fun k v acc ->
1177 (k, Update.Response.to_json v) :: acc
1178 ) updated_tbl [] in
1179 ("updated", `Assoc updated_assoc) :: fields
1180 | None -> fields
1181 in
1182 let fields = match response.destroyed with
1183 | Some ids ->
1184 ("destroyed", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: fields
1185 | None -> fields
1186 in
1187 let fields = match response.not_created with
1188 | Some tbl ->
1189 let not_created_assoc = Hashtbl.fold (fun k v acc ->
1190 (k, Jmap.Error.Set_error.to_json v) :: acc
1191 ) tbl [] in
1192 ("notCreated", `Assoc not_created_assoc) :: fields
1193 | None -> fields
1194 in
1195 let fields = match response.not_updated with
1196 | Some tbl ->
1197 let not_updated_assoc = Hashtbl.fold (fun k v acc ->
1198 (k, Jmap.Error.Set_error.to_json v) :: acc
1199 ) tbl [] in
1200 ("notUpdated", `Assoc not_updated_assoc) :: fields
1201 | None -> fields
1202 in
1203 let fields = match response.not_destroyed with
1204 | Some tbl ->
1205 let not_destroyed_assoc = Hashtbl.fold (fun k v acc ->
1206 (k, Jmap.Error.Set_error.to_json v) :: acc
1207 ) tbl [] in
1208 ("notDestroyed", `Assoc not_destroyed_assoc) :: fields
1209 | None -> fields
1210 in
1211 `Assoc fields
1212
1213 let of_json json =
1214 try
1215 match json with
1216 | `Assoc fields ->
1217 let get_field name = List.assoc name fields in
1218 let get_optional_field name = try Some (get_field name) with Not_found -> None in
1219 let account_id = match get_field "accountId" with
1220 | `String s -> (match Jmap.Id.of_string s with
1221 | Ok id -> id
1222 | Error _ -> failwith ("Invalid accountId: " ^ s))
1223 | _ -> failwith "Expected string for accountId"
1224 in
1225 let old_state = match get_optional_field "oldState" with
1226 | Some (`String s) -> Some s
1227 | _ -> None
1228 in
1229 let new_state = match get_field "newState" with
1230 | `String s -> s
1231 | _ -> failwith "Expected string for newState"
1232 in
1233 let created =
1234 let tbl = Hashtbl.create 10 in
1235 (match get_optional_field "created" with
1236 | Some (`Assoc created_list) ->
1237 List.iter (fun (k, v) ->
1238 match Create.Response.of_json v with
1239 | Ok resp -> Hashtbl.add tbl k resp
1240 | Error _ -> ()
1241 ) created_list
1242 | _ -> ());
1243 tbl
1244 in
1245 let updated = match get_optional_field "updated" with
1246 | Some (`Assoc updated_list) ->
1247 let tbl = Hashtbl.create (List.length updated_list) in
1248 List.iter (fun (k, v) ->
1249 match Update.Response.of_json v with
1250 | Ok resp -> Hashtbl.add tbl k resp
1251 | Error _ -> ()
1252 ) updated_list;
1253 Some tbl
1254 | _ -> None
1255 in
1256 let destroyed = match get_optional_field "destroyed" with
1257 | Some (`List id_list) ->
1258 Some (List.filter_map (function
1259 | `String s -> (match Jmap.Id.of_string s with
1260 | Ok id -> Some id
1261 | Error _ -> None)
1262 | _ -> None) id_list)
1263 | _ -> None
1264 in
1265 let parse_error_table field_name =
1266 match get_optional_field field_name with
1267 | Some (`Assoc error_list) ->
1268 let tbl = Hashtbl.create (List.length error_list) in
1269 List.iter (fun (k, v) ->
1270 match Jmap.Error.Set_error.of_json v with
1271 | Ok err -> Hashtbl.add tbl k err
1272 | Error _ -> ()
1273 ) error_list;
1274 Some tbl
1275 | _ -> None
1276 in
1277 let not_created = parse_error_table "notCreated" in
1278 let not_updated = parse_error_table "notUpdated" in
1279 let not_destroyed = parse_error_table "notDestroyed" in
1280 Ok { account_id; old_state; new_state; created; updated; destroyed;
1281 not_created; not_updated; not_destroyed }
1282 | _ -> Error "Expected JSON object for Set_response"
1283 with
1284 | Not_found -> Error "Missing required field in Set_response JSON"
1285 | Failure msg -> Error ("Set_response JSON parsing error: " ^ msg)
1286 | exn -> Error ("Set_response JSON parsing exception: " ^ Printexc.to_string exn)
1287
1288 let account_id response = response.account_id
1289 let old_state response = response.old_state
1290 let new_state response = response.new_state
1291 let created response = response.created
1292 let updated response = response.updated
1293 let destroyed response = response.destroyed
1294 let not_created response = response.not_created
1295 let not_updated response = response.not_updated
1296 let not_destroyed response = response.not_destroyed
1297end
1298
1299(** {1 Filter Helper Functions} *)
1300
1301module Filter = struct
1302
1303 let identity_ids ids =
1304 let id_values = List.map (fun id -> `String (Jmap.Id.to_string id)) ids in
1305 Jmap.Methods.Filter.property_in "identityId" id_values
1306
1307 let email_ids ids =
1308 let id_values = List.map (fun id -> `String (Jmap.Id.to_string id)) ids in
1309 Jmap.Methods.Filter.property_in "emailId" id_values
1310
1311 let thread_ids ids =
1312 let id_values = List.map (fun id -> `String (Jmap.Id.to_string id)) ids in
1313 Jmap.Methods.Filter.property_in "threadId" id_values
1314
1315 let undo_status status =
1316 let status_value = `String (undo_status_to_string status) in
1317 Jmap.Methods.Filter.property_equals "undoStatus" status_value
1318
1319 let before date =
1320 Jmap.Methods.Filter.property_lt "sendAt" (`Float (Jmap.Date.to_timestamp date))
1321
1322 let after date =
1323 Jmap.Methods.Filter.property_gt "sendAt" (`Float (Jmap.Date.to_timestamp date))
1324
1325 let date_range ~after_date ~before_date =
1326 Jmap.Methods.Filter.and_ [
1327 after after_date;
1328 before before_date;
1329 ]
1330end
1331
1332(** {1 Sort Helper Functions} *)
1333
1334module Sort = struct
1335
1336 let send_newest_first () =
1337 Jmap.Methods.Comparator.v ~property:"sendAt" ~is_ascending:false ()
1338
1339 let send_oldest_first () =
1340 Jmap.Methods.Comparator.v ~property:"sendAt" ~is_ascending:true ()
1341
1342 let identity_id ?(ascending=true) () =
1343 Jmap.Methods.Comparator.v ~property:"identityId" ~is_ascending:ascending ()
1344
1345 let email_id ?(ascending=true) () =
1346 Jmap.Methods.Comparator.v ~property:"emailId" ~is_ascending:ascending ()
1347
1348 let thread_id ?(ascending=true) () =
1349 Jmap.Methods.Comparator.v ~property:"threadId" ~is_ascending:ascending ()
1350
1351 let undo_status ?(ascending=true) () =
1352 Jmap.Methods.Comparator.v ~property:"undoStatus" ~is_ascending:ascending ()
1353end
1354
1355module Property = struct
1356 type t = [
1357 | `Id
1358 | `IdentityId
1359 | `EmailId
1360 | `ThreadId
1361 | `Envelope
1362 | `SendAt
1363 | `UndoStatus
1364 | `DeliveryStatus
1365 | `DsnBlobIds
1366 | `MdnBlobIds
1367 ]
1368
1369 let to_string = function
1370 | `Id -> "Id.t"
1371 | `IdentityId -> "identityId"
1372 | `EmailId -> "emailId"
1373 | `ThreadId -> "threadId"
1374 | `Envelope -> "envelope"
1375 | `SendAt -> "sendAt"
1376 | `UndoStatus -> "undoStatus"
1377 | `DeliveryStatus -> "deliveryStatus"
1378 | `DsnBlobIds -> "dsnBlobIds"
1379 | `MdnBlobIds -> "mdnBlobIds"
1380
1381 let of_string = function
1382 | "Id.t" -> Some `Id
1383 | "identityId" -> Some `IdentityId
1384 | "emailId" -> Some `EmailId
1385 | "threadId" -> Some `ThreadId
1386 | "envelope" -> Some `Envelope
1387 | "sendAt" -> Some `SendAt
1388 | "undoStatus" -> Some `UndoStatus
1389 | "deliveryStatus" -> Some `DeliveryStatus
1390 | "dsnBlobIds" -> Some `DsnBlobIds
1391 | "mdnBlobIds" -> Some `MdnBlobIds
1392 | _ -> None
1393
1394 let all_properties = [
1395 `Id; `IdentityId; `EmailId; `ThreadId; `Envelope;
1396 `SendAt; `UndoStatus; `DeliveryStatus; `DsnBlobIds; `MdnBlobIds
1397 ]
1398
1399 let to_string_list props = List.map to_string props
1400
1401 let of_string_list strings =
1402 List.filter_map of_string strings
1403
1404 let common_properties = [`Id; `IdentityId; `EmailId; `ThreadId; `SendAt; `UndoStatus]
1405
1406 let detailed_properties = all_properties
1407end