···
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
| Error e -> Lwt.return (Error e)
1936
+
(** {1 Email Submission} *)
1938
+
(** Create a new email draft
1939
+
@param conn The JMAP connection
1940
+
@param account_id The account ID
1941
+
@param mailbox_id The mailbox ID to store the draft in (usually "drafts")
1942
+
@param from The sender's email address
1943
+
@param to_addresses List of recipient email addresses
1944
+
@param subject The email subject line
1945
+
@param text_body Plain text message body
1946
+
@param html_body Optional HTML message body
1947
+
@return The created email ID if successful
1951
+
let create_email_draft conn ~account_id ~mailbox_id ~from ~to_addresses ~subject ~text_body ?html_body () =
1952
+
(* Create email addresses *)
1954
+
Types.name = None;
1959
+
let to_addrs = List.map (fun addr -> {
1960
+
Types.name = None;
1963
+
}) to_addresses in
1965
+
(* Create text body part *)
1967
+
Types.part_id = Some "part1";
1972
+
type_ = Some "text/plain";
1973
+
charset = Some "utf-8";
1974
+
disposition = None;
1979
+
header_parameter_name = None;
1980
+
header_parameter_value = None;
1983
+
(* Create HTML body part if provided *)
1984
+
let html_part_opt = match html_body with
1985
+
| Some _html -> Some {
1986
+
Types.part_id = Some "part2";
1991
+
type_ = Some "text/html";
1992
+
charset = Some "utf-8";
1993
+
disposition = None;
1998
+
header_parameter_name = None;
1999
+
header_parameter_value = None;
2004
+
(* Create body values *)
2005
+
let body_values = [
2006
+
("part1", text_body)
2007
+
] @ (match html_body with
2008
+
| Some html -> [("part2", html)]
2012
+
(* Create email *)
2013
+
let html_body_list = match html_part_opt with
2014
+
| Some part -> Some [part]
2018
+
let _email_creation = {
2019
+
Types.mailbox_ids = [(mailbox_id, true)];
2020
+
keywords = Some [(Draft, true)];
2021
+
received_at = None; (* Server will set this *)
2022
+
message_id = None; (* Server will generate this *)
2023
+
in_reply_to = None;
2024
+
references = None;
2026
+
from = Some [from_addr];
2027
+
to_ = Some to_addrs;
2031
+
subject = Some subject;
2032
+
body_values = Some body_values;
2033
+
text_body = Some [text_part];
2034
+
html_body = html_body_list;
2035
+
attachments = None;
2041
+
Jmap.Capability.to_string Jmap.Capability.Core;
2042
+
Capability.to_string Capability.Mail
2046
+
name = "Email/set";
2048
+
("accountId", `String account_id);
2052
+
("mailboxIds", `O [(mailbox_id, `Bool true)]);
2053
+
("keywords", `O [("$draft", `Bool true)]);
2054
+
("from", `A [`O [("name", `Null); ("email", `String from)]]);
2055
+
("to", `A (List.map (fun addr ->
2056
+
`O [("name", `Null); ("email", `String addr)]
2058
+
("subject", `String subject);
2059
+
("bodyStructure", `O [
2060
+
("type", `String "multipart/alternative");
2063
+
("partId", `String "part1");
2064
+
("type", `String "text/plain")
2067
+
("partId", `String "part2");
2068
+
("type", `String "text/html")
2072
+
("bodyValues", `O ([
2073
+
("part1", `O [("value", `String text_body)])
2074
+
] @ (match html_body with
2075
+
| Some html -> [("part2", `O [("value", `String html)])]
2076
+
| None -> [("part2", `O [("value", `String ("<html><body>" ^ text_body ^ "</body></html>"))])]
2082
+
method_call_id = "m1";
2085
+
created_ids = None;
2088
+
let* response_result = make_request conn.config request in
2089
+
match response_result with
2093
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2094
+
inv.name = "Email/set") response.method_responses in
2095
+
let args = method_response.arguments in
2096
+
match Ezjsonm.find_opt args ["created"] with
2097
+
| Some (`O created) ->
2098
+
let draft_created = List.find_opt (fun (id, _) -> id = "draft1") created in
2099
+
(match draft_created with
2100
+
| Some (_, json) ->
2101
+
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
2103
+
| None -> Error (Parse_error "Created email not found in response"))
2105
+
match Ezjsonm.find_opt args ["notCreated"] with
2106
+
| Some (`O errors) ->
2107
+
let error_msg = match List.find_opt (fun (id, _) -> id = "draft1") errors with
2108
+
| Some (_, err) ->
2109
+
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
2111
+
match Ezjsonm.find_opt err ["description"] with
2112
+
| Some (`String desc) -> desc
2113
+
| _ -> "Unknown error"
2115
+
"Error type: " ^ type_ ^ ", Description: " ^ description
2116
+
| None -> "Unknown error"
2118
+
Error (Parse_error ("Failed to create email: " ^ error_msg))
2119
+
| _ -> Error (Parse_error "Unexpected response format")
2121
+
| Not_found -> Error (Parse_error "Email/set method response not found")
2122
+
| e -> Error (Parse_error (Printexc.to_string e))
2125
+
| Error e -> Lwt.return (Error e)
2127
+
(** Get all identities for an account
2128
+
@param conn The JMAP connection
2129
+
@param account_id The account ID
2130
+
@return A list of identities if successful
2134
+
let get_identities conn ~account_id =
2137
+
Jmap.Capability.to_string Jmap.Capability.Core;
2138
+
Capability.to_string Capability.Submission
2142
+
name = "Identity/get";
2144
+
("accountId", `String account_id);
2146
+
method_call_id = "m1";
2149
+
created_ids = None;
2152
+
let* response_result = make_request conn.config request in
2153
+
match response_result with
2157
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2158
+
inv.name = "Identity/get") response.method_responses in
2159
+
let args = method_response.arguments in
2160
+
match Ezjsonm.find_opt args ["list"] with
2161
+
| Some (`A identities) ->
2162
+
let parse_identity json =
2164
+
let open Ezjsonm in
2165
+
let id = get_string (find json ["id"]) in
2166
+
let name = get_string (find json ["name"]) in
2167
+
let email = get_string (find json ["email"]) in
2169
+
let parse_email_addresses field =
2170
+
match find_opt json [field] with
2171
+
| Some (`A items) ->
2172
+
Some (List.map (fun addr_json ->
2174
+
match find_opt addr_json ["name"] with
2175
+
| Some (`String s) -> Some s
2176
+
| Some (`Null) -> None
2180
+
let email = get_string (find addr_json ["email"]) in
2182
+
match find_opt addr_json ["parameters"] with
2183
+
| Some (`O items) -> List.map (fun (k, v) ->
2185
+
| `String s -> (k, s)
2190
+
{ Types.name; email; parameters }
2195
+
let reply_to = parse_email_addresses "replyTo" in
2196
+
let bcc = parse_email_addresses "bcc" in
2198
+
let text_signature =
2199
+
match find_opt json ["textSignature"] with
2200
+
| Some (`String s) -> Some s
2204
+
let html_signature =
2205
+
match find_opt json ["htmlSignature"] with
2206
+
| Some (`String s) -> Some s
2211
+
match find_opt json ["mayDelete"] with
2212
+
| Some (`Bool b) -> b
2216
+
(* Create our own identity record for simplicity *)
2217
+
let r : Types.identity = {
2221
+
reply_to = reply_to;
2223
+
text_signature = text_signature;
2224
+
html_signature = html_signature;
2225
+
may_delete = may_delete
2228
+
| Not_found -> Error (Parse_error "Required field not found in identity object")
2229
+
| Invalid_argument msg -> Error (Parse_error msg)
2230
+
| e -> Error (Parse_error (Printexc.to_string e))
2233
+
let results = List.map parse_identity identities in
2234
+
let (successes, failures) = List.partition Result.is_ok results in
2235
+
if List.length failures > 0 then
2236
+
Error (Parse_error "Failed to parse some identity objects")
2238
+
Ok (List.map Result.get_ok successes)
2239
+
| _ -> Error (Parse_error "Identity list not found in response")
2241
+
| Not_found -> Error (Parse_error "Identity/get method response not found")
2242
+
| e -> Error (Parse_error (Printexc.to_string e))
2245
+
| Error e -> Lwt.return (Error e)
2247
+
(** Find a suitable identity by email address
2248
+
@param conn The JMAP connection
2249
+
@param account_id The account ID
2250
+
@param email The email address to match
2251
+
@return The identity if found, otherwise Error
2255
+
let find_identity_by_email conn ~account_id ~email =
2256
+
let* identities_result = get_identities conn ~account_id in
2257
+
match identities_result with
2258
+
| Ok identities -> begin
2259
+
let matching_identity = List.find_opt (fun (identity:Types.identity) ->
2261
+
if String.lowercase_ascii identity.email = String.lowercase_ascii email then
2264
+
(* Wildcard match (e.g., *@example.com) *)
2265
+
let parts = String.split_on_char '@' identity.email in
2266
+
if List.length parts = 2 && List.hd parts = "*" then
2267
+
let domain = List.nth parts 1 in
2268
+
let email_parts = String.split_on_char '@' email in
2269
+
if List.length email_parts = 2 then
2270
+
List.nth email_parts 1 = domain
2277
+
match matching_identity with
2278
+
| Some identity -> Lwt.return (Ok identity)
2279
+
| None -> Lwt.return (Error (Parse_error "No matching identity found"))
2281
+
| Error e -> Lwt.return (Error e)
2283
+
(** Submit an email for delivery
2284
+
@param conn The JMAP connection
2285
+
@param account_id The account ID
2286
+
@param identity_id The identity ID to send from
2287
+
@param email_id The email ID to submit
2288
+
@param envelope Optional custom envelope
2289
+
@return The submission ID if successful
2293
+
let submit_email conn ~account_id ~identity_id ~email_id ?envelope () =
2296
+
Jmap.Capability.to_string Jmap.Capability.Core;
2297
+
Capability.to_string Capability.Mail;
2298
+
Capability.to_string Capability.Submission
2302
+
name = "EmailSubmission/set";
2304
+
("accountId", `String account_id);
2306
+
("submission1", `O (
2308
+
("emailId", `String email_id);
2309
+
("identityId", `String identity_id);
2310
+
] @ (match envelope with
2314
+
("email", `String env.Types.mail_from.email);
2315
+
("parameters", match env.Types.mail_from.parameters with
2316
+
| Some params -> `O (List.map (fun (k, v) -> (k, `String v)) params)
2320
+
("rcptTo", `A (List.map (fun (rcpt:Types.submission_address) ->
2322
+
("email", `String rcpt.Types.email);
2323
+
("parameters", match rcpt.Types.parameters with
2324
+
| Some params -> `O (List.map (fun (k, v) -> (k, `String v)) params)
2328
+
) env.Types.rcpt_to))
2335
+
("onSuccessUpdateEmail", `O [
2338
+
("$draft", `Bool false);
2339
+
("$sent", `Bool true);
2344
+
method_call_id = "m1";
2347
+
created_ids = None;
2350
+
let* response_result = make_request conn.config request in
2351
+
match response_result with
2355
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2356
+
inv.name = "EmailSubmission/set") response.method_responses in
2357
+
let args = method_response.arguments in
2358
+
match Ezjsonm.find_opt args ["created"] with
2359
+
| Some (`O created) ->
2360
+
let submission_created = List.find_opt (fun (id, _) -> id = "submission1") created in
2361
+
(match submission_created with
2362
+
| Some (_, json) ->
2363
+
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
2365
+
| None -> Error (Parse_error "Created submission not found in response"))
2367
+
match Ezjsonm.find_opt args ["notCreated"] with
2368
+
| Some (`O errors) ->
2369
+
let error_msg = match List.find_opt (fun (id, _) -> id = "submission1") errors with
2370
+
| Some (_, err) ->
2371
+
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
2373
+
match Ezjsonm.find_opt err ["description"] with
2374
+
| Some (`String desc) -> desc
2375
+
| _ -> "Unknown error"
2377
+
"Error type: " ^ type_ ^ ", Description: " ^ description
2378
+
| None -> "Unknown error"
2380
+
Error (Parse_error ("Failed to submit email: " ^ error_msg))
2381
+
| _ -> Error (Parse_error "Unexpected response format")
2383
+
| Not_found -> Error (Parse_error "EmailSubmission/set method response not found")
2384
+
| e -> Error (Parse_error (Printexc.to_string e))
2387
+
| Error e -> Lwt.return (Error e)
2389
+
(** Create and submit an email in one operation
2390
+
@param conn The JMAP connection
2391
+
@param account_id The account ID
2392
+
@param from The sender's email address
2393
+
@param to_addresses List of recipient email addresses
2394
+
@param subject The email subject line
2395
+
@param text_body Plain text message body
2396
+
@param html_body Optional HTML message body
2397
+
@return The submission ID if successful
2401
+
let create_and_submit_email conn ~account_id ~from ~to_addresses ~subject ~text_body ?html_body:_ () =
2402
+
(* First get accounts to find the draft mailbox and identity in a single request *)
2403
+
let* initial_result =
2406
+
Jmap.Capability.to_string Jmap.Capability.Core;
2407
+
Capability.to_string Capability.Mail;
2408
+
Capability.to_string Capability.Submission
2412
+
name = "Mailbox/get";
2414
+
("accountId", `String account_id);
2416
+
method_call_id = "m1";
2419
+
name = "Identity/get";
2421
+
("accountId", `String account_id)
2423
+
method_call_id = "m2";
2426
+
created_ids = None;
2428
+
make_request conn.config request
2431
+
match initial_result with
2432
+
| Ok initial_response -> begin
2433
+
(* Find drafts mailbox ID *)
2434
+
let find_drafts_result =
2436
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2437
+
inv.name = "Mailbox/get") initial_response.method_responses in
2438
+
let args = method_response.arguments in
2439
+
match Ezjsonm.find_opt args ["list"] with
2440
+
| Some (`A mailboxes) -> begin
2441
+
let draft_mailbox = List.find_opt (fun mailbox ->
2442
+
match Ezjsonm.find_opt mailbox ["role"] with
2443
+
| Some (`String role) -> role = "drafts"
2447
+
match draft_mailbox with
2448
+
| Some mb -> Ok (Ezjsonm.get_string (Ezjsonm.find mb ["id"]))
2449
+
| None -> Error (Parse_error "No drafts mailbox found")
2451
+
| _ -> Error (Parse_error "Mailbox list not found in response")
2453
+
| Not_found -> Error (Parse_error "Mailbox/get method response not found")
2454
+
| e -> Error (Parse_error (Printexc.to_string e))
2457
+
(* Find matching identity for from address *)
2458
+
let find_identity_result =
2460
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2461
+
inv.name = "Identity/get") initial_response.method_responses in
2462
+
let args = method_response.arguments in
2463
+
match Ezjsonm.find_opt args ["list"] with
2464
+
| Some (`A identities) -> begin
2465
+
let matching_identity = List.find_opt (fun identity ->
2466
+
match Ezjsonm.find_opt identity ["email"] with
2467
+
| Some (`String email) ->
2468
+
let email_lc = String.lowercase_ascii email in
2469
+
let from_lc = String.lowercase_ascii from in
2470
+
email_lc = from_lc || (* Exact match *)
2471
+
(* Wildcard domain match *)
2472
+
(let parts = String.split_on_char '@' email_lc in
2473
+
if List.length parts = 2 && List.hd parts = "*" then
2474
+
let domain = List.nth parts 1 in
2475
+
let from_parts = String.split_on_char '@' from_lc in
2476
+
if List.length from_parts = 2 then
2477
+
List.nth from_parts 1 = domain
2483
+
match matching_identity with
2485
+
let identity_id = Ezjsonm.get_string (Ezjsonm.find id ["id"]) in
2487
+
| None -> Error (Parse_error ("No matching identity found for " ^ from))
2489
+
| _ -> Error (Parse_error "Identity list not found in response")
2491
+
| Not_found -> Error (Parse_error "Identity/get method response not found")
2492
+
| e -> Error (Parse_error (Printexc.to_string e))
2495
+
(* If we have both required IDs, create and submit the email in one request *)
2496
+
match (find_drafts_result, find_identity_result) with
2497
+
| (Ok drafts_id, Ok identity_id) -> begin
2498
+
(* Now create and submit the email in a single request *)
2501
+
Jmap.Capability.to_string Jmap.Capability.Core;
2502
+
Capability.to_string Capability.Mail;
2503
+
Capability.to_string Capability.Submission
2507
+
name = "Email/set";
2509
+
("accountId", `String account_id);
2513
+
("mailboxIds", `O [(drafts_id, `Bool true)]);
2514
+
("keywords", `O [("$draft", `Bool true)]);
2515
+
("from", `A [`O [("email", `String from)]]);
2516
+
("to", `A (List.map (fun addr ->
2517
+
`O [("email", `String addr)]
2519
+
("subject", `String subject);
2520
+
("textBody", `A [`O [
2521
+
("partId", `String "body");
2522
+
("type", `String "text/plain")
2524
+
("bodyValues", `O [
2526
+
("charset", `String "utf-8");
2527
+
("value", `String text_body)
2534
+
method_call_id = "0";
2537
+
name = "EmailSubmission/set";
2539
+
("accountId", `String account_id);
2542
+
("emailId", `String "#draft");
2543
+
("identityId", `String identity_id)
2547
+
method_call_id = "1";
2550
+
created_ids = None;
2553
+
let* submit_result = make_request conn.config request in
2554
+
match submit_result with
2555
+
| Ok submit_response -> begin
2557
+
let submission_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2558
+
inv.name = "EmailSubmission/set") submit_response.method_responses in
2559
+
let args = submission_method.arguments in
2561
+
(* Check if email was created and submission was created *)
2562
+
match Ezjsonm.find_opt args ["created"] with
2563
+
| Some (`O created) -> begin
2564
+
(* Extract the submission ID *)
2565
+
let submission_created = List.find_opt (fun (id, _) -> id = "sendIt") created in
2566
+
match submission_created with
2567
+
| Some (_, json) ->
2568
+
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
2569
+
Lwt.return (Ok id)
2571
+
(* Check if there was an error in creation *)
2572
+
match Ezjsonm.find_opt args ["notCreated"] with
2573
+
| Some (`O errors) ->
2574
+
let error_msg = match List.find_opt (fun (id, _) -> id = "sendIt") errors with
2575
+
| Some (_, err) ->
2576
+
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
2578
+
match Ezjsonm.find_opt err ["description"] with
2579
+
| Some (`String desc) -> desc
2580
+
| _ -> "Unknown error"
2582
+
"Error type: " ^ type_ ^ ", Description: " ^ description
2583
+
| None -> "Unknown error"
2585
+
Lwt.return (Error (Parse_error ("Failed to submit email: " ^ error_msg)))
2586
+
| Some _ -> Lwt.return (Error (Parse_error "Email submission not found in response"))
2587
+
| None -> Lwt.return (Error (Parse_error "Email submission not found in response"))
2590
+
| Some (`Null) -> Lwt.return (Error (Parse_error "No created submissions in response"))
2591
+
| Some _ -> Lwt.return (Error (Parse_error "Invalid response format for created submissions"))
2592
+
| None -> Lwt.return (Error (Parse_error "No created submissions in response"))
2594
+
| Not_found -> Lwt.return (Error (Parse_error "EmailSubmission/set method response not found"))
2595
+
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e)))
2597
+
| Error e -> Lwt.return (Error e)
2599
+
| (Error e, _) -> Lwt.return (Error e)
2600
+
| (_, Error e) -> Lwt.return (Error e)
2602
+
| Error e -> Lwt.return (Error e)
2604
+
(** Get status of an email submission
2605
+
@param conn The JMAP connection
2606
+
@param account_id The account ID
2607
+
@param submission_id The email submission ID
2608
+
@return The submission status if successful
2612
+
let get_submission_status conn ~account_id ~submission_id =
2615
+
Jmap.Capability.to_string Jmap.Capability.Core;
2616
+
Capability.to_string Capability.Submission
2620
+
name = "EmailSubmission/get";
2622
+
("accountId", `String account_id);
2623
+
("ids", `A [`String submission_id]);
2625
+
method_call_id = "m1";
2628
+
created_ids = None;
2631
+
let* response_result = make_request conn.config request in
2632
+
match response_result with
2636
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2637
+
inv.name = "EmailSubmission/get") response.method_responses in
2638
+
let args = method_response.arguments in
2639
+
match Ezjsonm.find_opt args ["list"] with
2640
+
| Some (`A [submission]) ->
2641
+
let parse_submission json =
2643
+
let open Ezjsonm in
2644
+
let id = get_string (find json ["id"]) in
2645
+
let identity_id = get_string (find json ["identityId"]) in
2646
+
let email_id = get_string (find json ["emailId"]) in
2647
+
let thread_id = get_string (find json ["threadId"]) in
2650
+
match find_opt json ["envelope"] with
2651
+
| Some (`O env) -> begin
2652
+
let parse_address addr_json =
2653
+
let email = get_string (find addr_json ["email"]) in
2655
+
match find_opt addr_json ["parameters"] with
2656
+
| Some (`O params) ->
2657
+
Some (List.map (fun (k, v) -> (k, get_string v)) params)
2660
+
{ Types.email; parameters }
2663
+
let mail_from = parse_address (find (`O env) ["mailFrom"]) in
2665
+
match find (`O env) ["rcptTo"] with
2666
+
| `A rcpts -> List.map parse_address rcpts
2670
+
Some { Types.mail_from; rcpt_to }
2676
+
match find_opt json ["sendAt"] with
2677
+
| Some (`String date) -> Some date
2682
+
match find_opt json ["undoStatus"] with
2683
+
| Some (`String "pending") -> Some `pending
2684
+
| Some (`String "final") -> Some `final
2685
+
| Some (`String "canceled") -> Some `canceled
2689
+
let parse_delivery_status deliveries =
2690
+
match deliveries with
2692
+
Some (List.map (fun (email, status_json) ->
2693
+
let smtp_reply = get_string (find status_json ["smtpReply"]) in
2695
+
match find_opt status_json ["delivered"] with
2696
+
| Some (`String d) -> Some d
2699
+
(email, { Types.smtp_reply; delivered })
2704
+
let delivery_status =
2705
+
match find_opt json ["deliveryStatus"] with
2706
+
| Some status -> parse_delivery_status status
2710
+
let dsn_blob_ids =
2711
+
match find_opt json ["dsnBlobIds"] with
2712
+
| Some (`O ids) -> Some (List.map (fun (email, id) -> (email, get_string id)) ids)
2716
+
let mdn_blob_ids =
2717
+
match find_opt json ["mdnBlobIds"] with
2718
+
| Some (`O ids) -> Some (List.map (fun (email, id) -> (email, get_string id)) ids)
2735
+
| Not_found -> Error (Parse_error "Required field not found in submission object")
2736
+
| Invalid_argument msg -> Error (Parse_error msg)
2737
+
| e -> Error (Parse_error (Printexc.to_string e))
2740
+
parse_submission submission
2741
+
| Some (`A []) -> Error (Parse_error ("Submission not found: " ^ submission_id))
2742
+
| _ -> Error (Parse_error "Expected single submission in response")
2744
+
| Not_found -> Error (Parse_error "EmailSubmission/get method response not found")
2745
+
| e -> Error (Parse_error (Printexc.to_string e))
2748
+
| Error e -> Lwt.return (Error e)
(** {1 Email Address Utilities} *)
(** Custom implementation of substring matching *)
anil.recoil.org