My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** JMAP Identity Implementation.
2
3 This module implements the JMAP Identity data type representing user
4 sending identities with their associated properties like email addresses,
5 signatures, and default headers.
6
7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-6> RFC 8621, Section 6: Identity
8*)
9
10open Jmap.Method_names
11open Jmap.Error
12
13(** Identity object *)
14type t = {
15 id : Jmap.Id.t option;
16 name : string;
17 email : string;
18 reply_to : Address.t list option;
19 bcc : Address.t list option;
20 text_signature : string;
21 html_signature : string;
22 may_delete : bool;
23}
24
25let id t = t.id
26let name t = t.name
27let email t = t.email
28let reply_to t = t.reply_to
29let bcc t = t.bcc
30let text_signature t = t.text_signature
31let html_signature t = t.html_signature
32let may_delete t = t.may_delete
33
34let v ~id ?(name = "") ~email ?reply_to ?bcc ?(text_signature = "")
35 ?(html_signature = "") ~may_delete () = {
36 id = Some id;
37 name;
38 email;
39 reply_to;
40 bcc;
41 text_signature;
42 html_signature;
43 may_delete;
44}
45
46let to_json t =
47 let fields = [
48 ("id", (match t.id with Some id -> `String (Jmap.Id.to_string id) | None -> `Null));
49 ("name", `String t.name);
50 ("email", `String t.email);
51 ("textSignature", `String t.text_signature);
52 ("htmlSignature", `String t.html_signature);
53 ("mayDelete", `Bool t.may_delete);
54 ] in
55 let fields = match t.reply_to with
56 | None -> ("replyTo", `Null) :: fields
57 | Some addrs -> ("replyTo", `List (List.map Address.to_json addrs)) :: fields
58 in
59 let fields = match t.bcc with
60 | None -> ("bcc", `Null) :: fields
61 | Some addrs -> ("bcc", `List (List.map Address.to_json addrs)) :: fields
62 in
63 `Assoc (List.rev fields)
64
65(* JMAP_OBJECT implementation *)
66let create ?id () =
67 let id_opt = match id with
68 | None -> None
69 | Some id_str ->
70 (match Jmap.Id.of_string id_str with
71 | Ok jmap_id -> Some jmap_id
72 | Error _ -> failwith ("Invalid identity id: " ^ id_str)) in
73 { id = id_opt; name = ""; email = ""; reply_to = None; bcc = None;
74 text_signature = ""; html_signature = ""; may_delete = true }
75
76let to_json_with_properties ~properties t =
77 let all_fields = [
78 ("id", (match t.id with Some id -> `String (Jmap.Id.to_string id) | None -> `Null));
79 ("name", `String t.name);
80 ("email", `String t.email);
81 ("replyTo", (match t.reply_to with
82 | None -> `Null
83 | Some addrs -> `List (List.map Address.to_json addrs)));
84 ("bcc", (match t.bcc with
85 | None -> `Null
86 | Some addrs -> `List (List.map Address.to_json addrs)));
87 ("textSignature", `String t.text_signature);
88 ("htmlSignature", `String t.html_signature);
89 ("mayDelete", `Bool t.may_delete);
90 ] in
91 let filtered_fields = List.filter (fun (name, _) ->
92 List.mem name properties
93 ) all_fields in
94 `Assoc filtered_fields
95
96let valid_properties () = [
97 "Id.t"; "name"; "email"; "replyTo"; "bcc"; "textSignature"; "htmlSignature"; "mayDelete"
98] (* TODO: Use Property.to_string_list Property.all_properties when module ordering is fixed *)
99
100let of_json json =
101 try
102 match json with
103 | `Assoc fields ->
104 let get_string key default =
105 match List.assoc_opt key fields with
106 | Some (`String s) -> s
107 | Some `Null | None -> default
108 | _ -> failwith ("Invalid " ^ key ^ " field in Identity")
109 in
110 let get_bool key default =
111 match List.assoc_opt key fields with
112 | Some (`Bool b) -> b
113 | Some `Null | None -> default
114 | _ -> failwith ("Invalid " ^ key ^ " field in Identity")
115 in
116 let get_addresses key =
117 match List.assoc_opt key fields with
118 | Some (`List addrs) ->
119 let rec process_addresses acc = function
120 | [] -> Some (List.rev acc)
121 | addr :: rest ->
122 (match Address.of_json addr with
123 | Ok a -> process_addresses (a :: acc) rest
124 | Error _ -> failwith ("Invalid address in " ^ key ^ " field"))
125 in
126 process_addresses [] addrs
127 | Some `Null | None -> None
128 | _ -> failwith ("Invalid " ^ key ^ " field in Identity")
129 in
130 let id = get_string "id" "" in
131 let email = get_string "email" "" in
132 if email = "" then failwith "Missing required 'email' field in Identity";
133 Ok {
134 id = (if id = "" then None else match Jmap.Id.of_string id with
135 | Ok id_t -> Some id_t
136 | Error _ -> failwith ("Invalid ID: " ^ id));
137 name = get_string "name" "";
138 email;
139 reply_to = get_addresses "replyTo";
140 bcc = get_addresses "bcc";
141 text_signature = get_string "textSignature" "";
142 html_signature = get_string "htmlSignature" "";
143 may_delete = get_bool "mayDelete" false;
144 }
145 | _ -> Error "Identity must be a JSON object"
146 with
147 | Failure msg -> Error msg
148 | exn -> Error ("Failed to parse Identity JSON: " ^ Printexc.to_string exn)
149
150(* Pretty printing implementation for PRINTABLE signature *)
151let pp ppf t =
152 let name_str = if t.name = "" then "<no-name>" else t.name in
153 let id_str = match t.id with Some id -> Jmap.Id.to_string id | None -> "(no-id)" in
154 Format.fprintf ppf "Identity{id=%s; name=%s; email=%s; may_delete=%b}"
155 id_str name_str t.email t.may_delete
156
157(* Alias for pp following Fmt conventions *)
158let pp_hum = pp
159
160(** Identity creation operations *)
161module Create = struct
162 type t = {
163 name : string option;
164 email : string;
165 reply_to : Address.t list option;
166 bcc : Address.t list option;
167 text_signature : string option;
168 html_signature : string option;
169 }
170
171 let name t = t.name
172 let email t = t.email
173 let reply_to t = t.reply_to
174 let bcc t = t.bcc
175 let text_signature t = t.text_signature
176 let html_signature t = t.html_signature
177
178 let v ?name ~email ?reply_to ?bcc ?text_signature ?html_signature () = {
179 name;
180 email;
181 reply_to;
182 bcc;
183 text_signature;
184 html_signature;
185 }
186
187 let to_json t =
188 let fields = [("email", `String t.email)] in
189 let fields = match t.name with
190 | None -> fields
191 | Some n -> ("name", `String n) :: fields
192 in
193 let fields = match t.reply_to with
194 | None -> fields
195 | Some addrs -> ("replyTo", `List (List.map Address.to_json addrs)) :: fields
196 in
197 let fields = match t.bcc with
198 | None -> fields
199 | Some addrs -> ("bcc", `List (List.map Address.to_json addrs)) :: fields
200 in
201 let fields = match t.text_signature with
202 | None -> fields
203 | Some s -> ("textSignature", `String s) :: fields
204 in
205 let fields = match t.html_signature with
206 | None -> fields
207 | Some s -> ("htmlSignature", `String s) :: fields
208 in
209 `Assoc (List.rev fields)
210
211 let of_json json =
212 try
213 match json with
214 | `Assoc fields ->
215 let get_string_opt key =
216 match List.assoc_opt key fields with
217 | Some (`String s) -> Some s
218 | Some `Null | None -> None
219 | _ -> failwith ("Invalid " ^ key ^ " field in Identity creation")
220 in
221 let get_addresses_opt key =
222 match List.assoc_opt key fields with
223 | Some (`List addrs) ->
224 let rec process_addresses acc = function
225 | [] -> Some (List.rev acc)
226 | addr :: rest ->
227 (match Address.of_json addr with
228 | Ok a -> process_addresses (a :: acc) rest
229 | Error _ -> failwith ("Invalid address in " ^ key ^ " field"))
230 in
231 process_addresses [] addrs
232 | Some `Null | None -> None
233 | _ -> failwith ("Invalid " ^ key ^ " field in Identity creation")
234 in
235 let email = match List.assoc_opt "email" fields with
236 | Some (`String s) -> s
237 | _ -> failwith "Missing required 'email' field in Identity creation"
238 in
239 Ok {
240 name = get_string_opt "name";
241 email;
242 reply_to = get_addresses_opt "replyTo";
243 bcc = get_addresses_opt "bcc";
244 text_signature = get_string_opt "textSignature";
245 html_signature = get_string_opt "htmlSignature";
246 }
247 | _ -> Error "Identity creation must be a JSON object"
248 with
249 | Failure msg -> Error msg
250 | exn -> Error ("Failed to parse Identity creation JSON: " ^ Printexc.to_string exn)
251
252 (** Server response with info about the created identity *)
253 module Response = struct
254 type t = {
255 id : Jmap.Id.t;
256 may_delete : bool;
257 }
258
259 let id t = t.id
260 let may_delete t = t.may_delete
261
262 let v ~id ~may_delete () = {
263 id;
264 may_delete;
265 }
266
267 let to_json t =
268 `Assoc [
269 ("id", `String (Jmap.Id.to_string t.id));
270 ("mayDelete", `Bool t.may_delete);
271 ]
272
273 let of_json json =
274 try
275 match json with
276 | `Assoc fields ->
277 let id = match List.assoc_opt "Id.t" fields with
278 | Some (`String s) -> (match Jmap.Id.of_string s with
279 | Ok id -> id
280 | Error _ -> failwith ("Invalid id: " ^ s))
281 | _ -> failwith "Missing required 'Id.t' field in Identity creation response"
282 in
283 let may_delete = match List.assoc_opt "mayDelete" fields with
284 | Some (`Bool b) -> b
285 | _ -> failwith "Missing required 'mayDelete' field in Identity creation response"
286 in
287 Ok { id; may_delete }
288 | _ -> Error "Identity creation response must be a JSON object"
289 with
290 | Failure msg -> Error msg
291 | exn -> Error ("Failed to parse Identity creation response: " ^ Printexc.to_string exn)
292 end
293end
294
295(** Identity update operations *)
296module Update = struct
297 type t = {
298 name : string option;
299 reply_to : Address.t list option option;
300 bcc : Address.t list option option;
301 text_signature : string option;
302 html_signature : string option;
303 }
304
305 let set_name name = {
306 name = Some name;
307 reply_to = None;
308 bcc = None;
309 text_signature = None;
310 html_signature = None;
311 }
312
313 let set_reply_to reply_to = {
314 name = None;
315 reply_to = Some reply_to;
316 bcc = None;
317 text_signature = None;
318 html_signature = None;
319 }
320
321 let set_bcc bcc = {
322 name = None;
323 reply_to = None;
324 bcc = Some bcc;
325 text_signature = None;
326 html_signature = None;
327 }
328
329 let set_text_signature text_signature = {
330 name = None;
331 reply_to = None;
332 bcc = None;
333 text_signature = Some text_signature;
334 html_signature = None;
335 }
336
337 let set_html_signature html_signature = {
338 name = None;
339 reply_to = None;
340 bcc = None;
341 text_signature = None;
342 html_signature = Some html_signature;
343 }
344
345 let combine updates =
346 List.fold_left (fun acc update ->
347 {
348 name = (match update.name with None -> acc.name | Some _ as x -> x);
349 reply_to = (match update.reply_to with None -> acc.reply_to | Some _ as x -> x);
350 bcc = (match update.bcc with None -> acc.bcc | Some _ as x -> x);
351 text_signature = (match update.text_signature with None -> acc.text_signature | Some _ as x -> x);
352 html_signature = (match update.html_signature with None -> acc.html_signature | Some _ as x -> x);
353 }
354 ) {
355 name = None;
356 reply_to = None;
357 bcc = None;
358 text_signature = None;
359 html_signature = None;
360 } updates
361
362 let to_json t =
363 let fields = [] in
364 let fields = match t.name with
365 | None -> fields
366 | Some n -> ("name", `String n) :: fields
367 in
368 let fields = match t.reply_to with
369 | None -> fields
370 | Some None -> ("replyTo", `Null) :: fields
371 | Some (Some addrs) -> ("replyTo", `List (List.map Address.to_json addrs)) :: fields
372 in
373 let fields = match t.bcc with
374 | None -> fields
375 | Some None -> ("bcc", `Null) :: fields
376 | Some (Some addrs) -> ("bcc", `List (List.map Address.to_json addrs)) :: fields
377 in
378 let fields = match t.text_signature with
379 | None -> fields
380 | Some s -> ("textSignature", `String s) :: fields
381 in
382 let fields = match t.html_signature with
383 | None -> fields
384 | Some s -> ("htmlSignature", `String s) :: fields
385 in
386 `Assoc (List.rev fields)
387
388 let of_json json =
389 try
390 match json with
391 | `Assoc fields ->
392 let get_string_opt key =
393 match List.assoc_opt key fields with
394 | Some (`String s) -> Some s
395 | _ -> None
396 in
397 let get_addresses_opt_opt key =
398 if List.mem_assoc key fields then
399 match List.assoc key fields with
400 | `Null -> Some None
401 | `List addrs ->
402 let rec process_addresses acc = function
403 | [] -> Some (Some (List.rev acc))
404 | addr :: rest ->
405 (match Address.of_json addr with
406 | Ok a -> process_addresses (a :: acc) rest
407 | Error _ -> failwith ("Invalid address in " ^ key ^ " field"))
408 in
409 process_addresses [] addrs
410 | _ -> failwith ("Invalid " ^ key ^ " field in Identity update")
411 else None
412 in
413 Ok {
414 name = get_string_opt "name";
415 reply_to = get_addresses_opt_opt "replyTo";
416 bcc = get_addresses_opt_opt "bcc";
417 text_signature = get_string_opt "textSignature";
418 html_signature = get_string_opt "htmlSignature";
419 }
420 | _ -> Error "Identity update must be a JSON object"
421 with
422 | Failure msg -> Error ("Identity Update JSON parsing error: " ^ msg)
423 | exn -> Error ("Identity Update JSON parsing exception: " ^ Printexc.to_string exn)
424
425 (** Server response for successful identity update *)
426 module Response = struct
427 type t = {
428 may_delete : bool option;
429 }
430
431 let may_delete t = t.may_delete
432
433 let v ?may_delete () = {
434 may_delete;
435 }
436
437 let to_json t =
438 let fields = match t.may_delete with
439 | None -> []
440 | Some b -> [("mayDelete", `Bool b)]
441 in
442 `Assoc fields
443
444 let of_json json =
445 try
446 match json with
447 | `Assoc fields ->
448 let may_delete = match List.assoc_opt "mayDelete" fields with
449 | Some (`Bool b) -> Some b
450 | Some `Null | None -> None
451 | _ -> failwith "Invalid 'mayDelete' field in Identity update response"
452 in
453 Ok { may_delete }
454 | _ -> Error "Identity update response must be a JSON object"
455 with
456 | Failure msg -> Error ("Update.Response JSON parsing error: " ^ msg)
457 | exn -> Error ("Update.Response JSON parsing exception: " ^ Printexc.to_string exn)
458 end
459end
460
461(** Arguments for Identity/get method *)
462module Get_args = struct
463 type t = {
464 account_id : Jmap.Id.t;
465 ids : Jmap.Id.t list option;
466 properties : string list option;
467 }
468
469 let account_id t = t.account_id
470 let ids t = t.ids
471 let properties t = t.properties
472
473 let v ~account_id ?ids ?properties () =
474 { account_id; ids; properties }
475
476 let to_json t =
477 let fields = [("accountId", `String (Jmap.Id.to_string t.account_id))] in
478 let fields = match t.ids with
479 | None -> fields
480 | Some ids -> ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: fields
481 in
482 let fields = match t.properties with
483 | None -> fields
484 | Some props -> ("properties", `List (List.map (fun p -> `String p) props)) :: fields
485 in
486 `Assoc (List.rev fields)
487
488 let of_json json =
489 try
490 match json with
491 | `Assoc fields ->
492 let account_id = match List.assoc_opt "accountId" fields with
493 | Some (`String s) -> (match Jmap.Id.of_string s with
494 | Ok id -> id | Error err -> failwith ("Invalid accountId: " ^ err))
495 | _ -> failwith "Missing required 'accountId' field in Identity/get arguments"
496 in
497 let ids = match List.assoc_opt "ids" fields with
498 | Some (`List ids) -> Some (List.map (function `String s -> (match Jmap.Id.of_string s with Ok id -> id | Error err -> failwith ("Invalid ID: " ^ err)) | _ -> failwith "Invalid ID in 'ids' list") ids)
499 | Some `Null | None -> None
500 | _ -> failwith "Invalid 'ids' field in Identity/get arguments"
501 in
502 let properties = match List.assoc_opt "properties" fields with
503 | Some (`List props) -> Some (List.map (function `String s -> s | _ -> failwith "Invalid property in 'properties' list") props)
504 | Some `Null | None -> None
505 | _ -> failwith "Invalid 'properties' field in Identity/get arguments"
506 in
507 Ok { account_id; ids; properties }
508 | _ -> Error "Identity/get arguments must be a JSON object"
509 with
510 | Failure msg -> Error ("Identity Get_args JSON parsing error: " ^ msg)
511 | exn -> Error ("Identity Get_args JSON parsing exception: " ^ Printexc.to_string exn)
512
513 let pp fmt t =
514 Format.fprintf fmt "Identity.Get_args{account=%s;ids=%s}"
515 (Jmap.Id.to_string t.account_id)
516 (match t.ids with Some ids -> string_of_int (List.length ids) | None -> "all")
517
518 let pp_hum fmt t = pp fmt t
519
520 let validate _t = Ok ()
521
522 let method_name () = method_to_string `Identity_get
523end
524
525
526(** Arguments for Identity/set method *)
527module Set_args = struct
528 type t = {
529 account_id : Jmap.Id.t;
530 if_in_state : string option;
531 create : (string, Create.t) Hashtbl.t option;
532 update : (string, Update.t) Hashtbl.t option;
533 destroy : Jmap.Id.t list option;
534 }
535
536 let account_id t = t.account_id
537 let if_in_state t = t.if_in_state
538 let create t = t.create
539 let update t = t.update
540 let destroy t = t.destroy
541
542 let v ~account_id ?if_in_state ?create ?update ?destroy () =
543 { account_id; if_in_state; create; update; destroy }
544
545 let to_json t =
546 let fields = [("accountId", `String (Jmap.Id.to_string t.account_id))] in
547 let fields = match t.if_in_state with
548 | None -> fields
549 | Some state -> ("ifInState", `String state) :: fields
550 in
551 let fields = match t.create with
552 | None -> fields
553 | Some create_map ->
554 let create_obj = Hashtbl.fold (fun k v acc ->
555 (k, Create.to_json v) :: acc
556 ) create_map [] in
557 ("create", `Assoc create_obj) :: fields
558 in
559 let fields = match t.update with
560 | None -> fields
561 | Some update_map ->
562 let update_obj = Hashtbl.fold (fun k v acc ->
563 (k, Update.to_json v) :: acc
564 ) update_map [] in
565 ("update", `Assoc update_obj) :: fields
566 in
567 let fields = match t.destroy with
568 | None -> fields
569 | Some ids -> ("destroy", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: fields
570 in
571 `Assoc (List.rev fields)
572
573 let of_json json =
574 try
575 match json with
576 | `Assoc fields ->
577 let account_id = match List.assoc_opt "accountId" fields with
578 | Some (`String s) -> (match Jmap.Id.of_string s with
579 | Ok id -> id
580 | Error _ -> failwith ("Invalid accountId: " ^ s))
581 | _ -> failwith "Missing required 'accountId' field in Identity/set arguments"
582 in
583 let if_in_state = match List.assoc_opt "ifInState" fields with
584 | Some (`String s) -> Some s
585 | Some `Null | None -> None
586 | _ -> failwith "Invalid 'ifInState' field in Identity/set arguments"
587 in
588 let create = match List.assoc_opt "create" fields with
589 | Some (`Assoc create_list) ->
590 let create_map = Hashtbl.create 16 in
591 List.iter (fun (k, v) ->
592 match Create.of_json v with
593 | Ok create_obj -> Hashtbl.add create_map k create_obj
594 | Error _ -> failwith ("Invalid create object for ID: " ^ k)
595 ) create_list;
596 Some create_map
597 | Some `Null | None -> None
598 | _ -> failwith "Invalid 'create' field in Identity/set arguments"
599 in
600 let update = match List.assoc_opt "update" fields with
601 | Some (`Assoc update_list) ->
602 let update_map = Hashtbl.create 16 in
603 List.iter (fun (k, v) ->
604 try
605 match Update.of_json v with
606 | Ok update_obj -> Hashtbl.add update_map k update_obj
607 | Error err -> failwith ("Invalid update object for ID " ^ k ^ ": " ^ err)
608 with exn -> failwith ("Invalid update object for ID " ^ k ^ ": " ^ Printexc.to_string exn)
609 ) update_list;
610 Some update_map
611 | Some `Null | None -> None
612 | _ -> failwith "Invalid 'update' field in Identity/set arguments"
613 in
614 let destroy = match List.assoc_opt "destroy" fields with
615 | Some (`List ids) -> Some (List.map (function `String s -> (match Jmap.Id.of_string s with Ok id -> id | Error _ -> failwith ("Invalid ID in 'destroy' list: " ^ s)) | _ -> failwith "Invalid ID in 'destroy' list") ids)
616 | Some `Null | None -> None
617 | _ -> failwith "Invalid 'destroy' field in Identity/set arguments"
618 in
619 Ok { account_id; if_in_state; create; update; destroy }
620 | _ -> Error "Identity/set arguments must be a JSON object"
621 with
622 | Failure msg -> Error ("Identity/set JSON parsing error: " ^ msg)
623 | exn -> Error ("Identity/set JSON parsing exception: " ^ Printexc.to_string exn)
624
625 let pp fmt t =
626 Format.fprintf fmt "Identity.Set_args{account=%s}" (Jmap.Id.to_string t.account_id)
627
628 let pp_hum fmt t = pp fmt t
629
630 let validate _t = Ok ()
631
632 let method_name () = method_to_string `Identity_set
633end
634
635(** Response for Identity/set method *)
636module Set_response = struct
637 type t = {
638 account_id : Jmap.Id.t;
639 old_state : string;
640 new_state : string;
641 created : (string, Create.Response.t) Hashtbl.t;
642 updated : (string, Update.Response.t) Hashtbl.t;
643 destroyed : Jmap.Id.t list;
644 not_created : (string, Set_error.t) Hashtbl.t;
645 not_updated : (string, Set_error.t) Hashtbl.t;
646 not_destroyed : (string, Set_error.t) Hashtbl.t;
647 }
648
649 let account_id t = t.account_id
650 let old_state t = t.old_state
651 let new_state t = t.new_state
652 let created t = t.created
653 let updated t = t.updated
654 let destroyed t = t.destroyed
655 let not_created t = t.not_created
656 let not_updated t = t.not_updated
657 let not_destroyed t = t.not_destroyed
658
659 let v ~account_id ~old_state ~new_state ?(created = Hashtbl.create 0)
660 ?(updated = Hashtbl.create 0) ?(destroyed = [])
661 ?(not_created = Hashtbl.create 0) ?(not_updated = Hashtbl.create 0)
662 ?(not_destroyed = Hashtbl.create 0) () =
663 { account_id; old_state; new_state; created; updated; destroyed;
664 not_created; not_updated; not_destroyed }
665
666 let to_json t =
667 let hashtbl_to_assoc to_json_fn tbl =
668 Hashtbl.fold (fun k v acc -> (k, to_json_fn v) :: acc) tbl []
669 in
670 `Assoc [
671 ("accountId", `String (Jmap.Id.to_string t.account_id));
672 ("oldState", `String t.old_state);
673 ("newState", `String t.new_state);
674 ("created", `Assoc (hashtbl_to_assoc Create.Response.to_json t.created));
675 ("updated", `Assoc (hashtbl_to_assoc Update.Response.to_json t.updated));
676 ("destroyed", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) t.destroyed));
677 ("notCreated", `Assoc (hashtbl_to_assoc (fun _ -> `String "placeholder") t.not_created));
678 ("notUpdated", `Assoc (hashtbl_to_assoc (fun _ -> `String "placeholder") t.not_updated));
679 ("notDestroyed", `Assoc (hashtbl_to_assoc (fun _ -> `String "placeholder") t.not_destroyed));
680 ]
681
682 let of_json json =
683 try
684 match json with
685 | `Assoc fields ->
686 let account_id = match List.assoc_opt "accountId" fields with
687 | Some (`String s) -> (match Jmap.Id.of_string s with
688 | Ok id -> id
689 | Error _ -> failwith ("Invalid accountId: " ^ s))
690 | _ -> failwith "Missing required 'accountId' field in Identity/set response"
691 in
692 let old_state = match List.assoc_opt "oldState" fields with
693 | Some (`String s) -> s
694 | _ -> failwith "Missing required 'oldState' field in Identity/set response"
695 in
696 let new_state = match List.assoc_opt "newState" fields with
697 | Some (`String s) -> s
698 | _ -> failwith "Missing required 'newState' field in Identity/set response"
699 in
700 let assoc_to_hashtbl of_json_fn assoc_list =
701 let tbl = Hashtbl.create 16 in
702 List.iter (fun (k, v) ->
703 match of_json_fn v with
704 | Ok value -> Hashtbl.add tbl k value
705 | Error _ -> () (* Skip entries that fail to parse *)
706 ) assoc_list;
707 tbl
708 in
709 let created = match List.assoc_opt "created" fields with
710 | Some (`Assoc assoc_list) -> assoc_to_hashtbl Create.Response.of_json assoc_list
711 | _ -> Hashtbl.create 0
712 in
713 let updated = match List.assoc_opt "updated" fields with
714 | Some (`Assoc assoc_list) -> assoc_to_hashtbl Update.Response.of_json assoc_list
715 | _ -> Hashtbl.create 0
716 in
717 let destroyed = match List.assoc_opt "destroyed" fields with
718 | Some (`List ids) -> List.map (function `String s -> (match Jmap.Id.of_string s with Ok id -> id | Error _ -> failwith ("Invalid ID in 'destroyed' list: " ^ s)) | _ -> failwith "Invalid ID in 'destroyed' list") ids
719 | _ -> []
720 in
721 let not_created = match List.assoc_opt "notCreated" fields with
722 | Some (`Assoc assoc_list) -> assoc_to_hashtbl (fun _ -> Ok (Set_error.v `NotFound)) assoc_list
723 | _ -> Hashtbl.create 0
724 in
725 let not_updated = match List.assoc_opt "notUpdated" fields with
726 | Some (`Assoc assoc_list) -> assoc_to_hashtbl (fun _ -> Ok (Set_error.v `NotFound)) assoc_list
727 | _ -> Hashtbl.create 0
728 in
729 let not_destroyed = match List.assoc_opt "notDestroyed" fields with
730 | Some (`Assoc assoc_list) -> assoc_to_hashtbl (fun _ -> Ok (Set_error.v `NotFound)) assoc_list
731 | _ -> Hashtbl.create 0
732 in
733 Ok { account_id; old_state; new_state; created; updated; destroyed;
734 not_created; not_updated; not_destroyed }
735 | _ -> Error "Identity/set response must be a JSON object"
736 with
737 | Failure msg -> Error ("Identity/set response JSON parsing error: " ^ msg)
738 | exn -> Error ("Identity/set response JSON parsing exception: " ^ Printexc.to_string exn)
739end
740
741(** Arguments for Identity/changes method *)
742module Changes_args = struct
743 type t = {
744 account_id : Jmap.Id.t;
745 since_state : string;
746 max_changes : int option;
747 }
748
749 let account_id t = t.account_id
750 let since_state t = t.since_state
751 let max_changes t = t.max_changes
752
753 let v ~account_id ~since_state ?max_changes () =
754 { account_id; since_state; max_changes }
755
756 let to_json t =
757 let fields = [
758 ("accountId", `String (Jmap.Id.to_string t.account_id));
759 ("sinceState", `String t.since_state);
760 ] in
761 let fields = match t.max_changes with
762 | None -> fields
763 | Some n -> ("maxChanges", `Int n) :: fields
764 in
765 `Assoc (List.rev fields)
766
767 let of_json json =
768 try
769 match json with
770 | `Assoc fields ->
771 let account_id = match List.assoc_opt "accountId" fields with
772 | Some (`String s) -> (match Jmap.Id.of_string s with
773 | Ok id -> id
774 | Error _ -> failwith ("Invalid accountId: " ^ s))
775 | _ -> failwith "Missing required 'accountId' field in Identity/changes arguments"
776 in
777 let since_state = match List.assoc_opt "sinceState" fields with
778 | Some (`String s) -> s
779 | _ -> failwith "Missing required 'sinceState' field in Identity/changes arguments"
780 in
781 let max_changes = match List.assoc_opt "maxChanges" fields with
782 | Some (`Int n) -> Some n
783 | Some `Null | None -> None
784 | _ -> failwith "Invalid 'maxChanges' field in Identity/changes arguments"
785 in
786 Ok { account_id; since_state; max_changes }
787 | _ -> Error "Identity/changes arguments must be a JSON object"
788 with
789 | Failure msg -> Error ("Identity/changes arguments JSON parsing error: " ^ msg)
790 | exn -> Error ("Identity/changes arguments JSON parsing exception: " ^ Printexc.to_string exn)
791
792 let pp fmt t =
793 Format.fprintf fmt "Identity.Changes_args{account=%s;since=%s}"
794 (Jmap.Id.to_string t.account_id) t.since_state
795
796 let pp_hum fmt t = pp fmt t
797
798 let validate _t = Ok ()
799
800 let method_name () = method_to_string `Identity_changes
801end
802
803(** Response for Identity/changes method *)
804module Changes_response = struct
805 type t = {
806 account_id : Jmap.Id.t;
807 old_state : string;
808 new_state : string;
809 has_more_changes : bool;
810 created : Jmap.Id.t list;
811 updated : Jmap.Id.t list;
812 destroyed : Jmap.Id.t list;
813 }
814
815 let account_id t = t.account_id
816 let old_state t = t.old_state
817 let new_state t = t.new_state
818 let has_more_changes t = t.has_more_changes
819 let created t = t.created
820 let updated t = t.updated
821 let destroyed t = t.destroyed
822
823 let v ~account_id ~old_state ~new_state ~has_more_changes
824 ?(created = []) ?(updated = []) ?(destroyed = []) () =
825 { account_id; old_state; new_state; has_more_changes;
826 created; updated; destroyed }
827
828 let to_json t =
829 `Assoc [
830 ("accountId", `String (Jmap.Id.to_string t.account_id));
831 ("oldState", `String t.old_state);
832 ("newState", `String t.new_state);
833 ("hasMoreChanges", `Bool t.has_more_changes);
834 ("created", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) t.created));
835 ("updated", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) t.updated));
836 ("destroyed", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) t.destroyed));
837 ]
838
839 let of_json json =
840 try
841 match json with
842 | `Assoc fields ->
843 let account_id = match List.assoc_opt "accountId" fields with
844 | Some (`String s) -> (match Jmap.Id.of_string s with
845 | Ok id -> id
846 | Error _ -> failwith ("Invalid accountId: " ^ s))
847 | _ -> failwith "Missing required 'accountId' field in Identity/changes response"
848 in
849 let old_state = match List.assoc_opt "oldState" fields with
850 | Some (`String s) -> s
851 | _ -> failwith "Missing required 'oldState' field in Identity/changes response"
852 in
853 let new_state = match List.assoc_opt "newState" fields with
854 | Some (`String s) -> s
855 | _ -> failwith "Missing required 'newState' field in Identity/changes response"
856 in
857 let has_more_changes = match List.assoc_opt "hasMoreChanges" fields with
858 | Some (`Bool b) -> b
859 | _ -> failwith "Missing required 'hasMoreChanges' field in Identity/changes response"
860 in
861 let get_id_list key =
862 match List.assoc_opt key fields with
863 | Some (`List ids) -> List.map (function `String s -> (match Jmap.Id.of_string s with Ok id -> id | Error _ -> failwith ("Invalid ID in '" ^ key ^ "' list: " ^ s)) | _ -> failwith ("Invalid ID in '" ^ key ^ "' list")) ids
864 | Some `Null | None -> []
865 | _ -> failwith ("Invalid '" ^ key ^ "' field in Identity/changes response")
866 in
867 let created = get_id_list "created" in
868 let updated = get_id_list "updated" in
869 let destroyed = get_id_list "destroyed" in
870 Ok { account_id; old_state; new_state; has_more_changes;
871 created; updated; destroyed }
872 | _ -> Error "Identity/changes response must be a JSON object"
873 with
874 | Failure msg -> Error ("Identity/changes response JSON parsing error: " ^ msg)
875 | exn -> Error ("Identity/changes response JSON parsing exception: " ^ Printexc.to_string exn)
876end
877
878module Get_response = struct
879 (* Use the outer module's type *)
880 type identity = {
881 id : Jmap.Id.t;
882 name : string;
883 email : string;
884 reply_to : Address.t list option;
885 bcc : Address.t list option;
886 text_signature : string;
887 html_signature : string;
888 may_delete : bool;
889 }
890
891 type t = {
892 account_id : Jmap.Id.t;
893 state : string;
894 list : identity list;
895 not_found : Jmap.Id.t list;
896 }
897
898 let account_id t = t.account_id
899 let state t = t.state
900 let list t = t.list
901 let not_found t = t.not_found
902
903 let v ~account_id ~state ~list ~not_found () =
904 { account_id; state; list; not_found }
905
906 let identity_to_json identity =
907 let fields = [
908 ("Id.t", `String (Jmap.Id.to_string identity.id));
909 ("name", `String identity.name);
910 ("email", `String identity.email);
911 ("textSignature", `String identity.text_signature);
912 ("htmlSignature", `String identity.html_signature);
913 ("mayDelete", `Bool identity.may_delete);
914 ] in
915 let fields = match identity.reply_to with
916 | None -> ("replyTo", `Null) :: fields
917 | Some addrs -> ("replyTo", `List (List.map Address.to_json addrs)) :: fields
918 in
919 let fields = match identity.bcc with
920 | None -> ("bcc", `Null) :: fields
921 | Some addrs -> ("bcc", `List (List.map Address.to_json addrs)) :: fields
922 in
923 `Assoc (List.rev fields)
924
925 let identity_of_json json =
926 match json with
927 | `Assoc fields ->
928 let get_string key default =
929 match List.assoc_opt key fields with
930 | Some (`String s) -> s
931 | Some `Null | None -> default
932 | _ -> failwith ("Invalid " ^ key ^ " field in Identity")
933 in
934 let get_bool key default =
935 match List.assoc_opt key fields with
936 | Some (`Bool b) -> b
937 | Some `Null | None -> default
938 | _ -> failwith ("Invalid " ^ key ^ " field in Identity")
939 in
940 let get_addresses key =
941 match List.assoc_opt key fields with
942 | Some (`List addrs) ->
943 let rec process_addresses acc = function
944 | [] -> Some (List.rev acc)
945 | addr :: rest ->
946 (match Address.of_json addr with
947 | Ok a -> process_addresses (a :: acc) rest
948 | Error _ -> failwith ("Invalid address in " ^ key ^ " field"))
949 in
950 process_addresses [] addrs
951 | Some `Null | None -> None
952 | _ -> failwith ("Invalid " ^ key ^ " field in Identity")
953 in
954 let id_str = get_string "Id.t" "" in
955 if id_str = "" then failwith "Missing required 'id' field in Identity";
956 let id = match Jmap.Id.of_string id_str with
957 | Ok id -> id
958 | Error _ -> failwith ("Invalid id: " ^ id_str) in
959 let email = get_string "email" "" in
960 if email = "" then failwith "Missing required 'email' field in Identity";
961 {
962 id;
963 name = get_string "name" "";
964 email;
965 reply_to = get_addresses "replyTo";
966 bcc = get_addresses "bcc";
967 text_signature = get_string "textSignature" "";
968 html_signature = get_string "htmlSignature" "";
969 may_delete = get_bool "mayDelete" false;
970 }
971 | _ -> failwith "Identity must be a JSON object"
972
973 let to_json t =
974 `Assoc [
975 ("accountId", `String (Jmap.Id.to_string t.account_id));
976 ("state", `String t.state);
977 ("list", `List (List.map identity_to_json t.list));
978 ("notFound", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) t.not_found));
979 ]
980
981 let of_json json =
982 try
983 match json with
984 | `Assoc fields ->
985 let account_id = match List.assoc_opt "accountId" fields with
986 | Some (`String s) -> (match Jmap.Id.of_string s with
987 | Ok id -> id
988 | Error _ -> failwith ("Invalid accountId: " ^ s))
989 | _ -> failwith "Missing required 'accountId' field in Identity/get response"
990 in
991 let state = match List.assoc_opt "state" fields with
992 | Some (`String s) -> s
993 | _ -> failwith "Missing required 'state' field in Identity/get response"
994 in
995 let list = match List.assoc_opt "list" fields with
996 | Some (`List items) -> List.map identity_of_json items
997 | _ -> failwith "Missing required 'list' field in Identity/get response"
998 in
999 let not_found = match List.assoc_opt "notFound" fields with
1000 | Some (`List ids) -> List.filter_map (function
1001 | `String s -> (match Jmap.Id.of_string s with
1002 | Ok id -> Some id
1003 | Error _ -> None)
1004 | _ -> None) ids
1005 | _ -> failwith "Missing required 'notFound' field in Identity/get response"
1006 in
1007 Ok { account_id; state; list; not_found }
1008 | _ -> Error "Identity/get response must be a JSON object"
1009 with
1010 | Failure msg -> Error ("Identity/get JSON parsing error: " ^ msg)
1011 | exn -> Error ("Identity/get JSON parsing exception: " ^ Printexc.to_string exn)
1012end
1013
1014module Property = struct
1015 type t = [
1016 | `Id
1017 | `Name
1018 | `Email
1019 | `ReplyTo
1020 | `Bcc
1021 | `TextSignature
1022 | `HtmlSignature
1023 | `MayDelete
1024 ]
1025
1026 let to_string = function
1027 | `Id -> "Id.t"
1028 | `Name -> "name"
1029 | `Email -> "email"
1030 | `ReplyTo -> "replyTo"
1031 | `Bcc -> "bcc"
1032 | `TextSignature -> "textSignature"
1033 | `HtmlSignature -> "htmlSignature"
1034 | `MayDelete -> "mayDelete"
1035
1036 let of_string = function
1037 | "Id.t" -> Some `Id
1038 | "name" -> Some `Name
1039 | "email" -> Some `Email
1040 | "replyTo" -> Some `ReplyTo
1041 | "bcc" -> Some `Bcc
1042 | "textSignature" -> Some `TextSignature
1043 | "htmlSignature" -> Some `HtmlSignature
1044 | "mayDelete" -> Some `MayDelete
1045 | _ -> None
1046
1047 let all_properties = [
1048 `Id; `Name; `Email; `ReplyTo; `Bcc;
1049 `TextSignature; `HtmlSignature; `MayDelete
1050 ]
1051
1052 let to_string_list props = List.map to_string props
1053
1054 let of_string_list strings =
1055 List.filter_map of_string strings
1056
1057 let common_properties = [`Id; `Name; `Email; `MayDelete]
1058
1059 let detailed_properties = all_properties
1060end