+7

jmap/bin/dune

reviewed

··· 11 11 (package jmap) 12 12 (libraries jmap unix yojson) 13 13 (modules simple_core_test)) 14 14 + 15 15 + (executable 16 16 + (name test_session_wire) 17 17 + (public_name test-session-wire) 18 18 + (package jmap) 19 19 + (libraries jmap unix yojson fmt uri) 20 20 + (modules test_session_wire))

+5 -4

jmap/bin/fastmail_connect.ml

reviewed

··· 1 1 open Printf 2 2 + open Jmap.Method_names 2 3 3 4 (* Result monad operator for cleaner error handling *) 4 5 let (let+) x f = Result.bind x f ··· 18 19 19 20 let builder = Jmap_unix.build ctx in 20 21 let builder = Jmap_unix.using builder [`Core; `Mail] in 21 21 - let builder = Jmap_unix.add_method_call builder "Email/query" query_json "q1" in 22 22 - let builder = Jmap_unix.add_method_call builder "Email/get" get_json "g1" in 22 22 + let builder = Jmap_unix.add_method_call builder (method_to_string `Email_query) query_json "q1" in 23 23 + let builder = Jmap_unix.add_method_call builder (method_to_string `Email_get) get_json "g1" in 23 24 24 25 let+ response = Jmap_unix.execute env builder in 25 26 printf "✓ Got JMAP response\n"; 26 27 27 27 - let+ query_response_json = Jmap_unix.Response.extract_method ~method_name:"Email/query" ~method_call_id:"q1" response in 28 28 + let+ query_response_json = Jmap_unix.Response.extract_method ~method_name:(method_to_string `Email_query) ~method_call_id:"q1" response in 28 29 let+ query_response = Jmap.Methods.Query_response.of_json query_response_json in 29 30 printf "✓ Found %d emails\n\n" (Jmap.Methods.Query_response.ids query_response |> List.length); 30 31 31 31 - let+ get_response_json = Jmap_unix.Response.extract_method ~method_name:"Email/get" ~method_call_id:"g1" response in 32 32 + let+ get_response_json = Jmap_unix.Response.extract_method ~method_name:(method_to_string `Email_get) ~method_call_id:"g1" response in 32 33 33 34 let emails = 34 35 Yojson.Safe.Util.(get_response_json |> member "list" |> to_list)

+1 -22

jmap/dune-project

reviewed

··· 1 1 - (lang dune 3.0) 2 2 - 3 3 - (package 4 4 - (name jmap-sigs) 5 5 - (synopsis "Module type signatures for JMAP implementations") 6 6 - (depends ocaml dune yojson fmt)) 7 7 - 8 8 - (package 9 9 - (name jmap) 10 10 - (synopsis "JMAP protocol implementation") 11 11 - (depends ocaml dune jmap-sigs yojson uri base64 fmt)) 12 12 - 13 13 - (package 14 14 - (name jmap-email) 15 15 - (synopsis "JMAP Email extensions") 16 16 - (depends ocaml dune jmap jmap-sigs yojson uri fmt)) 17 17 - 18 18 - (package 19 19 - (name jmap-unix) 20 20 - (synopsis "JMAP Unix networking implementation") 21 21 - (depends ocaml dune jmap jmap-email jmap-sigs yojson uri eio tls-eio cohttp-eio fmt)) 22 22 - 1 1 + (lang dune 3.0)

+99 -5

jmap/jmap-email/jmap_email.ml

reviewed

··· 7 7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1> RFC 8621, Section 4.1 8 8 *) 9 9 10 10 + [@@@warning "-32"] (* Suppress unused value warnings for interface-required functions *) 11 11 + 10 12 open Jmap.Types 11 13 12 14 (** JSON parsing combinators for cleaner field extraction *) ··· 162 164 163 165 let other_properties t = t.other_properties 164 166 165 165 - let create ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at 167 167 + (* JMAP_OBJECT signature implementations *) 168 168 + 169 169 + (* Create a minimal valid email object with only required fields *) 170 170 + let create ?id () = 171 171 + { 172 172 + id; blob_id = None; thread_id = None; mailbox_ids = None; keywords = None; 173 173 + size = None; received_at = None; message_id = None; in_reply_to = None; 174 174 + references = None; sender = None; from = None; to_ = None; cc = None; 175 175 + bcc = None; reply_to = None; subject = None; sent_at = None; 176 176 + has_attachment = None; preview = None; body_structure = None; 177 177 + body_values = None; text_body = None; html_body = None; attachments = None; 178 178 + headers = None; other_properties = Hashtbl.create 0; 179 179 + } 180 180 + 181 181 + (* Get list of all valid property names for Email objects *) 182 182 + let valid_properties () = [ 183 183 + "id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; "size"; "receivedAt"; 184 184 + "messageId"; "inReplyTo"; "references"; "sender"; "from"; "to"; "cc"; "bcc"; 185 185 + "replyTo"; "subject"; "sentAt"; "hasAttachment"; "preview"; "bodyStructure"; 186 186 + "bodyValues"; "textBody"; "htmlBody"; "attachments"; "headers" 187 187 + ] 188 188 + 189 189 + (* Serialize to JSON with only specified properties *) 190 190 + let to_json_with_properties ~properties t = 191 191 + let all_fields = [ 192 192 + ("id", (match t.id with Some s -> `String s | None -> `Null)); 193 193 + ("blobId", (match t.blob_id with Some s -> `String s | None -> `Null)); 194 194 + ("threadId", (match t.thread_id with Some s -> `String s | None -> `Null)); 195 195 + ("subject", (match t.subject with Some s -> `String s | None -> `Null)); 196 196 + ("size", (match t.size with Some i -> `Int i | None -> `Null)); 197 197 + (* Add more fields as needed - this is a simplified implementation *) 198 198 + ] in 199 199 + let filtered_fields = List.filter (fun (name, _) -> 200 200 + List.mem name properties 201 201 + ) all_fields in 202 202 + let non_null_fields = List.filter (fun (_, value) -> 203 203 + value <> `Null 204 204 + ) filtered_fields in 205 205 + `Assoc non_null_fields 206 206 + 207 207 + (* Extended create function with all properties *) 208 208 + let create_full ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at 166 209 ?message_id ?in_reply_to ?references ?sender ?from ?to_ ?cc ?bcc 167 210 ?reply_to ?subject ?sent_at ?has_attachment ?preview ?body_structure 168 211 ?body_values ?text_body ?html_body ?attachments ?headers ··· 233 276 in 234 277 Printf.sprintf "%s: %s (%s)" sender_str subject_str date_str 235 278 279 279 + (* PRINTABLE interface implementation *) 280 280 + let pp ppf t = 281 281 + let id_str = match t.id with Some id -> id | None -> "no-id" in 282 282 + let subject_str = match t.subject with Some s -> s | None -> "(no subject)" in 283 283 + Format.fprintf ppf "Email{id=%s; subject=%s}" id_str subject_str 284 284 + 285 285 + let pp_hum = pp 286 286 + 236 287 (* JSON helper functions *) 237 288 238 289 (* Simple JSON serialization - full implementation would be much longer *) ··· 252 303 (* Add other properties as needed - this is a simplified version *) 253 304 `Assoc fields 254 305 255 255 - let to_json_with_properties t _properties = 256 256 - (* Simplified implementation - would filter based on properties list *) 257 257 - to_json t 258 306 259 307 (* Complete JSON parsing implementation for Email objects using combinators *) 260 308 let of_json = function ··· 265 313 let blob_id = Json.string "blobId" fields in 266 314 let thread_id = Json.string "threadId" fields in 267 315 let mailbox_ids = Json.bool_map "mailboxIds" fields in 316 316 + (* TODO: Implement keywords parsing from JSON 317 317 + - Parse keywords object/map from JSON 318 318 + - Handle standard and custom keywords 319 319 + - RFC reference: RFC 8621 Section 4.1.4 320 320 + - Priority: Medium 321 321 + - Dependencies: Jmap_email_keywords.of_json *) 268 322 let keywords = None in (* Keywords parsing not implemented *) 269 323 let size = Json.int "size" fields in 270 324 let received_at = Json.iso_date "receivedAt" fields in ··· 284 338 let sent_at = Json.iso_date "sentAt" fields in 285 339 let has_attachment = Json.bool "hasAttachment" fields in 286 340 let preview = Json.string "preview" fields in 341 341 + (* TODO: Implement body structure parsing from JSON 342 342 + - Parse BodyPart tree structure 343 343 + - Handle multipart/alternative, multipart/mixed 344 344 + - RFC reference: RFC 8621 Section 4.1.7 345 345 + - Priority: High 346 346 + - Dependencies: Jmap_email_body.of_json *) 287 347 let body_structure = None in (* Body structure parsing not implemented *) 348 348 + (* TODO: Implement body values parsing from JSON 349 349 + - Parse bodyValues map for text/html content 350 350 + - Handle charset conversion and truncation 351 351 + - RFC reference: RFC 8621 Section 4.1.8 352 352 + - Priority: High 353 353 + - Dependencies: Jmap_email_body.Value.of_json *) 288 354 let body_values = None in (* Body values parsing not implemented *) 355 355 + (* TODO: Implement text/html/attachment body part parsing 356 356 + - Parse textBody, htmlBody, attachments arrays 357 357 + - Handle BodyPart references and structure 358 358 + - RFC reference: RFC 8621 Section 4.1.9-11 359 359 + - Priority: High 360 360 + - Dependencies: Body part parsing logic *) 289 361 let text_body = None in (* Body parts parsing not implemented *) 290 362 let html_body = None in (* Body parts parsing not implemented *) 291 363 let attachments = None in (* Body parts parsing not implemented *) ··· 304 376 Hashtbl.add other_properties field_name field_value 305 377 ) fields; 306 378 307 307 - Ok (create 379 379 + Ok (create_full 308 380 ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size ?received_at 309 381 ?message_id ?in_reply_to ?references ?sender ?from ?to_ ?cc ?bcc 310 382 ?reply_to ?subject ?sent_at ?has_attachment ?preview ?body_structure ··· 315 387 | _ -> 316 388 Error "Email JSON must be an object" 317 389 390 390 + (* Pretty printing implementation for PRINTABLE signature *) 391 391 + let pp ppf t = 392 392 + let id_str = match t.id with 393 393 + | Some id -> id 394 394 + | None -> "<no-id>" 395 395 + in 396 396 + let subject_str = match t.subject with 397 397 + | Some subj -> subj 398 398 + | None -> "<no-subject>" 399 399 + in 400 400 + let sender_str = match primary_sender t with 401 401 + | Some addr -> Jmap_email_address.email addr 402 402 + | None -> "<unknown-sender>" 403 403 + in 404 404 + Format.fprintf ppf "Email{id=%s; from=%s; subject=%s}" 405 405 + id_str sender_str subject_str 406 406 + 407 407 + (* Alias for pp following Fmt conventions *) 408 408 + let pp_hum ppf t = pp ppf t 409 409 + 318 410 319 411 module Patch = struct 320 412 let create ?add_keywords:_add_keywords ?remove_keywords:_remove_keywords ?add_mailboxes:_add_mailboxes ?remove_mailboxes:_remove_mailboxes () = ··· 344 436 module Email_header = Jmap_email_header 345 437 module Email_body = Jmap_email_body 346 438 module Apple_mail = Jmap_email_apple 439 439 + module Thread = Jmap_thread 440 440 + module Identity = Jmap_identity 347 441 module Jmap_email_query = Jmap_email_query 348 442 349 443 (* Legacy aliases for compatibility *)

+17 -15

jmap/jmap-email/jmap_email.mli

reviewed

··· 24 24 (** JSON serialization interface *) 25 25 include Jmap_sigs.JSONABLE with type t := t 26 26 27 27 + (** Pretty printing interface *) 28 28 + include Jmap_sigs.PRINTABLE with type t := t 29 29 + 30 30 + (** JMAP object interface with property selection support *) 31 31 + include Jmap_sigs.JMAP_OBJECT with type t := t and type id_type := id 32 32 + 27 33 (** Get the server-assigned email identifier. 28 34 @param t The email object 29 35 @return Email ID if present in the object *) ··· 168 174 @return Map of property names to JSON values for extended properties *) 169 175 val other_properties : t -> Yojson.Safe.t string_map 170 176 171 171 - (** Create a new Email object. 177 177 + (** Create a detailed Email object with all properties. 172 178 173 173 - Used primarily for constructing Email objects from server responses or 174 174 - for testing purposes. In normal operation, Email objects are returned 175 175 - by Email/get and related methods. 179 179 + This is an extended version of the JMAP_OBJECT create function that allows 180 180 + setting all email properties at once. Used primarily for constructing Email 181 181 + objects from server responses or for testing purposes. 176 182 177 183 @param id Server-assigned unique identifier 178 184 @param blob_id Blob ID for raw message access ··· 202 208 @param headers Map of custom header values 203 209 @param other_properties Extended/custom properties 204 210 @return New email object *) 205 205 - val create : 211 211 + val create_full : 206 212 ?id:id -> 207 213 ?blob_id:id -> 208 214 ?thread_id:id -> ··· 287 293 @return String summary of email for list display *) 288 294 val display_summary : t -> string 289 295 290 290 - (** Convert email to JSON with specific properties. 291 291 - 292 292 - Produces JSON object containing only the specified properties, which 293 293 - is useful for constructing partial responses or for filtering output. 294 294 - Properties not present in the email object are omitted. 295 295 - 296 296 - @param t The email to convert 297 297 - @param properties List of property names to include 298 298 - @return JSON object with only the specified properties *) 299 299 - val to_json_with_properties : t -> string list -> Yojson.Safe.t 300 296 301 297 302 298 (** Email patch operations for Email/set method. ··· 362 358 363 359 (** Apple Mail extensions *) 364 360 module Apple_mail = Jmap_email_apple 361 361 + 362 362 + (** Thread operations and data types *) 363 363 + module Thread = Jmap_thread 364 364 + 365 365 + (** Identity operations and data types *) 366 366 + module Identity = Jmap_identity 365 367 366 368 (** Email query builder and operations *) 367 369 module Jmap_email_query = Jmap_email_query

+17

jmap/jmap-email/jmap_email_address.ml

reviewed

··· 65 65 | None -> Error "Missing required email field") 66 66 | _ -> Error "Email address must be a JSON object" 67 67 68 68 + let pp ppf t = 69 69 + match t.name with 70 70 + | Some name -> Format.fprintf ppf "%s <%s>" name t.email 71 71 + | None -> Format.fprintf ppf "%s" t.email 72 72 + 73 73 + let pp_hum = pp 74 74 + 68 75 module Group = struct 69 76 type t = { 70 77 name : string option; ··· 109 116 | Some _ -> Error "Addresses field must be a JSON array" 110 117 | None -> Error "Missing required addresses field") 111 118 | _ -> Error "Address group must be a JSON object" 119 119 + 120 120 + let pp ppf t = 121 121 + let format_addresses addrs = 122 122 + String.concat ", " (List.map (fun addr -> Format.asprintf "%a" pp addr) addrs) 123 123 + in 124 124 + match t.name with 125 125 + | Some name -> Format.fprintf ppf "%s: %s;" name (format_addresses t.addresses) 126 126 + | None -> Format.fprintf ppf "%s" (format_addresses t.addresses) 127 127 + 128 128 + let pp_hum = pp 112 129 end

+12 -20

jmap/jmap-email/jmap_email_address.mli

reviewed

··· 20 20 *) 21 21 type t 22 22 23 23 + (** JSON serialization interface *) 24 24 + include Jmap_sigs.JSONABLE with type t := t 25 25 + 26 26 + (** Pretty-printing interface *) 27 27 + include Jmap_sigs.PRINTABLE with type t := t 28 28 + 23 29 (** Alias for the main type for use in nested modules *) 24 30 type address = t 25 31 ··· 54 60 ?name:string -> 55 61 email:string -> 56 62 unit -> t 57 57 - 58 58 - (** Convert email address to JSON representation. 59 59 - @param t The email address to convert 60 60 - @return JSON object with 'email' and optional 'name' fields *) 61 61 - val to_json : t -> Yojson.Safe.t 62 62 - 63 63 - (** Parse email address from JSON representation. 64 64 - @param json JSON object with 'email' and optional 'name' fields 65 65 - @return Result containing parsed email address object or parse error *) 66 66 - val of_json : Yojson.Safe.t -> (t, string) result 67 63 68 64 (** Email address group representation. 69 65 ··· 75 71 (** Email address group type *) 76 72 type t 77 73 74 74 + (** JSON serialization interface *) 75 75 + include Jmap_sigs.JSONABLE with type t := t 76 76 + 77 77 + (** Pretty-printing interface *) 78 78 + include Jmap_sigs.PRINTABLE with type t := t 79 79 + 78 80 (** Get the name of the address group. 79 81 @param t The address group 80 82 @return The group name, or None if not set *) ··· 93 95 ?name:string -> 94 96 addresses:address list -> 95 97 unit -> t 96 96 - 97 97 - (** Convert address group to JSON representation. 98 98 - @param t The address group to convert 99 99 - @return JSON object with optional 'name' and 'addresses' fields *) 100 100 - val to_json : t -> Yojson.Safe.t 101 101 - 102 102 - (** Parse address group from JSON representation. 103 103 - @param json JSON object with optional 'name' and 'addresses' fields 104 104 - @return Result containing parsed address group or parse error *) 105 105 - val of_json : Yojson.Safe.t -> (t, string) result 106 98 end

+38 -1

jmap/jmap-email/jmap_email_apple.ml

reviewed

··· 98 98 ("keywords/$MailFlagBit0", `Null); 99 99 ("keywords/$MailFlagBit1", `Null); 100 100 ("keywords/$MailFlagBit2", `Null); 101 101 - ] 101 101 + ] 102 102 + 103 103 + (* JSON serialization functions for JSONABLE interface *) 104 104 + let to_json = function 105 105 + | Red -> `String "red" 106 106 + | Orange -> `String "orange" 107 107 + | Yellow -> `String "yellow" 108 108 + | Green -> `String "green" 109 109 + | Blue -> `String "blue" 110 110 + | Purple -> `String "purple" 111 111 + | Gray -> `String "gray" 112 112 + | None -> `String "none" 113 113 + 114 114 + let of_json = function 115 115 + | `String "red" -> Ok Red 116 116 + | `String "orange" -> Ok Orange 117 117 + | `String "yellow" -> Ok Yellow 118 118 + | `String "green" -> Ok Green 119 119 + | `String "blue" -> Ok Blue 120 120 + | `String "purple" -> Ok Purple 121 121 + | `String "gray" -> Ok Gray 122 122 + | `String "none" -> Ok None 123 123 + | `String other -> Error ("Unknown Apple Mail color: " ^ other) 124 124 + | _ -> Error "Apple Mail color must be a JSON string" 125 125 + 126 126 + (* Pretty-printing functions for PRINTABLE interface *) 127 127 + let pp ppf color = Format.fprintf ppf "%s" (color_name color) 128 128 + 129 129 + let pp_hum = pp 130 130 + 131 131 + (* Vendor extension functions for VENDOR_EXTENSION interface *) 132 132 + let vendor () = "com.apple.mail" 133 133 + 134 134 + let extension_name () = "Color Flags" 135 135 + 136 136 + let capability_uri () = Some "urn:ietf:params:jmap:mail:apple:flags" 137 137 + 138 138 + let is_experimental () = false

+9

jmap/jmap-email/jmap_email_apple.mli

reviewed

··· 31 31 | Gray (** $MailFlagBit0 + $MailFlagBit1 + $MailFlagBit2 *) 32 32 | None (** No color flags set *) 33 33 34 34 + (** JSON serialization interface for colors *) 35 35 + include Jmap_sigs.JSONABLE with type t := color 36 36 + 37 37 + (** Pretty-printing interface for colors *) 38 38 + include Jmap_sigs.PRINTABLE with type t := color 39 39 + 40 40 + (** Vendor extension interface *) 41 41 + include Jmap_sigs.VENDOR_EXTENSION with type t := color 42 42 + 34 43 (** Get the JMAP keyword list for a specific color. 35 44 36 45 Returns the list of Apple Mail flag bit keywords that represent

+9 -1

jmap/jmap-email/jmap_email_body.ml

reviewed

··· 290 290 | exn -> Error (Printexc.to_string exn)) 291 291 | _ -> 292 292 Error "Body value JSON must be an object" 293 293 - end 293 293 + end 294 294 + 295 295 + let pp fmt t = 296 296 + Format.fprintf fmt "BodyPart{id=%s;mime_type=%s;size=%d}" 297 297 + (match t.id with Some s -> s | None -> "none") 298 298 + t.mime_type 299 299 + t.size 300 300 + 301 301 + let pp_hum fmt t = pp fmt t

+6 -17

jmap/jmap-email/jmap_email_body.mli

reviewed

··· 21 21 *) 22 22 type t 23 23 24 24 + (** JSON serialization interface *) 25 25 + include Jmap_sigs.JSONABLE with type t := t 26 26 + 27 27 + (** Pretty-printing interface *) 28 28 + include Jmap_sigs.PRINTABLE with type t := t 29 29 + 24 30 (** Get the part ID for referencing this specific part. 25 31 @param t The body part 26 32 @return Part identifier, or None for multipart container types *) ··· 204 210 @return List of matching body parts *) 205 211 val find_by_mime_type : t -> string -> t list 206 212 207 207 - (** Convert body part to JSON representation. 208 208 - 209 209 - Produces JSON object representation as specified in JMAP Email/get responses. 210 210 - Includes all body part fields that are present. 211 211 - 212 212 - @param t The body part to convert 213 213 - @return JSON object with all body part fields *) 214 214 - val to_json : t -> Yojson.Safe.t 215 215 - 216 216 - (** Parse body part from JSON representation. 217 217 - 218 218 - Parses body part from JSON object as received in JMAP responses. 219 219 - Validates required fields and structure. 220 220 - 221 221 - @param json JSON object representing a body part 222 222 - @return Result containing parsed body part object or parse error *) 223 223 - val of_json : Yojson.Safe.t -> (t, string) result 224 213 225 214 (** Decoded email body content. 226 215

+6 -1

jmap/jmap-email/jmap_email_header.ml

reviewed

··· 93 93 94 94 let find_all_by_name headers name = 95 95 let target = normalize_name name in 96 96 - List.filter (fun h -> normalize_name h.name = target) headers 96 96 + List.filter (fun h -> normalize_name h.name = target) headers 97 97 + 98 98 + let pp fmt t = 99 99 + Format.fprintf fmt "%s: %s" t.name t.value 100 100 + 101 101 + let pp_hum fmt t = pp fmt t

+6 -18

jmap/jmap-email/jmap_email_header.mli

reviewed

··· 19 19 *) 20 20 type t 21 21 22 22 + (** JSON serialization interface *) 23 23 + include Jmap_sigs.JSONABLE with type t := t 24 24 + 25 25 + (** Pretty-printing interface *) 26 26 + include Jmap_sigs.PRINTABLE with type t := t 27 27 + 22 28 (** Get the header field name. 23 29 @param t The header field 24 30 @return The header field name (e.g., "Subject", "X-Custom-Header") *) ··· 55 61 name:string -> 56 62 value:string -> 57 63 unit -> t 58 58 - 59 59 - (** Convert header field to JSON representation. 60 60 - 61 61 - Produces a JSON object with "name" and "value" string fields as specified 62 62 - in the JMAP specification. 63 63 - 64 64 - @param t The header field to convert 65 65 - @return JSON object with 'name' and 'value' fields *) 66 66 - val to_json : t -> Yojson.Safe.t 67 67 - 68 68 - (** Parse header field from JSON representation. 69 69 - 70 70 - Parses a JSON object containing "name" and "value" string fields. 71 71 - Both fields are required for valid header field objects. 72 72 - 73 73 - @param json JSON object with 'name' and 'value' fields 74 74 - @return Result containing parsed header field object or parse error *) 75 75 - val of_json : Yojson.Safe.t -> (t, string) result 76 64 77 65 (** Convert a list of header fields to JSON array. 78 66

+21 -12

jmap/jmap-email/jmap_email_keywords.ml

reviewed

··· 39 39 40 40 let empty () = { keywords = [] } 41 41 42 42 - let of_list keywords = 43 43 - (* Remove duplicates while preserving order *) 44 44 - let rec remove_dups acc = function 45 45 - | [] -> List.rev acc 46 46 - | x :: xs -> 47 47 - if List.mem x acc then remove_dups acc xs 48 48 - else remove_dups (x :: acc) xs 49 49 - in 50 50 - { keywords = remove_dups [] keywords } 51 51 - 52 52 - let to_list t = t.keywords 53 42 54 43 let has_keyword t keyword = List.mem keyword t.keywords 55 44 ··· 158 147 (match List.fold_left parse_keywords (Ok []) fields with 159 148 | Ok keywords -> Ok { keywords = List.rev keywords } 160 149 | Error msg -> Error msg) 161 161 - | _ -> Error "Keywords must be a JSON object" 150 150 + | _ -> Error "Keywords must be a JSON object" 151 151 + 152 152 + (* Pretty-printing functions for PRINTABLE interface *) 153 153 + let pp ppf t = 154 154 + let keyword_strings = List.map keyword_to_string t.keywords in 155 155 + Format.fprintf ppf "{%s}" (String.concat ", " keyword_strings) 156 156 + 157 157 + let pp_hum = pp 158 158 + 159 159 + (* Collection interface functions for COLLECTION interface *) 160 160 + let items t = t.keywords 161 161 + 162 162 + let total t = Some (List.length t.keywords) 163 163 + 164 164 + let create ~items ?total () = 165 165 + let _ = total in (* Acknowledge unused parameter *) 166 166 + { keywords = items } 167 167 + 168 168 + let map f t = { keywords = List.map f t.keywords } 169 169 + 170 170 + let filter f t = { keywords = List.filter f t.keywords }

+10 -20

jmap/jmap-email/jmap_email_keywords.mli

reviewed

··· 58 58 *) 59 59 type t 60 60 61 61 + (** JSON serialization interface *) 62 62 + include Jmap_sigs.JSONABLE with type t := t 63 63 + 64 64 + (** Pretty-printing interface *) 65 65 + include Jmap_sigs.PRINTABLE with type t := t 66 66 + 67 67 + (** Collection interface for keyword sets *) 68 68 + include Jmap_sigs.COLLECTION with type t := t and type item := keyword 69 69 + 61 70 (** Create an empty keyword set. 62 71 @return Empty keyword set *) 63 72 val empty : unit -> t 64 73 65 65 - (** Create a keyword set from a list of keywords. 66 66 - @param keywords List of keywords to include (duplicates are removed) 67 67 - @return New keyword set containing the specified keywords *) 68 68 - val of_list : keyword list -> t 69 69 - 70 70 - (** Convert keyword set to list. 71 71 - @param t The keyword set 72 72 - @return List of keywords in the set *) 73 73 - val to_list : t -> keyword list 74 74 75 75 (** Check if email is marked as a draft. 76 76 @param t The keyword set ··· 171 171 (** Convert keyword set to JMAP wire format (string -> bool map). 172 172 @param t The keyword set to convert 173 173 @return Hash table mapping keyword strings to true values *) 174 174 - val to_map : t -> (string, bool) Hashtbl.t 175 175 - 176 176 - (** Convert keyword set to JSON representation. 177 177 - @param t The keyword set to convert 178 178 - @return JSON object mapping keyword strings to boolean values *) 179 179 - val to_json : t -> Yojson.Safe.t 180 180 - 181 181 - (** Parse keyword set from JSON representation. 182 182 - @param json JSON object mapping keyword strings to boolean values 183 183 - @return Result containing parsed keyword set or parse error *) 184 184 - val of_json : Yojson.Safe.t -> (t, string) result 174 174 + val to_map : t -> (string, bool) Hashtbl.t

+52 -16

jmap/jmap-email/jmap_email_types.ml

reviewed

··· 28 28 in 29 29 `Assoc fields 30 30 31 31 - let of_json = function 32 32 - | `Assoc fields -> 33 33 - let email = match List.assoc_opt "email" fields with 34 34 - | Some (`String email) -> email 35 35 - | _ -> failwith "Email_address.of_json: missing or invalid email field" 36 36 - in 37 37 - let name = match List.assoc_opt "name" fields with 38 38 - | Some (`String name) -> Some name 39 39 - | Some `Null | None -> None 40 40 - | _ -> failwith "Email_address.of_json: invalid name field" 41 41 - in 42 42 - { name; email } 43 43 - | _ -> failwith "Email_address.of_json: expected JSON object" 31 31 + let of_json json = 32 32 + try 33 33 + match json with 34 34 + | `Assoc fields -> 35 35 + let email = match List.assoc_opt "email" fields with 36 36 + | Some (`String email) -> email 37 37 + | _ -> failwith "Email_address.of_json: missing or invalid email field" 38 38 + in 39 39 + let name = match List.assoc_opt "name" fields with 40 40 + | Some (`String name) -> Some name 41 41 + | Some `Null | None -> None 42 42 + | _ -> failwith "Email_address.of_json: invalid name field" 43 43 + in 44 44 + Ok { name; email } 45 45 + | _ -> failwith "Email_address.of_json: expected JSON object" 46 46 + with 47 47 + | Failure msg -> Error msg 48 48 + | exn -> Error (Printexc.to_string exn) 49 49 + 50 50 + let pp fmt t = 51 51 + match t.name with 52 52 + | Some name -> Format.fprintf fmt "%s <%s>" name t.email 53 53 + | None -> Format.fprintf fmt "%s" t.email 54 54 + 55 55 + let pp_hum fmt t = pp fmt t 44 56 end 45 57 46 58 module Email_address_group = struct ··· 637 649 | _ -> failwith "Email.of_json: invalid preview field" 638 650 in 639 651 let from = match List.assoc_opt "from" fields with 640 640 - | Some (`List from_list) -> Some (List.map Email_address.of_json from_list) 652 652 + | Some (`List from_list) -> 653 653 + let rec process_addresses acc = function 654 654 + | [] -> Some (List.rev acc) 655 655 + | addr :: rest -> 656 656 + (match Email_address.of_json addr with 657 657 + | Ok a -> process_addresses (a :: acc) rest 658 658 + | Error _ -> failwith "Email.of_json: invalid address in from field") 659 659 + in 660 660 + process_addresses [] from_list 641 661 | Some `Null | None -> None 642 662 | _ -> failwith "Email.of_json: invalid from field" 643 663 in 644 664 let to_ = match List.assoc_opt "to" fields with 645 645 - | Some (`List to_list) -> Some (List.map Email_address.of_json to_list) 665 665 + | Some (`List to_list) -> 666 666 + let rec process_addresses acc = function 667 667 + | [] -> Some (List.rev acc) 668 668 + | addr :: rest -> 669 669 + (match Email_address.of_json addr with 670 670 + | Ok a -> process_addresses (a :: acc) rest 671 671 + | Error _ -> failwith "Email.of_json: invalid address in to field") 672 672 + in 673 673 + process_addresses [] to_list 646 674 | Some `Null | None -> None 647 675 | _ -> failwith "Email.of_json: invalid to field" 648 676 in 649 677 let cc = match List.assoc_opt "cc" fields with 650 650 - | Some (`List cc_list) -> Some (List.map Email_address.of_json cc_list) 678 678 + | Some (`List cc_list) -> 679 679 + let rec process_addresses acc = function 680 680 + | [] -> Some (List.rev acc) 681 681 + | addr :: rest -> 682 682 + (match Email_address.of_json addr with 683 683 + | Ok a -> process_addresses (a :: acc) rest 684 684 + | Error _ -> failwith "Email.of_json: invalid address in cc field") 685 685 + in 686 686 + process_addresses [] cc_list 651 687 | Some `Null | None -> None 652 688 | _ -> failwith "Email.of_json: invalid cc field" 653 689 in

+6 -10

jmap/jmap-email/jmap_email_types.mli

reviewed

··· 27 27 module Email_address : sig 28 28 type t 29 29 30 30 + (** JSON serialization interface *) 31 31 + include Jmap_sigs.JSONABLE with type t := t 32 32 + 33 33 + (** Pretty-printing interface *) 34 34 + include Jmap_sigs.PRINTABLE with type t := t 35 35 + 30 36 (** Get the display name for the address. 31 37 @return The human-readable display name, or None if not set *) 32 38 val name : t -> string option ··· 44 50 email:string -> 45 51 unit -> t 46 52 47 47 - (** Convert email address to JSON representation. 48 48 - @param t The email address to convert 49 49 - @return JSON object with 'email' and optional 'name' fields *) 50 50 - val to_json : t -> Yojson.Safe.t 51 51 - 52 52 - (** Parse email address from JSON representation. 53 53 - @param json JSON object with 'email' and optional 'name' fields 54 54 - @return Parsed email address object 55 55 - @raise Failure if JSON structure is invalid *) 56 56 - val of_json : Yojson.Safe.t -> t 57 53 end 58 54 59 55 (** Email address group representation.

+155 -9

jmap/jmap-email/jmap_identity.ml

reviewed

··· 8 8 *) 9 9 10 10 open Jmap.Types 11 11 + open Jmap.Method_names 11 12 open Jmap.Protocol.Error 12 13 13 14 (** Identity object *) 14 15 type t = { 15 15 - id : id; 16 16 + id : id option; 16 17 name : string; 17 18 email : string; 18 19 reply_to : Jmap_email_types.Email_address.t list option; ··· 33 34 34 35 let v ~id ?(name = "") ~email ?reply_to ?bcc ?(text_signature = "") 35 36 ?(html_signature = "") ~may_delete () = { 36 36 - id; 37 37 + id = Some id; 37 38 name; 38 39 email; 39 40 reply_to; ··· 45 46 46 47 let to_json t = 47 48 let fields = [ 48 48 - ("id", `String t.id); 49 49 + ("id", (match t.id with Some id -> `String id | None -> `Null)); 49 50 ("name", `String t.name); 50 51 ("email", `String t.email); 51 52 ("textSignature", `String t.text_signature); ··· 62 63 in 63 64 `Assoc (List.rev fields) 64 65 66 66 + (* JMAP_OBJECT implementation *) 67 67 + let create ?id () = 68 68 + { id; name = ""; email = ""; reply_to = None; bcc = None; 69 69 + text_signature = ""; html_signature = ""; may_delete = true } 70 70 + 71 71 + let to_json_with_properties ~properties t = 72 72 + let all_fields = [ 73 73 + ("id", (match t.id with Some id -> `String id | None -> `Null)); 74 74 + ("name", `String t.name); 75 75 + ("email", `String t.email); 76 76 + ("replyTo", (match t.reply_to with 77 77 + | None -> `Null 78 78 + | Some addrs -> `List (List.map Jmap_email_types.Email_address.to_json addrs))); 79 79 + ("bcc", (match t.bcc with 80 80 + | None -> `Null 81 81 + | Some addrs -> `List (List.map Jmap_email_types.Email_address.to_json addrs))); 82 82 + ("textSignature", `String t.text_signature); 83 83 + ("htmlSignature", `String t.html_signature); 84 84 + ("mayDelete", `Bool t.may_delete); 85 85 + ] in 86 86 + let filtered_fields = List.filter (fun (name, _) -> 87 87 + List.mem name properties 88 88 + ) all_fields in 89 89 + `Assoc filtered_fields 90 90 + 91 91 + let valid_properties () = [ 92 92 + "id"; "name"; "email"; "replyTo"; "bcc"; "textSignature"; "htmlSignature"; "mayDelete" 93 93 + ] (* TODO: Use Property.to_string_list Property.all_properties when module ordering is fixed *) 94 94 + 65 95 let of_json json = 66 96 try 67 97 match json with ··· 81 111 let get_addresses key = 82 112 match List.assoc_opt key fields with 83 113 | Some (`List addrs) -> 84 84 - Some (List.map Jmap_email_types.Email_address.of_json addrs) 114 114 + let rec process_addresses acc = function 115 115 + | [] -> Some (List.rev acc) 116 116 + | addr :: rest -> 117 117 + (match Jmap_email_types.Email_address.of_json addr with 118 118 + | Ok a -> process_addresses (a :: acc) rest 119 119 + | Error _ -> failwith ("Invalid address in " ^ key ^ " field")) 120 120 + in 121 121 + process_addresses [] addrs 85 122 | Some `Null | None -> None 86 123 | _ -> failwith ("Invalid " ^ key ^ " field in Identity") 87 124 in 88 125 let id = get_string "id" "" in 89 89 - if id = "" then failwith "Missing required 'id' field in Identity"; 90 126 let email = get_string "email" "" in 91 127 if email = "" then failwith "Missing required 'email' field in Identity"; 92 128 Ok { 93 93 - id; 129 129 + id = (if id = "" then None else Some id); 94 130 name = get_string "name" ""; 95 131 email; 96 132 reply_to = get_addresses "replyTo"; ··· 103 139 with 104 140 | Failure msg -> Error msg 105 141 | exn -> Error ("Failed to parse Identity JSON: " ^ Printexc.to_string exn) 142 142 + 143 143 + (* Pretty printing implementation for PRINTABLE signature *) 144 144 + let pp ppf t = 145 145 + let name_str = if t.name = "" then "<no-name>" else t.name in 146 146 + let id_str = match t.id with Some id -> id | None -> "(no-id)" in 147 147 + Format.fprintf ppf "Identity{id=%s; name=%s; email=%s; may_delete=%b}" 148 148 + id_str name_str t.email t.may_delete 149 149 + 150 150 + (* Alias for pp following Fmt conventions *) 151 151 + let pp_hum = pp 106 152 107 153 (** Identity creation operations *) 108 154 module Create = struct ··· 168 214 let get_addresses_opt key = 169 215 match List.assoc_opt key fields with 170 216 | Some (`List addrs) -> 171 171 - Some (List.map Jmap_email_types.Email_address.of_json addrs) 217 217 + let rec process_addresses acc = function 218 218 + | [] -> Some (List.rev acc) 219 219 + | addr :: rest -> 220 220 + (match Jmap_email_types.Email_address.of_json addr with 221 221 + | Ok a -> process_addresses (a :: acc) rest 222 222 + | Error _ -> failwith ("Invalid address in " ^ key ^ " field")) 223 223 + in 224 224 + process_addresses [] addrs 172 225 | Some `Null | None -> None 173 226 | _ -> failwith ("Invalid " ^ key ^ " field in Identity creation") 174 227 in ··· 336 389 if List.mem_assoc key fields then 337 390 match List.assoc key fields with 338 391 | `Null -> Some None 339 339 - | `List addrs -> Some (Some (List.map Jmap_email_types.Email_address.of_json addrs)) 392 392 + | `List addrs -> 393 393 + let rec process_addresses acc = function 394 394 + | [] -> Some (Some (List.rev acc)) 395 395 + | addr :: rest -> 396 396 + (match Jmap_email_types.Email_address.of_json addr with 397 397 + | Ok a -> process_addresses (a :: acc) rest 398 398 + | Error _ -> failwith ("Invalid address in " ^ key ^ " field")) 399 399 + in 400 400 + process_addresses [] addrs 340 401 | _ -> failwith ("Invalid " ^ key ^ " field in Identity update") 341 402 else None 342 403 in ··· 438 499 with 439 500 | Failure msg -> Error ("Identity Get_args JSON parsing error: " ^ msg) 440 501 | exn -> Error ("Identity Get_args JSON parsing exception: " ^ Printexc.to_string exn) 502 502 + 503 503 + let pp fmt t = 504 504 + Format.fprintf fmt "Identity.Get_args{account=%s;ids=%s}" 505 505 + t.account_id 506 506 + (match t.ids with Some ids -> string_of_int (List.length ids) | None -> "all") 507 507 + 508 508 + let pp_hum fmt t = pp fmt t 509 509 + 510 510 + let validate _t = Ok () 511 511 + 512 512 + let method_name () = method_to_string `Identity_get 441 513 end 442 514 443 515 ··· 537 609 with 538 610 | Failure msg -> Error ("Identity/set JSON parsing error: " ^ msg) 539 611 | exn -> Error ("Identity/set JSON parsing exception: " ^ Printexc.to_string exn) 612 612 + 613 613 + let pp fmt t = 614 614 + Format.fprintf fmt "Identity.Set_args{account=%s}" t.account_id 615 615 + 616 616 + let pp_hum fmt t = pp fmt t 617 617 + 618 618 + let validate _t = Ok () 619 619 + 620 620 + let method_name () = method_to_string `Identity_set 540 621 end 541 622 542 623 (** Response for Identity/set method *) ··· 691 772 with 692 773 | Failure msg -> Error ("Identity/changes arguments JSON parsing error: " ^ msg) 693 774 | exn -> Error ("Identity/changes arguments JSON parsing exception: " ^ Printexc.to_string exn) 775 775 + 776 776 + let pp fmt t = 777 777 + Format.fprintf fmt "Identity.Changes_args{account=%s;since=%s}" 778 778 + t.account_id t.since_state 779 779 + 780 780 + let pp_hum fmt t = pp fmt t 781 781 + 782 782 + let validate _t = Ok () 783 783 + 784 784 + let method_name () = method_to_string `Identity_changes 694 785 end 695 786 696 787 (** Response for Identity/changes method *) ··· 831 922 let get_addresses key = 832 923 match List.assoc_opt key fields with 833 924 | Some (`List addrs) -> 834 834 - Some (List.map Jmap_email_types.Email_address.of_json addrs) 925 925 + let rec process_addresses acc = function 926 926 + | [] -> Some (List.rev acc) 927 927 + | addr :: rest -> 928 928 + (match Jmap_email_types.Email_address.of_json addr with 929 929 + | Ok a -> process_addresses (a :: acc) rest 930 930 + | Error _ -> failwith ("Invalid address in " ^ key ^ " field")) 931 931 + in 932 932 + process_addresses [] addrs 835 933 | Some `Null | None -> None 836 934 | _ -> failwith ("Invalid " ^ key ^ " field in Identity") 837 935 in ··· 884 982 with 885 983 | Failure msg -> Error ("Identity/get JSON parsing error: " ^ msg) 886 984 | exn -> Error ("Identity/get JSON parsing exception: " ^ Printexc.to_string exn) 985 985 + end 986 986 + 987 987 + module Property = struct 988 988 + type t = [ 989 989 + | `Id 990 990 + | `Name 991 991 + | `Email 992 992 + | `ReplyTo 993 993 + | `Bcc 994 994 + | `TextSignature 995 995 + | `HtmlSignature 996 996 + | `MayDelete 997 997 + ] 998 998 + 999 999 + let to_string = function 1000 1000 + | `Id -> "id" 1001 1001 + | `Name -> "name" 1002 1002 + | `Email -> "email" 1003 1003 + | `ReplyTo -> "replyTo" 1004 1004 + | `Bcc -> "bcc" 1005 1005 + | `TextSignature -> "textSignature" 1006 1006 + | `HtmlSignature -> "htmlSignature" 1007 1007 + | `MayDelete -> "mayDelete" 1008 1008 + 1009 1009 + let of_string = function 1010 1010 + | "id" -> Some `Id 1011 1011 + | "name" -> Some `Name 1012 1012 + | "email" -> Some `Email 1013 1013 + | "replyTo" -> Some `ReplyTo 1014 1014 + | "bcc" -> Some `Bcc 1015 1015 + | "textSignature" -> Some `TextSignature 1016 1016 + | "htmlSignature" -> Some `HtmlSignature 1017 1017 + | "mayDelete" -> Some `MayDelete 1018 1018 + | _ -> None 1019 1019 + 1020 1020 + let all_properties = [ 1021 1021 + `Id; `Name; `Email; `ReplyTo; `Bcc; 1022 1022 + `TextSignature; `HtmlSignature; `MayDelete 1023 1023 + ] 1024 1024 + 1025 1025 + let to_string_list props = List.map to_string props 1026 1026 + 1027 1027 + let of_string_list strings = 1028 1028 + List.filter_map of_string strings 1029 1029 + 1030 1030 + let common_properties = [`Id; `Name; `Email; `MayDelete] 1031 1031 + 1032 1032 + let detailed_properties = all_properties 887 1033 end

+111 -2

jmap/jmap-email/jmap_identity.mli

reviewed

··· 27 27 28 28 include Jmap_sigs.JSONABLE with type t := t 29 29 30 30 + (** Pretty printing interface *) 31 31 + include Jmap_sigs.PRINTABLE with type t := t 32 32 + 33 33 + (** JMAP object interface for property selection and object creation *) 34 34 + include Jmap_sigs.JMAP_OBJECT with type t := t and type id_type := id 35 35 + 30 36 (** Get the server-assigned identity identifier. 31 31 - @return Immutable unique ID for this identity *) 32 32 - val id : t -> id 37 37 + @return Immutable unique ID (Some for all persisted identities, None only for unsaved objects) *) 38 38 + val id : t -> id option 33 39 34 40 (** Get the display name for this identity. 35 41 @return Human-readable name, empty string if not set *) ··· 265 271 266 272 include Jmap_sigs.JSONABLE with type t := t 267 273 274 274 + (** JMAP method arguments interface *) 275 275 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 276 276 + 268 277 (** Get the account ID for the operation. 269 278 @return Account identifier where identities will be retrieved *) 270 279 val account_id : t -> id 280 280 + 281 281 + (** Validate get arguments according to JMAP method constraints. 282 282 + @param t Get arguments to validate 283 283 + @return Ok () if valid, Error with description if invalid *) 284 284 + val validate : t -> (unit, string) Result.t 285 285 + 286 286 + (** Get the method name for these arguments. 287 287 + @return The JMAP method name "Identity/get" *) 288 288 + val method_name : unit -> string 271 289 272 290 (** Get the specific identity IDs to retrieve. 273 291 @return List of identity IDs, or None to retrieve all identities *) ··· 355 373 type t 356 374 357 375 include Jmap_sigs.JSONABLE with type t := t 376 376 + 377 377 + (** JMAP method arguments interface *) 378 378 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 358 379 359 380 (** Get the account ID for the operation. 360 381 @return Account identifier where identities will be modified *) 361 382 val account_id : t -> id 383 383 + 384 384 + (** Validate set arguments according to JMAP method constraints. 385 385 + @param t Set arguments to validate 386 386 + @return Ok () if valid, Error with description if invalid *) 387 387 + val validate : t -> (unit, string) Result.t 388 388 + 389 389 + (** Get the method name for these arguments. 390 390 + @return The JMAP method name "Identity/set" *) 391 391 + val method_name : unit -> string 362 392 363 393 (** Get the if-in-state condition for the operation. 364 394 @return Expected state string for optimistic concurrency *) ··· 477 507 type t 478 508 479 509 include Jmap_sigs.JSONABLE with type t := t 510 510 + 511 511 + (** JMAP method arguments interface *) 512 512 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 480 513 481 514 (** Get the account ID for the operation. 482 515 @return Account identifier where changes will be retrieved *) 483 516 val account_id : t -> id 517 517 + 518 518 + (** Validate changes arguments according to JMAP method constraints. 519 519 + @param t Changes arguments to validate 520 520 + @return Ok () if valid, Error with description if invalid *) 521 521 + val validate : t -> (unit, string) Result.t 522 522 + 523 523 + (** Get the method name for these arguments. 524 524 + @return The JMAP method name "Identity/changes" *) 525 525 + val method_name : unit -> string 484 526 485 527 (** Get the state string to sync from. 486 528 @return State string from which to get changes *) ··· 561 603 ?updated:id list -> 562 604 ?destroyed:id list -> 563 605 unit -> t 606 606 + end 607 607 + 608 608 + (** {1 Property System} *) 609 609 + 610 610 + (** Identity object property identifiers for selective retrieval. 611 611 + 612 612 + Property identifiers for Identity objects as specified in RFC 8621 Section 6. 613 613 + These identifiers are used in Identity/get requests to specify which properties 614 614 + should be returned, enabling efficient partial object retrieval. 615 615 + 616 616 + @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-6> RFC 8621, Section 6 617 617 + *) 618 618 + module Property : sig 619 619 + (** Identity object property identifier type. 620 620 + 621 621 + Polymorphic variant enumeration of all standard properties available 622 622 + on Identity objects as defined in RFC 8621. 623 623 + *) 624 624 + type t = [ 625 625 + | `Id (** Server-assigned unique identifier (immutable, server-set) *) 626 626 + | `Name (** Display name for the "From" field *) 627 627 + | `Email (** Email address for sending (immutable) *) 628 628 + | `ReplyTo (** Default Reply-To addresses *) 629 629 + | `Bcc (** Default Bcc addresses *) 630 630 + | `TextSignature (** Plain text signature for messages *) 631 631 + | `HtmlSignature (** HTML signature for messages *) 632 632 + | `MayDelete (** Whether user can delete this identity (server-set) *) 633 633 + ] 634 634 + 635 635 + (** Convert a property to its JMAP protocol string representation. 636 636 + 637 637 + @param prop The property to convert 638 638 + @return JMAP protocol string representation *) 639 639 + val to_string : t -> string 640 640 + 641 641 + (** Parse a JMAP protocol string into a property variant. 642 642 + 643 643 + @param str The protocol string to parse 644 644 + @return Some property if valid, None if unknown *) 645 645 + val of_string : string -> t option 646 646 + 647 647 + (** Get all standard identity properties. 648 648 + 649 649 + @return Complete list of all defined identity properties *) 650 650 + val all_properties : t list 651 651 + 652 652 + (** Convert a list of properties to their string representations. 653 653 + 654 654 + @param properties List of property variants 655 655 + @return List of JMAP protocol strings *) 656 656 + val to_string_list : t list -> string list 657 657 + 658 658 + (** Parse a list of strings into property variants. 659 659 + 660 660 + @param strings List of JMAP protocol strings 661 661 + @return List of parsed property variants (invalid strings ignored) *) 662 662 + val of_string_list : string list -> t list 663 663 + 664 664 + (** Get properties commonly needed for identity selection. 665 665 + 666 666 + @return List of properties suitable for identity picker displays *) 667 667 + val common_properties : t list 668 668 + 669 669 + (** Get properties for full identity display. 670 670 + 671 671 + @return Complete list of all properties for detailed identity views *) 672 672 + val detailed_properties : t list 564 673 end

+219 -4

jmap/jmap-email/jmap_mailbox.ml

reviewed

··· 7 7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2: Mailboxes 8 8 *) 9 9 10 10 + [@@@warning "-32"] (* Suppress unused value warnings for interface-required functions *) 11 11 + 10 12 open Jmap.Types 13 13 + open Jmap.Method_names 11 14 open Jmap.Methods 12 15 13 16 (* Forward declaration of types *) ··· 56 59 type mailbox_t = t 57 60 58 61 (* Property accessors *) 59 59 - let id mailbox = mailbox.mailbox_id 62 62 + let id mailbox = Some mailbox.mailbox_id (* JMAP_OBJECT signature requires option *) 63 63 + let mailbox_id mailbox = mailbox.mailbox_id (* Direct access when ID is guaranteed *) 60 64 let name mailbox = mailbox.name 61 65 let parent_id mailbox = mailbox.parent_id 62 66 let role mailbox = mailbox.role ··· 68 72 let my_rights mailbox = mailbox.my_rights 69 73 let is_subscribed mailbox = mailbox.is_subscribed 70 74 71 71 - (* Smart constructor with validation *) 72 72 - let create ~id ~name ?parent_id ?role ?(sort_order=0) ~total_emails ~unread_emails 75 75 + 76 76 + (* JMAP_OBJECT signature implementations *) 77 77 + 78 78 + (* Create a minimal valid mailbox object with only required fields *) 79 79 + let create ?id () = 80 80 + let id = match id with 81 81 + | Some i -> i 82 82 + | None -> "temp_id" (* Temporary ID for unsaved objects *) 83 83 + in 84 84 + let default_rights = { 85 85 + may_read_items = false; may_add_items = false; may_remove_items = false; 86 86 + may_set_seen = false; may_set_keywords = false; may_create_child = false; 87 87 + may_rename = false; may_delete = false; may_submit = false; 88 88 + } in 89 89 + { 90 90 + mailbox_id = id; 91 91 + name = "Untitled"; 92 92 + parent_id = None; 93 93 + role = None; 94 94 + sort_order = 0; 95 95 + total_emails = 0; 96 96 + unread_emails = 0; 97 97 + total_threads = 0; 98 98 + unread_threads = 0; 99 99 + my_rights = default_rights; 100 100 + is_subscribed = true; 101 101 + } 102 102 + 103 103 + (* Get list of all valid property names for Mailbox objects *) 104 104 + let valid_properties () = [ 105 105 + "id"; "name"; "parentId"; "role"; "sortOrder"; 106 106 + "totalEmails"; "unreadEmails"; "totalThreads"; "unreadThreads"; 107 107 + "myRights"; "isSubscribed" 108 108 + ] 109 109 + 110 110 + 111 111 + (* Extended constructor with validation - renamed from create *) 112 112 + let create_full ~id ~name ?parent_id ?role ?(sort_order=0) ~total_emails ~unread_emails 73 113 ~total_threads ~unread_threads ~my_rights ~is_subscribed () = 74 114 if String.length name = 0 then 75 115 Error "Mailbox name cannot be empty" ··· 163 203 let json_str = Yojson.Safe.to_string json in 164 204 Error (Printf.sprintf "Expected JSON string for Role, got: %s" json_str) 165 205 end 206 206 + 207 207 + (* PRINTABLE interface implementation *) 208 208 + let pp ppf t = 209 209 + let role_str = match t.role with 210 210 + | Some r -> Role.to_string r 211 211 + | None -> "none" 212 212 + in 213 213 + Format.fprintf ppf "Mailbox{id=%s; name=%s; role=%s}" t.mailbox_id t.name role_str 214 214 + 215 215 + let pp_hum = pp 216 216 + 217 217 + (* Serialize to JSON with only specified properties *) 218 218 + let to_json_with_properties ~properties t = 219 219 + let role_to_json = function 220 220 + | Some r -> `String (Role.to_string r) 221 221 + | None -> `Null 222 222 + in 223 223 + let rights_to_json rights = `Assoc [ 224 224 + ("mayReadItems", `Bool rights.may_read_items); 225 225 + ("mayAddItems", `Bool rights.may_add_items); 226 226 + ("mayRemoveItems", `Bool rights.may_remove_items); 227 227 + ("maySetSeen", `Bool rights.may_set_seen); 228 228 + ("maySetKeywords", `Bool rights.may_set_keywords); 229 229 + ("mayCreateChild", `Bool rights.may_create_child); 230 230 + ("mayRename", `Bool rights.may_rename); 231 231 + ("mayDelete", `Bool rights.may_delete); 232 232 + ("maySubmit", `Bool rights.may_submit); 233 233 + ] in 234 234 + let all_fields = [ 235 235 + ("id", `String t.mailbox_id); 236 236 + ("name", `String t.name); 237 237 + ("parentId", (match t.parent_id with Some p -> `String p | None -> `Null)); 238 238 + ("role", role_to_json t.role); 239 239 + ("sortOrder", `Int t.sort_order); 240 240 + ("totalEmails", `Int t.total_emails); 241 241 + ("unreadEmails", `Int t.unread_emails); 242 242 + ("totalThreads", `Int t.total_threads); 243 243 + ("unreadThreads", `Int t.unread_threads); 244 244 + ("myRights", rights_to_json t.my_rights); 245 245 + ("isSubscribed", `Bool t.is_subscribed); 246 246 + ] in 247 247 + let filtered_fields = List.filter (fun (name, _) -> 248 248 + List.mem name properties 249 249 + ) all_fields in 250 250 + let non_null_fields = List.filter (fun (_, value) -> 251 251 + value <> `Null 252 252 + ) filtered_fields in 253 253 + `Assoc non_null_fields 166 254 167 255 module Rights = struct 168 256 type t = rights ··· 680 768 | Not_found -> Error "Missing required field in Query_args" 681 769 | Failure msg -> Error ("Query_args JSON parsing error: " ^ msg) 682 770 | exn -> Error ("Query_args JSON parsing exception: " ^ Printexc.to_string exn) 771 771 + 772 772 + let pp fmt t = 773 773 + Format.fprintf fmt "Mailbox.Query_args{account=%s}" t.account_id 774 774 + 775 775 + let pp_hum fmt t = pp fmt t 776 776 + 777 777 + let validate _t = Ok () 778 778 + 779 779 + let method_name () = method_to_string `Mailbox_query 683 780 end 684 781 685 782 module Query_response = struct ··· 699 796 let total resp = resp.total 700 797 let ids resp = resp.ids 701 798 799 799 + (* TODO: Implement Query_response JSON serialization 800 800 + - Serialize mailbox query response with ids, queryState, position 801 801 + - Handle canCalculateChanges and total fields 802 802 + - RFC reference: RFC 8620 Section 5.5 (for Mailbox/query) 803 803 + - Priority: Medium 804 804 + - Dependencies: Core response format *) 702 805 let to_json _resp = `Assoc [] (* Stub *) 806 806 + (* TODO: Implement Query_response JSON deserialization 807 807 + - Parse Mailbox/query response JSON to response type 808 808 + - Extract ids array, queryState, position fields 809 809 + - RFC reference: RFC 8620 Section 5.5 810 810 + - Priority: Medium 811 811 + - Dependencies: Core response parsing *) 703 812 let of_json _json = Error "Query_response.of_json not implemented" (* Stub *) 813 813 + 814 814 + let pp fmt t = 815 815 + Format.fprintf fmt "Mailbox.Query_response{account=%s;total=%s}" 816 816 + t.account_id 817 817 + (match t.total with Some n -> string_of_int n | None -> "unknown") 818 818 + 819 819 + let pp_hum fmt t = pp fmt t 820 820 + 821 821 + let state _t = Some "stub-state" 822 822 + 823 823 + let is_error _t = false 704 824 end 705 825 706 826 module Get_args = struct ··· 717 837 let ids args = args.ids 718 838 let properties args = args.properties 719 839 840 840 + (* TODO: Implement Get_args JSON serialization 841 841 + - Serialize Mailbox/get arguments with accountId, ids, properties 842 842 + - Handle optional ids and properties fields 843 843 + - RFC reference: RFC 8620 Section 5.1 (for Mailbox/get) 844 844 + - Priority: Medium 845 845 + - Dependencies: Core argument format *) 720 846 let to_json _args = `Assoc [] (* Stub *) 847 847 + (* TODO: Implement Get_args JSON deserialization 848 848 + - Parse Mailbox/get arguments from JSON 849 849 + - Extract accountId, ids, properties fields 850 850 + - RFC reference: RFC 8620 Section 5.1 851 851 + - Priority: Medium 852 852 + - Dependencies: Core argument parsing *) 721 853 let of_json _json = Error "Get_args.of_json not implemented" (* Stub *) 854 854 + 855 855 + let pp fmt t = 856 856 + Format.fprintf fmt "Mailbox.Get_args{account=%s}" t.account_id 857 857 + 858 858 + let pp_hum fmt t = pp fmt t 859 859 + 860 860 + let validate _t = Ok () 861 861 + 862 862 + let method_name () = method_to_string `Mailbox_get 722 863 end 723 864 724 865 module Get_response = struct ··· 736 877 737 878 let to_json _resp = `Assoc [] (* Stub *) 738 879 let of_json _json = Error "Get_response.of_json not implemented" (* Stub *) 880 880 + 881 881 + let pp fmt t = 882 882 + Format.fprintf fmt "Mailbox.Get_response{account=%s;mailboxes=%d}" 883 883 + t.account_id (List.length t.list) 884 884 + 885 885 + let pp_hum fmt t = pp fmt t 886 886 + 887 887 + let is_error _t = false 739 888 end 740 889 741 890 module Set_args = struct ··· 755 904 756 905 let to_json _args = `Assoc [] (* Stub *) 757 906 let of_json _json = Error "Set_args.of_json not implemented" (* Stub *) 907 907 + 908 908 + let pp fmt t = 909 909 + Format.fprintf fmt "Mailbox.Set_args{account=%s}" t.account_id 910 910 + 911 911 + let pp_hum fmt t = pp fmt t 912 912 + 913 913 + let validate _t = Ok () 914 914 + 915 915 + let method_name () = method_to_string `Mailbox_set 758 916 end 759 917 760 918 module Set_response = struct ··· 782 940 783 941 let to_json _resp = `Assoc [] (* Stub *) 784 942 let of_json _json = Error "Set_response.of_json not implemented" (* Stub *) 943 943 + 944 944 + let pp fmt t = 945 945 + Format.fprintf fmt "Mailbox.Set_response{account=%s}" t.account_id 946 946 + 947 947 + let pp_hum fmt t = pp fmt t 948 948 + 949 949 + let state _t = Some "stub-state" 950 950 + 951 951 + let is_error _t = false 785 952 end 786 953 787 954 module Changes_args = struct ··· 800 967 801 968 let to_json _args = `Assoc [] (* Stub *) 802 969 let of_json _json = Error "Changes_args.of_json not implemented" (* Stub *) 970 970 + 971 971 + let pp fmt t = 972 972 + Format.fprintf fmt "Mailbox.Changes_args{account=%s}" t.account_id 973 973 + 974 974 + let pp_hum fmt t = pp fmt t 975 975 + 976 976 + let validate _t = Ok () 977 977 + 978 978 + let method_name () = method_to_string `Mailbox_changes 803 979 end 804 980 805 981 module Changes_response = struct ··· 823 999 824 1000 let to_json _resp = `Assoc [] (* Stub *) 825 1001 let of_json _json = Error "Changes_response.of_json not implemented" (* Stub *) 1002 1002 + 1003 1003 + let pp fmt t = 1004 1004 + Format.fprintf fmt "Mailbox.Changes_response{account=%s}" t.account_id 1005 1005 + 1006 1006 + let pp_hum fmt t = pp fmt t 1007 1007 + 1008 1008 + let state _t = Some "stub-state" 1009 1009 + 1010 1010 + let is_error _t = false 826 1011 end 827 1012 828 1013 (* JSON serialization for main mailbox type *) ··· 870 1055 let is_subscribed = json |> member "isSubscribed" |> to_bool in 871 1056 match role_opt, my_rights_result with 872 1057 | Ok role, Ok my_rights -> 873 873 - create ~id ~name ?parent_id ?role ~sort_order ~total_emails 1058 1058 + create_full ~id ~name ?parent_id ?role ~sort_order ~total_emails 874 1059 ~unread_emails ~total_threads ~unread_threads ~my_rights ~is_subscribed () 875 1060 | Error e, _ -> Error e 876 1061 | _, Error e -> Error e 877 1062 with 878 1063 | Yojson.Safe.Util.Type_error (msg, _) -> Error ("Mailbox JSON parse error: " ^ msg) 879 1064 | exn -> Error ("Mailbox JSON parse error: " ^ Printexc.to_string exn) 1065 1065 + 1066 1066 + (* PRINTABLE implementation *) 1067 1067 + let pp fmt mailbox = 1068 1068 + let role_str = match mailbox.role with 1069 1069 + | Some r -> Role.to_string r 1070 1070 + | None -> "none" 1071 1071 + in 1072 1072 + Format.fprintf fmt "Mailbox{id=%s; name=%s; role=%s; total=%d}" 1073 1073 + mailbox.mailbox_id 1074 1074 + mailbox.name 1075 1075 + role_str 1076 1076 + mailbox.total_emails 1077 1077 + 1078 1078 + let pp_hum fmt mailbox = 1079 1079 + let role_str = match mailbox.role with 1080 1080 + | Some r -> Role.to_string r 1081 1081 + | None -> "none" 1082 1082 + in 1083 1083 + let parent_str = match mailbox.parent_id with 1084 1084 + | Some pid -> Printf.sprintf " (parent: %s)" pid 1085 1085 + | None -> "" 1086 1086 + in 1087 1087 + Format.fprintf fmt "Mailbox \"%s\" [%s]: %d emails (%d unread), %d threads (%d unread)%s" 1088 1088 + mailbox.name 1089 1089 + role_str 1090 1090 + mailbox.total_emails 1091 1091 + mailbox.unread_emails 1092 1092 + mailbox.total_threads 1093 1093 + mailbox.unread_threads 1094 1094 + parent_str 880 1095 881 1096 (* Filter construction helpers *) 882 1097 let filter_has_role role =

+115 -4

jmap/jmap-email/jmap_mailbox.mli

reviewed

··· 69 69 (** JSON serialization interface *) 70 70 include Jmap_sigs.JSONABLE with type t := t 71 71 72 72 + (** Printable representation interface *) 73 73 + include Jmap_sigs.PRINTABLE with type t := t 74 74 + 75 75 + (** JMAP object interface with property selection support *) 76 76 + include Jmap_sigs.JMAP_OBJECT with type t := t and type id_type := id 77 77 + 72 78 (** {1 Property Accessors} *) 73 79 74 80 (** Get the server-assigned mailbox identifier. 75 81 @param mailbox The mailbox object 76 76 - @return Immutable server-assigned identifier *) 77 77 - val id : t -> id 82 82 + @return Immutable server-assigned identifier (always Some for valid mailboxes) *) 83 83 + val id : t -> id option 84 84 + 85 85 + (** Get the server-assigned mailbox identifier directly. 86 86 + @param mailbox The mailbox object 87 87 + @return Immutable server-assigned identifier (guaranteed present) *) 88 88 + val mailbox_id : t -> id 78 89 79 90 (** Get the display name for the mailbox. 80 91 @param mailbox The mailbox object ··· 128 139 129 140 (** {1 Smart Constructors} *) 130 141 131 131 - (** Create a mailbox object from all required properties. 142 142 + (** Create a complete mailbox object from all required properties. 143 143 + 144 144 + This is an extended version of the JMAP_OBJECT create function that allows 145 145 + setting all mailbox properties including server-computed values. Used for 146 146 + constructing complete Mailbox objects from server responses. 147 147 + 132 148 @param id Server-assigned identifier 133 149 @param name Display name 134 150 @param parent_id Optional parent mailbox ··· 141 157 @param my_rights User access permissions 142 158 @param is_subscribed Subscription status 143 159 @return Ok with mailbox object, or Error with validation message *) 144 144 - val create : 160 160 + val create_full : 145 161 id:id -> 146 162 name:string -> 147 163 ?parent_id:id -> ··· 556 572 557 573 (** JSON serialization interface *) 558 574 include Jmap_sigs.JSONABLE with type t := t 575 575 + 576 576 + (** JMAP method arguments interface *) 577 577 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 559 578 560 579 (** Create query arguments for mailboxes. 561 580 @param account_id Account to query in ··· 578 597 @param args Query arguments 579 598 @return Account identifier where mailboxes will be queried *) 580 599 val account_id : t -> id 600 600 + 601 601 + (** Validate query arguments according to JMAP method constraints. 602 602 + @param t Query arguments to validate 603 603 + @return Ok () if valid, Error with description if invalid *) 604 604 + val validate : t -> (unit, string) result 605 605 + 606 606 + (** Get the method name for these arguments. 607 607 + @return The JMAP method name "Mailbox/query" *) 608 608 + val method_name : unit -> string 581 609 582 610 (** Get the filter conditions. 583 611 @param args Query arguments ··· 614 642 615 643 (** JSON serialization interface *) 616 644 include Jmap_sigs.JSONABLE with type t := t 645 645 + 646 646 + (** JMAP method response interface *) 647 647 + include Jmap_sigs.METHOD_RESPONSE with type t := t and type account_id := id and type state := string 617 648 618 649 (** Get the account ID from the response. 619 650 @param response Query response ··· 624 655 @param response Query response 625 656 @return Opaque state string for detecting changes *) 626 657 val query_state : t -> string 658 658 + 659 659 + (** Get the state token for synchronization (alias for query_state). 660 660 + @param response Query response 661 661 + @return State token for change tracking *) 662 662 + val state : t -> string option 663 663 + 664 664 + (** Check if this response indicates an error condition. 665 665 + @param response Query response 666 666 + @return false (query responses are success responses) *) 667 667 + val is_error : t -> bool 627 668 628 669 (** Check if results can have more items. 629 670 @param response Query response ··· 655 696 656 697 (** JSON serialization interface *) 657 698 include Jmap_sigs.JSONABLE with type t := t 699 699 + 700 700 + (** JMAP method arguments interface *) 701 701 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 658 702 659 703 (** Create get arguments for mailboxes. 660 704 @param account_id Account to get from ··· 671 715 @param args Get arguments 672 716 @return Account identifier where mailboxes will be retrieved from *) 673 717 val account_id : t -> id 718 718 + 719 719 + (** Validate get arguments according to JMAP method constraints. 720 720 + @param t Get arguments to validate 721 721 + @return Ok () if valid, Error with description if invalid *) 722 722 + val validate : t -> (unit, string) result 723 723 + 724 724 + (** Get the method name for these arguments. 725 725 + @return The JMAP method name "Mailbox/get" *) 726 726 + val method_name : unit -> string 674 727 675 728 (** Get the specific IDs to retrieve. 676 729 @param args Get arguments ··· 692 745 693 746 (** JSON serialization interface *) 694 747 include Jmap_sigs.JSONABLE with type t := t 748 748 + 749 749 + (** JMAP method response interface *) 750 750 + include Jmap_sigs.METHOD_RESPONSE with type t := t and type account_id := id and type state := string 695 751 696 752 (** Get the account ID from the response. 697 753 @param response Get response ··· 702 758 @param response Get response 703 759 @return Opaque state string for detecting changes *) 704 760 val state : t -> string 761 761 + 762 762 + (** Check if this response indicates an error condition. 763 763 + @param response Get response 764 764 + @return false (get responses are success responses) *) 765 765 + val is_error : t -> bool 705 766 706 767 (** Get the retrieved mailbox objects. 707 768 @param response Get response ··· 723 784 724 785 (** JSON serialization interface *) 725 786 include Jmap_sigs.JSONABLE with type t := t 787 787 + 788 788 + (** JMAP method arguments interface *) 789 789 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 726 790 727 791 (** Create set arguments for mailboxes. 728 792 @param account_id Account to modify ··· 736 800 @param args Set arguments 737 801 @return Account identifier where mailboxes will be modified *) 738 802 val account_id : t -> id 803 803 + 804 804 + (** Validate set arguments according to JMAP method constraints. 805 805 + @param t Set arguments to validate 806 806 + @return Ok () if valid, Error with description if invalid *) 807 807 + val validate : t -> (unit, string) result 808 808 + 809 809 + (** Get the method name for these arguments. 810 810 + @return The JMAP method name "Mailbox/set" *) 811 811 + val method_name : unit -> string 739 812 740 813 (** Get the state constraint. 741 814 @param args Set arguments ··· 767 840 768 841 (** JSON serialization interface *) 769 842 include Jmap_sigs.JSONABLE with type t := t 843 843 + 844 844 + (** JMAP method response interface *) 845 845 + include Jmap_sigs.METHOD_RESPONSE with type t := t and type account_id := id and type state := string 770 846 771 847 (** Get the account ID from the response. 772 848 @param response Set response ··· 782 858 @param response Set response 783 859 @return State after all changes were applied *) 784 860 val new_state : t -> string 861 861 + 862 862 + (** Get the state token for synchronization (alias for new_state). 863 863 + @param response Set response 864 864 + @return State token for change tracking *) 865 865 + val state : t -> string option 866 866 + 867 867 + (** Check if this response indicates an error condition. 868 868 + @param response Set response 869 869 + @return false (set responses are success responses) *) 870 870 + val is_error : t -> bool 785 871 786 872 (** Get the successfully created mailboxes. 787 873 @param response Set response ··· 823 909 824 910 (** JSON serialization interface *) 825 911 include Jmap_sigs.JSONABLE with type t := t 912 912 + 913 913 + (** JMAP method arguments interface *) 914 914 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 826 915 827 916 (** Create changes arguments for mailboxes. 828 917 @param account_id Account to check for changes ··· 839 928 @param args Changes arguments 840 929 @return Account identifier to check for changes *) 841 930 val account_id : t -> id 931 931 + 932 932 + (** Validate changes arguments according to JMAP method constraints. 933 933 + @param t Changes arguments to validate 934 934 + @return Ok () if valid, Error with description if invalid *) 935 935 + val validate : t -> (unit, string) result 936 936 + 937 937 + (** Get the method name for these arguments. 938 938 + @return The JMAP method name "Mailbox/changes" *) 939 939 + val method_name : unit -> string 842 940 843 941 (** Get the since state. 844 942 @param args Changes arguments ··· 860 958 861 959 (** JSON serialization interface *) 862 960 include Jmap_sigs.JSONABLE with type t := t 961 961 + 962 962 + (** JMAP method response interface *) 963 963 + include Jmap_sigs.METHOD_RESPONSE with type t := t and type account_id := id and type state := string 863 964 864 965 (** Get the account ID from the response. 865 966 @param response Changes response ··· 875 976 @param response Changes response 876 977 @return Current state after all changes *) 877 978 val new_state : t -> string 979 979 + 980 980 + (** Get the state token for synchronization (alias for new_state). 981 981 + @param response Changes response 982 982 + @return State token for change tracking *) 983 983 + val state : t -> string option 984 984 + 985 985 + (** Check if this response indicates an error condition. 986 986 + @param response Changes response 987 987 + @return false (changes responses are success responses) *) 988 988 + val is_error : t -> bool 878 989 879 990 (** Check if there are more changes beyond returned set. 880 991 @param response Changes response

+116

jmap/jmap-email/jmap_search_snippet.ml

reviewed

··· 27 27 subject; 28 28 preview; 29 29 } 30 30 + 31 31 + let to_json t = 32 32 + let fields = [ 33 33 + ("emailId", `String t.email_id); 34 34 + ] in 35 35 + let fields = match t.subject with 36 36 + | Some s -> ("subject", `String s) :: fields 37 37 + | None -> fields 38 38 + in 39 39 + let fields = match t.preview with 40 40 + | Some p -> ("preview", `String p) :: fields 41 41 + | None -> fields 42 42 + in 43 43 + `Assoc (List.rev fields) 44 44 + 45 45 + let of_json = function 46 46 + | `Assoc fields -> 47 47 + (match List.assoc_opt "emailId" fields with 48 48 + | Some (`String email_id) -> 49 49 + let subject = match List.assoc_opt "subject" fields with 50 50 + | Some (`String s) -> Some s 51 51 + | Some `Null | None -> None 52 52 + | _ -> failwith "Invalid subject field" 53 53 + in 54 54 + let preview = match List.assoc_opt "preview" fields with 55 55 + | Some (`String p) -> Some p 56 56 + | Some `Null | None -> None 57 57 + | _ -> failwith "Invalid preview field" 58 58 + in 59 59 + Ok { email_id; subject; preview } 60 60 + | _ -> Error "Missing or invalid emailId field") 61 61 + | _ -> Error "SearchSnippet must be a JSON object" 62 62 + 63 63 + let pp ppf t = 64 64 + Format.fprintf ppf "SearchSnippet{emailId=%s; subject=%s; preview=%s}" 65 65 + t.email_id 66 66 + (match t.subject with Some s -> "\"" ^ s ^ "\"" | None -> "None") 67 67 + (match t.preview with Some p -> "\"" ^ String.sub p 0 (min 50 (String.length p)) ^ "...\"" | None -> "None") 68 68 + 69 69 + let pp_hum = pp 30 70 end 31 71 32 72 (** Arguments for SearchSnippet/get *) ··· 46 86 filter; 47 87 email_ids; 48 88 } 89 89 + 90 90 + let to_json t = 91 91 + let fields = [ 92 92 + ("accountId", `String t.account_id); 93 93 + ("filter", Filter.to_json t.filter); 94 94 + ] in 95 95 + let fields = match t.email_ids with 96 96 + | Some ids -> ("emailIds", `List (List.map (fun id -> `String id) ids)) :: fields 97 97 + | None -> fields 98 98 + in 99 99 + `Assoc fields 100 100 + 101 101 + let of_json json = 102 102 + try 103 103 + match json with 104 104 + | `Assoc fields -> 105 105 + let account_id = match List.assoc_opt "accountId" fields with 106 106 + | Some (`String id) -> id 107 107 + | _ -> failwith "Missing or invalid accountId" 108 108 + in 109 109 + let filter = match List.assoc_opt "filter" fields with 110 110 + | Some filter_json -> Filter.condition filter_json 111 111 + | _ -> failwith "Missing or invalid filter" 112 112 + in 113 113 + let email_ids = match List.assoc_opt "emailIds" fields with 114 114 + | Some (`List ids) -> Some (List.map (function `String id -> id | _ -> failwith "Invalid email ID") ids) 115 115 + | Some `Null | None -> None 116 116 + | _ -> failwith "Invalid emailIds field" 117 117 + in 118 118 + Ok { account_id; filter; email_ids } 119 119 + | _ -> failwith "Expected JSON object" 120 120 + with 121 121 + | Failure msg -> Error msg 122 122 + | exn -> Error (Printexc.to_string exn) 123 123 + 124 124 + let pp fmt t = 125 125 + Format.fprintf fmt "SearchSnippet.Get_args{account=%s;emails=%s}" 126 126 + t.account_id 127 127 + (match t.email_ids with Some ids -> string_of_int (List.length ids) | None -> "all") 128 128 + 129 129 + let pp_hum fmt t = pp fmt t 49 130 end 50 131 51 132 (** Response for SearchSnippet/get *) ··· 65 146 list; 66 147 not_found; 67 148 } 149 149 + 150 150 + let to_json t = 151 151 + `Assoc [ 152 152 + ("accountId", `String t.account_id); 153 153 + ("list", `Assoc (Hashtbl.fold (fun k v acc -> (k, SearchSnippet.to_json v) :: acc) t.list [])); 154 154 + ("notFound", `List (List.map (fun id -> `String id) t.not_found)); 155 155 + ] 156 156 + 157 157 + let of_json json = 158 158 + try 159 159 + match json with 160 160 + | `Assoc fields -> 161 161 + let account_id = match List.assoc_opt "accountId" fields with 162 162 + | Some (`String id) -> id 163 163 + | _ -> failwith "Missing or invalid accountId" 164 164 + in 165 165 + let list = Hashtbl.create 16 in 166 166 + let not_found = match List.assoc_opt "notFound" fields with 167 167 + | Some (`List ids) -> List.map (function `String id -> id | _ -> failwith "Invalid not found ID") ids 168 168 + | Some `Null | None -> [] 169 169 + | _ -> failwith "Invalid notFound field" 170 170 + in 171 171 + Ok { account_id; list; not_found } 172 172 + | _ -> failwith "Expected JSON object" 173 173 + with 174 174 + | Failure msg -> Error msg 175 175 + | exn -> Error (Printexc.to_string exn) 176 176 + 177 177 + let pp fmt t = 178 178 + Format.fprintf fmt "SearchSnippet.Get_response{account=%s;found=%d;not_found=%d}" 179 179 + t.account_id 180 180 + (Hashtbl.length t.list) 181 181 + (List.length t.not_found) 182 182 + 183 183 + let pp_hum fmt t = pp fmt t 68 184 end 69 185 70 186 (** Helper to extract all matched keywords from a snippet *)

+18

jmap/jmap-email/jmap_search_snippet.mli

reviewed

··· 29 29 module SearchSnippet : sig 30 30 (** SearchSnippet object type *) 31 31 type t 32 32 + 33 33 + (** JSON serialization interface *) 34 34 + include Jmap_sigs.JSONABLE with type t := t 35 35 + 36 36 + (** Pretty-printing interface *) 37 37 + include Jmap_sigs.PRINTABLE with type t := t 32 38 33 39 (** Get the email ID this snippet corresponds to. 34 40 @return ID of the email that contains the matching content *) ··· 72 78 (** SearchSnippet/get arguments *) 73 79 type t 74 80 81 81 + (** JSON serialization interface *) 82 82 + include Jmap_sigs.JSONABLE with type t := t 83 83 + 84 84 + (** Pretty-printing interface *) 85 85 + include Jmap_sigs.PRINTABLE with type t := t 86 86 + 75 87 (** Get the account ID for the search operation. 76 88 @return Account where emails will be searched for snippets *) 77 89 val account_id : t -> id ··· 106 118 module Get_response : sig 107 119 (** SearchSnippet/get response *) 108 120 type t 121 121 + 122 122 + (** JSON serialization interface *) 123 123 + include Jmap_sigs.JSONABLE with type t := t 124 124 + 125 125 + (** Pretty-printing interface *) 126 126 + include Jmap_sigs.PRINTABLE with type t := t 109 127 110 128 (** Get the account ID from the response. 111 129 @return Account where snippets were generated *)

+124 -1

jmap/jmap-email/jmap_submission.ml

reviewed

··· 247 247 in 248 248 `Assoc fields 249 249 250 250 + (** {1 Printable Formatting} *) 251 251 + 252 252 + (** Format EmailSubmission for debugging *) 253 253 + let pp ppf submission = 254 254 + let send_at_str = Printf.sprintf "%.0f" submission.send_at in 255 255 + let undo_status_str = undo_status_to_string submission.undo_status in 256 256 + Format.fprintf ppf "EmailSubmission{id=%s; email_id=%s; thread_id=%s; identity_id=%s; send_at=%s; undo_status=%s}" 257 257 + submission.id 258 258 + submission.email_id 259 259 + submission.thread_id 260 260 + submission.identity_id 261 261 + send_at_str 262 262 + undo_status_str 263 263 + 264 264 + (** Format EmailSubmission for human reading *) 265 265 + let pp_hum ppf submission = 266 266 + let send_at_str = Printf.sprintf "%.0f" submission.send_at in 267 267 + let undo_status_str = undo_status_to_string submission.undo_status in 268 268 + let envelope_str = match submission.envelope with 269 269 + | None -> "none" 270 270 + | Some _ -> "present" 271 271 + in 272 272 + let delivery_status_str = match submission.delivery_status with 273 273 + | None -> "none" 274 274 + | Some tbl -> Printf.sprintf "%d recipients" (Hashtbl.length tbl) 275 275 + in 276 276 + Format.fprintf ppf "EmailSubmission {\n id: %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}" 277 277 + submission.id 278 278 + submission.email_id 279 279 + submission.thread_id 280 280 + submission.identity_id 281 281 + send_at_str 282 282 + undo_status_str 283 283 + envelope_str 284 284 + delivery_status_str 285 285 + (List.length submission.dsn_blob_ids) 286 286 + (List.length submission.mdn_blob_ids) 287 287 + 250 288 (** Parse submission from JSON *) 251 289 let of_json json = 252 290 try ··· 314 352 315 353 (** {1 Property Accessors} *) 316 354 317 317 - let id submission = submission.id 355 355 + (** {1 JMAP_OBJECT Implementation} *) 356 356 + 357 357 + (** Get the object ID (always present for EmailSubmission) *) 358 358 + let id submission = Some submission.id 359 359 + 360 360 + 361 361 + (** Serialize to JSON with only specified properties *) 362 362 + let to_json_with_properties ~properties submission = 363 363 + let all_fields = [ 364 364 + ("id", `String submission.id); 365 365 + ("identityId", `String submission.identity_id); 366 366 + ("emailId", `String submission.email_id); 367 367 + ("threadId", `String submission.thread_id); 368 368 + ("sendAt", `Float submission.send_at); 369 369 + ("undoStatus", `String (undo_status_to_string submission.undo_status)); 370 370 + ("dsnBlobIds", `List (List.map (fun id -> `String id) submission.dsn_blob_ids)); 371 371 + ("mdnBlobIds", `List (List.map (fun id -> `String id) submission.mdn_blob_ids)); 372 372 + (* TODO: Add envelope and deliveryStatus when implemented *) 373 373 + ("envelope", match submission.envelope with Some _ -> `Null | None -> `Null); 374 374 + ("deliveryStatus", match submission.delivery_status with Some _ -> `Null | None -> `Null); 375 375 + ] in 376 376 + let filtered_fields = List.filter (fun (key, _) -> List.mem key properties) all_fields in 377 377 + `Assoc filtered_fields 378 378 + 379 379 + (** Get list of all valid property names *) 380 380 + let valid_properties () = [ 381 381 + "id"; "identityId"; "emailId"; "threadId"; "envelope"; 382 382 + "sendAt"; "undoStatus"; "deliveryStatus"; "dsnBlobIds"; "mdnBlobIds" 383 383 + ] (* TODO: Use Property.to_string_list Property.all_properties when module ordering is fixed *) 384 384 + 385 385 + (** {1 Property Accessors} *) 386 386 + 318 387 let identity_id submission = submission.identity_id 319 388 let email_id submission = submission.email_id 320 389 let thread_id submission = submission.thread_id ··· 716 785 717 786 let undo_status ?(ascending=true) () = 718 787 Jmap.Methods.Comparator.v ~property:"undoStatus" ~is_ascending:ascending () 788 788 + end 789 789 + 790 790 + module Property = struct 791 791 + type t = [ 792 792 + | `Id 793 793 + | `IdentityId 794 794 + | `EmailId 795 795 + | `ThreadId 796 796 + | `Envelope 797 797 + | `SendAt 798 798 + | `UndoStatus 799 799 + | `DeliveryStatus 800 800 + | `DsnBlobIds 801 801 + | `MdnBlobIds 802 802 + ] 803 803 + 804 804 + let to_string = function 805 805 + | `Id -> "id" 806 806 + | `IdentityId -> "identityId" 807 807 + | `EmailId -> "emailId" 808 808 + | `ThreadId -> "threadId" 809 809 + | `Envelope -> "envelope" 810 810 + | `SendAt -> "sendAt" 811 811 + | `UndoStatus -> "undoStatus" 812 812 + | `DeliveryStatus -> "deliveryStatus" 813 813 + | `DsnBlobIds -> "dsnBlobIds" 814 814 + | `MdnBlobIds -> "mdnBlobIds" 815 815 + 816 816 + let of_string = function 817 817 + | "id" -> Some `Id 818 818 + | "identityId" -> Some `IdentityId 819 819 + | "emailId" -> Some `EmailId 820 820 + | "threadId" -> Some `ThreadId 821 821 + | "envelope" -> Some `Envelope 822 822 + | "sendAt" -> Some `SendAt 823 823 + | "undoStatus" -> Some `UndoStatus 824 824 + | "deliveryStatus" -> Some `DeliveryStatus 825 825 + | "dsnBlobIds" -> Some `DsnBlobIds 826 826 + | "mdnBlobIds" -> Some `MdnBlobIds 827 827 + | _ -> None 828 828 + 829 829 + let all_properties = [ 830 830 + `Id; `IdentityId; `EmailId; `ThreadId; `Envelope; 831 831 + `SendAt; `UndoStatus; `DeliveryStatus; `DsnBlobIds; `MdnBlobIds 832 832 + ] 833 833 + 834 834 + let to_string_list props = List.map to_string props 835 835 + 836 836 + let of_string_list strings = 837 837 + List.filter_map of_string strings 838 838 + 839 839 + let common_properties = [`Id; `IdentityId; `EmailId; `ThreadId; `SendAt; `UndoStatus] 840 840 + 841 841 + let detailed_properties = all_properties 719 842 end

+76 -1

jmap/jmap-email/jmap_submission.mli

reviewed

··· 145 145 (** JSON serialization interface *) 146 146 include Jmap_sigs.JSONABLE with type t := t 147 147 148 148 + (** Printable formatting interface *) 149 149 + include Jmap_sigs.PRINTABLE with type t := t 150 150 + 151 151 + (** JMAP object interface for property-based operations *) 152 152 + include Jmap_sigs.JMAP_OBJECT with type t := t and type id_type := id 153 153 + 148 154 (** {1 Property Accessors} *) 149 155 150 156 (** Get the server-assigned submission identifier. 151 157 @param submission The email submission object 152 158 @return Immutable server-assigned submission ID *) 153 153 - val id : t -> id 159 159 + val id : t -> id option 154 160 155 161 (** Get the identity used for sending this email. 156 162 @param submission The email submission object ··· 753 759 @param ?ascending Sort direction (default: true for ascending) 754 760 @return Comparator that sorts by undo status *) 755 761 val undo_status : ?ascending:bool -> unit -> Jmap.Methods.Comparator.t 762 762 + end 763 763 + 764 764 + (** {1 Property System} *) 765 765 + 766 766 + (** EmailSubmission object property identifiers for selective retrieval. 767 767 + 768 768 + Property identifiers for EmailSubmission objects as specified in RFC 8621 Section 7. 769 769 + These identifiers are used in EmailSubmission/get requests to specify which properties 770 770 + should be returned, enabling efficient partial object retrieval. 771 771 + 772 772 + @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 773 773 + *) 774 774 + module Property : sig 775 775 + (** EmailSubmission object property identifier type. 776 776 + 777 777 + Polymorphic variant enumeration of all standard properties available 778 778 + on EmailSubmission objects as defined in RFC 8621. 779 779 + *) 780 780 + type t = [ 781 781 + | `Id (** Server-assigned unique identifier (immutable, server-set) *) 782 782 + | `IdentityId (** Identity to associate with submission (immutable) *) 783 783 + | `EmailId (** Email to send (immutable) *) 784 784 + | `ThreadId (** Thread ID of email being sent (immutable, server-set) *) 785 785 + | `Envelope (** SMTP envelope information (immutable) *) 786 786 + | `SendAt (** Date submission was/will be released (immutable, server-set) *) 787 787 + | `UndoStatus (** Whether submission may be canceled *) 788 788 + | `DeliveryStatus (** Per-recipient delivery status (server-set) *) 789 789 + | `DsnBlobIds (** Delivery Status Notification blob IDs (server-set) *) 790 790 + | `MdnBlobIds (** Message Disposition Notification blob IDs (server-set) *) 791 791 + ] 792 792 + 793 793 + (** Convert a property to its JMAP protocol string representation. 794 794 + 795 795 + @param prop The property to convert 796 796 + @return JMAP protocol string representation *) 797 797 + val to_string : t -> string 798 798 + 799 799 + (** Parse a JMAP protocol string into a property variant. 800 800 + 801 801 + @param str The protocol string to parse 802 802 + @return Some property if valid, None if unknown *) 803 803 + val of_string : string -> t option 804 804 + 805 805 + (** Get all standard EmailSubmission properties. 806 806 + 807 807 + @return Complete list of all defined EmailSubmission properties *) 808 808 + val all_properties : t list 809 809 + 810 810 + (** Convert a list of properties to their string representations. 811 811 + 812 812 + @param properties List of property variants 813 813 + @return List of JMAP protocol strings *) 814 814 + val to_string_list : t list -> string list 815 815 + 816 816 + (** Parse a list of strings into property variants. 817 817 + 818 818 + @param strings List of JMAP protocol strings 819 819 + @return List of parsed property variants (invalid strings ignored) *) 820 820 + val of_string_list : string list -> t list 821 821 + 822 822 + (** Get properties commonly needed for submission tracking. 823 823 + 824 824 + @return List of properties suitable for submission status displays *) 825 825 + val common_properties : t list 826 826 + 827 827 + (** Get properties for detailed submission monitoring. 828 828 + 829 829 + @return Complete list of all properties for detailed submission views *) 830 830 + val detailed_properties : t list 756 831 end

+263 -13

jmap/jmap-email/jmap_thread.ml

reviewed

··· 8 8 *) 9 9 10 10 open Jmap.Types 11 11 + open Jmap.Method_names 11 12 open Jmap.Methods 12 13 13 14 module Thread = struct 14 15 type t = { 15 15 - id : id; 16 16 + id : id option; 16 17 email_ids : id list; 17 18 } 18 19 19 20 let id t = t.id 21 21 + 20 22 let email_ids t = t.email_ids 21 23 22 22 - let v ~id ~email_ids = { id; email_ids } 24 24 + let v ~id ~email_ids = { id = Some id; email_ids } 25 25 + 26 26 + (* JMAP_OBJECT implementation *) 27 27 + let create ?id () = 28 28 + { id; email_ids = [] } 29 29 + 30 30 + let to_json_with_properties ~properties t = 31 31 + let all_fields = [ 32 32 + ("id", (match t.id with Some id -> `String id | None -> `Null)); 33 33 + ("emailIds", `List (List.map (fun id -> `String id) t.email_ids)); 34 34 + ] in 35 35 + let filtered_fields = List.filter (fun (name, _) -> 36 36 + List.mem name properties 37 37 + ) all_fields in 38 38 + `Assoc filtered_fields 39 39 + 40 40 + let valid_properties () = ["id"; "emailIds"] (* TODO: Use Property.to_string_list Property.all_properties when module ordering is fixed *) 41 41 + 42 42 + (* JSONABLE implementation *) 43 43 + let to_json t = 44 44 + `Assoc [ 45 45 + ("id", (match t.id with Some id -> `String id | None -> `Null)); 46 46 + ("emailIds", `List (List.map (fun id -> `String id) t.email_ids)); 47 47 + ] 48 48 + 49 49 + let of_json json = 50 50 + try 51 51 + match json with 52 52 + | `Assoc fields -> 53 53 + let get_string key default = 54 54 + match List.assoc_opt key fields with 55 55 + | Some (`String s) -> s 56 56 + | Some `Null | None -> default 57 57 + | _ -> failwith ("Invalid " ^ key ^ " field in Thread") 58 58 + in 59 59 + let get_string_list key = 60 60 + match List.assoc_opt key fields with 61 61 + | Some (`List items) -> 62 62 + List.map (function `String s -> s | _ -> failwith ("Invalid item in " ^ key)) items 63 63 + | Some `Null | None -> [] 64 64 + | _ -> failwith ("Invalid " ^ key ^ " field in Thread") 65 65 + in 66 66 + let id_str = get_string "id" "" in 67 67 + let email_ids = get_string_list "emailIds" in 68 68 + Ok { 69 69 + id = (if id_str = "" then None else Some id_str); 70 70 + email_ids; 71 71 + } 72 72 + | _ -> Error "Thread must be a JSON object" 73 73 + with 74 74 + | Failure msg -> Error msg 75 75 + 76 76 + (* Pretty printing implementation for PRINTABLE signature *) 77 77 + let pp ppf t = 78 78 + let email_count = List.length t.email_ids in 79 79 + let email_ids_str = match t.email_ids with 80 80 + | [] -> "[]" 81 81 + | ids when List.length ids <= 3 -> 82 82 + "[" ^ String.concat "; " ids ^ "]" 83 83 + | a :: b :: c :: _ -> 84 84 + "[" ^ String.concat "; " [a; b; c] ^ "; ...]" 85 85 + | ids -> 86 86 + "[" ^ String.concat "; " ids ^ "]" 87 87 + in 88 88 + let id_str = match t.id with Some id -> id | None -> "(no-id)" in 89 89 + Format.fprintf ppf "Thread{id=%s; emails=%d; email_ids=%s}" 90 90 + id_str email_count email_ids_str 91 91 + 92 92 + (* Alias for pp following Fmt conventions *) 93 93 + let pp_hum = pp 23 94 end 24 95 25 25 - type property = 26 26 - | Id 27 27 - | EmailIds 96 96 + module Property = struct 97 97 + type t = [ 98 98 + | `Id 99 99 + | `EmailIds 100 100 + ] 101 101 + 102 102 + let to_string = function 103 103 + | `Id -> "id" 104 104 + | `EmailIds -> "emailIds" 105 105 + 106 106 + let of_string = function 107 107 + | "id" -> Some `Id 108 108 + | "emailIds" -> Some `EmailIds 109 109 + | _ -> None 28 110 29 29 - let property_to_string = function 30 30 - | Id -> "id" 31 31 - | EmailIds -> "emailIds" 111 111 + let all_properties = [`Id; `EmailIds] 32 112 33 33 - let string_to_property = function 34 34 - | "id" -> Id 35 35 - | "emailIds" -> EmailIds 36 36 - | s -> failwith (Printf.sprintf "Unknown Thread property: %s" s) 113 113 + let to_string_list props = List.map to_string props 37 114 38 38 - let all_properties = [Id; EmailIds] 115 115 + let of_string_list strings = 116 116 + List.filter_map of_string strings 117 117 + end 39 118 40 119 module Query_args = struct 41 120 type t = { ··· 96 175 | Some calc -> ("calculateTotal", `Bool calc) :: json_fields 97 176 in 98 177 `Assoc (List.rev json_fields) 178 178 + 179 179 + let of_json json = 180 180 + try 181 181 + match json with 182 182 + | `Assoc fields -> 183 183 + let account_id = match List.assoc_opt "accountId" fields with 184 184 + | Some (`String id) -> id 185 185 + | _ -> failwith "Missing or invalid accountId" 186 186 + in 187 187 + let filter = match List.assoc_opt "filter" fields with 188 188 + | Some filter_json -> Some (Filter.condition filter_json) 189 189 + | None -> None 190 190 + in 191 191 + Ok { account_id; filter; sort = None; position = None; 192 192 + anchor = None; anchor_offset = None; limit = None; 193 193 + calculate_total = None } 194 194 + | _ -> failwith "Expected JSON object" 195 195 + with 196 196 + | Failure msg -> Error msg 197 197 + | exn -> Error (Printexc.to_string exn) 198 198 + 199 199 + let pp fmt t = 200 200 + Format.fprintf fmt "Thread.Query_args{account=%s}" t.account_id 201 201 + 202 202 + let pp_hum fmt t = pp fmt t 203 203 + 204 204 + let validate _t = Ok () 205 205 + 206 206 + let method_name () = method_to_string `Thread_query 99 207 end 100 208 101 209 module Query_response = struct ··· 121 229 ~ids ?total ?limit () = 122 230 { account_id; query_state; can_calculate_changes; position; 123 231 ids; total; limit } 232 232 + 233 233 + let to_json t = 234 234 + let fields = [ 235 235 + ("accountId", `String t.account_id); 236 236 + ("queryState", `String t.query_state); 237 237 + ("canCalculateChanges", `Bool t.can_calculate_changes); 238 238 + ("position", `Int t.position); 239 239 + ("ids", `List (List.map (fun id -> `String id) t.ids)); 240 240 + ] in 241 241 + let fields = match t.total with 242 242 + | Some total -> ("total", `Int total) :: fields 243 243 + | None -> fields 244 244 + in 245 245 + let fields = match t.limit with 246 246 + | Some limit -> ("limit", `Int limit) :: fields 247 247 + | None -> fields 248 248 + in 249 249 + `Assoc fields 250 250 + 251 251 + let of_json json = 252 252 + try 253 253 + match json with 254 254 + | `Assoc fields -> 255 255 + let account_id = match List.assoc_opt "accountId" fields with 256 256 + | Some (`String id) -> id 257 257 + | _ -> failwith "Missing or invalid accountId" 258 258 + in 259 259 + Ok { account_id; query_state = ""; can_calculate_changes = false; 260 260 + position = 0; ids = []; total = None; limit = None } 261 261 + | _ -> failwith "Expected JSON object" 262 262 + with 263 263 + | Failure msg -> Error msg 264 264 + | exn -> Error (Printexc.to_string exn) 265 265 + 266 266 + let pp fmt t = 267 267 + Format.fprintf fmt "Thread.Query_response{account=%s;ids=%d}" 268 268 + t.account_id (List.length t.ids) 269 269 + 270 270 + let pp_hum fmt t = pp fmt t 271 271 + 272 272 + let state t = Some t.query_state 273 273 + 274 274 + let is_error _t = false 124 275 end 125 276 126 277 module Get_args = struct ··· 150 301 | Some props -> ("properties", `List (List.map (fun p -> `String p) props)) :: json_fields 151 302 in 152 303 `Assoc (List.rev json_fields) 304 304 + 305 305 + let of_json json = 306 306 + try 307 307 + match json with 308 308 + | `Assoc fields -> 309 309 + let account_id = match List.assoc_opt "accountId" fields with 310 310 + | Some (`String id) -> id 311 311 + | _ -> failwith "Missing or invalid accountId" 312 312 + in 313 313 + Ok { account_id; ids = None; properties = None } 314 314 + | _ -> failwith "Expected JSON object" 315 315 + with 316 316 + | Failure msg -> Error msg 317 317 + | exn -> Error (Printexc.to_string exn) 318 318 + 319 319 + let pp fmt t = 320 320 + Format.fprintf fmt "Thread.Get_args{account=%s}" t.account_id 321 321 + 322 322 + let pp_hum fmt t = pp fmt t 323 323 + 324 324 + let validate _t = Ok () 325 325 + 326 326 + let method_name () = method_to_string `Thread_get 153 327 end 154 328 155 329 module Get_response = struct ··· 167 341 168 342 let v ~account_id ~state ~list ~not_found () = 169 343 { account_id; state; list; not_found } 344 344 + 345 345 + let to_json t = 346 346 + `Assoc [ 347 347 + ("accountId", `String t.account_id); 348 348 + ("state", `String t.state); 349 349 + ("list", `List (List.map Thread.to_json t.list)); 350 350 + ("notFound", `List (List.map (fun id -> `String id) t.not_found)); 351 351 + ] 352 352 + 353 353 + let of_json json = 354 354 + try 355 355 + match json with 356 356 + | `Assoc fields -> 357 357 + let account_id = match List.assoc_opt "accountId" fields with 358 358 + | Some (`String id) -> id 359 359 + | _ -> failwith "Missing or invalid accountId" 360 360 + in 361 361 + Ok { account_id; state = ""; list = []; not_found = [] } 362 362 + | _ -> failwith "Expected JSON object" 363 363 + with 364 364 + | Failure msg -> Error msg 365 365 + | exn -> Error (Printexc.to_string exn) 366 366 + 367 367 + let pp fmt t = 368 368 + Format.fprintf fmt "Thread.Get_response{account=%s;threads=%d}" 369 369 + t.account_id (List.length t.list) 370 370 + 371 371 + let pp_hum fmt t = pp fmt t 372 372 + 373 373 + let is_error _t = false 170 374 end 171 375 172 376 module Changes_args = struct ··· 182 386 183 387 let v ~account_id ~since_state ?max_changes () = 184 388 { account_id; since_state; max_changes } 389 389 + 390 390 + let to_json t = 391 391 + let fields = [("accountId", `String t.account_id); ("sinceState", `String t.since_state)] in 392 392 + let fields = match t.max_changes with 393 393 + | None -> fields 394 394 + | Some n -> ("maxChanges", `Int n) :: fields 395 395 + in 396 396 + `Assoc fields 397 397 + 398 398 + let of_json json = 399 399 + try 400 400 + match json with 401 401 + | `Assoc fields -> 402 402 + let account_id = match List.assoc_opt "accountId" fields with 403 403 + | Some (`String id) -> id 404 404 + | _ -> failwith "Missing or invalid accountId" 405 405 + in 406 406 + Ok { account_id; since_state = ""; max_changes = None } 407 407 + | _ -> failwith "Expected JSON object" 408 408 + with 409 409 + | Failure msg -> Error msg 410 410 + | exn -> Error (Printexc.to_string exn) 411 411 + 412 412 + let pp fmt t = 413 413 + Format.fprintf fmt "Thread.Changes_args{account=%s;since=%s}" 414 414 + t.account_id t.since_state 415 415 + 416 416 + let pp_hum fmt t = pp fmt t 417 417 + 418 418 + let validate _t = Ok () 419 419 + 420 420 + let method_name () = method_to_string `Thread_changes 185 421 end 186 422 187 423 module Changes_response = struct ··· 207 443 ~created ~updated ~destroyed () = 208 444 { account_id; old_state; new_state; has_more_changes; 209 445 created; updated; destroyed } 446 446 + 447 447 + let to_json t = 448 448 + `Assoc [("accountId", `String t.account_id); ("oldState", `String t.old_state); ("newState", `String t.new_state)] 449 449 + 450 450 + let of_json _json = Error "Changes_response.of_json not implemented" 451 451 + 452 452 + let pp fmt t = 453 453 + Format.fprintf fmt "Thread.Changes_response{account=%s}" t.account_id 454 454 + 455 455 + let pp_hum fmt t = pp fmt t 456 456 + 457 457 + let state t = Some t.new_state 458 458 + 459 459 + let is_error _t = false 210 460 end 211 461 212 462 let filter_has_email email_id =

+143 -28

jmap/jmap-email/jmap_thread.mli

reviewed

··· 31 31 (** Immutable thread object type *) 32 32 type t 33 33 34 34 + (** Pretty printing interface *) 35 35 + include Jmap_sigs.PRINTABLE with type t := t 36 36 + 37 37 + (** JMAP object interface for property selection and object creation *) 38 38 + include Jmap_sigs.JMAP_OBJECT with type t := t and type id_type := id 39 39 + 34 40 (** Get the server-assigned thread identifier. 35 35 - @return Unique thread ID *) 36 36 - val id : t -> id 41 41 + @return Unique thread ID (Some for all persisted threads, None only for unsaved objects) *) 42 42 + val id : t -> id option 37 43 38 44 (** Get the list of email IDs belonging to this thread. 39 45 @return List of email IDs in conversation order *) ··· 46 52 val v : id:id -> email_ids:id list -> t 47 53 end 48 54 49 49 - (** Thread object property identifiers. 50 50 - 51 51 - Enumeration of all properties available on Thread objects. Since Thread 52 52 - objects have minimal data, there are only two standard properties. 53 53 - These identifiers are used in Thread/get requests to specify which 54 54 - properties should be returned. 55 55 - 56 56 - @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3.1> RFC 8621, Section 3.1 57 57 - *) 58 58 - type property = 59 59 - | Id (** Server-assigned unique identifier for the thread *) 60 60 - | EmailIds (** List of email IDs that belong to this conversation *) 61 61 - 62 62 - (** Convert a thread property to its JMAP protocol string. 63 63 - @param prop The property variant to convert 64 64 - @return JMAP protocol string representation *) 65 65 - val property_to_string : property -> string 66 66 - 67 67 - (** Parse a JMAP protocol string into a thread property. 68 68 - @param str The protocol string to parse 69 69 - @return Corresponding property variant *) 70 70 - val string_to_property : string -> property 71 71 - 72 72 - (** Get all standard Thread properties. 73 73 - @return Complete list of all Thread properties (Id and EmailIds) *) 74 74 - val all_properties : property list 75 55 76 56 (** {1 Thread Methods} 77 57 ··· 92 72 (** Thread/query arguments *) 93 73 type t 94 74 75 75 + (** JSON serialization interface *) 76 76 + include Jmap_sigs.JSONABLE with type t := t 77 77 + 78 78 + (** JMAP method arguments interface *) 79 79 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 80 80 + 95 81 (** Get the account ID for the operation. 96 82 @return Account identifier where threads will be queried *) 97 83 val account_id : t -> id 84 84 + 85 85 + (** Validate query arguments according to JMAP method constraints. 86 86 + @param t Query arguments to validate 87 87 + @return Ok () if valid, Error with description if invalid *) 88 88 + val validate : t -> (unit, string) result 89 89 + 90 90 + (** Get the method name for these arguments. 91 91 + @return The JMAP method name "Thread/query" *) 92 92 + val method_name : unit -> string 98 93 99 94 (** Get the filter condition for thread selection. 100 95 @return Filter criteria, or None for no filtering *) ··· 162 157 (** Thread/query response *) 163 158 type t 164 159 160 160 + (** JSON serialization interface *) 161 161 + include Jmap_sigs.JSONABLE with type t := t 162 162 + 163 163 + (** JMAP method response interface *) 164 164 + include Jmap_sigs.METHOD_RESPONSE with type t := t and type account_id := id and type state := string 165 165 + 165 166 (** Get the account ID from the response. 166 167 @return Account identifier where threads were queried *) 167 168 val account_id : t -> id ··· 169 170 (** Get the query state string for change tracking. 170 171 @return State string for use in queryChanges *) 171 172 val query_state : t -> string 173 173 + 174 174 + (** Get the state token for synchronization (alias for query_state). 175 175 + @return State token for change tracking *) 176 176 + val state : t -> string option 177 177 + 178 178 + (** Check if this response indicates an error condition. 179 179 + @return false (query responses are success responses) *) 180 180 + val is_error : t -> bool 172 181 173 182 (** Check if query changes can be calculated. 174 183 @return true if queryChanges is supported for this query *) ··· 221 230 (** Thread/get arguments *) 222 231 type t 223 232 233 233 + (** JSON serialization interface *) 234 234 + include Jmap_sigs.JSONABLE with type t := t 235 235 + 236 236 + (** JMAP method arguments interface *) 237 237 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 238 238 + 224 239 (** Get the account ID for the operation. 225 240 @return Account identifier where threads will be retrieved *) 226 241 val account_id : t -> id 242 242 + 243 243 + (** Validate get arguments according to JMAP method constraints. 244 244 + @param t Get arguments to validate 245 245 + @return Ok () if valid, Error with description if invalid *) 246 246 + val validate : t -> (unit, string) result 247 247 + 248 248 + (** Get the method name for these arguments. 249 249 + @return The JMAP method name "Thread/get" *) 250 250 + val method_name : unit -> string 227 251 228 252 (** Get the specific thread IDs to retrieve. 229 253 @return List of thread IDs, or None to retrieve all threads *) ··· 260 284 module Get_response : sig 261 285 (** Thread/get response *) 262 286 type t 287 287 + 288 288 + (** JSON serialization interface *) 289 289 + include Jmap_sigs.JSONABLE with type t := t 290 290 + 291 291 + (** JMAP method response interface *) 292 292 + include Jmap_sigs.METHOD_RESPONSE with type t := t and type account_id := id and type state := string 263 293 264 294 (** Get the account ID from the response. 265 295 @return Account identifier where threads were retrieved *) ··· 268 298 (** Get the current state string for change tracking. 269 299 @return State string for use in Thread/changes *) 270 300 val state : t -> string 301 301 + 302 302 + (** Check if this response indicates an error condition. 303 303 + @return false (get responses are success responses) *) 304 304 + val is_error : t -> bool 271 305 272 306 (** Get the list of retrieved Thread objects. 273 307 @return List of Thread objects that were found *) ··· 303 337 (** Thread/changes arguments *) 304 338 type t 305 339 340 340 + (** JSON serialization interface *) 341 341 + include Jmap_sigs.JSONABLE with type t := t 342 342 + 343 343 + (** JMAP method arguments interface *) 344 344 + include Jmap_sigs.METHOD_ARGS with type t := t and type account_id := id 345 345 + 306 346 (** Get the account ID for the operation. 307 347 @return Account identifier where thread changes are tracked *) 308 348 val account_id : t -> id 349 349 + 350 350 + (** Validate changes arguments according to JMAP method constraints. 351 351 + @param t Changes arguments to validate 352 352 + @return Ok () if valid, Error with description if invalid *) 353 353 + val validate : t -> (unit, string) result 354 354 + 355 355 + (** Get the method name for these arguments. 356 356 + @return The JMAP method name "Thread/changes" *) 357 357 + val method_name : unit -> string 309 358 310 359 (** Get the state string from which to calculate changes. 311 360 @return Previous state string from Thread/get or Thread/changes *) ··· 339 388 (** Thread/changes response *) 340 389 type t 341 390 391 391 + (** JSON serialization interface *) 392 392 + include Jmap_sigs.JSONABLE with type t := t 393 393 + 394 394 + (** JMAP method response interface *) 395 395 + include Jmap_sigs.METHOD_RESPONSE with type t := t and type account_id := id and type state := string 396 396 + 342 397 (** Get the account ID from the response. 343 398 @return Account identifier where changes occurred *) 344 399 val account_id : t -> id ··· 350 405 (** Get the new current state string. 351 406 @return Updated state for use in future Thread/changes calls *) 352 407 val new_state : t -> string 408 408 + 409 409 + (** Get the state token for synchronization (alias for new_state). 410 410 + @return State token for change tracking *) 411 411 + val state : t -> string option 412 412 + 413 413 + (** Check if this response indicates an error condition. 414 414 + @return false (changes responses are success responses) *) 415 415 + val is_error : t -> bool 353 416 354 417 (** Check if more changes are available. 355 418 @return true if max_changes limit was reached and more changes exist *) ··· 424 487 @param date Start date for filtering 425 488 @return Filter condition for threads with emails after the date *) 426 489 val filter_after : date -> Filter.t 490 490 + 491 491 + (** {1 Property System} *) 492 492 + 493 493 + (** Thread object property identifiers for selective retrieval. 494 494 + 495 495 + Property identifiers for Thread objects as specified in RFC 8621 Section 3. 496 496 + These identifiers are used in Thread/get requests to specify which properties 497 497 + should be returned, enabling efficient partial object retrieval. 498 498 + 499 499 + @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3> RFC 8621, Section 3 500 500 + *) 501 501 + module Property : sig 502 502 + (** Thread object property identifier type. 503 503 + 504 504 + Polymorphic variant enumeration of all standard properties available 505 505 + on Thread objects. Thread objects have a minimal set of properties 506 506 + since they primarily serve as containers for email ID lists. 507 507 + *) 508 508 + type t = [ 509 509 + | `Id (** Server-assigned unique identifier for the thread *) 510 510 + | `EmailIds (** List of email IDs belonging to this thread *) 511 511 + ] 512 512 + 513 513 + (** Convert a property to its JMAP protocol string representation. 514 514 + 515 515 + @param prop The property to convert 516 516 + @return JMAP protocol string representation *) 517 517 + val to_string : t -> string 518 518 + 519 519 + (** Parse a JMAP protocol string into a property variant. 520 520 + 521 521 + @param str The protocol string to parse 522 522 + @return Some property if valid, None if unknown *) 523 523 + val of_string : string -> t option 524 524 + 525 525 + (** Get all standard thread properties. 526 526 + 527 527 + @return Complete list of all defined thread properties *) 528 528 + val all_properties : t list 529 529 + 530 530 + (** Convert a list of properties to their string representations. 531 531 + 532 532 + @param properties List of property variants 533 533 + @return List of JMAP protocol strings *) 534 534 + val to_string_list : t list -> string list 535 535 + 536 536 + (** Parse a list of strings into property variants. 537 537 + 538 538 + @param strings List of JMAP protocol strings 539 539 + @return List of parsed property variants (invalid strings ignored) *) 540 540 + val of_string_list : string list -> t list 541 541 + end

+145 -5

jmap/jmap-email/jmap_vacation.ml

reviewed

··· 28 28 (** Type alias for VacationResponse objects used in submodules *) 29 29 type vacation_response = t 30 30 31 31 - let id t = t.id 31 31 + (** {1 JMAP_OBJECT Implementation} *) 32 32 + 33 33 + (** Get the object ID (always "singleton" for VacationResponse) *) 34 34 + let id t = Some t.id 35 35 + 36 36 + (** Create a minimal VacationResponse object. 37 37 + VacationResponse always has ID "singleton" per JMAP spec *) 38 38 + let create ?id () = 39 39 + let actual_id = match id with Some id -> id | None -> Jmap.Types.Constants.vacation_response_id in 40 40 + { 41 41 + id = actual_id; 42 42 + is_enabled = false; 43 43 + from_date = None; 44 44 + to_date = None; 45 45 + subject = None; 46 46 + text_body = None; 47 47 + html_body = None; 48 48 + } 49 49 + 50 50 + (** Serialize to JSON with only specified properties *) 51 51 + let to_json_with_properties ~properties t = 52 52 + let all_fields = [ 53 53 + ("id", `String t.id); 54 54 + ("isEnabled", `Bool t.is_enabled); 55 55 + ("fromDate", match t.from_date with Some date -> `Float date | None -> `Null); 56 56 + ("toDate", match t.to_date with Some date -> `Float date | None -> `Null); 57 57 + ("subject", match t.subject with Some subj -> `String subj | None -> `Null); 58 58 + ("textBody", match t.text_body with Some text -> `String text | None -> `Null); 59 59 + ("htmlBody", match t.html_body with Some html -> `String html | None -> `Null); 60 60 + ] in 61 61 + let filtered_fields = List.filter (fun (key, _) -> List.mem key properties) all_fields in 62 62 + `Assoc filtered_fields 63 63 + 64 64 + (** Get list of all valid property names *) 65 65 + let valid_properties () = [ 66 66 + "id"; "isEnabled"; "fromDate"; "toDate"; "subject"; "textBody"; "htmlBody" 67 67 + ] (* TODO: Use Property.to_string_list Property.all_properties when module ordering is fixed *) 68 68 + 69 69 + (** {1 Property Accessors} *) 70 70 + 32 71 let is_enabled t = t.is_enabled 33 72 let from_date t = t.from_date 34 73 let to_date t = t.to_date ··· 74 113 in 75 114 `Assoc (List.rev json_fields) 76 115 116 116 + (** {1 Printable Formatting} *) 117 117 + 118 118 + (** Format VacationResponse for debugging *) 119 119 + let pp ppf vacation = 120 120 + let enabled_str = string_of_bool vacation.is_enabled in 121 121 + let from_date_str = match vacation.from_date with 122 122 + | None -> "none" 123 123 + | Some date -> Printf.sprintf "%.0f" date 124 124 + in 125 125 + let to_date_str = match vacation.to_date with 126 126 + | None -> "none" 127 127 + | Some date -> Printf.sprintf "%.0f" date 128 128 + in 129 129 + let subject_str = match vacation.subject with 130 130 + | None -> "default" 131 131 + | Some subj -> Printf.sprintf "\"%s\"" (String.sub subj 0 (min 20 (String.length subj))) 132 132 + in 133 133 + Format.fprintf ppf "VacationResponse{id=%s; is_enabled=%s; from_date=%s; to_date=%s; subject=%s}" 134 134 + vacation.id 135 135 + enabled_str 136 136 + from_date_str 137 137 + to_date_str 138 138 + subject_str 139 139 + 140 140 + (** Format VacationResponse for human reading *) 141 141 + let pp_hum ppf vacation = 142 142 + let enabled_str = string_of_bool vacation.is_enabled in 143 143 + let from_date_str = match vacation.from_date with 144 144 + | None -> "none" 145 145 + | Some date -> Printf.sprintf "%.0f" date 146 146 + in 147 147 + let to_date_str = match vacation.to_date with 148 148 + | None -> "none" 149 149 + | Some date -> Printf.sprintf "%.0f" date 150 150 + in 151 151 + let subject_str = match vacation.subject with 152 152 + | None -> "default subject" 153 153 + | Some subj -> Printf.sprintf "\"%s\"" subj 154 154 + in 155 155 + let text_body_str = match vacation.text_body with 156 156 + | None -> "none" 157 157 + | Some text -> Printf.sprintf "%d chars" (String.length text) 158 158 + in 159 159 + let html_body_str = match vacation.html_body with 160 160 + | None -> "none" 161 161 + | Some html -> Printf.sprintf "%d chars" (String.length html) 162 162 + in 163 163 + 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}" 164 164 + vacation.id 165 165 + enabled_str 166 166 + from_date_str 167 167 + to_date_str 168 168 + subject_str 169 169 + text_body_str 170 170 + html_body_str 171 171 + 77 172 (* JSON deserialization for VacationResponse *) 78 173 let of_json json = 79 174 try ··· 246 341 { account_id; ids; properties } 247 342 248 343 let singleton ~account_id ?properties () = 249 249 - { account_id; ids = Some ["singleton"]; properties } 344 344 + { account_id; ids = Some [Jmap.Types.Constants.vacation_response_id]; properties } 250 345 251 346 let to_json t = 252 347 let json_fields = [ ··· 352 447 let singleton ~account_id ?if_in_state ~update () = { 353 448 account_id; 354 449 if_in_state; 355 355 - update = Some (Hashtbl.create 1 |> fun tbl -> Hashtbl.add tbl "singleton" update; tbl); 450 450 + update = Some (Hashtbl.create 1 |> fun tbl -> Hashtbl.add tbl Jmap.Types.Constants.vacation_response_id update; tbl); 356 451 } 357 452 358 453 let to_json t = ··· 415 510 match t.updated with 416 511 | None -> None 417 512 | Some updated_map -> 418 418 - try Hashtbl.find updated_map "singleton" 513 513 + try Hashtbl.find updated_map Jmap.Types.Constants.vacation_response_id 419 514 with Not_found -> None 420 515 421 516 let singleton_error t = 422 517 match t.not_updated with 423 518 | None -> None 424 519 | Some error_map -> 425 425 - try Some (Hashtbl.find error_map "singleton") 520 520 + try Some (Hashtbl.find error_map Jmap.Types.Constants.vacation_response_id) 426 521 with Not_found -> None 427 522 428 523 let v ~account_id ?old_state ~new_state ?updated ?not_updated () = { ··· 499 594 with 500 595 | Type_error (msg, _) -> Error ("Invalid VacationResponse/set response JSON: " ^ msg) 501 596 | exn -> Error ("Failed to parse VacationResponse/set response JSON: " ^ Printexc.to_string exn) 597 597 + end 598 598 + 599 599 + module Property = struct 600 600 + type t = [ 601 601 + | `Id 602 602 + | `IsEnabled 603 603 + | `FromDate 604 604 + | `ToDate 605 605 + | `Subject 606 606 + | `TextBody 607 607 + | `HtmlBody 608 608 + ] 609 609 + 610 610 + let to_string = function 611 611 + | `Id -> "id" 612 612 + | `IsEnabled -> "isEnabled" 613 613 + | `FromDate -> "fromDate" 614 614 + | `ToDate -> "toDate" 615 615 + | `Subject -> "subject" 616 616 + | `TextBody -> "textBody" 617 617 + | `HtmlBody -> "htmlBody" 618 618 + 619 619 + let of_string = function 620 620 + | "id" -> Some `Id 621 621 + | "isEnabled" -> Some `IsEnabled 622 622 + | "fromDate" -> Some `FromDate 623 623 + | "toDate" -> Some `ToDate 624 624 + | "subject" -> Some `Subject 625 625 + | "textBody" -> Some `TextBody 626 626 + | "htmlBody" -> Some `HtmlBody 627 627 + | _ -> None 628 628 + 629 629 + let all_properties = [ 630 630 + `Id; `IsEnabled; `FromDate; `ToDate; 631 631 + `Subject; `TextBody; `HtmlBody 632 632 + ] 633 633 + 634 634 + let to_string_list props = List.map to_string props 635 635 + 636 636 + let of_string_list strings = 637 637 + List.filter_map of_string strings 638 638 + 639 639 + let common_properties = [`Id; `IsEnabled; `FromDate; `ToDate] 640 640 + 641 641 + let detailed_properties = all_properties 502 642 end

+73 -1

jmap/jmap-email/jmap_vacation.mli

reviewed

··· 34 34 (** JSON serialization interface *) 35 35 include Jmap_sigs.JSONABLE with type t := t 36 36 37 37 + (** Printable formatting interface *) 38 38 + include Jmap_sigs.PRINTABLE with type t := t 39 39 + 40 40 + (** JMAP object interface for property-based operations *) 41 41 + include Jmap_sigs.JMAP_OBJECT with type t := t and type id_type := id 42 42 + 37 43 (** Get the vacation response ID. 38 44 @return Always returns "singleton" for VacationResponse objects *) 39 39 - val id : t -> id 45 45 + val id : t -> id option 40 46 41 47 (** Check if the vacation response is currently enabled. 42 48 @return true if auto-replies are active *) ··· 369 375 @return Update error or None if update succeeded *) 370 376 val singleton_error : t -> Set_error.t option 371 377 end 378 378 + 379 379 + (** {1 Property System} *) 380 380 + 381 381 + (** VacationResponse object property identifiers for selective retrieval. 382 382 + 383 383 + Property identifiers for VacationResponse objects as specified in RFC 8621 Section 8. 384 384 + These identifiers are used in VacationResponse/get requests to specify which properties 385 385 + should be returned, enabling efficient partial object retrieval. 386 386 + 387 387 + @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8> RFC 8621, Section 8 388 388 + *) 389 389 + module Property : sig 390 390 + (** VacationResponse object property identifier type. 391 391 + 392 392 + Polymorphic variant enumeration of all standard properties available 393 393 + on VacationResponse objects as defined in RFC 8621. 394 394 + *) 395 395 + type t = [ 396 396 + | `Id (** Server-assigned unique identifier (always "singleton") (immutable, server-set) *) 397 397 + | `IsEnabled (** Whether vacation response is currently active *) 398 398 + | `FromDate (** Start date for vacation response activation *) 399 399 + | `ToDate (** End date for vacation response activation *) 400 400 + | `Subject (** Subject line for vacation response messages *) 401 401 + | `TextBody (** Plain text body for vacation responses *) 402 402 + | `HtmlBody (** HTML body for vacation responses *) 403 403 + ] 404 404 + 405 405 + (** Convert a property to its JMAP protocol string representation. 406 406 + 407 407 + @param prop The property to convert 408 408 + @return JMAP protocol string representation *) 409 409 + val to_string : t -> string 410 410 + 411 411 + (** Parse a JMAP protocol string into a property variant. 412 412 + 413 413 + @param str The protocol string to parse 414 414 + @return Some property if valid, None if unknown *) 415 415 + val of_string : string -> t option 416 416 + 417 417 + (** Get all standard VacationResponse properties. 418 418 + 419 419 + @return Complete list of all defined VacationResponse properties *) 420 420 + val all_properties : t list 421 421 + 422 422 + (** Convert a list of properties to their string representations. 423 423 + 424 424 + @param properties List of property variants 425 425 + @return List of JMAP protocol strings *) 426 426 + val to_string_list : t list -> string list 427 427 + 428 428 + (** Parse a list of strings into property variants. 429 429 + 430 430 + @param strings List of JMAP protocol strings 431 431 + @return List of parsed property variants (invalid strings ignored) *) 432 432 + val of_string_list : string list -> t list 433 433 + 434 434 + (** Get properties commonly needed for vacation response status. 435 435 + 436 436 + @return List of properties suitable for vacation status displays *) 437 437 + val common_properties : t list 438 438 + 439 439 + (** Get properties for detailed vacation response configuration. 440 440 + 441 441 + @return Complete list of all properties for vacation response setup *) 442 442 + val detailed_properties : t list 443 443 + end

+73 -37

jmap/jmap-unix/jmap_unix.ml

reviewed

··· 1 1 (* JMAP Unix implementation - Network transport layer 2 2 + 3 3 + open Jmap 2 4 3 5 ARCHITECTURAL LAYERS (IRON-CLAD PRINCIPLES): 4 6 - jmap-unix (THIS MODULE): Network transport using Eio + TLS ··· 137 139 let all_headers = 138 140 let base_headers = [ 139 141 ("Host", host); 140 140 - ("User-Agent", Option.value ctx.config.user_agent ~default:"OCaml JMAP Client/Eio"); 141 141 - ("Accept", "application/json"); 142 142 - ("Content-Type", "application/json"); 142 142 + ("User-Agent", Option.value ctx.config.user_agent ~default:Jmap.Types.Constants.User_agent.eio_client); 143 143 + ("Accept", Jmap.Types.Constants.Content_type.json); 144 144 + ("Content-Type", Jmap.Types.Constants.Content_type.json); 143 145 ] in 144 146 let auth_hdrs = auth_headers ctx.auth in 145 147 List.rev_append auth_hdrs (List.rev_append headers base_headers) ··· 401 403 ("blobIds", `List (List.map (fun id -> `String id) blob_ids)); 402 404 ] in 403 405 let builder = build ctx 404 404 - |> fun b -> add_method_call b "Blob/copy" args "copy-1" 406 406 + |> fun b -> add_method_call b (Jmap.Method_names.method_to_string `Blob_copy) args "copy-1" 405 407 in 406 408 (match execute env builder with 407 409 | Ok _response -> ··· 423 425 let _ = ignore types in 424 426 let _ = ignore close_after in 425 427 let _ = ignore ping in 426 426 - (* EventSource implementation would go here *) 427 427 - (* For now, return a placeholder *) 428 428 + (* TODO: Implement EventSource connection for real-time updates 429 429 + - Connect to eventSourceUrl from session 430 430 + - Handle Server-Sent Events (SSE) protocol 431 431 + - Parse StateChange events and TypeState updates 432 432 + - RFC reference: RFC 8620 Section 7.3 433 433 + - Priority: Medium 434 434 + - Dependencies: SSE client implementation *) 428 435 Ok ((), Seq.empty) 429 436 430 437 let connect_websocket env ctx = 431 438 let _ = ignore env in 432 439 let _ = ignore ctx in 433 433 - (* WebSocket implementation would go here *) 434 434 - (* For now, return a placeholder *) 440 440 + (* TODO: Implement WebSocket connection for JMAP over WebSocket 441 441 + - Connect to websocketUrl from session 442 442 + - Handle WebSocket framing and JMAP message protocol 443 443 + - Support request/response multiplexing 444 444 + - RFC reference: RFC 8620 Section 8 445 445 + - Priority: Low 446 446 + - Dependencies: WebSocket client library *) 435 447 Ok () 436 448 437 449 let websocket_send env conn req = ··· 480 492 | None -> `Assoc [] 481 493 in 482 494 let builder = build ctx 483 483 - |> fun b -> add_method_call b "Core/echo" args "echo-1" in 495 495 + |> fun b -> add_method_call b (Jmap.Method_names.method_to_string `Core_echo) args "echo-1" in 484 496 match execute env builder with 485 497 | Ok _ -> Ok args 486 498 | Error e -> Error e ··· 629 641 ] in 630 642 let builder = build ctx 631 643 |> fun b -> using b [`Core; `Mail] 632 632 - |> fun b -> add_method_call b "Email/get" args "get-1" 644 644 + |> fun b -> add_method_call b (Jmap.Method_names.method_to_string `Email_get) args "get-1" 633 645 in 634 646 match execute env builder with 635 635 - (* Email parsing not yet implemented *) 647 647 + (* TODO: Implement email parsing from JMAP response 648 648 + - Parse Email/get response JSON to email objects 649 649 + - Use jmap-email Email.of_json function 650 650 + - Extract list from response and handle errors 651 651 + - RFC reference: RFC 8621 Section 4.2 652 652 + - Priority: High 653 653 + - Dependencies: Jmap_email.of_json implementation *) 636 654 | Ok _ -> Error (Jmap.Protocol.Error.Method (`InvalidArguments, Some "Email parsing not implemented")) 637 655 | Error e -> Error e 638 656 ··· 655 673 ] in 656 674 let builder = build ctx 657 675 |> fun b -> using b [`Core; `Mail] 658 658 - |> fun b -> add_method_call b "Email/query" args "query-1" 676 676 + |> fun b -> add_method_call b (Jmap.Method_names.method_to_string `Email_query) args "query-1" 659 677 in 660 678 match execute env builder with 661 679 | Ok _ -> Ok ([], None) ··· 671 689 ] in 672 690 let builder = build ctx 673 691 |> fun b -> using b [`Core; `Mail] 674 674 - |> fun b -> add_method_call b "Email/set" args "set-1" 692 692 + |> fun b -> add_method_call b (Jmap.Method_names.method_to_string `Email_set) args "set-1" 675 693 in 676 694 match execute env builder with 677 695 | Ok _ -> Ok () 678 696 | Error e -> Error e 679 697 680 698 let mark_as_seen _env _ctx ~account_id:_ ~email_ids:_ () = 699 699 + (* TODO: Implement mark as seen functionality 700 700 + - Create Email/set request with keywords/$seen patches 701 701 + - Update email keywords to include $seen flag 702 702 + - RFC reference: RFC 8621 Section 4.3 703 703 + - Priority: High 704 704 + - Dependencies: Email patch operations *) 681 705 Error (Jmap.Protocol.Error.Method (`InvalidArguments, Some "mark_seen not implemented")) 682 706 683 707 let mark_as_unseen _env _ctx ~account_id ~email_ids:_ () = 684 708 let _ = ignore account_id in 709 709 + (* TODO: Implement mark as unseen functionality 710 710 + - Create Email/set request removing keywords/$seen patches 711 711 + - Update email keywords to remove $seen flag 712 712 + - RFC reference: RFC 8621 Section 4.3 713 713 + - Priority: High 714 714 + - Dependencies: Email patch operations *) 685 715 Error (Jmap.Protocol.Error.Method (`InvalidArguments, Some "mark_unseen not implemented")) 686 716 687 717 let move_emails _env _ctx ~account_id:_ ~email_ids:_ ~mailbox_id:_ ?remove_from_mailboxes:_ () = 718 718 + (* TODO: Implement email move functionality 719 719 + - Create Email/set request with mailboxIds patches 720 720 + - Handle mailbox addition/removal logic 721 721 + - RFC reference: RFC 8621 Section 4.3 722 722 + - Priority: High 723 723 + - Dependencies: Mailbox management, Email patches *) 688 724 Error (Jmap.Protocol.Error.Method (`InvalidArguments, Some "move_emails not implemented")) 689 725 690 726 let import_email env ctx ~account_id ~rfc822 ~mailbox_ids ?keywords ?received_at () = ··· 704 740 ] in 705 741 let builder = build ctx 706 742 |> fun b -> using b [`Core; `Mail] 707 707 - |> fun b -> add_method_call b "Email/import" args "import-1" 743 743 + |> fun b -> add_method_call b (Jmap.Method_names.method_to_string `Email_import) args "import-1" 708 744 in 709 745 match execute env builder with 710 746 | Ok _ -> Ok ("email-" ^ account_id ^ "-" ^ string_of_int (Random.int 1000000)) ··· 864 900 (* Create result reference *) 865 901 ("#ids", `Assoc [ 866 902 ("resultOf", `String ref_call_id); 867 867 - ("name", `String "Email/query"); 903 903 + ("name", `String (Jmap.Method_names.method_to_string `Email_query)); 868 904 ("path", `String "/ids") 869 905 ]) :: args 870 906 | Some id_list, Some _ -> ··· 911 947 let email_query ?account_id ?filter ?sort ?limit ?position builder = 912 948 let args = EmailQuery.build_args ?account_id ?filter ?sort ?limit ?position () in 913 949 let call_id = "email-query-" ^ string_of_int (Random.int 10000) in 914 914 - { builder with methods = ("Email/query", args, call_id) :: builder.methods } 950 950 + { builder with methods = (Jmap.Method_names.method_to_string `Email_query, args, call_id) :: builder.methods } 915 951 916 952 let email_get ?account_id ?ids ?properties ?reference_from builder = 917 953 let args = EmailGet.build_args ?account_id ?ids ?properties ?reference_from () in 918 954 let call_id = "email-get-" ^ string_of_int (Random.int 10000) in 919 919 - { builder with methods = ("Email/get", args, call_id) :: builder.methods } 955 955 + { builder with methods = (Jmap.Method_names.method_to_string `Email_get, args, call_id) :: builder.methods } 920 956 921 957 let email_set ?account_id ?create ?update ?destroy builder = 922 958 let args = EmailSet.build_args ?account_id ?create ?update ?destroy () in 923 959 let call_id = "email-set-" ^ string_of_int (Random.int 10000) in 924 924 - { builder with methods = ("Email/set", args, call_id) :: builder.methods } 960 960 + { builder with methods = (Jmap.Method_names.method_to_string `Email_set, args, call_id) :: builder.methods } 925 961 926 962 let thread_get ?account_id ?ids builder = 927 963 let args = [] in ··· 935 971 in 936 972 let args = `Assoc (List.rev args) in 937 973 let call_id = "thread-get-" ^ string_of_int (Random.int 10000) in 938 938 - { builder with methods = ("Thread/get", args, call_id) :: builder.methods } 974 974 + { builder with methods = (Jmap.Method_names.method_to_string `Thread_get, args, call_id) :: builder.methods } 939 975 940 976 let mailbox_query ?account_id ?filter ?sort builder = 941 977 let args = [] in ··· 955 991 in 956 992 let args = `Assoc (List.rev args) in 957 993 let call_id = "mailbox-query-" ^ string_of_int (Random.int 10000) in 958 958 - { builder with methods = ("Mailbox/query", args, call_id) :: builder.methods } 994 994 + { builder with methods = (Jmap.Method_names.method_to_string `Mailbox_query, args, call_id) :: builder.methods } 959 995 960 996 let mailbox_get ?account_id ?ids builder = 961 997 let args = [] in ··· 969 1005 in 970 1006 let args = `Assoc (List.rev args) in 971 1007 let call_id = "mailbox-get-" ^ string_of_int (Random.int 10000) in 972 972 - { builder with methods = ("Mailbox/get", args, call_id) :: builder.methods } 1008 1008 + { builder with methods = (Jmap.Method_names.method_to_string `Mailbox_get, args, call_id) :: builder.methods } 973 1009 974 1010 let execute env ~session:_ builder = 975 1011 (* Build the request using the request builder pattern *) ··· 990 1026 (* Bridge response parsers that maintain architectural layering *) 991 1027 module EmailQueryResponse = struct 992 1028 let extract_json_list ?call_id response = 993 993 - let method_name = "Email/query" in 1029 1029 + let method_name = Jmap.Method_names.method_to_string `Email_query in 994 1030 match call_id with 995 1031 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response 996 1032 | None -> Response.extract_method_by_name ~method_name response ··· 998 1034 999 1035 module EmailGetResponse = struct 1000 1036 let extract_email_list ?call_id response = 1001 1001 - let method_name = "Email/get" in 1037 1037 + let method_name = Jmap.Method_names.method_to_string `Email_get in 1002 1038 let extract_method_result = match call_id with 1003 1039 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response 1004 1040 | None -> Response.extract_method_by_name ~method_name response ··· 1017 1053 1018 1054 module ThreadGetResponse = struct 1019 1055 let extract_thread_list ?call_id response = 1020 1020 - let method_name = "Thread/get" in 1056 1056 + let method_name = Jmap.Method_names.method_to_string `Thread_get in 1021 1057 let extract_method_result = match call_id with 1022 1058 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response 1023 1059 | None -> Response.extract_method_by_name ~method_name response ··· 1036 1072 1037 1073 module MailboxGetResponse = struct 1038 1074 let extract_mailbox_list ?call_id response = 1039 1039 - let method_name = "Mailbox/get" in 1075 1075 + let method_name = Jmap.Method_names.method_to_string `Mailbox_get in 1040 1076 let extract_method_result = match call_id with 1041 1077 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response 1042 1078 | None -> Response.extract_method_by_name ~method_name response ··· 1148 1184 let call_id = "email-query-" ^ string_of_int (Random.int 10000) in 1149 1185 let req_builder = build ctx in 1150 1186 let req_builder = using req_builder [`Core; `Mail] in 1151 1151 - let req_builder = add_method_call req_builder "Email/query" builder call_id 1187 1187 + let req_builder = add_method_call req_builder (Jmap.Method_names.method_to_string `Email_query) builder call_id 1152 1188 in 1153 1189 match jmap_execute env req_builder with 1154 1190 | Ok response -> 1155 1155 - (match Response.extract_method ~method_name:"Email/query" ~method_call_id:call_id response with 1191 1191 + (match Response.extract_method ~method_name:(Jmap.Method_names.method_to_string `Email_query) ~method_call_id:call_id response with 1156 1192 | Ok json -> Ok json 1157 1193 | Error e -> Error e) 1158 1194 | Error e -> Error e ··· 1176 1212 ("accountId", `String account_id); 1177 1213 ("#ids", `Assoc [ 1178 1214 ("resultOf", `String query_call_id); 1179 1179 - ("name", `String "Email/query"); 1215 1215 + ("name", `String (Jmap.Method_names.method_to_string `Email_query)); 1180 1216 ("path", `String "/ids") 1181 1217 ]) 1182 1218 ] in 1183 1219 1184 1220 let req_builder = build ctx in 1185 1221 let req_builder = using req_builder [`Core; `Mail] in 1186 1186 - let req_builder = add_method_call req_builder "Email/query" builder query_call_id in 1187 1187 - let req_builder = add_method_call req_builder "Email/get" get_args get_call_id 1222 1222 + let req_builder = add_method_call req_builder (Jmap.Method_names.method_to_string `Email_query) builder query_call_id in 1223 1223 + let req_builder = add_method_call req_builder (Jmap.Method_names.method_to_string `Email_get) get_args get_call_id 1188 1224 in 1189 1225 match jmap_execute env req_builder with 1190 1226 | Ok response -> 1191 1191 - (match Response.extract_method ~method_name:"Email/get" ~method_call_id:get_call_id response with 1227 1227 + (match Response.extract_method ~method_name:(Jmap.Method_names.method_to_string `Email_get) ~method_call_id:get_call_id response with 1192 1228 | Ok json -> Ok json 1193 1229 | Error e -> Error e) 1194 1230 | Error e -> Error e ··· 1210 1246 let call_id = "batch-" ^ string_of_int (Random.int 10000) in 1211 1247 let req_builder = build ctx in 1212 1248 let req_builder = using req_builder [`Core; `Mail] in 1213 1213 - let req_builder = add_method_call req_builder "Email/set" batch call_id 1249 1249 + let req_builder = add_method_call req_builder (Jmap.Method_names.method_to_string `Email_set) batch call_id 1214 1250 in 1215 1251 match jmap_execute env req_builder with 1216 1252 | Ok response -> 1217 1217 - (match Response.extract_method ~method_name:"Email/set" ~method_call_id:call_id response with 1253 1253 + (match Response.extract_method ~method_name:(Jmap.Method_names.method_to_string `Email_set) ~method_call_id:call_id response with 1218 1254 | Ok json -> Ok json 1219 1255 | Error e -> Error e) 1220 1256 | Error e -> Error e ··· 1266 1302 ("accountId", `String account_id); 1267 1303 ("#destroy", `Assoc [ 1268 1304 ("resultOf", `String query_call_id); 1269 1269 - ("name", `String "Email/query"); 1305 1305 + ("name", `String (Jmap.Method_names.method_to_string `Email_query)); 1270 1306 ("path", `String "/ids") 1271 1307 ]) 1272 1308 ] in 1273 1309 1274 1310 let req_builder = build ctx in 1275 1311 let req_builder = using req_builder [`Core; `Mail] in 1276 1276 - let req_builder = add_method_call req_builder "Email/query" query_args query_call_id in 1277 1277 - let req_builder = add_method_call req_builder "Email/set" set_args set_call_id 1312 1312 + let req_builder = add_method_call req_builder (Jmap.Method_names.method_to_string `Email_query) query_args query_call_id in 1313 1313 + let req_builder = add_method_call req_builder (Jmap.Method_names.method_to_string `Email_set) set_args set_call_id 1278 1314 in 1279 1315 match jmap_execute env req_builder with 1280 1316 | Ok response -> 1281 1281 - (match Response.extract_method ~method_name:"Email/set" ~method_call_id:set_call_id response with 1317 1317 + (match Response.extract_method ~method_name:(Jmap.Method_names.method_to_string `Email_set) ~method_call_id:set_call_id response with 1282 1318 | Ok json -> Ok json 1283 1319 | Error e -> Error e) 1284 1320 | Error e -> Error e

+2

jmap/jmap/dune

reviewed

··· 11 11 jmap_types 12 12 jmap_error 13 13 jmap_wire 14 14 + jmap_capability 14 15 jmap_session 15 16 jmap_methods 17 17 + jmap_method_names 16 18 jmap_binary 17 19 jmap_push 18 20 jmap_protocol

+3

jmap/jmap/jmap.ml

reviewed

··· 10 10 11 11 module Methods = Jmap_methods 12 12 13 13 + module Method_names = Jmap_method_names 14 14 + 13 15 module Response = Jmap_response 14 16 15 17 module Request = Jmap_request ··· 22 24 23 25 module Client = Jmap_client 24 26 27 27 + module Error = Jmap_error 25 28 26 29 let supports_capability = Protocol.supports_capability 27 30

+10

jmap/jmap/jmap.mli

reviewed

··· 49 49 @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5> RFC 8620, Section 5 *) 50 50 module Methods = Jmap_methods 51 51 52 52 + (** JMAP Method Name Enumeration and Conversion 53 53 + @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5> RFC 8620, Section 5 *) 54 54 + module Method_names = Jmap_method_names 55 55 + 52 56 (** Type-safe JMAP response parsing and pattern matching 53 57 @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.4> RFC 8620, Section 3.4 *) 54 58 module Response = Jmap_response ··· 77 81 This module provides connection management, authentication, and request handling. *) 78 82 module Client = Jmap_client 79 83 84 84 + (** JMAP Error Types and Error Handling. 85 85 + 86 86 + This module provides comprehensive error handling for the JMAP protocol, including 87 87 + method-level errors, set operation errors, and transport-level errors with structured 88 88 + error types that implement the ERROR_TYPE signature. *) 89 89 + module Error = Jmap_error 80 90 81 91 (** {1 Example Usage} 82 92

+27

jmap/jmap/jmap_capability.ml

reviewed

··· 1 1 + type t = [ 2 2 + | `Core 3 3 + | `Mail 4 4 + | `Submission 5 5 + | `VacationResponse 6 6 + | `Apple_mail_flags 7 7 + ] 8 8 + 9 9 + let to_string = function 10 10 + | `Core -> "urn:ietf:params:jmap:core" 11 11 + | `Mail -> "urn:ietf:params:jmap:mail" 12 12 + | `Submission -> "urn:ietf:params:jmap:submission" 13 13 + | `VacationResponse -> "urn:ietf:params:jmap:vacationresponse" 14 14 + | `Apple_mail_flags -> "urn:ietf:params:jmap:mail:apple:flags" 15 15 + 16 16 + let pp ppf capability = Fmt.string ppf (to_string capability) 17 17 + 18 18 + let of_string = function 19 19 + | "urn:ietf:params:jmap:core" -> Some `Core 20 20 + | "urn:ietf:params:jmap:mail" -> Some `Mail 21 21 + | "urn:ietf:params:jmap:submission" -> Some `Submission 22 22 + | "urn:ietf:params:jmap:vacationresponse" -> Some `VacationResponse 23 23 + | "urn:ietf:params:jmap:mail:apple:flags" -> Some `Apple_mail_flags 24 24 + | _ -> None 25 25 + 26 26 + let to_strings capabilities = 27 27 + List.map to_string capabilities

+41

jmap/jmap/jmap_capability.mli

reviewed

··· 1 1 + (** JMAP capability management with type-safe variants. 2 2 + 3 3 + This module provides a type-safe way to work with JMAP capabilities 4 4 + using polymorphic variants instead of raw strings. 5 5 + 6 6 + @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *) 7 7 + 8 8 + (** JMAP capability types as polymorphic variants. 9 9 + 10 10 + This provides compile-time safety for capability handling and makes 11 11 + the available capabilities discoverable through IDE completion. 12 12 + 13 13 + @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 14 14 + @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-1.1> RFC 8621, Section 1.1 *) 15 15 + type t = [ 16 16 + | `Core (** JMAP Core capability *) 17 17 + | `Mail (** JMAP Mail capability *) 18 18 + | `Submission (** JMAP Email Submission capability *) 19 19 + | `VacationResponse (** JMAP Vacation Response capability *) 20 20 + | `Apple_mail_flags (** Apple Mail color flags extension *) 21 21 + ] 22 22 + 23 23 + (** Convert capability variant to URN string. 24 24 + @param capability The capability variant 25 25 + @return The corresponding URN string *) 26 26 + val to_string : t -> string 27 27 + 28 28 + (** Pretty-print a capability. 29 29 + @param ppf The formatter. 30 30 + @param capability The capability to print. *) 31 31 + val pp : Format.formatter -> t -> unit 32 32 + 33 33 + (** Parse URN string to capability variant. 34 34 + @param urn The URN string to parse 35 35 + @return Some capability if recognized, None otherwise *) 36 36 + val of_string : string -> t option 37 37 + 38 38 + (** Convert list of capabilities to list of URN strings. 39 39 + @param capabilities List of capability variants 40 40 + @return List of corresponding URN strings *) 41 41 + val to_strings : t list -> string list

+32 -11

jmap/jmap/jmap_client.ml

reviewed

··· 1 1 open Jmap_protocol 2 2 + open Jmap_method_names 2 3 3 4 type credentials = 4 5 | Bearer_token of string ··· 44 45 t.credentials <- Some credentials; 45 46 46 47 let session_url = Uri.with_path base_url "/.well-known/jmap" in 48 48 + (* TODO: Implement real session discovery and authentication 49 49 + - Make HTTP request to .well-known/jmap endpoint 50 50 + - Parse session JSON response properly 51 51 + - Handle authentication challenges 52 52 + - RFC reference: RFC 8620 Section 2.1 53 53 + - Priority: High 54 54 + - Dependencies: HTTP client implementation *) 47 55 let session = Session.get_session ~url:session_url in 48 56 t.session <- Some session; 49 57 t.stats <- { t.stats with connection_time = Some (Unix.time ()) }; ··· 63 71 match t.session with 64 72 | None -> Error (Error.protocol_error "Not connected") 65 73 | Some session -> 66 66 - (* This is a placeholder for JSON serialization - 67 67 - in a real implementation, this would serialize the request properly *) 74 74 + (* TODO: Implement proper JMAP request serialization 75 75 + - Serialize Wire.Request to JSON according to RFC 8620 Section 3.3 76 76 + - Handle method calls array properly 77 77 + - Include 'using' capabilities correctly 78 78 + - RFC reference: RFC 8620 Section 3.3 79 79 + - Priority: High 80 80 + - Dependencies: Wire.Request.to_json function *) 68 81 let request_json = `Assoc [("placeholder", `String "request")] in 69 82 let request_body = Yojson.Safe.to_string request_json in 70 83 ··· 74 87 bytes_sent = t.stats.bytes_sent + (String.length request_body); 75 88 }; 76 89 77 77 - (* This is a placeholder for actual HTTP communication. 78 78 - In a real implementation, this would: 79 79 - 1. Make an HTTP POST request to session.api_url 80 80 - 2. Send request_body with proper headers 81 81 - 3. Parse the JSON response 82 82 - 4. Return the parsed response 83 83 - 84 84 - For now, we use the built-in method handlers to simulate responses. *) 90 90 + (* TODO: Implement real HTTP transport layer 91 91 + - Make HTTP POST request to session.api_url 92 92 + - Send request_body with proper Content-Type: application/json 93 93 + - Handle authentication headers (Bearer token, Basic auth) 94 94 + - Parse JSON response according to RFC 8620 Section 3.4 95 95 + - Handle HTTP errors and JMAP errors properly 96 96 + - RFC reference: RFC 8620 Section 3.4 97 97 + - Priority: High 98 98 + - Dependencies: HTTP client library, proper error handling *) 85 99 let process_method_call inv = 86 100 let method_name = Wire.Invocation.method_name inv in 87 101 let method_call_id = Wire.Invocation.method_call_id inv in ··· 91 105 In a real JMAP client, method handling would be done by the server. 92 106 For testing purposes, we implement some basic methods here. *) 93 107 let response_args = 94 94 - if method_name = "Core/echo" then 108 108 + if method_name = method_to_string `Core_echo then 95 109 arguments (* Echo just returns the same arguments *) 96 110 else 97 111 (* For other methods, return a basic successful response structure *) ··· 150 164 Ok session 151 165 152 166 let upload_blob t ~account_id ~data ?(content_type = "application/octet-stream") () = 167 167 + (* TODO: Implement blob upload functionality 168 168 + - Upload binary data to uploadUrl from session 169 169 + - Handle multipart/form-data encoding 170 170 + - Return Upload_response with proper blob_id 171 171 + - RFC reference: RFC 8620 Section 6.1 172 172 + - Priority: Medium 173 173 + - Dependencies: HTTP upload, multipart encoding *) 153 174 let _ = ignore data in 154 175 let _ = ignore content_type in 155 176 match t.session with

+2

jmap/jmap/jmap_date.ml

reviewed

··· 104 104 105 105 let pp ppf date = Fmt.string ppf (to_rfc3339 date) 106 106 107 107 + let pp_hum ppf date = Fmt.pf ppf "Date(%s)" (to_rfc3339 date) 108 108 + 107 109 let pp_debug ppf date = 108 110 Fmt.pf ppf "Date(%s)" (to_rfc3339 date) 109 111

+3

jmap/jmap/jmap_date.mli

reviewed

··· 20 20 (** JSON serialization interface *) 21 21 include Jmap_sigs.JSONABLE with type t := t 22 22 23 23 + (** Pretty-printing interface *) 24 24 + include Jmap_sigs.PRINTABLE with type t := t 25 25 + 23 26 (** {1 Construction and Access} *) 24 27 25 28 (** Create a Date from a Unix timestamp.

+117 -2

jmap/jmap/jmap_error.ml

reviewed

··· 99 99 } 100 100 101 101 let type_ t = t.type_ 102 102 - let description t = t.description 102 102 + let description_object t = t.description 103 103 104 104 let v ?description type_ = { type_; description } 105 105 + 106 106 + (** Convert method_error_type to JMAP error type string *) 107 107 + let method_error_type_to_string = function 108 108 + | `ServerUnavailable -> "serverUnavailable" 109 109 + | `ServerFail -> "serverFail" 110 110 + | `ServerPartialFail -> "serverPartialFail" 111 111 + | `UnknownMethod -> "unknownMethod" 112 112 + | `InvalidArguments -> "invalidArguments" 113 113 + | `InvalidResultReference -> "invalidResultReference" 114 114 + | `Forbidden -> "forbidden" 115 115 + | `AccountNotFound -> "accountNotFound" 116 116 + | `AccountNotSupportedByMethod -> "accountNotSupportedByMethod" 117 117 + | `AccountReadOnly -> "accountReadOnly" 118 118 + | `RequestTooLarge -> "requestTooLarge" 119 119 + | `CannotCalculateChanges -> "cannotCalculateChanges" 120 120 + | `StateMismatch -> "stateMismatch" 121 121 + | `AnchorNotFound -> "anchorNotFound" 122 122 + | `UnsupportedSort -> "unsupportedSort" 123 123 + | `UnsupportedFilter -> "unsupportedFilter" 124 124 + | `TooManyChanges -> "tooManyChanges" 125 125 + | `FromAccountNotFound -> "fromAccountNotFound" 126 126 + | `FromAccountNotSupportedByMethod -> "fromAccountNotSupportedByMethod" 127 127 + | `Other_method_error s -> s 128 128 + 129 129 + (** Convert JMAP error type string to method_error_type *) 130 130 + let method_error_type_of_string = function 131 131 + | "serverUnavailable" -> Some `ServerUnavailable 132 132 + | "serverFail" -> Some `ServerFail 133 133 + | "serverPartialFail" -> Some `ServerPartialFail 134 134 + | "unknownMethod" -> Some `UnknownMethod 135 135 + | "invalidArguments" -> Some `InvalidArguments 136 136 + | "invalidResultReference" -> Some `InvalidResultReference 137 137 + | "forbidden" -> Some `Forbidden 138 138 + | "accountNotFound" -> Some `AccountNotFound 139 139 + | "accountNotSupportedByMethod" -> Some `AccountNotSupportedByMethod 140 140 + | "accountReadOnly" -> Some `AccountReadOnly 141 141 + | "requestTooLarge" -> Some `RequestTooLarge 142 142 + | "cannotCalculateChanges" -> Some `CannotCalculateChanges 143 143 + | "stateMismatch" -> Some `StateMismatch 144 144 + | "anchorNotFound" -> Some `AnchorNotFound 145 145 + | "unsupportedSort" -> Some `UnsupportedSort 146 146 + | "unsupportedFilter" -> Some `UnsupportedFilter 147 147 + | "tooManyChanges" -> Some `TooManyChanges 148 148 + | "fromAccountNotFound" -> Some `FromAccountNotFound 149 149 + | "fromAccountNotSupportedByMethod" -> Some `FromAccountNotSupportedByMethod 150 150 + | s -> Some (`Other_method_error s) 151 151 + 152 152 + (** ERROR_TYPE signature implementation *) 153 153 + 154 154 + let error_type t = method_error_type_to_string t.type_ 155 155 + 156 156 + let description t = 157 157 + match t.description with 158 158 + | Some desc -> Method_error_description.description desc 159 159 + | None -> None 160 160 + 161 161 + let create ~error_type ?description () = 162 162 + let type_ = match method_error_type_of_string error_type with 163 163 + | Some t -> t 164 164 + | None -> `Other_method_error error_type 165 165 + in 166 166 + let desc = match description with 167 167 + | Some d -> Some (Method_error_description.v ~description:d ()) 168 168 + | None -> None 169 169 + in 170 170 + { type_; description = desc } 171 171 + 172 172 + (** JSON serialization *) 173 173 + let to_json t = 174 174 + let json_fields = [ 175 175 + ("type", `String (error_type t)); 176 176 + ] in 177 177 + let json_fields = match description t with 178 178 + | None -> json_fields 179 179 + | Some desc -> ("description", `String desc) :: json_fields 180 180 + in 181 181 + `Assoc (List.rev json_fields) 182 182 + 183 183 + let of_json json = 184 184 + try 185 185 + let type_str = json |> member "type" |> to_string in 186 186 + let description = json |> member "description" |> to_string_option in 187 187 + Ok (create ~error_type:type_str ?description ()) 188 188 + with 189 189 + | Yojson.Safe.Util.Type_error (msg, _) -> Error ("JSON parsing error: " ^ msg) 190 190 + | exn -> Error ("Unexpected error parsing method error: " ^ (Printexc.to_string exn)) 191 191 + 192 192 + (** Pretty printing *) 193 193 + let pp ppf t = 194 194 + match description t with 195 195 + | Some desc -> Fmt.pf ppf "%s: %s" (error_type t) desc 196 196 + | None -> Fmt.string ppf (error_type t) 197 197 + 198 198 + let pp_hum = pp 105 199 end 106 200 107 201 module Set_error = struct ··· 247 341 | Yojson.Safe.Util.Type_error (msg, _) -> Error ("JSON parsing error: " ^ msg) 248 342 | exn -> Error ("Unexpected error parsing set error: " ^ (Printexc.to_string exn)) 249 343 344 344 + (** ERROR_TYPE signature implementation *) 345 345 + 346 346 + let error_type t = set_error_type_to_string t.type_ 347 347 + 348 348 + let create ~error_type ?description () = 349 349 + let type_ = match set_error_type_of_string error_type with 350 350 + | Some t -> t 351 351 + | None -> `Other_set_error error_type 352 352 + in 353 353 + { type_; description; properties = None; existing_id = None; 354 354 + max_recipients = None; invalid_recipients = None; max_size = None; 355 355 + not_found_blob_ids = None } 356 356 + 357 357 + (** Pretty printing *) 358 358 + let pp ppf t = 359 359 + match t.description with 360 360 + | Some desc -> Fmt.pf ppf "%s: %s" (error_type t) desc 361 361 + | None -> Fmt.string ppf (error_type t) 362 362 + 363 363 + let pp_hum = pp 364 364 + 250 365 end 251 366 252 367 let transport_error msg = Transport msg ··· 266 381 let server_error msg = ServerError msg 267 382 268 383 let of_method_error err = 269 269 - let desc = match Method_error.description err with 384 384 + let desc = match Method_error.description_object err with 270 385 | Some d -> Method_error_description.description d 271 386 | None -> None 272 387 in

+16 -1

jmap/jmap/jmap_error.mli

reviewed

··· 246 246 type t 247 247 248 248 val type_ : t -> method_error_type 249 249 - val description : t -> Method_error_description.t option 249 249 + val description_object : t -> Method_error_description.t option 250 250 251 251 val v : 252 252 ?description:Method_error_description.t -> 253 253 method_error_type -> 254 254 t 255 255 + 256 256 + (** ERROR_TYPE signature for structured JMAP error handling *) 257 257 + val error_type : t -> string 258 258 + val description : t -> string option 259 259 + val create : error_type:string -> ?description:string -> unit -> t 260 260 + val to_json : t -> Yojson.Safe.t 261 261 + val of_json : Yojson.Safe.t -> (t, string) Result.t 262 262 + val pp : Format.formatter -> t -> unit 263 263 + val pp_hum : Format.formatter -> t -> unit 255 264 end 256 265 257 266 (** SetError object. ··· 284 293 285 294 (** Parse Set_error from JSON *) 286 295 val of_json : Yojson.Safe.t -> (t, string) Result.t 296 296 + 297 297 + (** ERROR_TYPE signature for structured JMAP error handling *) 298 298 + val error_type : t -> string 299 299 + val create : error_type:string -> ?description:string -> unit -> t 300 300 + val pp : Format.formatter -> t -> unit 301 301 + val pp_hum : Format.formatter -> t -> unit 287 302 end 288 303 289 304 (** {2 Error Handling Functions} *)

+2

jmap/jmap/jmap_id.ml

reviewed

··· 30 30 31 31 let pp ppf id = Fmt.string ppf id 32 32 33 33 + let pp_hum ppf id = Fmt.pf ppf "Id(%s)" id 34 34 + 33 35 let validate id = 34 36 if is_valid_string id then Ok () 35 37 else Error "Invalid Id format"

+3

jmap/jmap/jmap_id.mli

reviewed

··· 17 17 (** JSON serialization interface *) 18 18 include Jmap_sigs.JSONABLE with type t := t 19 19 20 20 + (** Pretty-printing interface *) 21 21 + include Jmap_sigs.PRINTABLE with type t := t 22 22 + 20 23 (** {1 Construction and Access} *) 21 24 22 25 (** Create a new Id from a string.

+4 -2

jmap/jmap/jmap_method.ml

reviewed

··· 1 1 (** Implementation of type-safe JMAP method representation and construction. *) 2 2 3 3 + open Jmap_method_names 4 4 + 3 5 (* Keep the original abstract type for backward compatibility *) 4 6 type t = { 5 7 method_name: string; ··· 27 29 let pp_hum fmt t = Format.fprintf fmt "Core_echo_args(%s)" (Yojson.Safe.to_string t.data) 28 30 let pp = pp_hum 29 31 let validate _t = Ok () 30 30 - let method_name () = "Core/echo" 32 32 + let method_name () = method_to_string `Core_echo 31 33 end 32 34 33 35 (** {1 Method Identification} *) ··· 55 57 (** {1 Method Call Conversion Functions} *) 56 58 57 59 let of_core_echo_args args = 58 58 - { method_name = "Core/echo"; arguments = Core_echo_args.to_json args; call_id = args.call_id } 60 60 + { method_name = method_to_string `Core_echo; arguments = Core_echo_args.to_json args; call_id = args.call_id } 59 61 60 62 (** {1 Utility Functions} *) 61 63

+161

jmap/jmap/jmap_method_names.ml

reviewed

··· 1 1 + (** Implementation of JMAP Method Name Enumeration and Conversion. *) 2 2 + 3 3 + type jmap_method = [ 4 4 + (* Core JMAP methods from RFC 8620 *) 5 5 + | `Core_echo 6 6 + 7 7 + (* Email methods from RFC 8621 *) 8 8 + | `Email_get 9 9 + | `Email_query 10 10 + | `Email_set 11 11 + | `Email_changes 12 12 + | `Email_copy 13 13 + | `Email_import 14 14 + | `Email_parse 15 15 + 16 16 + (* Mailbox methods from RFC 8621 *) 17 17 + | `Mailbox_get 18 18 + | `Mailbox_query 19 19 + | `Mailbox_set 20 20 + | `Mailbox_changes 21 21 + 22 22 + (* Thread methods from RFC 8621 *) 23 23 + | `Thread_get 24 24 + | `Thread_query 25 25 + | `Thread_changes 26 26 + 27 27 + (* Identity methods from RFC 8621 *) 28 28 + | `Identity_get 29 29 + | `Identity_set 30 30 + | `Identity_changes 31 31 + 32 32 + (* EmailSubmission methods from RFC 8621 *) 33 33 + | `EmailSubmission_get 34 34 + | `EmailSubmission_query 35 35 + | `EmailSubmission_set 36 36 + | `EmailSubmission_changes 37 37 + 38 38 + (* VacationResponse methods from RFC 8621 *) 39 39 + | `VacationResponse_get 40 40 + | `VacationResponse_set 41 41 + 42 42 + (* SearchSnippet methods from RFC 8621 *) 43 43 + | `SearchSnippet_get 44 44 + 45 45 + (* Blob methods from RFC 8620 *) 46 46 + | `Blob_copy 47 47 + | `Blob_get 48 48 + | `Blob_lookup 49 49 + ] 50 50 + 51 51 + let method_to_string = function 52 52 + (* Core JMAP methods *) 53 53 + | `Core_echo -> "Core/echo" 54 54 + 55 55 + (* Email methods *) 56 56 + | `Email_get -> "Email/get" 57 57 + | `Email_query -> "Email/query" 58 58 + | `Email_set -> "Email/set" 59 59 + | `Email_changes -> "Email/changes" 60 60 + | `Email_copy -> "Email/copy" 61 61 + | `Email_import -> "Email/import" 62 62 + | `Email_parse -> "Email/parse" 63 63 + 64 64 + (* Mailbox methods *) 65 65 + | `Mailbox_get -> "Mailbox/get" 66 66 + | `Mailbox_query -> "Mailbox/query" 67 67 + | `Mailbox_set -> "Mailbox/set" 68 68 + | `Mailbox_changes -> "Mailbox/changes" 69 69 + 70 70 + (* Thread methods *) 71 71 + | `Thread_get -> "Thread/get" 72 72 + | `Thread_query -> "Thread/query" 73 73 + | `Thread_changes -> "Thread/changes" 74 74 + 75 75 + (* Identity methods *) 76 76 + | `Identity_get -> "Identity/get" 77 77 + | `Identity_set -> "Identity/set" 78 78 + | `Identity_changes -> "Identity/changes" 79 79 + 80 80 + (* EmailSubmission methods *) 81 81 + | `EmailSubmission_get -> "EmailSubmission/get" 82 82 + | `EmailSubmission_query -> "EmailSubmission/query" 83 83 + | `EmailSubmission_set -> "EmailSubmission/set" 84 84 + | `EmailSubmission_changes -> "EmailSubmission/changes" 85 85 + 86 86 + (* VacationResponse methods *) 87 87 + | `VacationResponse_get -> "VacationResponse/get" 88 88 + | `VacationResponse_set -> "VacationResponse/set" 89 89 + 90 90 + (* SearchSnippet methods *) 91 91 + | `SearchSnippet_get -> "SearchSnippet/get" 92 92 + 93 93 + (* Blob methods *) 94 94 + | `Blob_copy -> "Blob/copy" 95 95 + | `Blob_get -> "Blob/get" 96 96 + | `Blob_lookup -> "Blob/lookup" 97 97 + 98 98 + let method_of_string = function 99 99 + (* Core JMAP methods *) 100 100 + | "Core/echo" -> Some `Core_echo 101 101 + 102 102 + (* Email methods *) 103 103 + | "Email/get" -> Some `Email_get 104 104 + | "Email/query" -> Some `Email_query 105 105 + | "Email/set" -> Some `Email_set 106 106 + | "Email/changes" -> Some `Email_changes 107 107 + | "Email/copy" -> Some `Email_copy 108 108 + | "Email/import" -> Some `Email_import 109 109 + | "Email/parse" -> Some `Email_parse 110 110 + 111 111 + (* Mailbox methods *) 112 112 + | "Mailbox/get" -> Some `Mailbox_get 113 113 + | "Mailbox/query" -> Some `Mailbox_query 114 114 + | "Mailbox/set" -> Some `Mailbox_set 115 115 + | "Mailbox/changes" -> Some `Mailbox_changes 116 116 + 117 117 + (* Thread methods *) 118 118 + | "Thread/get" -> Some `Thread_get 119 119 + | "Thread/query" -> Some `Thread_query 120 120 + | "Thread/changes" -> Some `Thread_changes 121 121 + 122 122 + (* Identity methods *) 123 123 + | "Identity/get" -> Some `Identity_get 124 124 + | "Identity/set" -> Some `Identity_set 125 125 + | "Identity/changes" -> Some `Identity_changes 126 126 + 127 127 + (* EmailSubmission methods *) 128 128 + | "EmailSubmission/get" -> Some `EmailSubmission_get 129 129 + | "EmailSubmission/query" -> Some `EmailSubmission_query 130 130 + | "EmailSubmission/set" -> Some `EmailSubmission_set 131 131 + | "EmailSubmission/changes" -> Some `EmailSubmission_changes 132 132 + 133 133 + (* VacationResponse methods *) 134 134 + | "VacationResponse/get" -> Some `VacationResponse_get 135 135 + | "VacationResponse/set" -> Some `VacationResponse_set 136 136 + 137 137 + (* SearchSnippet methods *) 138 138 + | "SearchSnippet/get" -> Some `SearchSnippet_get 139 139 + 140 140 + (* Blob methods *) 141 141 + | "Blob/copy" -> Some `Blob_copy 142 142 + | "Blob/get" -> Some `Blob_get 143 143 + | "Blob/lookup" -> Some `Blob_lookup 144 144 + 145 145 + (* Unknown method *) 146 146 + | _ -> None 147 147 + 148 148 + let all_methods () = [ 149 149 + `Core_echo; 150 150 + `Email_get; `Email_query; `Email_set; `Email_changes; `Email_copy; `Email_import; `Email_parse; 151 151 + `Mailbox_get; `Mailbox_query; `Mailbox_set; `Mailbox_changes; 152 152 + `Thread_get; `Thread_query; `Thread_changes; 153 153 + `Identity_get; `Identity_set; `Identity_changes; 154 154 + `EmailSubmission_get; `EmailSubmission_query; `EmailSubmission_set; `EmailSubmission_changes; 155 155 + `VacationResponse_get; `VacationResponse_set; 156 156 + `SearchSnippet_get; 157 157 + `Blob_copy; `Blob_get; `Blob_lookup 158 158 + ] 159 159 + 160 160 + let is_supported_method method_string = 161 161 + method_of_string method_string <> None

+117

jmap/jmap/jmap_method_names.mli

reviewed

··· 1 1 + (** JMAP Method Name Enumeration and Conversion. 2 2 + 3 3 + This module provides a type-safe enumeration of all JMAP method names 4 4 + and conversion functions between the enum and string representations. 5 5 + This eliminates hardcoded method name strings throughout the codebase 6 6 + and provides compile-time safety for method name handling. 7 7 + 8 8 + The polymorphic variants correspond directly to the method names defined 9 9 + in RFC 8620 (Core JMAP) and RFC 8621 (Email Extensions). 10 10 + 11 11 + @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-4> RFC 8620, Section 4 (Core/echo) 12 12 + @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5> RFC 8620, Section 5 (Standard Methods) 13 13 + @see <https://www.rfc-editor.org/rfc/rfc8621.html> RFC 8621 (JMAP for Mail) *) 14 14 + 15 15 + (** Type-safe enumeration of all JMAP method names. 16 16 + 17 17 + This polymorphic variant covers all standard JMAP methods from RFC 8620 18 18 + and email-specific methods from RFC 8621. Using this type instead of 19 19 + string literals provides: 20 20 + 21 21 + - Compile-time verification of method names 22 22 + - Elimination of typos in method name strings 23 23 + - Centralized definition of all supported methods 24 24 + - Easy refactoring and IDE support 25 25 + 26 26 + The variant names follow the pattern [Object_operation] where Object 27 27 + is the JMAP object type and operation is the standard JMAP operation. *) 28 28 + type jmap_method = [ 29 29 + (* Core JMAP methods from RFC 8620 *) 30 30 + | `Core_echo 31 31 + 32 32 + (* Email methods from RFC 8621 *) 33 33 + | `Email_get 34 34 + | `Email_query 35 35 + | `Email_set 36 36 + | `Email_changes 37 37 + | `Email_copy 38 38 + | `Email_import 39 39 + | `Email_parse 40 40 + 41 41 + (* Mailbox methods from RFC 8621 *) 42 42 + | `Mailbox_get 43 43 + | `Mailbox_query 44 44 + | `Mailbox_set 45 45 + | `Mailbox_changes 46 46 + 47 47 + (* Thread methods from RFC 8621 *) 48 48 + | `Thread_get 49 49 + | `Thread_query 50 50 + | `Thread_changes 51 51 + 52 52 + (* Identity methods from RFC 8621 *) 53 53 + | `Identity_get 54 54 + | `Identity_set 55 55 + | `Identity_changes 56 56 + 57 57 + (* EmailSubmission methods from RFC 8621 *) 58 58 + | `EmailSubmission_get 59 59 + | `EmailSubmission_query 60 60 + | `EmailSubmission_set 61 61 + | `EmailSubmission_changes 62 62 + 63 63 + (* VacationResponse methods from RFC 8621 *) 64 64 + | `VacationResponse_get 65 65 + | `VacationResponse_set 66 66 + 67 67 + (* SearchSnippet methods from RFC 8621 *) 68 68 + | `SearchSnippet_get 69 69 + 70 70 + (* Blob methods from RFC 8620 *) 71 71 + | `Blob_copy 72 72 + | `Blob_get 73 73 + | `Blob_lookup 74 74 + ] 75 75 + 76 76 + (** Convert a method enum to its wire protocol string representation. 77 77 + 78 78 + This function maps each polymorphic variant to the exact string 79 79 + that should appear in JMAP request/response wire protocol messages. 80 80 + The strings match the method names defined in RFC 8620 and RFC 8621. 81 81 + 82 82 + @param method The method enum to convert 83 83 + @return The wire protocol string (e.g., "Email/get", "Core/echo") 84 84 + 85 85 + Example: 86 86 + {[ 87 87 + method_to_string `Email_get = "Email/get" 88 88 + method_to_string `Core_echo = "Core/echo" 89 89 + ]} *) 90 90 + val method_to_string : jmap_method -> string 91 91 + 92 92 + (** Parse a wire protocol method name string into a method enum. 93 93 + 94 94 + This function is the inverse of [method_to_string]. It parses 95 95 + method name strings from JMAP wire protocol messages and returns 96 96 + the corresponding type-safe enum value. 97 97 + 98 98 + @param method_string The wire protocol method name string 99 99 + @return Some enum value if recognized, None if unknown 100 100 + 101 101 + Example: 102 102 + {[ 103 103 + method_of_string "Email/get" = Some `Email_get 104 104 + method_of_string "Unknown/method" = None 105 105 + ]} *) 106 106 + val method_of_string : string -> jmap_method option 107 107 + 108 108 + (** Get all supported JMAP method names. 109 109 + 110 110 + @return List of all method enums supported by this library *) 111 111 + val all_methods : unit -> jmap_method list 112 112 + 113 113 + (** Check if a method name string is supported. 114 114 + 115 115 + @param method_string The method name to check 116 116 + @return true if the method is recognized, false otherwise *) 117 117 + val is_supported_method : string -> bool

+2 -1

jmap/jmap/jmap_methods.ml

reviewed

··· 1 1 open Jmap_types 2 2 + open Jmap_method_names 2 3 3 4 type generic_record 4 5 ··· 744 745 let core_echo_handler args = Ok args 745 746 746 747 let init_core_handlers () = 747 747 - register_handler "Core/echo" core_echo_handler 748 748 + register_handler (method_to_string `Core_echo) core_echo_handler 748 749 end 749 750 750 751

+13

jmap/jmap/jmap_patch.ml

reviewed

··· 108 108 with 109 109 | Failure _ -> false 110 110 111 111 + let pp ppf patch = 112 112 + Fmt.pf ppf "%s" (Yojson.Safe.to_string (to_json_object patch)) 113 113 + 114 114 + let pp_hum ppf patch = 115 115 + let operations = to_operations patch in 116 116 + let op_count = List.length operations in 117 117 + let key_list = List.map fst operations in 118 118 + let key_str = match key_list with 119 119 + | [] -> "none" 120 120 + | keys -> String.concat ", " keys 121 121 + in 122 122 + Fmt.pf ppf "Patch{operations=%d; keys=[%s]}" op_count key_str 123 123 + 111 124 let to_string_debug patch = 112 125 let operations = to_operations patch in 113 126 let op_strings = List.map (fun (prop, value) ->

+3

jmap/jmap/jmap_patch.mli

reviewed

··· 22 22 (** JSON serialization interface *) 23 23 include Jmap_sigs.JSONABLE with type t := t 24 24 25 25 + (** Pretty-printing interface *) 26 26 + include Jmap_sigs.PRINTABLE with type t := t 27 27 + 25 28 (** {1 Construction and Access} *) 26 29 27 30 (** Create an empty patch object.

+93 -17

jmap/jmap/jmap_protocol.ml

reviewed

··· 16 16 17 17 type problem_details = Error.Problem_details.t 18 18 19 19 - module Capability = struct 19 19 + module Capability = Jmap_capability 20 20 + 21 21 + module Error_type = struct 20 22 type t = [ 21 21 - | `Core 22 22 - | `Mail 23 23 - | `Submission 24 24 - | `VacationResponse 23 23 + | `UnknownCapability 24 24 + | `NotJSON 25 25 + | `NotRequest 26 26 + | `Limit 25 27 ] 26 28 27 29 let to_string = function 28 28 - | `Core -> "urn:ietf:params:jmap:core" 29 29 - | `Mail -> "urn:ietf:params:jmap:mail" 30 30 - | `Submission -> "urn:ietf:params:jmap:submission" 31 31 - | `VacationResponse -> "urn:ietf:params:jmap:vacationresponse" 32 32 - 33 33 - let pp ppf capability = Fmt.string ppf (to_string capability) 30 30 + | `UnknownCapability -> "urn:ietf:params:jmap:error:unknownCapability" 31 31 + | `NotJSON -> "urn:ietf:params:jmap:error:notJSON" 32 32 + | `NotRequest -> "urn:ietf:params:jmap:error:notRequest" 33 33 + | `Limit -> "urn:ietf:params:jmap:error:limit" 34 34 35 35 let of_string = function 36 36 - | "urn:ietf:params:jmap:core" -> Some `Core 37 37 - | "urn:ietf:params:jmap:mail" -> Some `Mail 38 38 - | "urn:ietf:params:jmap:submission" -> Some `Submission 39 39 - | "urn:ietf:params:jmap:vacationresponse" -> Some `VacationResponse 36 36 + | "urn:ietf:params:jmap:error:unknownCapability" -> Some `UnknownCapability 37 37 + | "urn:ietf:params:jmap:error:notJSON" -> Some `NotJSON 38 38 + | "urn:ietf:params:jmap:error:notRequest" -> Some `NotRequest 39 39 + | "urn:ietf:params:jmap:error:limit" -> Some `Limit 40 40 | _ -> None 41 41 42 42 - let to_strings capabilities = 43 43 - List.map to_string capabilities 42 42 + let pp ppf error_type = Fmt.string ppf (to_string error_type) 44 43 end 44 44 + 45 45 + module Mime_type = struct 46 46 + type t = [ 47 47 + | `Text_plain 48 48 + | `Text_html 49 49 + | `Text_other of string 50 50 + | `Multipart_mixed 51 51 + | `Multipart_alternative 52 52 + | `Multipart_digest 53 53 + | `Multipart_other of string 54 54 + | `Message_rfc822 55 55 + | `Message_global 56 56 + | `Message_other of string 57 57 + | `Application_json 58 58 + | `Application_octet_stream 59 59 + | `Application_other of string 60 60 + | `Image_other of string 61 61 + | `Audio_other of string 62 62 + | `Video_other of string 63 63 + | `Other of string * string 64 64 + ] 65 65 + 66 66 + let to_string = function 67 67 + | `Text_plain -> "text/plain" 68 68 + | `Text_html -> "text/html" 69 69 + | `Text_other subtype -> "text/" ^ subtype 70 70 + | `Multipart_mixed -> "multipart/mixed" 71 71 + | `Multipart_alternative -> "multipart/alternative" 72 72 + | `Multipart_digest -> "multipart/digest" 73 73 + | `Multipart_other subtype -> "multipart/" ^ subtype 74 74 + | `Message_rfc822 -> "message/rfc822" 75 75 + | `Message_global -> "message/global" 76 76 + | `Message_other subtype -> "message/" ^ subtype 77 77 + | `Application_json -> "application/json" 78 78 + | `Application_octet_stream -> "application/octet-stream" 79 79 + | `Application_other subtype -> "application/" ^ subtype 80 80 + | `Image_other subtype -> "image/" ^ subtype 81 81 + | `Audio_other subtype -> "audio/" ^ subtype 82 82 + | `Video_other subtype -> "video/" ^ subtype 83 83 + | `Other (typ, subtype) -> typ ^ "/" ^ subtype 84 84 + 85 85 + let of_string mime_string = 86 86 + match String.split_on_char '/' mime_string with 87 87 + | ["text"; "plain"] -> `Text_plain 88 88 + | ["text"; "html"] -> `Text_html 89 89 + | ["text"; subtype] -> `Text_other subtype 90 90 + | ["multipart"; "mixed"] -> `Multipart_mixed 91 91 + | ["multipart"; "alternative"] -> `Multipart_alternative 92 92 + | ["multipart"; "digest"] -> `Multipart_digest 93 93 + | ["multipart"; subtype] -> `Multipart_other subtype 94 94 + | ["message"; "rfc822"] -> `Message_rfc822 95 95 + | ["message"; "global"] -> `Message_global 96 96 + | ["message"; subtype] -> `Message_other subtype 97 97 + | ["application"; "json"] -> `Application_json 98 98 + | ["application"; "octet-stream"] -> `Application_octet_stream 99 99 + | ["application"; subtype] -> `Application_other subtype 100 100 + | ["image"; subtype] -> `Image_other subtype 101 101 + | ["audio"; subtype] -> `Audio_other subtype 102 102 + | ["video"; subtype] -> `Video_other subtype 103 103 + | [typ; subtype] -> `Other (typ, subtype) 104 104 + | _ -> `Other ("application", "octet-stream") (* Fallback for malformed MIME types *) 105 105 + 106 106 + let pp ppf mime_type = Fmt.string ppf (to_string mime_type) 107 107 + 108 108 + let is_text = function 109 109 + | `Text_plain | `Text_html | `Text_other _ -> true 110 110 + | _ -> false 111 111 + 112 112 + let is_multipart = function 113 113 + | `Multipart_mixed | `Multipart_alternative | `Multipart_digest | `Multipart_other _ -> true 114 114 + | _ -> false 115 115 + 116 116 + let is_message = function 117 117 + | `Message_rfc822 | `Message_global | `Message_other _ -> true 118 118 + | _ -> false 119 119 + end 120 120 + 45 121 46 122 let supports_capability session capability = 47 123 Hashtbl.mem (Session.Session.capabilities session) capability

+97

jmap/jmap/jmap_protocol.mli

reviewed

··· 86 86 | `Mail (** JMAP Mail capability *) 87 87 | `Submission (** JMAP Email Submission capability *) 88 88 | `VacationResponse (** JMAP Vacation Response capability *) 89 89 + | `Apple_mail_flags (** Apple Mail color flags extension *) 89 90 ] 90 91 91 92 (** Convert capability variant to URN string. ··· 108 109 @return List of corresponding URN strings *) 109 110 val to_strings : t list -> string list 110 111 end 112 112 + 113 113 + (** JMAP error type management with type-safe variants. 114 114 + 115 115 + This module provides type-safe error URIs for JMAP problem details, 116 116 + converting the standardized error type URIs to polymorphic variants. 117 117 + 118 118 + @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6> RFC 8620, Section 3.6 *) 119 119 + module Error_type : sig 120 120 + (** JMAP standard error types as polymorphic variants. 121 121 + 122 122 + These map to the standardized error type URIs defined in RFC 8620 123 123 + for use in problem details objects. 124 124 + 125 125 + @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6> RFC 8620, Section 3.6 *) 126 126 + type t = [ 127 127 + | `UnknownCapability (** urn:ietf:params:jmap:error:unknownCapability *) 128 128 + | `NotJSON (** urn:ietf:params:jmap:error:notJSON *) 129 129 + | `NotRequest (** urn:ietf:params:jmap:error:notRequest *) 130 130 + | `Limit (** urn:ietf:params:jmap:error:limit *) 131 131 + ] 132 132 + 133 133 + (** Convert error type variant to URN string. 134 134 + @param error_type The error type variant 135 135 + @return The corresponding URN string *) 136 136 + val to_string : t -> string 137 137 + 138 138 + (** Parse URN string to error type variant. 139 139 + @param urn The URN string to parse 140 140 + @return Some error type if recognized, None otherwise *) 141 141 + val of_string : string -> t option 142 142 + 143 143 + (** Pretty-print an error type. 144 144 + @param ppf The formatter. 145 145 + @param error_type The error type to print. *) 146 146 + val pp : Format.formatter -> t -> unit 147 147 + end 148 148 + 149 149 + (** MIME type management with type-safe variants. 150 150 + 151 151 + This module provides commonly used MIME types as polymorphic variants 152 152 + for use in email body parts and attachments. 153 153 + 154 154 + @see <https://www.rfc-editor.org/rfc/rfc2046.html> RFC 2046: Media Types *) 155 155 + module Mime_type : sig 156 156 + (** Common MIME types as polymorphic variants. *) 157 157 + type t = [ 158 158 + | `Text_plain (** text/plain *) 159 159 + | `Text_html (** text/html *) 160 160 + | `Text_other of string (** text/* with custom subtype *) 161 161 + | `Multipart_mixed (** multipart/mixed *) 162 162 + | `Multipart_alternative (** multipart/alternative *) 163 163 + | `Multipart_digest (** multipart/digest *) 164 164 + | `Multipart_other of string (** multipart/* with custom subtype *) 165 165 + | `Message_rfc822 (** message/rfc822 *) 166 166 + | `Message_global (** message/global *) 167 167 + | `Message_other of string (** message/* with custom subtype *) 168 168 + | `Application_json (** application/json *) 169 169 + | `Application_octet_stream (** application/octet-stream *) 170 170 + | `Application_other of string (** application/* with custom subtype *) 171 171 + | `Image_other of string (** image/* *) 172 172 + | `Audio_other of string (** audio/* *) 173 173 + | `Video_other of string (** video/* *) 174 174 + | `Other of string * string (** type/subtype for custom MIME types *) 175 175 + ] 176 176 + 177 177 + (** Convert MIME type variant to string. 178 178 + @param mime_type The MIME type variant 179 179 + @return The corresponding MIME type string *) 180 180 + val to_string : t -> string 181 181 + 182 182 + (** Parse MIME type string to variant. 183 183 + @param mime_string The MIME type string to parse 184 184 + @return MIME type variant (uses Other for unrecognized types) *) 185 185 + val of_string : string -> t 186 186 + 187 187 + (** Pretty-print a MIME type. 188 188 + @param ppf The formatter. 189 189 + @param mime_type The MIME type to print. *) 190 190 + val pp : Format.formatter -> t -> unit 191 191 + 192 192 + (** Check if a MIME type is text-based. 193 193 + @param mime_type The MIME type to check 194 194 + @return true if it's a text/* type *) 195 195 + val is_text : t -> bool 196 196 + 197 197 + (** Check if a MIME type is multipart. 198 198 + @param mime_type The MIME type to check 199 199 + @return true if it's a multipart/* type *) 200 200 + val is_multipart : t -> bool 201 201 + 202 202 + (** Check if a MIME type is a message. 203 203 + @param mime_type The MIME type to check 204 204 + @return true if it's a message/* type *) 205 205 + val is_message : t -> bool 206 206 + end 207 207 + 111 208 112 209 (** {1 Protocol Helpers} *) 113 210

+90 -13

jmap/jmap/jmap_request.ml

reviewed

··· 21 21 } 22 22 23 23 let create_with_standard_capabilities ?additional_capabilities ?created_ids () = 24 24 - let standard_caps = [ 25 25 - "urn:ietf:params:jmap:core"; 26 26 - "urn:ietf:params:jmap:mail"; 27 27 - "urn:ietf:params:jmap:submission"; 28 28 - "urn:ietf:params:jmap:vacationresponse"; 24 24 + let standard_caps = Jmap_capability.to_strings [ 25 25 + `Core; 26 26 + `Mail; 27 27 + `Submission; 28 28 + `VacationResponse; 29 29 ] in 30 30 let all_caps = match additional_capabilities with 31 31 | None -> standard_caps ··· 172 172 ("methodCalls", `List method_calls_json); 173 173 ] @ created_ids_json) 174 174 175 175 + (** Parse a request from JSON representation. 176 176 + 177 177 + @param json The JSON value to parse 178 178 + @return Result containing the parsed request or error message *) 179 179 + let of_json json = 180 180 + let open Yojson.Safe.Util in 181 181 + try 182 182 + (* For now, implement a simplified parser that just validates structure *) 183 183 + let _using = json |> member "using" |> to_list |> List.map to_string in 184 184 + let _method_calls = json |> member "methodCalls" |> to_list |> List.map (function 185 185 + | `List [method_name_json; _arguments; call_id_json] -> 186 186 + let _method_name = to_string method_name_json in 187 187 + let _call_id = to_string call_id_json in 188 188 + () (* Just validate structure for now *) 189 189 + | _ -> failwith "Invalid method call format" 190 190 + ) in 191 191 + let _created_ids = try 192 192 + let _ids_json = json |> member "createdIds" |> to_assoc in 193 193 + () 194 194 + with _ -> () in 195 195 + Error "Request parsing from JSON not yet fully implemented" 196 196 + with 197 197 + | exn -> Error ("Failed to parse JMAP request: " ^ Printexc.to_string exn) 198 198 + 199 199 + (** Pretty-printer for requests. 200 200 + 201 201 + @param ppf The formatter to write to 202 202 + @param t The request to print *) 203 203 + let pp ppf t = 204 204 + Format.fprintf ppf "@[<v 2>JMAP Request:@,"; 205 205 + Format.fprintf ppf "Capabilities: [%s]@," (String.concat "; " t.using); 206 206 + Format.fprintf ppf "Methods (%d):@," (List.length t.methods); 207 207 + List.rev t.methods |> List.iteri (fun i (method_call, call_id) -> 208 208 + let method_name = Jmap_method.method_name method_call in 209 209 + Format.fprintf ppf " %d. %s (call_id: %s)@," i method_name call_id 210 210 + ); 211 211 + (match t.created_ids with 212 212 + | None -> Format.fprintf ppf "Created IDs: none@," 213 213 + | Some ids -> Format.fprintf ppf "Created IDs: %d entries@," (Hashtbl.length ids)); 214 214 + Format.fprintf ppf "@]" 215 215 + 216 216 + (** Alternative name for pp, following Fmt conventions *) 217 217 + let pp_hum = pp 218 218 + 175 219 (** {1 Request Validation} *) 176 220 177 221 let validate_result_references t = ··· 208 252 let validate_capabilities t = 209 253 (* Check that required capabilities are present *) 210 254 let required_caps = [ 211 211 - "urn:ietf:params:jmap:core" (* Always required *) 255 255 + Jmap_capability.to_string `Core (* Always required *) 212 256 ] in 213 257 let missing_caps = List.filter (fun cap -> not (has_capability t cap)) required_caps in 214 258 if missing_caps = [] then ··· 217 261 Error missing_caps 218 262 219 263 let validate t = 220 220 - match validate_result_references t with 221 221 - | Error msg -> Error msg 222 222 - | Ok () -> 223 223 - match validate_capabilities t with 224 224 - | Error missing_caps -> 225 225 - Error ("Missing required capabilities: " ^ String.concat ", " missing_caps) 226 226 - | Ok () -> Ok () 264 264 + (* Comprehensive WIRE_TYPE validation for JMAP requests *) 265 265 + 266 266 + (* 1. Check using capabilities *) 267 267 + if t.using = [] then 268 268 + Error "Request must declare at least one capability" 269 269 + else if not (List.mem (Jmap_capability.to_string `Core) t.using) then 270 270 + Error "Request must include core JMAP capability" 271 271 + 272 272 + (* 2. Check method calls *) 273 273 + else if t.methods = [] then 274 274 + Error "Request must contain at least one method call" 275 275 + 276 276 + (* 3. Validate call IDs are unique *) 277 277 + else 278 278 + let call_ids = List.rev t.methods |> List.map snd in 279 279 + let unique_call_ids = List.sort_uniq String.compare call_ids in 280 280 + if List.length call_ids <> List.length unique_call_ids then 281 281 + Error "Request contains duplicate method call IDs" 282 282 + 283 283 + (* 4. Validate result references *) 284 284 + else match validate_result_references t with 285 285 + | Error msg -> Error ("Invalid result references: " ^ msg) 286 286 + | Ok () -> 287 287 + (* 5. Validate individual method calls *) 288 288 + let validate_method_call (method_call, call_id) = 289 289 + let method_name = Jmap_method.method_name method_call in 290 290 + if call_id = "" then 291 291 + Error ("Empty call ID for method " ^ method_name) 292 292 + else if String.contains call_id '\000' then 293 293 + Error ("Invalid call ID contains null character: " ^ call_id) 294 294 + else 295 295 + Ok () 296 296 + in 297 297 + let method_results = List.map validate_method_call (List.rev t.methods) in 298 298 + let rec check_results = function 299 299 + | [] -> Ok () 300 300 + | Ok () :: rest -> check_results rest 301 301 + | Error msg :: _ -> Error msg 302 302 + in 303 303 + check_results method_results 227 304 228 305 (** {1 Request Debugging} *) 229 306

+3

jmap/jmap/jmap_request.mli

reviewed

··· 33 33 references. *) 34 34 type t 35 35 36 36 + (** Request objects implement the WIRE_TYPE signature for protocol validation and formatting. *) 37 37 + include Jmap_sigs.WIRE_TYPE with type t := t 38 38 + 36 39 (** {1 Request Creation} *) 37 40 38 41 (** Create a new empty request.

+119 -25

jmap/jmap/jmap_response.ml

reviewed

··· 1 1 (** Implementation of type-safe JMAP response parsing and pattern matching. *) 2 2 3 3 + open Jmap_method_names 4 4 + 3 5 (* Internal representation of a JMAP response *) 4 6 type response_data = 5 7 | Core_echo_data of Yojson.Safe.t ··· 65 67 66 68 let parse_method_response ~method_name json = 67 69 try 68 68 - let result = match method_name with 69 69 - | "Core/echo" -> 70 70 + let result = match method_of_string method_name with 71 71 + | Some `Core_echo -> 70 72 Ok (Core_echo_data json) 71 73 72 72 - | "Email/query" -> 74 74 + | Some `Email_query -> 73 75 (match Jmap_methods.Query_response.of_json json with 74 76 | Ok query_resp -> Ok (Email_query_data query_resp) 75 77 | Error err -> Error err) 76 78 77 77 - | "Email/get" -> 79 79 + | Some `Email_get -> 78 80 (match Jmap_methods.Get_response.of_json ~from_json:(fun j -> j) json with 79 81 | Ok get_resp -> Ok (Email_get_data get_resp) 80 82 | Error err -> Error err) 81 83 82 82 - | "Email/set" -> 84 84 + | Some `Email_set -> 83 85 (match Jmap_methods.Set_response.of_json 84 86 ~from_created_json:(fun j -> j) 85 87 ~from_updated_json:(fun j -> j) json with 86 88 | Ok set_resp -> Ok (Email_set_data set_resp) 87 89 | Error err -> Error err) 88 90 89 89 - | "Email/changes" -> 91 91 + | Some `Email_changes -> 90 92 (match Jmap_methods.Changes_response.of_json json with 91 93 | Ok changes_resp -> Ok (Email_changes_data changes_resp) 92 94 | Error err -> Error err) 93 95 94 94 - | "Mailbox/get" -> 96 96 + | Some `Mailbox_get -> 95 97 (match Jmap_methods.Get_response.of_json ~from_json:(fun j -> j) json with 96 98 | Ok get_resp -> Ok (Mailbox_get_data get_resp) 97 99 | Error err -> Error err) 98 100 99 99 - | "Mailbox/query" -> 101 101 + | Some `Mailbox_query -> 100 102 (match Jmap_methods.Query_response.of_json json with 101 103 | Ok query_resp -> Ok (Mailbox_query_data query_resp) 102 104 | Error err -> Error err) 103 105 104 104 - | "Thread/get" -> 106 106 + | Some `Thread_get -> 105 107 (match Jmap_methods.Get_response.of_json ~from_json:(fun j -> j) json with 106 108 | Ok get_resp -> Ok (Thread_get_data get_resp) 107 109 | Error err -> Error err) 108 110 109 109 - | "Identity/get" -> 111 111 + | Some `Identity_get -> 110 112 (match Jmap_methods.Get_response.of_json ~from_json:(fun j -> j) json with 111 113 | Ok get_resp -> Ok (Identity_get_data get_resp) 112 114 | Error err -> Error err) 113 115 114 114 - | "EmailSubmission/get" -> 116 116 + | Some `EmailSubmission_get -> 115 117 (match Jmap_methods.Get_response.of_json ~from_json:(fun j -> j) json with 116 118 | Ok get_resp -> Ok (Email_submission_get_data get_resp) 117 119 | Error err -> Error err) 118 120 119 119 - | "EmailSubmission/query" -> 121 121 + | Some `EmailSubmission_query -> 120 122 (match Jmap_methods.Query_response.of_json json with 121 123 | Ok query_resp -> Ok (Email_submission_query_data query_resp) 122 124 | Error err -> Error err) 123 125 124 124 - | "VacationResponse/get" -> 126 126 + | Some `VacationResponse_get -> 125 127 (match Jmap_methods.Get_response.of_json ~from_json:(fun j -> j) json with 126 128 | Ok get_resp -> Ok (Vacation_response_get_data get_resp) 127 129 | Error err -> Error err) 128 130 129 131 (* Email/queryChanges - not yet implemented *) 130 130 - | "Email/queryChanges" -> 131 131 - Error (Jmap_error.Method (`UnknownMethod, Some method_name)) 132 132 + (* | Some `Email_queryChanges -> ... *) 132 133 133 133 - | "Mailbox/set" -> 134 134 + | Some `Mailbox_set -> 134 135 (match Jmap_methods.Set_response.of_json 135 136 ~from_created_json:(fun j -> j) 136 137 ~from_updated_json:(fun j -> j) json with 137 138 | Ok set_resp -> Ok (Mailbox_set_data set_resp) 138 139 | Error err -> Error err) 139 140 140 140 - | "Mailbox/changes" -> 141 141 + | Some `Mailbox_changes -> 141 142 (match Jmap_methods.Changes_response.of_json json with 142 143 | Ok changes_resp -> Ok (Mailbox_changes_data changes_resp) 143 144 | Error err -> Error err) 144 145 145 145 - | "Thread/changes" -> 146 146 + | Some `Thread_changes -> 146 147 (match Jmap_methods.Changes_response.of_json json with 147 148 | Ok changes_resp -> Ok (Thread_changes_data changes_resp) 148 149 | Error err -> Error err) 149 150 150 150 - | "Identity/set" -> 151 151 + | Some `Identity_set -> 151 152 (match Jmap_methods.Set_response.of_json 152 153 ~from_created_json:(fun j -> j) 153 154 ~from_updated_json:(fun j -> j) json with 154 155 | Ok set_resp -> Ok (Identity_set_data set_resp) 155 156 | Error err -> Error err) 156 157 157 157 - | "Identity/changes" -> 158 158 + | Some `Identity_changes -> 158 159 (match Jmap_methods.Changes_response.of_json json with 159 160 | Ok changes_resp -> Ok (Identity_changes_data changes_resp) 160 161 | Error err -> Error err) 161 162 162 162 - | "EmailSubmission/set" -> 163 163 + | Some `EmailSubmission_set -> 163 164 (match Jmap_methods.Set_response.of_json 164 165 ~from_created_json:(fun j -> j) 165 166 ~from_updated_json:(fun j -> j) json with 166 167 | Ok set_resp -> Ok (Email_submission_set_data set_resp) 167 168 | Error err -> Error err) 168 169 169 169 - | "EmailSubmission/changes" -> 170 170 + | Some `EmailSubmission_changes -> 170 171 (match Jmap_methods.Changes_response.of_json json with 171 172 | Ok changes_resp -> Ok (Email_submission_changes_data changes_resp) 172 173 | Error err -> Error err) 173 174 174 174 - | "VacationResponse/set" -> 175 175 + | Some `VacationResponse_set -> 175 176 (match Jmap_methods.Set_response.of_json 176 177 ~from_created_json:(fun j -> j) 177 178 ~from_updated_json:(fun j -> j) json with 178 179 | Ok set_resp -> Ok (Vacation_response_set_data set_resp) 179 180 | Error err -> Error err) 180 181 181 181 - | _ -> 182 182 + (* Not yet implemented methods - return error for now *) 183 183 + | Some (`Blob_get | `Blob_lookup | `Email_parse | `Email_copy | `SearchSnippet_get 184 184 + | `Thread_query | `Email_import | `Blob_copy) -> 185 185 + Error (Jmap_error.Method (`UnknownMethod, Some method_name)) 186 186 + 187 187 + | None -> 182 188 Error (Jmap_error.Method (`UnknownMethod, Some method_name)) 183 189 in 184 190 match result with ··· 1099 1105 with 1100 1106 | _ -> None 1101 1107 1102 1102 - let to_json t = t.raw_json 1108 1108 + let to_json t = t.raw_json 1109 1109 + 1110 1110 + (** Parse a response from JSON representation. 1111 1111 + 1112 1112 + @param json The JSON value to parse 1113 1113 + @return Result containing the parsed response or error message *) 1114 1114 + let of_json _json = 1115 1115 + (* For now, return an error as response parsing is complex *) 1116 1116 + Error "Response parsing from JSON not yet fully implemented" 1117 1117 + 1118 1118 + (** Pretty-printer for responses. 1119 1119 + 1120 1120 + @param ppf The formatter to write to 1121 1121 + @param t The response to print *) 1122 1122 + let pp ppf t = 1123 1123 + Format.fprintf ppf "@[<v 2>JMAP Response:@,"; 1124 1124 + Format.fprintf ppf "Method: %s@," t.method_name; 1125 1125 + Format.fprintf ppf "Type: %s@," (match t.data with 1126 1126 + | Core_echo_data _ -> method_to_string `Core_echo 1127 1127 + | Email_query_data _ -> method_to_string `Email_query 1128 1128 + | Email_get_data _ -> method_to_string `Email_get 1129 1129 + | Email_set_data _ -> method_to_string `Email_set 1130 1130 + | Email_changes_data _ -> method_to_string `Email_changes 1131 1131 + | Mailbox_get_data _ -> method_to_string `Mailbox_get 1132 1132 + | Mailbox_query_data _ -> method_to_string `Mailbox_query 1133 1133 + | Mailbox_set_data _ -> method_to_string `Mailbox_set 1134 1134 + | Mailbox_changes_data _ -> method_to_string `Mailbox_changes 1135 1135 + | Thread_get_data _ -> method_to_string `Thread_get 1136 1136 + | Thread_changes_data _ -> method_to_string `Thread_changes 1137 1137 + | Identity_get_data _ -> method_to_string `Identity_get 1138 1138 + | Identity_set_data _ -> method_to_string `Identity_set 1139 1139 + | Identity_changes_data _ -> method_to_string `Identity_changes 1140 1140 + | Email_submission_get_data _ -> method_to_string `EmailSubmission_get 1141 1141 + | Email_submission_set_data _ -> method_to_string `EmailSubmission_set 1142 1142 + | Email_submission_query_data _ -> method_to_string `EmailSubmission_query 1143 1143 + | Email_submission_changes_data _ -> method_to_string `EmailSubmission_changes 1144 1144 + | Vacation_response_get_data _ -> method_to_string `VacationResponse_get 1145 1145 + | Vacation_response_set_data _ -> method_to_string `VacationResponse_set 1146 1146 + | Error_data _ -> "Error" 1147 1147 + ); 1148 1148 + (match error t with 1149 1149 + | Some _err -> Format.fprintf ppf "Status: Error@," 1150 1150 + | None -> Format.fprintf ppf "Status: Success@,"); 1151 1151 + Format.fprintf ppf "@]" 1152 1152 + 1153 1153 + (** Alternative name for pp, following Fmt conventions *) 1154 1154 + let pp_hum = pp 1155 1155 + 1156 1156 + (** Validate the response structure according to JMAP constraints. 1157 1157 + 1158 1158 + @return Ok () if valid, Error with description if invalid *) 1159 1159 + let validate t = 1160 1160 + (* Basic response validation *) 1161 1161 + if t.method_name = "" then 1162 1162 + Error "Response must have a non-empty method name" 1163 1163 + else if String.contains t.method_name '\000' then 1164 1164 + Error "Response method name contains invalid null character" 1165 1165 + else 1166 1166 + (* Check if the response data matches the claimed method name *) 1167 1167 + let expected_data_type = match method_of_string t.method_name with 1168 1168 + | Some `Core_echo -> (match t.data with Core_echo_data _ -> true | _ -> false) 1169 1169 + | Some `Email_query -> (match t.data with Email_query_data _ -> true | _ -> false) 1170 1170 + | Some `Email_get -> (match t.data with Email_get_data _ -> true | _ -> false) 1171 1171 + | Some `Email_set -> (match t.data with Email_set_data _ -> true | _ -> false) 1172 1172 + | Some `Email_changes -> (match t.data with Email_changes_data _ -> true | _ -> false) 1173 1173 + | Some `Mailbox_get -> (match t.data with Mailbox_get_data _ -> true | _ -> false) 1174 1174 + | Some `Mailbox_query -> (match t.data with Mailbox_query_data _ -> true | _ -> false) 1175 1175 + | Some `Mailbox_set -> (match t.data with Mailbox_set_data _ -> true | _ -> false) 1176 1176 + | Some `Mailbox_changes -> (match t.data with Mailbox_changes_data _ -> true | _ -> false) 1177 1177 + | Some `Thread_get -> (match t.data with Thread_get_data _ -> true | _ -> false) 1178 1178 + | Some `Thread_changes -> (match t.data with Thread_changes_data _ -> true | _ -> false) 1179 1179 + | Some `Identity_get -> (match t.data with Identity_get_data _ -> true | _ -> false) 1180 1180 + | Some `Identity_set -> (match t.data with Identity_set_data _ -> true | _ -> false) 1181 1181 + | Some `Identity_changes -> (match t.data with Identity_changes_data _ -> true | _ -> false) 1182 1182 + | Some `EmailSubmission_get -> (match t.data with Email_submission_get_data _ -> true | _ -> false) 1183 1183 + | Some `EmailSubmission_set -> (match t.data with Email_submission_set_data _ -> true | _ -> false) 1184 1184 + | Some `EmailSubmission_query -> (match t.data with Email_submission_query_data _ -> true | _ -> false) 1185 1185 + | Some `EmailSubmission_changes -> (match t.data with Email_submission_changes_data _ -> true | _ -> false) 1186 1186 + | Some `VacationResponse_get -> (match t.data with Vacation_response_get_data _ -> true | _ -> false) 1187 1187 + | Some `VacationResponse_set -> (match t.data with Vacation_response_set_data _ -> true | _ -> false) 1188 1188 + (* Not yet implemented methods *) 1189 1189 + | Some (`Blob_get | `Blob_lookup | `Email_parse | `Email_copy | `SearchSnippet_get 1190 1190 + | `Thread_query | `Email_import | `Blob_copy) -> false 1191 1191 + | None -> (match t.data with Error_data _ -> true | _ -> false) 1192 1192 + in 1193 1193 + if not expected_data_type then 1194 1194 + Error ("Response data type does not match method name: " ^ t.method_name) 1195 1195 + else 1196 1196 + Ok ()

+3

jmap/jmap/jmap_response.mli

reviewed

··· 35 35 type-safe pattern matching to determine the specific response type. *) 36 36 type t 37 37 38 38 + (** Response objects implement the WIRE_TYPE signature for protocol validation and formatting. *) 39 39 + include Jmap_sigs.WIRE_TYPE with type t := t 40 40 + 38 41 (** Specific response types for pattern matching *) 39 42 type response_type = 40 43 | Core_echo_response of Yojson.Safe.t

+182 -17

jmap/jmap/jmap_session.ml

reviewed

··· 61 61 let max_objects_in_set = json |> member "maxObjectsInSet" |> to_int in 62 62 let collation_algorithms = 63 63 json |> member "collationAlgorithms" |> to_list |> List.map to_string in 64 64 - Some (v ~max_size_upload ~max_concurrent_upload ~max_size_request 65 65 - ~max_concurrent_requests ~max_calls_in_request ~max_objects_in_get 66 66 - ~max_objects_in_set ~collation_algorithms ()) 64 64 + Ok (v ~max_size_upload ~max_concurrent_upload ~max_size_request 65 65 + ~max_concurrent_requests ~max_calls_in_request ~max_objects_in_get 66 66 + ~max_objects_in_set ~collation_algorithms ()) 67 67 with 68 68 - | _ -> None 68 68 + | Yojson.Safe.Util.Type_error (msg, _) -> Error ("JSON type error: " ^ msg) 69 69 + | Yojson.Safe.Util.Undefined (msg, _) -> Error ("Missing JSON field: " ^ msg) 70 70 + | exn -> Error ("JSON parsing error: " ^ Printexc.to_string exn) 69 71 end 70 72 71 73 module Account = struct ··· 105 107 | `Assoc caps -> 106 108 List.iter (fun (k, v) -> Hashtbl.add account_capabilities k v) caps 107 109 | _ -> ()); 108 108 - Some (v ~name ~is_personal ~is_read_only ~account_capabilities ()) 110 110 + Ok (v ~name ~is_personal ~is_read_only ~account_capabilities ()) 109 111 with 110 110 - | _ -> None 112 112 + | Yojson.Safe.Util.Type_error (msg, _) -> Error ("JSON type error: " ^ msg) 113 113 + | Yojson.Safe.Util.Undefined (msg, _) -> Error ("Missing JSON field: " ^ msg) 114 114 + | exn -> Error ("JSON parsing error: " ^ Printexc.to_string exn) 111 115 end 112 116 113 117 module Session = struct ··· 154 158 ("state", `String t.state) 155 159 ] 156 160 161 161 + let of_json json = 162 162 + try 163 163 + let open Yojson.Safe.Util in 164 164 + 165 165 + let username = json |> member "username" |> to_string in 166 166 + let api_url = json |> member "apiUrl" |> to_string |> Uri.of_string in 167 167 + let download_url = json |> member "downloadUrl" |> to_string |> Uri.of_string in 168 168 + let upload_url = json |> member "uploadUrl" |> to_string |> Uri.of_string in 169 169 + let event_source_url = json |> member "eventSourceUrl" |> to_string |> Uri.of_string in 170 170 + let state = json |> member "state" |> to_string in 171 171 + 172 172 + let capabilities = Hashtbl.create 16 in 173 173 + (match json |> member "capabilities" with 174 174 + | `Assoc caps_list -> 175 175 + List.iter (fun (cap, value) -> 176 176 + Hashtbl.add capabilities cap value 177 177 + ) caps_list 178 178 + | _ -> ()); 179 179 + 180 180 + let accounts = Hashtbl.create 16 in 181 181 + (match json |> member "accounts" with 182 182 + | `Assoc account_list -> 183 183 + List.iter (fun (acc_id, acc_obj) -> 184 184 + match Account.of_json acc_obj with 185 185 + | Ok account -> Hashtbl.add accounts acc_id account 186 186 + | Error _ -> () 187 187 + ) account_list 188 188 + | _ -> ()); 189 189 + 190 190 + let primary_accounts = Hashtbl.create 16 in 191 191 + (match json |> member "primaryAccounts" with 192 192 + | `Assoc pa_list -> 193 193 + List.iter (fun (cap, acc_id) -> 194 194 + let acc_id_str = acc_id |> to_string in 195 195 + Hashtbl.add primary_accounts cap acc_id_str 196 196 + ) pa_list 197 197 + | _ -> ()); 198 198 + 199 199 + let session = v 200 200 + ~capabilities 201 201 + ~accounts 202 202 + ~primary_accounts 203 203 + ~username 204 204 + ~api_url 205 205 + ~download_url 206 206 + ~upload_url 207 207 + ~event_source_url 208 208 + ~state 209 209 + () in 210 210 + Ok session 211 211 + with 212 212 + | Yojson.Safe.Util.Type_error (msg, _) -> Error ("JSON type error: " ^ msg) 213 213 + | Yojson.Safe.Util.Undefined (msg, _) -> Error ("Missing JSON field: " ^ msg) 214 214 + | exn -> Error ("JSON parsing error: " ^ Printexc.to_string exn) 215 215 + 157 216 let get_core_capability t = 158 158 - match Hashtbl.find_opt t.capabilities "urn:ietf:params:jmap:core" with 159 159 - | Some json -> Core_capability.of_json json 217 217 + match Hashtbl.find_opt t.capabilities (Jmap_capability.to_string `Core) with 218 218 + | Some json -> 219 219 + (match Core_capability.of_json json with 220 220 + | Ok capability -> Some capability 221 221 + | Error _ -> None) 160 222 | None -> None 161 223 162 224 let has_capability t capability_uri = ··· 179 241 (id, account) :: acc 180 242 else acc 181 243 ) t.accounts [] 244 244 + 245 245 + let validate t = 246 246 + try 247 247 + (* Check that required URLs are not empty *) 248 248 + if Uri.to_string t.api_url = "" then 249 249 + Error "Session validation error: API URL cannot be empty" 250 250 + else if Uri.to_string t.download_url = "" then 251 251 + Error "Session validation error: Download URL cannot be empty" 252 252 + else if Uri.to_string t.upload_url = "" then 253 253 + Error "Session validation error: Upload URL cannot be empty" 254 254 + else if Uri.to_string t.event_source_url = "" then 255 255 + Error "Session validation error: Event source URL cannot be empty" 256 256 + else if String.length t.username = 0 then 257 257 + Error "Session validation error: Username cannot be empty" 258 258 + else if String.length t.state = 0 then 259 259 + Error "Session validation error: State cannot be empty" 260 260 + (* Check that core capability exists *) 261 261 + else if not (Hashtbl.mem t.capabilities (Jmap_capability.to_string `Core)) then 262 262 + Error "Session validation error: Core capability missing" 263 263 + (* Validate account consistency - each account must have valid capabilities *) 264 264 + else 265 265 + let primary_account_ids = Hashtbl.fold (fun _cap id acc -> id :: acc) t.primary_accounts [] in 266 266 + (* Check that primary accounts exist in accounts *) 267 267 + let invalid_primary = List.find_opt (fun id -> not (Hashtbl.mem t.accounts id)) primary_account_ids in 268 268 + match invalid_primary with 269 269 + | Some invalid_id -> 270 270 + Error ("Session validation error: Primary account '" ^ invalid_id ^ "' not found in accounts") 271 271 + | None -> 272 272 + (* Validate URL schemes *) 273 273 + let validate_url_scheme url field_name = 274 274 + match Uri.scheme url with 275 275 + | Some "https" | Some "http" -> Ok () 276 276 + | Some scheme -> Error ("Session validation error: " ^ field_name ^ " must use HTTP/HTTPS, got " ^ scheme) 277 277 + | None -> Error ("Session validation error: " ^ field_name ^ " must have a scheme") 278 278 + in 279 279 + match validate_url_scheme t.api_url "API URL" with 280 280 + | Error msg -> Error msg 281 281 + | Ok () -> 282 282 + match validate_url_scheme t.download_url "Download URL" with 283 283 + | Error msg -> Error msg 284 284 + | Ok () -> 285 285 + match validate_url_scheme t.upload_url "Upload URL" with 286 286 + | Error msg -> Error msg 287 287 + | Ok () -> 288 288 + match validate_url_scheme t.event_source_url "Event source URL" with 289 289 + | Error msg -> Error msg 290 290 + | Ok () -> Ok () 291 291 + with 292 292 + | exn -> Error ("Session validation error: " ^ Printexc.to_string exn) 293 293 + 294 294 + let pp ppf t = 295 295 + Format.fprintf ppf "@[<v 2>Session:@,\ 296 296 + Username: %s@,\ 297 297 + API URL: %s@,\ 298 298 + State: %s@,\ 299 299 + Capabilities: %d@,\ 300 300 + Accounts: %d@,\ 301 301 + Primary Accounts: %d@]" 302 302 + t.username 303 303 + (Uri.to_string t.api_url) 304 304 + t.state 305 305 + (Hashtbl.length t.capabilities) 306 306 + (Hashtbl.length t.accounts) 307 307 + (Hashtbl.length t.primary_accounts) 308 308 + 309 309 + let pp_hum ppf t = 310 310 + Format.fprintf ppf "@[<v 2>JMAP Session:@,\ 311 311 + User: %s@,\ 312 312 + Server: %s@,\ 313 313 + Session State: %s@,\ 314 314 + @,\ 315 315 + Capabilities (%d):@,\ 316 316 + %a@,\ 317 317 + @,\ 318 318 + Accounts (%d):@,\ 319 319 + %a@,\ 320 320 + @,\ 321 321 + Primary Accounts (%d):@,\ 322 322 + %a@]" 323 323 + t.username 324 324 + (Uri.to_string t.api_url) 325 325 + t.state 326 326 + (Hashtbl.length t.capabilities) 327 327 + (fun ppf caps -> 328 328 + Hashtbl.iter (fun cap _value -> 329 329 + Format.fprintf ppf " - %s@," cap 330 330 + ) caps 331 331 + ) t.capabilities 332 332 + (Hashtbl.length t.accounts) 333 333 + (fun ppf accounts -> 334 334 + Hashtbl.iter (fun id account -> 335 335 + Format.fprintf ppf " - %s: %s%s@," 336 336 + id 337 337 + (Account.name account) 338 338 + (if Account.is_personal account then " (personal)" else "") 339 339 + ) accounts 340 340 + ) t.accounts 341 341 + (Hashtbl.length t.primary_accounts) 342 342 + (fun ppf primaries -> 343 343 + Hashtbl.iter (fun cap acc_id -> 344 344 + Format.fprintf ppf " - %s: %s@," cap acc_id 345 345 + ) primaries 346 346 + ) t.primary_accounts 182 347 end 183 348 184 349 module Discovery = struct ··· 263 428 | No_auth -> [] 264 429 265 430 let make_request ~url ~auth = 266 266 - let headers = ("Accept", "application/json") :: ("User-Agent", "OCaml-JMAP/1.0") :: (auth_headers auth) in 431 431 + let headers = ("Accept", Jmap_types.Constants.Content_type.json) :: ("User-Agent", Jmap_types.Constants.User_agent.ocaml_jmap) :: (auth_headers auth) in 267 432 try 268 433 let response_json = `Assoc [ 269 434 ("capabilities", `Assoc [ 270 270 - ("urn:ietf:params:jmap:core", `Assoc [ 435 435 + (Jmap_capability.to_string `Core, `Assoc [ 271 436 ("maxSizeUpload", `Int 50_000_000); 272 437 ("maxConcurrentUpload", `Int 8); 273 438 ("maxSizeRequest", `Int 10_000_000); ··· 281 446 `String "i;unicode-casemap" 282 447 ]) 283 448 ]); 284 284 - ("urn:ietf:params:jmap:mail", `Assoc []); 449 449 + (Jmap_capability.to_string `Mail, `Assoc []); 285 450 ("urn:ietf:params:jmap:contacts", `Assoc []) 286 451 ]); 287 452 ("accounts", `Assoc [ ··· 290 455 ("isPersonal", `Bool true); 291 456 ("isReadOnly", `Bool false); 292 457 ("accountCapabilities", `Assoc [ 293 293 - ("urn:ietf:params:jmap:mail", `Assoc [ 458 458 + (Jmap_capability.to_string `Mail, `Assoc [ 294 459 ("maxMailboxesPerEmail", `Null); 295 460 ("maxMailboxDepth", `Int 10) 296 461 ]); ··· 299 464 ]) 300 465 ]); 301 466 ("primaryAccounts", `Assoc [ 302 302 - ("urn:ietf:params:jmap:mail", `String "A13824"); 467 467 + (Jmap_capability.to_string `Mail, `String "A13824"); 303 468 ("urn:ietf:params:jmap:contacts", `String "A13824") 304 469 ]); 305 470 ("username", `String (match auth with ··· 342 507 | `Assoc account_list -> 343 508 List.iter (fun (acc_id, acc_obj) -> 344 509 match Account.of_json acc_obj with 345 345 - | Some account -> Hashtbl.add accounts acc_id account 346 346 - | None -> () 510 510 + | Ok account -> Hashtbl.add accounts acc_id account 511 511 + | Error _ -> () 347 512 ) account_list 348 513 | _ -> ()); 349 514 ··· 370 535 with 371 536 | _ -> 372 537 let fallback_capabilities = Hashtbl.create 1 in 373 373 - Hashtbl.add fallback_capabilities "urn:ietf:params:jmap:core" 538 538 + Hashtbl.add fallback_capabilities (Jmap_capability.to_string `Core) 374 539 (`Assoc [ 375 540 ("maxSizeUpload", `Int 50_000_000); 376 541 ("maxConcurrentUpload", `Int 4); ··· 400 565 | Error _err -> 401 566 let fallback_json = `Assoc [ 402 567 ("capabilities", `Assoc [ 403 403 - ("urn:ietf:params:jmap:core", `Assoc [ 568 568 + (Jmap_capability.to_string `Core, `Assoc [ 404 569 ("maxSizeUpload", `Int 50_000_000); 405 570 ("maxConcurrentUpload", `Int 4); 406 571 ("maxSizeRequest", `Int 10_000_000);

+7 -5

jmap/jmap/jmap_session.mli

reviewed

··· 114 114 val to_json : t -> Yojson.Safe.t 115 115 116 116 (** Parse core capability from JSON. 117 117 - @param json JSON object to parse 118 118 - @return Core capability object if valid, None otherwise *) 119 119 - val of_json : Yojson.Safe.t -> t option 117 117 + @param json JSON object to parse 118 118 + @return Result containing the parsed core capability or error message *) 119 119 + val of_json : Yojson.Safe.t -> (t, string) result 120 120 end 121 121 122 122 (** {1 Account Information} *) ··· 171 171 172 172 (** Parse account from JSON. 173 173 @param json JSON object to parse 174 174 - @return Account object if valid, None otherwise *) 175 175 - val of_json : Yojson.Safe.t -> t option 174 174 + @return Result containing the parsed account or error message *) 175 175 + val of_json : Yojson.Safe.t -> (t, string) result 176 176 end 177 177 178 178 (** {1 Session Resource} *) ··· 193 193 @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *) 194 194 module Session : sig 195 195 type t 196 196 + 197 197 + include Jmap_sigs.WIRE_TYPE with type t := t 196 198 197 199 (** Get the server capabilities. 198 200 @return Map of capability URIs to server-specific capability metadata *)

+14 -1

jmap/jmap/jmap_types.ml

reviewed

··· 12 12 13 13 type 'v id_map = (id, 'v) Hashtbl.t 14 14 15 15 - type json_pointer = string 15 15 + type json_pointer = string 16 16 + 17 17 + module Constants = struct 18 18 + let vacation_response_id = "singleton" 19 19 + 20 20 + module Content_type = struct 21 21 + let json = "application/json" 22 22 + end 23 23 + 24 24 + module User_agent = struct 25 25 + let ocaml_jmap = "OCaml-JMAP/1.0" 26 26 + let eio_client = "OCaml JMAP Client/Eio" 27 27 + end 28 28 + end

+30 -1

jmap/jmap/jmap_types.mli

reviewed

··· 116 116 117 117 @see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.7> RFC 8620, Section 3.7 118 118 @see <https://www.rfc-editor.org/rfc/rfc6901.html> RFC 6901 (JSON Pointer) *) 119 119 - type json_pointer = string 119 119 + type json_pointer = string 120 120 + 121 121 + (** {1 Protocol Constants} *) 122 122 + 123 123 + (** Protocol constants for common values. 124 124 + 125 125 + This module contains commonly used constant values throughout the 126 126 + JMAP protocol, reducing hardcoded strings and providing type safety. *) 127 127 + module Constants : sig 128 128 + (** VacationResponse singleton object ID. 129 129 + 130 130 + VacationResponse objects always use this fixed ID per JMAP specification. 131 131 + @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *) 132 132 + val vacation_response_id : string 133 133 + 134 134 + (** HTTP Content-Type values for JMAP protocol. *) 135 135 + module Content_type : sig 136 136 + (** JMAP protocol content type. *) 137 137 + val json : string 138 138 + end 139 139 + 140 140 + (** Default User-Agent strings. *) 141 141 + module User_agent : sig 142 142 + (** Default OCaml JMAP client user agent. *) 143 143 + val ocaml_jmap : string 144 144 + 145 145 + (** Eio-based client user agent. *) 146 146 + val eio_client : string 147 147 + end 148 148 + end

+2

jmap/jmap/jmap_uint.ml

reviewed

··· 26 26 27 27 let pp ppf uint = Fmt.int ppf uint 28 28 29 29 + let pp_hum ppf uint = Fmt.pf ppf "UInt(%d)" uint 30 30 + 29 31 (* Constants *) 30 32 let zero = 0 31 33 let one = 1

+3

jmap/jmap/jmap_uint.mli

reviewed

··· 18 18 (** JSON serialization interface *) 19 19 include Jmap_sigs.JSONABLE with type t := t 20 20 21 21 + (** Pretty-printing interface *) 22 22 + include Jmap_sigs.PRINTABLE with type t := t 23 23 + 21 24 (** {1 Construction and Access} *) 22 25 23 26 (** Create an UnsignedInt from an int.