My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** JMAP Vacation Response Implementation.
2
3 This module implements the JMAP VacationResponse singleton data type
4 for managing automatic out-of-office email replies with Date.t ranges,
5 custom messages, and enable/disable functionality.
6
7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8> RFC 8621, Section 8: VacationResponse
8*)
9
10open Jmap.Error
11open Yojson.Safe.Util
12
13(* Alias for easier access to error types *)
14module Error = Jmap.Error
15
16(** VacationResponse object *)
17type t = {
18 id : Jmap.Id.t;
19 is_enabled : bool;
20 from_date : Jmap.Date.t option;
21 to_date : Jmap.Date.t option;
22 subject : string option;
23 text_body : string option;
24 html_body : string option;
25}
26
27(** Type alias for VacationResponse objects used in submodules *)
28type vacation_response = t
29
30(** {1 JMAP_OBJECT Implementation} *)
31
32(** Get the object ID (always "singleton" for VacationResponse) *)
33let id t = Some t.id
34
35(** Create a minimal VacationResponse object.
36 VacationResponse always has ID "singleton" per JMAP spec *)
37let create ?id () =
38 let actual_id = match id with Some id -> id | None -> "singleton" in
39 let id_result = match Jmap.Id.of_string actual_id with
40 | Ok id -> id
41 | Error e -> failwith ("Invalid vacation response ID: " ^ e) in
42 {
43 id = id_result;
44 is_enabled = false;
45 from_date = None;
46 to_date = None;
47 subject = None;
48 text_body = None;
49 html_body = None;
50 }
51
52(** Serialize to JSON with only specified properties *)
53let to_json_with_properties ~properties t =
54 let all_fields = [
55 ("id", `String (Jmap.Id.to_string t.id));
56 ("isEnabled", `Bool t.is_enabled);
57 ("fromDate", match t.from_date with Some date -> Jmap.Date.to_json date | None -> `Null);
58 ("toDate", match t.to_date with Some date -> Jmap.Date.to_json date | None -> `Null);
59 ("subject", match t.subject with Some subj -> `String subj | None -> `Null);
60 ("textBody", match t.text_body with Some text -> `String text | None -> `Null);
61 ("htmlBody", match t.html_body with Some html -> `String html | None -> `Null);
62 ] in
63 let filtered_fields = List.filter (fun (key, _) -> List.mem key properties) all_fields in
64 `Assoc filtered_fields
65
66(** Get list of all valid property names *)
67let valid_properties () = [
68 "Id.t"; "isEnabled"; "fromDate"; "toDate"; "subject"; "textBody"; "htmlBody"
69] (* TODO: Use Property.to_string_list Property.all_properties when module ordering is fixed *)
70
71(** {1 Property Accessors} *)
72
73let is_enabled t = t.is_enabled
74let from_date t = t.from_date
75let to_date t = t.to_date
76let subject t = t.subject
77let text_body t = t.text_body
78let html_body t = t.html_body
79
80let v ~id ~is_enabled ?from_date ?to_date ?subject ?text_body ?html_body () = {
81 id;
82 is_enabled;
83 from_date;
84 to_date;
85 subject;
86 text_body;
87 html_body;
88}
89
90(* JSON serialization for VacationResponse *)
91let to_json t =
92 let json_fields = [
93 ("id", `String (Jmap.Id.to_string t.id));
94 ("isEnabled", `Bool t.is_enabled);
95 ] in
96 let json_fields = match t.from_date with
97 | None -> json_fields
98 | Some date -> ("fromDate", `Float (Jmap.Date.to_timestamp date)) :: json_fields
99 in
100 let json_fields = match t.to_date with
101 | None -> json_fields
102 | Some date -> ("toDate", `Float (Jmap.Date.to_timestamp date)) :: json_fields
103 in
104 let json_fields = match t.subject with
105 | None -> json_fields
106 | Some subj -> ("subject", `String subj) :: json_fields
107 in
108 let json_fields = match t.text_body with
109 | None -> json_fields
110 | Some text -> ("textBody", `String text) :: json_fields
111 in
112 let json_fields = match t.html_body with
113 | None -> json_fields
114 | Some html -> ("htmlBody", `String html) :: json_fields
115 in
116 `Assoc (List.rev json_fields)
117
118(** {1 Printable Formatting} *)
119
120(** Format VacationResponse for debugging *)
121let pp ppf vacation =
122 let enabled_str = string_of_bool vacation.is_enabled in
123 let from_date_str = match vacation.from_date with
124 | None -> "none"
125 | Some date -> Printf.sprintf "%.0f" (Jmap.Date.to_timestamp date)
126 in
127 let to_date_str = match vacation.to_date with
128 | None -> "none"
129 | Some date -> Printf.sprintf "%.0f" (Jmap.Date.to_timestamp date)
130 in
131 let subject_str = match vacation.subject with
132 | None -> "default"
133 | Some subj -> Printf.sprintf "\"%s\"" (String.sub subj 0 (min 20 (String.length subj)))
134 in
135 Format.fprintf ppf "VacationResponse{id=%s; is_enabled=%s; from_date=%s; to_date=%s; subject=%s}"
136 (Jmap.Id.to_string vacation.id)
137 enabled_str
138 from_date_str
139 to_date_str
140 subject_str
141
142(** Format VacationResponse for human reading *)
143let pp_hum ppf vacation =
144 let enabled_str = string_of_bool vacation.is_enabled in
145 let from_date_str = match vacation.from_date with
146 | None -> "none"
147 | Some date -> Printf.sprintf "%.0f" (Jmap.Date.to_timestamp date)
148 in
149 let to_date_str = match vacation.to_date with
150 | None -> "none"
151 | Some date -> Printf.sprintf "%.0f" (Jmap.Date.to_timestamp date)
152 in
153 let subject_str = match vacation.subject with
154 | None -> "default subject"
155 | Some subj -> Printf.sprintf "\"%s\"" subj
156 in
157 let text_body_str = match vacation.text_body with
158 | None -> "none"
159 | Some text -> Printf.sprintf "%d chars" (String.length text)
160 in
161 let html_body_str = match vacation.html_body with
162 | None -> "none"
163 | Some html -> Printf.sprintf "%d chars" (String.length html)
164 in
165 Format.fprintf ppf "VacationResponse {\n id: %s\n is_enabled: %s\n from_date: %s\n to_date: %s\n subject: %s\n text_body: %s\n html_body: %s\n}"
166 (Jmap.Id.to_string vacation.id)
167 enabled_str
168 from_date_str
169 to_date_str
170 subject_str
171 text_body_str
172 html_body_str
173
174(* JSON deserialization for VacationResponse *)
175let of_json json =
176 try
177 let id = match Jmap.Id.of_string (json |> member "id" |> to_string) with
178 | Ok id -> id
179 | Error err -> failwith ("Invalid ID: " ^ err) in
180 let is_enabled = json |> member "isEnabled" |> to_bool in
181 let from_date =
182 match json |> member "fromDate" with
183 | `Float date -> Some (Jmap.Date.of_timestamp date)
184 | `String date_str ->
185 (* Parse ISO 8601 Date.t string to Unix timestamp - simplified *)
186 (try Some (Jmap.Date.of_timestamp (float_of_string date_str))
187 with _ -> None)
188 | `Null | _ -> None
189 in
190 let to_date =
191 match json |> member "toDate" with
192 | `Float date -> Some (Jmap.Date.of_timestamp date)
193 | `String date_str ->
194 (* Parse ISO 8601 Date.t string to Unix timestamp - simplified *)
195 (try Some (Jmap.Date.of_timestamp (float_of_string date_str))
196 with _ -> None)
197 | `Null | _ -> None
198 in
199 let subject = json |> member "subject" |> to_string_option in
200 let text_body = json |> member "textBody" |> to_string_option in
201 let html_body = json |> member "htmlBody" |> to_string_option in
202 Ok { id; is_enabled; from_date; to_date; subject; text_body; html_body }
203 with
204 | Type_error (msg, _) -> Error ("Invalid VacationResponse JSON: " ^ msg)
205 | exn -> Error ("Failed to parse VacationResponse JSON: " ^ Printexc.to_string exn)
206
207(** VacationResponse update operations *)
208module Update = struct
209 type t = {
210 is_enabled : bool option;
211 from_date : Jmap.Date.t option option;
212 to_date : Jmap.Date.t option option;
213 subject : string option option;
214 text_body : string option option;
215 html_body : string option option;
216 }
217
218 let is_enabled t = t.is_enabled
219 let from_date t = t.from_date
220 let to_date t = t.to_date
221 let subject t = t.subject
222 let text_body t = t.text_body
223 let html_body t = t.html_body
224
225 let v ?is_enabled ?from_date ?to_date ?subject ?text_body ?html_body () = {
226 is_enabled;
227 from_date;
228 to_date;
229 subject;
230 text_body;
231 html_body;
232 }
233
234 let enable ?from_date ?to_date ?subject ?text_body ?html_body () = {
235 is_enabled = Some true;
236 from_date = Option.map Option.some from_date;
237 to_date = Option.map Option.some to_date;
238 subject = Option.map Option.some subject;
239 text_body = Option.map Option.some text_body;
240 html_body = Option.map Option.some html_body;
241 }
242
243 let disable () = {
244 is_enabled = Some false;
245 from_date = None;
246 to_date = None;
247 subject = None;
248 text_body = None;
249 html_body = None;
250 }
251
252 (* JSON serialization for Update *)
253 let to_json t =
254 let json_fields = [] in
255 let json_fields = match t.is_enabled with
256 | None -> json_fields
257 | Some enabled -> ("isEnabled", `Bool enabled) :: json_fields
258 in
259 let json_fields = match t.from_date with
260 | None -> json_fields
261 | Some None -> ("fromDate", `Null) :: json_fields
262 | Some (Some date) -> ("fromDate", `Float (Jmap.Date.to_timestamp date)) :: json_fields
263 in
264 let json_fields = match t.to_date with
265 | None -> json_fields
266 | Some None -> ("toDate", `Null) :: json_fields
267 | Some (Some date) -> ("toDate", `Float (Jmap.Date.to_timestamp date)) :: json_fields
268 in
269 let json_fields = match t.subject with
270 | None -> json_fields
271 | Some None -> ("subject", `Null) :: json_fields
272 | Some (Some subj) -> ("subject", `String subj) :: json_fields
273 in
274 let json_fields = match t.text_body with
275 | None -> json_fields
276 | Some None -> ("textBody", `Null) :: json_fields
277 | Some (Some text) -> ("textBody", `String text) :: json_fields
278 in
279 let json_fields = match t.html_body with
280 | None -> json_fields
281 | Some None -> ("htmlBody", `Null) :: json_fields
282 | Some (Some html) -> ("htmlBody", `String html) :: json_fields
283 in
284 `Assoc (List.rev json_fields)
285
286 (* JSON deserialization for Update *)
287 let of_json json =
288 try
289 let is_enabled =
290 match json |> member "isEnabled" with
291 | `Bool b -> Some b
292 | _ -> None
293 in
294 let from_date =
295 match json |> member "fromDate" with
296 | `Null -> Some None
297 | `Float date -> Some (Some (Jmap.Date.of_timestamp date))
298 | `String date_str -> Some (Some (try Jmap.Date.of_timestamp (float_of_string date_str) with _ -> Jmap.Date.of_timestamp 0.0))
299 | _ -> None
300 in
301 let to_date =
302 match json |> member "toDate" with
303 | `Null -> Some None
304 | `Float date -> Some (Some (Jmap.Date.of_timestamp date))
305 | `String date_str -> Some (Some (try Jmap.Date.of_timestamp (float_of_string date_str) with _ -> Jmap.Date.of_timestamp 0.0))
306 | _ -> None
307 in
308 let subject =
309 match json |> member "subject" with
310 | `Null -> Some None
311 | `String s -> Some (Some s)
312 | _ -> None
313 in
314 let text_body =
315 match json |> member "textBody" with
316 | `Null -> Some None
317 | `String s -> Some (Some s)
318 | _ -> None
319 in
320 let html_body =
321 match json |> member "htmlBody" with
322 | `Null -> Some None
323 | `String s -> Some (Some s)
324 | _ -> None
325 in
326 Ok { is_enabled; from_date; to_date; subject; text_body; html_body }
327 with
328 | Type_error (msg, _) -> Error ("Invalid VacationResponse update JSON: " ^ msg)
329 | exn -> Error ("Failed to parse VacationResponse update JSON: " ^ Printexc.to_string exn)
330end
331
332(** Arguments for VacationResponse/get method *)
333module Get_args = struct
334 type t = {
335 account_id : Jmap.Id.t;
336 ids : Jmap.Id.t list option;
337 properties : string list option;
338 }
339
340 let account_id t = t.account_id
341 let ids t = t.ids
342 let properties t = t.properties
343
344 let v ~account_id ?ids ?properties () =
345 { account_id; ids; properties }
346
347 let singleton ~account_id ?properties () =
348 { account_id; ids = Some [Jmap.Id.of_string "singleton" |> Result.get_ok]; properties }
349
350 let to_json t =
351 let json_fields = [
352 ("accountId", `String (Jmap.Id.to_string t.account_id));
353 ] in
354 let json_fields = match t.ids with
355 | None -> json_fields
356 | Some ids -> ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: json_fields
357 in
358 let json_fields = match t.properties with
359 | None -> json_fields
360 | Some props -> ("properties", `List (List.map (fun p -> `String p) props)) :: json_fields
361 in
362 `Assoc (List.rev json_fields)
363
364 let of_json json =
365 try
366 let account_id_str = json |> member "accountId" |> to_string in
367 let account_id = match Jmap.Id.of_string account_id_str with
368 | Ok id -> id
369 | Error _ -> failwith ("Invalid accountId: " ^ account_id_str) in
370 let ids =
371 match json |> member "ids" with
372 | `List items ->
373 Some (List.map (fun item ->
374 let id_str = to_string item in
375 match Jmap.Id.of_string id_str with
376 | Ok id -> id
377 | Error _ -> failwith ("Invalid id: " ^ id_str)) items)
378 | _ -> None
379 in
380 let properties =
381 match json |> member "properties" with
382 | `List items -> Some (List.map (fun item -> to_string item) items)
383 | _ -> None
384 in
385 Ok { account_id; ids; properties }
386 with
387 | Type_error (msg, _) -> Error ("Invalid VacationResponse/get arguments JSON: " ^ msg)
388 | exn -> Error ("Failed to parse VacationResponse/get arguments JSON: " ^ Printexc.to_string exn)
389end
390
391(** Response for VacationResponse/get method *)
392module Get_response = struct
393 type vacation_response = t
394
395 type t = {
396 account_id : Jmap.Id.t;
397 state : string;
398 list : vacation_response list;
399 not_found : Jmap.Id.t list;
400 }
401
402 let account_id t = t.account_id
403 let state t = t.state
404 let list t = t.list
405 let not_found t = t.not_found
406
407 let singleton t = match t.list with
408 | [] -> None
409 | vacation :: _ -> Some vacation
410
411 let v ~account_id ~state ~list ~not_found () =
412 { account_id; state; list; not_found }
413
414 let to_json t =
415 `Assoc [
416 ("accountId", `String (Jmap.Id.to_string t.account_id));
417 ("state", `String t.state);
418 ("list", `List (List.map (fun item -> (to_json item : Yojson.Safe.t)) t.list));
419 ("notFound", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) t.not_found));
420 ]
421
422 let of_json json =
423 try
424 let account_id_str = json |> member "accountId" |> to_string in
425 let account_id = match Jmap.Id.of_string account_id_str with
426 | Ok id -> id
427 | Error _ -> failwith ("Invalid accountId: " ^ account_id_str) in
428 let state = json |> member "state" |> to_string in
429 let list_json = json |> member "list" |> to_list in
430 let list =
431 List.fold_left (fun acc item_json ->
432 match (of_json item_json : (vacation_response, string) Result.t) with
433 | Ok item -> item :: acc
434 | Error _ -> acc (* Skip invalid items *)
435 ) [] list_json |> List.rev
436 in
437 let not_found = json |> member "notFound" |> to_list |> List.filter_map (fun item ->
438 let str = to_string item in
439 match Jmap.Id.of_string str with
440 | Ok id -> Some id
441 | Error _ -> None) in
442 Ok { account_id; state; list; not_found }
443 with
444 | Type_error (msg, _) -> Error ("Invalid VacationResponse/get response JSON: " ^ msg)
445 | exn -> Error ("Failed to parse VacationResponse/get response JSON: " ^ Printexc.to_string exn)
446end
447
448(** VacationResponse/set: Args type *)
449module Set_args = struct
450 type t = {
451 account_id : Jmap.Id.t;
452 if_in_state : string option;
453 update : (string, Update.t) Hashtbl.t option;
454 }
455
456 let account_id t = t.account_id
457 let if_in_state t = t.if_in_state
458 let update t = t.update
459
460 let v ~account_id ?if_in_state ?update () = {
461 account_id;
462 if_in_state;
463 update;
464 }
465
466 let singleton ~account_id ?if_in_state ~update () = {
467 account_id;
468 if_in_state;
469 update = Some (Hashtbl.create 1 |> fun tbl -> Hashtbl.add tbl "singleton" update; tbl);
470 }
471
472 let to_json t =
473 let json_fields = [
474 ("accountId", `String (Jmap.Id.to_string t.account_id));
475 ] in
476 let json_fields = match t.if_in_state with
477 | None -> json_fields
478 | Some state -> ("ifInState", `String state) :: json_fields
479 in
480 let json_fields = match t.update with
481 | None -> json_fields
482 | Some update_map ->
483 let update_assoc = Hashtbl.fold (fun k v acc -> (k, Update.to_json v) :: acc) update_map [] in
484 ("update", `Assoc update_assoc) :: json_fields
485 in
486 `Assoc (List.rev json_fields)
487
488 let of_json json =
489 try
490 let account_id_str = json |> member "accountId" |> to_string in
491 let account_id = match Jmap.Id.of_string account_id_str with
492 | Ok id -> id
493 | Error _ -> failwith ("Invalid accountId: " ^ account_id_str) in
494 let if_in_state = json |> member "ifInState" |> to_string_option in
495 let update =
496 match json |> member "update" with
497 | `Assoc update_assoc ->
498 let update_map = Hashtbl.create (List.length update_assoc) in
499 List.iter (fun (k, v) ->
500 match Update.of_json v with
501 | Ok update_obj -> Hashtbl.add update_map k update_obj
502 | Error _ -> () (* Skip invalid updates *)
503 ) update_assoc;
504 Some update_map
505 | _ -> None
506 in
507 Ok { account_id; if_in_state; update }
508 with
509 | Type_error (msg, _) -> Error ("Invalid VacationResponse/set arguments JSON: " ^ msg)
510 | exn -> Error ("Failed to parse VacationResponse/set arguments JSON: " ^ Printexc.to_string exn)
511end
512
513(** VacationResponse/set: Response type *)
514module Set_response = struct
515 type vacation_response = t
516
517 type t = {
518 account_id : Jmap.Id.t;
519 old_state : string option;
520 new_state : string;
521 updated : (string, vacation_response option) Hashtbl.t option;
522 not_updated : (string, Set_error.t) Hashtbl.t option;
523 }
524
525 let account_id t = t.account_id
526 let old_state t = t.old_state
527 let new_state t = t.new_state
528 let updated t = t.updated
529 let not_updated t = t.not_updated
530
531 let singleton_updated t =
532 match t.updated with
533 | None -> None
534 | Some updated_map ->
535 try Hashtbl.find updated_map "singleton"
536 with Not_found -> None
537
538 let singleton_error t =
539 match t.not_updated with
540 | None -> None
541 | Some error_map ->
542 try Some (Hashtbl.find error_map "singleton")
543 with Not_found -> None
544
545 let v ~account_id ?old_state ~new_state ?updated ?not_updated () = {
546 account_id;
547 old_state;
548 new_state;
549 updated;
550 not_updated;
551 }
552
553 let to_json t =
554 let json_fields = [
555 ("accountId", `String (Jmap.Id.to_string t.account_id));
556 ("newState", `String t.new_state);
557 ] in
558 let json_fields = match t.old_state with
559 | None -> json_fields
560 | Some state -> ("oldState", `String state) :: json_fields
561 in
562 let json_fields = match t.updated with
563 | None -> json_fields
564 | Some updated_map ->
565 let updated_assoc = Hashtbl.fold (fun k v acc ->
566 let json_value = match v with
567 | None -> `Null
568 | Some vacation -> (to_json vacation : Yojson.Safe.t)
569 in
570 (k, json_value) :: acc
571 ) updated_map [] in
572 ("updated", `Assoc updated_assoc) :: json_fields
573 in
574 let json_fields = match t.not_updated with
575 | None -> json_fields
576 | Some error_map ->
577 let error_assoc = Hashtbl.fold (fun k v acc -> (k, Error.Set_error.to_json v) :: acc) error_map [] in
578 ("notUpdated", `Assoc error_assoc) :: json_fields
579 in
580 `Assoc (List.rev json_fields)
581
582 let of_json json =
583 try
584 let account_id_str = json |> member "accountId" |> to_string in
585 let account_id = match Jmap.Id.of_string account_id_str with
586 | Ok id -> id
587 | Error _ -> failwith ("Invalid accountId: " ^ account_id_str) in
588 let old_state = json |> member "oldState" |> to_string_option in
589 let new_state = json |> member "newState" |> to_string in
590 let updated =
591 match json |> member "updated" with
592 | `Assoc updated_assoc ->
593 let updated_map = Hashtbl.create (List.length updated_assoc) in
594 List.iter (fun (k, v) ->
595 let value =
596 if v = `Null then None
597 else match (of_json v : (vacation_response, string) Result.t) with
598 | Ok vacation -> Some vacation
599 | Error _ -> None
600 in
601 Hashtbl.add updated_map k value
602 ) updated_assoc;
603 Some updated_map
604 | _ -> None
605 in
606 let not_updated =
607 match json |> member "notUpdated" with
608 | `Assoc error_assoc ->
609 let error_map = Hashtbl.create (List.length error_assoc) in
610 List.iter (fun (k, v) ->
611 match Error.Set_error.of_json v with
612 | Ok error_obj -> Hashtbl.add error_map k error_obj
613 | Error _ -> () (* Skip invalid errors *)
614 ) error_assoc;
615 Some error_map
616 | _ -> None
617 in
618 Ok { account_id; old_state; new_state; updated; not_updated }
619 with
620 | Type_error (msg, _) -> Error ("Invalid VacationResponse/set response JSON: " ^ msg)
621 | exn -> Error ("Failed to parse VacationResponse/set response JSON: " ^ Printexc.to_string exn)
622end
623
624module Property = struct
625 type t = [
626 | `Id
627 | `IsEnabled
628 | `FromDate
629 | `ToDate
630 | `Subject
631 | `TextBody
632 | `HtmlBody
633 ]
634
635 let to_string = function
636 | `Id -> "Id.t"
637 | `IsEnabled -> "isEnabled"
638 | `FromDate -> "fromDate"
639 | `ToDate -> "toDate"
640 | `Subject -> "subject"
641 | `TextBody -> "textBody"
642 | `HtmlBody -> "htmlBody"
643
644 let of_string = function
645 | "Id.t" -> Some `Id
646 | "isEnabled" -> Some `IsEnabled
647 | "fromDate" -> Some `FromDate
648 | "toDate" -> Some `ToDate
649 | "subject" -> Some `Subject
650 | "textBody" -> Some `TextBody
651 | "htmlBody" -> Some `HtmlBody
652 | _ -> None
653
654 let all_properties = [
655 `Id; `IsEnabled; `FromDate; `ToDate;
656 `Subject; `TextBody; `HtmlBody
657 ]
658
659 let to_string_list props = List.map to_string props
660
661 let of_string_list strings =
662 List.filter_map of_string strings
663
664 let common_properties = [`Id; `IsEnabled; `FromDate; `ToDate]
665
666 let detailed_properties = all_properties
667end