···
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
| Error e -> Lwt.return (Error e)
+
(** {1 Email Submission} *)
+
(** Create a new email draft
+
@param conn The JMAP connection
+
@param account_id The account ID
+
@param mailbox_id The mailbox ID to store the draft in (usually "drafts")
+
@param from The sender's email address
+
@param to_addresses List of recipient email addresses
+
@param subject The email subject line
+
@param text_body Plain text message body
+
@param html_body Optional HTML message body
+
@return The created email ID if successful
+
let create_email_draft conn ~account_id ~mailbox_id ~from ~to_addresses ~subject ~text_body ?html_body () =
+
(* Create email addresses *)
+
let to_addrs = List.map (fun addr -> {
+
(* Create text body part *)
+
Types.part_id = Some "part1";
+
type_ = Some "text/plain";
+
charset = Some "utf-8";
+
header_parameter_name = None;
+
header_parameter_value = None;
+
(* Create HTML body part if provided *)
+
let html_part_opt = match html_body with
+
Types.part_id = Some "part2";
+
type_ = Some "text/html";
+
charset = Some "utf-8";
+
header_parameter_name = None;
+
header_parameter_value = None;
+
(* Create body values *)
+
] @ (match html_body with
+
| Some html -> [("part2", html)]
+
let html_body_list = match html_part_opt with
+
| Some part -> Some [part]
+
let _email_creation = {
+
Types.mailbox_ids = [(mailbox_id, true)];
+
keywords = Some [(Draft, true)];
+
received_at = None; (* Server will set this *)
+
message_id = None; (* Server will generate this *)
+
from = Some [from_addr];
+
subject = Some subject;
+
body_values = Some body_values;
+
text_body = Some [text_part];
+
html_body = html_body_list;
+
Jmap.Capability.to_string Jmap.Capability.Core;
+
Capability.to_string Capability.Mail
+
("accountId", `String account_id);
+
("mailboxIds", `O [(mailbox_id, `Bool true)]);
+
("keywords", `O [("$draft", `Bool true)]);
+
("from", `A [`O [("name", `Null); ("email", `String from)]]);
+
("to", `A (List.map (fun addr ->
+
`O [("name", `Null); ("email", `String addr)]
+
("subject", `String subject);
+
("type", `String "multipart/alternative");
+
("partId", `String "part1");
+
("type", `String "text/plain")
+
("partId", `String "part2");
+
("type", `String "text/html")
+
("part1", `O [("value", `String text_body)])
+
] @ (match html_body with
+
| Some html -> [("part2", `O [("value", `String html)])]
+
| None -> [("part2", `O [("value", `String ("<html><body>" ^ text_body ^ "</body></html>"))])]
+
let* response_result = make_request conn.config request in
+
match response_result with
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
+
inv.name = "Email/set") response.method_responses in
+
let args = method_response.arguments in
+
match Ezjsonm.find_opt args ["created"] with
+
let draft_created = List.find_opt (fun (id, _) -> id = "draft1") created in
+
(match draft_created with
+
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
+
| None -> Error (Parse_error "Created email not found in response"))
+
match Ezjsonm.find_opt args ["notCreated"] with
+
let error_msg = match List.find_opt (fun (id, _) -> id = "draft1") errors with
+
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
+
match Ezjsonm.find_opt err ["description"] with
+
| Some (`String desc) -> desc
+
"Error type: " ^ type_ ^ ", Description: " ^ description
+
| None -> "Unknown error"
+
Error (Parse_error ("Failed to create email: " ^ error_msg))
+
| _ -> Error (Parse_error "Unexpected response format")
+
| Not_found -> Error (Parse_error "Email/set method response not found")
+
| e -> Error (Parse_error (Printexc.to_string e))
+
| Error e -> Lwt.return (Error e)
+
(** Get all identities for an account
+
@param conn The JMAP connection
+
@param account_id The account ID
+
@return A list of identities if successful
+
let get_identities conn ~account_id =
+
Jmap.Capability.to_string Jmap.Capability.Core;
+
Capability.to_string Capability.Submission
+
("accountId", `String account_id);
+
let* response_result = make_request conn.config request in
+
match response_result with
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
+
inv.name = "Identity/get") response.method_responses in
+
let args = method_response.arguments in
+
match Ezjsonm.find_opt args ["list"] with
+
| Some (`A identities) ->
+
let parse_identity json =
+
let id = get_string (find json ["id"]) in
+
let name = get_string (find json ["name"]) in
+
let email = get_string (find json ["email"]) in
+
let parse_email_addresses field =
+
match find_opt json [field] with
+
Some (List.map (fun addr_json ->
+
match find_opt addr_json ["name"] with
+
| Some (`String s) -> Some s
+
let email = get_string (find addr_json ["email"]) in
+
match find_opt addr_json ["parameters"] with
+
| Some (`O items) -> List.map (fun (k, v) ->
+
{ Types.name; email; parameters }
+
let reply_to = parse_email_addresses "replyTo" in
+
let bcc = parse_email_addresses "bcc" in
+
match find_opt json ["textSignature"] with
+
| Some (`String s) -> Some s
+
match find_opt json ["htmlSignature"] with
+
| Some (`String s) -> Some s
+
match find_opt json ["mayDelete"] with
+
(* Create our own identity record for simplicity *)
+
let r : Types.identity = {
+
text_signature = text_signature;
+
html_signature = html_signature;
+
may_delete = may_delete
+
| Not_found -> Error (Parse_error "Required field not found in identity object")
+
| Invalid_argument msg -> Error (Parse_error msg)
+
| e -> Error (Parse_error (Printexc.to_string e))
+
let results = List.map parse_identity identities in
+
let (successes, failures) = List.partition Result.is_ok results in
+
if List.length failures > 0 then
+
Error (Parse_error "Failed to parse some identity objects")
+
Ok (List.map Result.get_ok successes)
+
| _ -> Error (Parse_error "Identity list not found in response")
+
| Not_found -> Error (Parse_error "Identity/get method response not found")
+
| e -> Error (Parse_error (Printexc.to_string e))
+
| Error e -> Lwt.return (Error e)
+
(** Find a suitable identity by email address
+
@param conn The JMAP connection
+
@param account_id The account ID
+
@param email The email address to match
+
@return The identity if found, otherwise Error
+
let find_identity_by_email conn ~account_id ~email =
+
let* identities_result = get_identities conn ~account_id in
+
match identities_result with
+
| Ok identities -> begin
+
let matching_identity = List.find_opt (fun (identity:Types.identity) ->
+
if String.lowercase_ascii identity.email = String.lowercase_ascii email then
+
(* Wildcard match (e.g., *@example.com) *)
+
let parts = String.split_on_char '@' identity.email in
+
if List.length parts = 2 && List.hd parts = "*" then
+
let domain = List.nth parts 1 in
+
let email_parts = String.split_on_char '@' email in
+
if List.length email_parts = 2 then
+
List.nth email_parts 1 = domain
+
match matching_identity with
+
| Some identity -> Lwt.return (Ok identity)
+
| None -> Lwt.return (Error (Parse_error "No matching identity found"))
+
| Error e -> Lwt.return (Error e)
+
(** Submit an email for delivery
+
@param conn The JMAP connection
+
@param account_id The account ID
+
@param identity_id The identity ID to send from
+
@param email_id The email ID to submit
+
@param envelope Optional custom envelope
+
@return The submission ID if successful
+
let submit_email conn ~account_id ~identity_id ~email_id ?envelope () =
+
Jmap.Capability.to_string Jmap.Capability.Core;
+
Capability.to_string Capability.Mail;
+
Capability.to_string Capability.Submission
+
name = "EmailSubmission/set";
+
("accountId", `String account_id);
+
("emailId", `String email_id);
+
("identityId", `String identity_id);
+
] @ (match envelope with
+
("email", `String env.Types.mail_from.email);
+
("parameters", match env.Types.mail_from.parameters with
+
| Some params -> `O (List.map (fun (k, v) -> (k, `String v)) params)
+
("rcptTo", `A (List.map (fun (rcpt:Types.submission_address) ->
+
("email", `String rcpt.Types.email);
+
("parameters", match rcpt.Types.parameters with
+
| Some params -> `O (List.map (fun (k, v) -> (k, `String v)) params)
+
("onSuccessUpdateEmail", `O [
+
("$draft", `Bool false);
+
let* response_result = make_request conn.config request in
+
match response_result with
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
+
inv.name = "EmailSubmission/set") response.method_responses in
+
let args = method_response.arguments in
+
match Ezjsonm.find_opt args ["created"] with
+
let submission_created = List.find_opt (fun (id, _) -> id = "submission1") created in
+
(match submission_created with
+
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
+
| None -> Error (Parse_error "Created submission not found in response"))
+
match Ezjsonm.find_opt args ["notCreated"] with
+
let error_msg = match List.find_opt (fun (id, _) -> id = "submission1") errors with
+
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
+
match Ezjsonm.find_opt err ["description"] with
+
| Some (`String desc) -> desc
+
"Error type: " ^ type_ ^ ", Description: " ^ description
+
| None -> "Unknown error"
+
Error (Parse_error ("Failed to submit email: " ^ error_msg))
+
| _ -> Error (Parse_error "Unexpected response format")
+
| Not_found -> Error (Parse_error "EmailSubmission/set method response not found")
+
| e -> Error (Parse_error (Printexc.to_string e))
+
| Error e -> Lwt.return (Error e)
+
(** Create and submit an email in one operation
+
@param conn The JMAP connection
+
@param account_id The account ID
+
@param from The sender's email address
+
@param to_addresses List of recipient email addresses
+
@param subject The email subject line
+
@param text_body Plain text message body
+
@param html_body Optional HTML message body
+
@return The submission ID if successful
+
let create_and_submit_email conn ~account_id ~from ~to_addresses ~subject ~text_body ?html_body:_ () =
+
(* First get accounts to find the draft mailbox and identity in a single request *)
+
Jmap.Capability.to_string Jmap.Capability.Core;
+
Capability.to_string Capability.Mail;
+
Capability.to_string Capability.Submission
+
("accountId", `String account_id);
+
("accountId", `String account_id)
+
make_request conn.config request
+
match initial_result with
+
| Ok initial_response -> begin
+
(* Find drafts mailbox ID *)
+
let find_drafts_result =
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
+
inv.name = "Mailbox/get") initial_response.method_responses in
+
let args = method_response.arguments in
+
match Ezjsonm.find_opt args ["list"] with
+
| Some (`A mailboxes) -> begin
+
let draft_mailbox = List.find_opt (fun mailbox ->
+
match Ezjsonm.find_opt mailbox ["role"] with
+
| Some (`String role) -> role = "drafts"
+
match draft_mailbox with
+
| Some mb -> Ok (Ezjsonm.get_string (Ezjsonm.find mb ["id"]))
+
| None -> Error (Parse_error "No drafts mailbox found")
+
| _ -> Error (Parse_error "Mailbox list not found in response")
+
| Not_found -> Error (Parse_error "Mailbox/get method response not found")
+
| e -> Error (Parse_error (Printexc.to_string e))
+
(* Find matching identity for from address *)
+
let find_identity_result =
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
+
inv.name = "Identity/get") initial_response.method_responses in
+
let args = method_response.arguments in
+
match Ezjsonm.find_opt args ["list"] with
+
| Some (`A identities) -> begin
+
let matching_identity = List.find_opt (fun identity ->
+
match Ezjsonm.find_opt identity ["email"] with
+
| Some (`String email) ->
+
let email_lc = String.lowercase_ascii email in
+
let from_lc = String.lowercase_ascii from in
+
email_lc = from_lc || (* Exact match *)
+
(* Wildcard domain match *)
+
(let parts = String.split_on_char '@' email_lc in
+
if List.length parts = 2 && List.hd parts = "*" then
+
let domain = List.nth parts 1 in
+
let from_parts = String.split_on_char '@' from_lc in
+
if List.length from_parts = 2 then
+
List.nth from_parts 1 = domain
+
match matching_identity with
+
let identity_id = Ezjsonm.get_string (Ezjsonm.find id ["id"]) in
+
| None -> Error (Parse_error ("No matching identity found for " ^ from))
+
| _ -> Error (Parse_error "Identity list not found in response")
+
| Not_found -> Error (Parse_error "Identity/get method response not found")
+
| e -> Error (Parse_error (Printexc.to_string e))
+
(* If we have both required IDs, create and submit the email in one request *)
+
match (find_drafts_result, find_identity_result) with
+
| (Ok drafts_id, Ok identity_id) -> begin
+
(* Now create and submit the email in a single request *)
+
Jmap.Capability.to_string Jmap.Capability.Core;
+
Capability.to_string Capability.Mail;
+
Capability.to_string Capability.Submission
+
("accountId", `String account_id);
+
("mailboxIds", `O [(drafts_id, `Bool true)]);
+
("keywords", `O [("$draft", `Bool true)]);
+
("from", `A [`O [("email", `String from)]]);
+
("to", `A (List.map (fun addr ->
+
`O [("email", `String addr)]
+
("subject", `String subject);
+
("partId", `String "body");
+
("type", `String "text/plain")
+
("charset", `String "utf-8");
+
("value", `String text_body)
+
name = "EmailSubmission/set";
+
("accountId", `String account_id);
+
("emailId", `String "#draft");
+
("identityId", `String identity_id)
+
let* submit_result = make_request conn.config request in
+
match submit_result with
+
| Ok submit_response -> begin
+
let submission_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
+
inv.name = "EmailSubmission/set") submit_response.method_responses in
+
let args = submission_method.arguments in
+
(* Check if email was created and submission was created *)
+
match Ezjsonm.find_opt args ["created"] with
+
| Some (`O created) -> begin
+
(* Extract the submission ID *)
+
let submission_created = List.find_opt (fun (id, _) -> id = "sendIt") created in
+
match submission_created with
+
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
+
(* Check if there was an error in creation *)
+
match Ezjsonm.find_opt args ["notCreated"] with
+
let error_msg = match List.find_opt (fun (id, _) -> id = "sendIt") errors with
+
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
+
match Ezjsonm.find_opt err ["description"] with
+
| Some (`String desc) -> desc
+
"Error type: " ^ type_ ^ ", Description: " ^ description
+
| None -> "Unknown error"
+
Lwt.return (Error (Parse_error ("Failed to submit email: " ^ error_msg)))
+
| Some _ -> Lwt.return (Error (Parse_error "Email submission not found in response"))
+
| None -> Lwt.return (Error (Parse_error "Email submission not found in response"))
+
| Some (`Null) -> Lwt.return (Error (Parse_error "No created submissions in response"))
+
| Some _ -> Lwt.return (Error (Parse_error "Invalid response format for created submissions"))
+
| None -> Lwt.return (Error (Parse_error "No created submissions in response"))
+
| Not_found -> Lwt.return (Error (Parse_error "EmailSubmission/set method response not found"))
+
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e)))
+
| Error e -> Lwt.return (Error e)
+
| (Error e, _) -> Lwt.return (Error e)
+
| (_, Error e) -> Lwt.return (Error e)
+
| Error e -> Lwt.return (Error e)
+
(** Get status of an email submission
+
@param conn The JMAP connection
+
@param account_id The account ID
+
@param submission_id The email submission ID
+
@return The submission status if successful
+
let get_submission_status conn ~account_id ~submission_id =
+
Jmap.Capability.to_string Jmap.Capability.Core;
+
Capability.to_string Capability.Submission
+
name = "EmailSubmission/get";
+
("accountId", `String account_id);
+
("ids", `A [`String submission_id]);
+
let* response_result = make_request conn.config request in
+
match response_result with
+
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
+
inv.name = "EmailSubmission/get") response.method_responses in
+
let args = method_response.arguments in
+
match Ezjsonm.find_opt args ["list"] with
+
| Some (`A [submission]) ->
+
let parse_submission json =
+
let id = get_string (find json ["id"]) in
+
let identity_id = get_string (find json ["identityId"]) in
+
let email_id = get_string (find json ["emailId"]) in
+
let thread_id = get_string (find json ["threadId"]) in
+
match find_opt json ["envelope"] with
+
| Some (`O env) -> begin
+
let parse_address addr_json =
+
let email = get_string (find addr_json ["email"]) in
+
match find_opt addr_json ["parameters"] with
+
Some (List.map (fun (k, v) -> (k, get_string v)) params)
+
{ Types.email; parameters }
+
let mail_from = parse_address (find (`O env) ["mailFrom"]) in
+
match find (`O env) ["rcptTo"] with
+
| `A rcpts -> List.map parse_address rcpts
+
Some { Types.mail_from; rcpt_to }
+
match find_opt json ["sendAt"] with
+
| Some (`String date) -> Some date
+
match find_opt json ["undoStatus"] with
+
| Some (`String "pending") -> Some `pending
+
| Some (`String "final") -> Some `final
+
| Some (`String "canceled") -> Some `canceled
+
let parse_delivery_status deliveries =
+
Some (List.map (fun (email, status_json) ->
+
let smtp_reply = get_string (find status_json ["smtpReply"]) in
+
match find_opt status_json ["delivered"] with
+
| Some (`String d) -> Some d
+
(email, { Types.smtp_reply; delivered })
+
match find_opt json ["deliveryStatus"] with
+
| Some status -> parse_delivery_status status
+
match find_opt json ["dsnBlobIds"] with
+
| Some (`O ids) -> Some (List.map (fun (email, id) -> (email, get_string id)) ids)
+
match find_opt json ["mdnBlobIds"] with
+
| Some (`O ids) -> Some (List.map (fun (email, id) -> (email, get_string id)) ids)
+
| Not_found -> Error (Parse_error "Required field not found in submission object")
+
| Invalid_argument msg -> Error (Parse_error msg)
+
| e -> Error (Parse_error (Printexc.to_string e))
+
parse_submission submission
+
| Some (`A []) -> Error (Parse_error ("Submission not found: " ^ submission_id))
+
| _ -> Error (Parse_error "Expected single submission in response")
+
| Not_found -> Error (Parse_error "EmailSubmission/get method response not found")
+
| e -> Error (Parse_error (Printexc.to_string e))
+
| Error e -> Lwt.return (Error e)
(** {1 Email Address Utilities} *)
(** Custom implementation of substring matching *)
anil.recoil.org