My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** High-level email submission API for JMAP clients.
2
3 This module provides ergonomic functions for submitting emails via JMAP,
4 including creating submissions, managing envelopes, and tracking delivery status.
5
6 Based on patterns from rust-jmap for a familiar API design.
7*)
8
9(* open Printf - removed unused *)
10
11(** Result type alias for cleaner signatures *)
12type 'a result = ('a, Jmap.Error.error) Result.t
13
14(** {1 Email Submission Creation} *)
15
16(** Submit an email with minimal configuration.
17
18 Creates an EmailSubmission for the specified email using the given identity.
19 The email will be sent immediately unless the server applies scheduling rules.
20
21 @param env Eio environment for network operations
22 @param ctx Connection context
23 @param email_id The ID of the email to submit
24 @param identity_id The identity to use for sending
25 @return The created EmailSubmission object or an error *)
26let submit_email _env _ctx ~email_id ~identity_id =
27 try
28 (* Get account ID from context *)
29 (* Extract account ID from context - we'll use a placeholder for now
30 In production, this would be extracted from the session *)
31 let account_id = match Jmap.Id.of_string "primary-account" with
32 | Ok id -> id
33 | Error _ -> failwith "Invalid account ID" in
34
35 (* Create the submission *)
36 let submission_create =
37 match Jmap_email.Submission.Create.create ~identity_id ~email_id () with
38 | Ok s -> s
39 | Error msg -> failwith msg
40 in
41
42 (* Build set request *)
43 let set_args = match Jmap_email.Submission.Set_args.create
44 ~account_id
45 ~create:[((match Jmap.Id.of_string "submission-create-1" with
46 | Ok id -> id
47 | Error _ -> failwith "Invalid ID"), submission_create)]
48 () with
49 | Ok args -> args
50 | Error msg -> failwith msg
51 in
52
53 (* Execute request *)
54 (* Build request - for now we'll create the JSON directly
55 In production, this would use the request builder *)
56 let _builder_json = Jmap_email.Submission.Set_args.to_json set_args in
57
58 (* Execute request - for now return a placeholder
59 In production, this would execute via the connection *)
60 match Error (`Protocol_error "Email submission API not yet fully integrated") with
61 | Ok response ->
62 (* Parse response *)
63 (match Jmap.Wire.Response.method_responses response with
64 | Ok invocation :: _ ->
65 let args_json = Jmap.Wire.Invocation.arguments invocation in
66 (match Jmap_email.Submission.Set_response.of_json args_json with
67 | Ok set_response ->
68 let created = Jmap_email.Submission.Set_response.created set_response in
69 (if Hashtbl.length created > 0 then begin
70 (* Get the first created submission *)
71 let submission_response = ref None in
72 Hashtbl.iter (fun _client_id response ->
73 submission_response := Some response
74 ) created;
75 match !submission_response with
76 | Some resp ->
77 (* Build a full submission object from the response *)
78 let id = Jmap_email.Submission.Create.Response.id resp in
79 let thread_id = Jmap_email.Submission.Create.Response.thread_id resp in
80 let send_at = Jmap_email.Submission.Create.Response.send_at resp in
81 (match Jmap_email.Submission.create
82 ~id ~identity_id ~email_id ~thread_id
83 ~send_at ~undo_status:`Pending () with
84 | Ok submission -> Ok submission
85 | Error msg -> Error (`Protocol_error msg))
86 | None -> Error (`Protocol_error "No submission in response")
87 end else
88 (* Check for errors *)
89 match Jmap_email.Submission.Set_response.not_created set_response with
90 | Some not_created when Hashtbl.length not_created > 0 ->
91 let error_msg = ref "Submission failed" in
92 Hashtbl.iter (fun _client_id err ->
93 error_msg := Option.value (Jmap.Error.Set_error.description err)
94 ~default:"Unknown error"
95 ) not_created;
96 Error (`Protocol_error !error_msg)
97 | _ -> Error (`Protocol_error "No submission created"))
98 | Error msg -> Error (`Protocol_error msg))
99 | Error (err, call_id) :: _ ->
100 Error (`Method_error ("EmailSubmission/set", call_id, Jmap.Error.Method_error.type_ err, None))
101 | [] -> Error (`Protocol_error "No method response"))
102 | Error error -> Error error
103 with
104 | Failure msg -> Error (`Protocol_error msg)
105 | exn -> Error (`Protocol_error (Printexc.to_string exn))
106
107(** Submit an email with a custom SMTP envelope.
108
109 Creates an EmailSubmission with explicit SMTP envelope addresses,
110 overriding the addresses derived from the email headers.
111
112 @param env Eio environment for network operations
113 @param ctx Connection context
114 @param email_id The ID of the email to submit
115 @param identity_id The identity to use for sending
116 @param mail_from SMTP MAIL FROM address
117 @param rcpt_to List of SMTP RCPT TO addresses
118 @return The created EmailSubmission object or an error *)
119let submit_email_with_envelope _env _ctx ~email_id ~identity_id ~mail_from ~rcpt_to =
120 try
121 (* Get account ID from context *)
122 (* Extract account ID from context - we'll use a placeholder for now
123 In production, this would be extracted from the session *)
124 let account_id = match Jmap.Id.of_string "primary-account" with
125 | Ok id -> id
126 | Error _ -> failwith "Invalid account ID" in
127
128 (* Create envelope addresses *)
129 let mail_from_addr = match Jmap_email.Submission.EnvelopeAddress.create ~email:mail_from () with
130 | Ok addr -> addr
131 | Error msg -> failwith msg
132 in
133
134 let rcpt_to_addrs = List.map (fun email ->
135 match Jmap_email.Submission.EnvelopeAddress.create ~email () with
136 | Ok addr -> addr
137 | Error msg -> failwith msg
138 ) rcpt_to in
139
140 (* Create envelope *)
141 let envelope = match Jmap_email.Submission.Envelope.create ~mail_from:mail_from_addr ~rcpt_to:rcpt_to_addrs with
142 | Ok env -> env
143 | Error msg -> failwith msg
144 in
145
146 (* Create the submission with envelope *)
147 let submission_create = match Jmap_email.Submission.Create.create ~identity_id ~email_id ~envelope () with
148 | Ok s -> s
149 | Error msg -> failwith msg
150 in
151
152 (* Build set request *)
153 let set_args = match Jmap_email.Submission.Set_args.create
154 ~account_id
155 ~create:[((match Jmap.Id.of_string "submission-create-1" with
156 | Ok id -> id
157 | Error _ -> failwith "Invalid ID"), submission_create)]
158 () with
159 | Ok args -> args
160 | Error msg -> failwith msg
161 in
162
163 (* Execute request *)
164 (* Build request - for now we'll create the JSON directly
165 In production, this would use the request builder *)
166 let _builder_json = Jmap_email.Submission.Set_args.to_json set_args in
167
168 (* Execute request - for now return a placeholder
169 In production, this would execute via the connection *)
170 match Error (`Protocol_error "Email submission API not yet fully integrated") with
171 | Ok response ->
172 (* Parse response - similar to submit_email *)
173 (match Jmap.Wire.Response.method_responses response with
174 | Ok invocation :: _ ->
175 let args_json = Jmap.Wire.Invocation.arguments invocation in
176 (match Jmap_email.Submission.Set_response.of_json args_json with
177 | Ok set_response ->
178 let created = Jmap_email.Submission.Set_response.created set_response in
179 (if Hashtbl.length created > 0 then begin
180 let submission_response = ref None in
181 Hashtbl.iter (fun _client_id response ->
182 submission_response := Some response
183 ) created;
184 match !submission_response with
185 | Some resp ->
186 let id = Jmap_email.Submission.Create.Response.id resp in
187 let thread_id = Jmap_email.Submission.Create.Response.thread_id resp in
188 let send_at = Jmap_email.Submission.Create.Response.send_at resp in
189 (match Jmap_email.Submission.create
190 ~id ~identity_id ~email_id ~thread_id ~envelope
191 ~send_at ~undo_status:`Pending () with
192 | Ok submission -> Ok submission
193 | Error msg -> Error (`Protocol_error msg))
194 | None -> Error (`Protocol_error "No submission in response")
195 end else
196 Error (`Protocol_error "No submission created"))
197 | Error msg -> Error (`Protocol_error msg))
198 | Error (err, call_id) :: _ -> Error (`Method_error ("EmailSubmission/set", call_id, Jmap.Error.Method_error.type_ err, None))
199 | [] -> Error (`Protocol_error "No method response"))
200 | Error error -> Error error
201 with
202 | Failure msg -> Error (`Protocol_error msg)
203 | exn -> Error (`Protocol_error (Printexc.to_string exn))
204
205(** Submit an email and automatically destroy the draft.
206
207 Creates an EmailSubmission and marks the original email for destruction
208 upon successful submission. Useful for sending draft emails.
209
210 @param env Eio environment for network operations
211 @param ctx Connection context
212 @param email_id The ID of the draft email to submit and destroy
213 @param identity_id The identity to use for sending
214 @return The created EmailSubmission object or an error *)
215let submit_and_destroy_draft _env _ctx ~email_id ~identity_id =
216 try
217 (* Get account ID from context *)
218 (* Extract account ID from context - we'll use a placeholder for now
219 In production, this would be extracted from the session *)
220 let account_id = match Jmap.Id.of_string "primary-account" with
221 | Ok id -> id
222 | Error _ -> failwith "Invalid account ID" in
223
224 (* Create the submission *)
225 let submission_create =
226 match Jmap_email.Submission.Create.create ~identity_id ~email_id () with
227 | Ok s -> s
228 | Error msg -> failwith msg
229 in
230
231 (* Build set request with onSuccessDestroyEmail *)
232 let set_args = match Jmap_email.Submission.Set_args.create
233 ~account_id
234 ~create:[((match Jmap.Id.of_string "submission-create-1" with
235 | Ok id -> id
236 | Error _ -> failwith "Invalid ID"), submission_create)]
237 ~on_success_destroy_email:[email_id]
238 () with
239 | Ok args -> args
240 | Error msg -> failwith msg
241 in
242
243 (* Execute request *)
244 (* Build request - for now we'll create the JSON directly
245 In production, this would use the request builder *)
246 let _builder_json = Jmap_email.Submission.Set_args.to_json set_args in
247
248 (* Execute request - for now return a placeholder
249 In production, this would execute via the connection *)
250 match Error (`Protocol_error "Email submission API not yet fully integrated") with
251 | Ok response ->
252 (* Parse response *)
253 (match Jmap.Wire.Response.method_responses response with
254 | Ok invocation :: _ ->
255 let args_json = Jmap.Wire.Invocation.arguments invocation in
256 (match Jmap_email.Submission.Set_response.of_json args_json with
257 | Ok set_response ->
258 let created = Jmap_email.Submission.Set_response.created set_response in
259 (if Hashtbl.length created > 0 then begin
260 let submission_response = ref None in
261 Hashtbl.iter (fun _client_id response ->
262 submission_response := Some response
263 ) created;
264 match !submission_response with
265 | Some resp ->
266 let id = Jmap_email.Submission.Create.Response.id resp in
267 let thread_id = Jmap_email.Submission.Create.Response.thread_id resp in
268 let send_at = Jmap_email.Submission.Create.Response.send_at resp in
269 (match Jmap_email.Submission.create
270 ~id ~identity_id ~email_id ~thread_id
271 ~send_at ~undo_status:`Pending () with
272 | Ok submission -> Ok submission
273 | Error msg -> Error (`Protocol_error msg))
274 | None -> Error (`Protocol_error "No submission in response")
275 end else
276 Error (`Protocol_error "No submission created"))
277 | Error msg -> Error (`Protocol_error msg))
278 | Error (err, call_id) :: _ -> Error (`Method_error ("EmailSubmission/set", call_id, Jmap.Error.Method_error.type_ err, None))
279 | [] -> Error (`Protocol_error "No method response"))
280 | Error error -> Error error
281 with
282 | Failure msg -> Error (`Protocol_error msg)
283 | exn -> Error (`Protocol_error (Printexc.to_string exn))
284
285(** {1 Submission Status Management} *)
286
287(** Cancel a pending email submission.
288
289 Changes the undo status of a pending submission to 'canceled',
290 preventing it from being sent. Only works for submissions with
291 undoStatus = 'pending'.
292
293 @param env Eio environment for network operations
294 @param ctx Connection context
295 @param submission_id The ID of the submission to cancel
296 @return Unit on success or an error *)
297let cancel_submission _env _ctx ~submission_id =
298 try
299 (* Get account ID from context *)
300 (* Extract account ID from context - we'll use a placeholder for now
301 In production, this would be extracted from the session *)
302 let account_id = match Jmap.Id.of_string "primary-account" with
303 | Ok id -> id
304 | Error _ -> failwith "Invalid account ID" in
305
306 (* Create update to cancel *)
307 let cancel_update = match Jmap_email.Submission.Update.cancel with
308 | Ok update -> update
309 | Error msg -> failwith msg
310 in
311
312 (* Build set request *)
313 let set_args = match Jmap_email.Submission.Set_args.create
314 ~account_id
315 ~update:[(submission_id, cancel_update)]
316 () with
317 | Ok args -> args
318 | Error msg -> failwith msg
319 in
320
321 (* Execute request *)
322 (* Build request - for now we'll create the JSON directly
323 In production, this would use the request builder *)
324 let _builder_json = Jmap_email.Submission.Set_args.to_json set_args in
325
326 (* Execute request - for now return a placeholder
327 In production, this would execute via the connection *)
328 match Error (`Protocol_error "Email submission API not yet fully integrated") with
329 | Ok response ->
330 (match Jmap.Wire.Response.method_responses response with
331 | Ok invocation :: _ ->
332 let args_json = Jmap.Wire.Invocation.arguments invocation in
333 (match Jmap_email.Submission.Set_response.of_json args_json with
334 | Ok set_response ->
335 (match Jmap_email.Submission.Set_response.updated set_response with
336 | Some updated when Hashtbl.length updated > 0 ->
337 Ok ()
338 | _ ->
339 (match Jmap_email.Submission.Set_response.not_updated set_response with
340 | Some not_updated when Hashtbl.length not_updated > 0 ->
341 let error_msg = ref "Failed to cancel" in
342 Hashtbl.iter (fun _id err ->
343 error_msg := Option.value (Jmap.Error.Set_error.description err)
344 ~default:"Unknown error"
345 ) not_updated;
346 Error (`Protocol_error !error_msg)
347 | _ -> Error (`Protocol_error "Submission not updated")))
348 | Error msg -> Error (`Protocol_error msg))
349 | Error (err, call_id) :: _ -> Error (`Method_error ("EmailSubmission/set", call_id, Jmap.Error.Method_error.type_ err, None))
350 | [] -> Error (`Protocol_error "No method response"))
351 | Error error -> Error error
352 with
353 | Failure msg -> Error (`Protocol_error msg)
354 | exn -> Error (`Protocol_error (Printexc.to_string exn))
355
356(** {1 Submission Queries} *)
357
358(** Get an email submission by ID.
359
360 Retrieves a single EmailSubmission object with all or specified properties.
361
362 @param env Eio environment for network operations
363 @param ctx Connection context
364 @param submission_id The ID of the submission to retrieve
365 @param properties Optional list of properties to fetch (None for all)
366 @return The EmailSubmission object or None if not found *)
367let get_submission _env _ctx ~submission_id ?properties () =
368 try
369 (* Get account ID from context *)
370 (* Extract account ID from context - we'll use a placeholder for now
371 In production, this would be extracted from the session *)
372 let account_id = match Jmap.Id.of_string "primary-account" with
373 | Ok id -> id
374 | Error _ -> failwith "Invalid account ID" in
375
376 (* Build get request *)
377 let get_args = match Jmap_email.Submission.Get_args.create
378 ~account_id
379 ~ids:[submission_id]
380 ?properties
381 () with
382 | Ok args -> args
383 | Error msg -> failwith msg
384 in
385
386 (* Execute request *)
387 (* Build request - for now we'll create the JSON directly
388 In production, this would use the request builder *)
389 let _builder_json = Jmap_email.Submission.Get_args.to_json get_args in
390
391 (* Execute request - for now return a placeholder
392 In production, this would execute via the connection *)
393 match Error (`Protocol_error "Email submission API not yet fully integrated") with
394 | Ok response ->
395 (match Jmap.Wire.Response.method_responses response with
396 | Ok invocation :: _ ->
397 let args_json = Jmap.Wire.Invocation.arguments invocation in
398 (match Jmap_email.Submission.Get_response.of_json args_json with
399 | Ok get_response ->
400 let submissions = Jmap_email.Submission.Get_response.list get_response in
401 (match submissions with
402 | submission :: _ -> Ok (Some submission)
403 | [] ->
404 let not_found = Jmap_email.Submission.Get_response.not_found get_response in
405 if List.mem submission_id not_found then
406 Ok None
407 else
408 Ok None)
409 | Error msg -> Error (`Protocol_error msg))
410 | Error (err, call_id) :: _ -> Error (`Method_error ("EmailSubmission/set", call_id, Jmap.Error.Method_error.type_ err, None))
411 | [] -> Error (`Protocol_error "No method response"))
412 | Error error -> Error error
413 with
414 | Failure msg -> Error (`Protocol_error msg)
415 | exn -> Error (`Protocol_error (Printexc.to_string exn))
416
417(** Query email submissions with filters.
418
419 Searches for EmailSubmission objects matching the specified criteria.
420
421 @param env Eio environment for network operations
422 @param ctx Connection context
423 @param filter Optional filter to apply
424 @param sort Optional sort order
425 @param limit Maximum number of results
426 @return List of submission IDs matching the query *)
427let query_submissions _env _ctx ?filter ?sort ?limit () =
428 try
429 (* Get account ID from context *)
430 (* Extract account ID from context - we'll use a placeholder for now
431 In production, this would be extracted from the session *)
432 let account_id = match Jmap.Id.of_string "primary-account" with
433 | Ok id -> id
434 | Error _ -> failwith "Invalid account ID" in
435
436 (* Build query request *)
437 let query_args = match Jmap_email.Submission.Query_args.create
438 ~account_id
439 ?filter
440 ?sort
441 ?limit
442 () with
443 | Ok args -> args
444 | Error msg -> failwith msg
445 in
446
447 (* Execute request *)
448 (* Build request - for now we'll create the JSON directly
449 In production, this would use the request builder *)
450 let _builder_json = Jmap_email.Submission.Query_args.to_json query_args in
451
452 (* Execute request - for now return a placeholder
453 In production, this would execute via the connection *)
454 match Error (`Protocol_error "Email submission API not yet fully integrated") with
455 | Ok response ->
456 (match Jmap.Wire.Response.method_responses response with
457 | Ok invocation :: _ ->
458 let args_json = Jmap.Wire.Invocation.arguments invocation in
459 (match Jmap_email.Submission.Query_response.of_json args_json with
460 | Ok query_response ->
461 Ok (Jmap_email.Submission.Query_response.ids query_response)
462 | Error msg -> Error (`Protocol_error msg))
463 | Error (err, call_id) :: _ -> Error (`Method_error ("EmailSubmission/set", call_id, Jmap.Error.Method_error.type_ err, None))
464 | [] -> Error (`Protocol_error "No method response"))
465 | Error error -> Error error
466 with
467 | Failure msg -> Error (`Protocol_error msg)
468 | exn -> Error (`Protocol_error (Printexc.to_string exn))
469
470(** Query for pending submissions.
471
472 Convenience function to find all submissions that can still be cancelled.
473
474 @param env Eio environment for network operations
475 @param ctx Connection context
476 @return List of pending submission IDs *)
477let query_pending_submissions env ctx =
478 let filter = Jmap_email.Submission.Filter.undo_status `Pending in
479 query_submissions env ctx ~filter ()
480
481(** Query submissions for a specific email.
482
483 Finds all submissions associated with a particular email ID.
484
485 @param env Eio environment for network operations
486 @param ctx Connection context
487 @param email_id The email ID to search for
488 @return List of submission IDs for the email *)
489let query_submissions_for_email env ctx ~email_id =
490 let filter = Jmap_email.Submission.Filter.email_ids [email_id] in
491 query_submissions env ctx ~filter ()
492
493(** {1 Delivery Status} *)
494
495(** Check delivery status of a submission.
496
497 Retrieves the current delivery status for all recipients of a submission.
498
499 @param env Eio environment for network operations
500 @param ctx Connection context
501 @param submission_id The submission to check
502 @return Hashtable of recipient addresses to delivery status, or None *)
503let get_delivery_status env ctx ~submission_id =
504 match get_submission env ctx ~submission_id
505 ~properties:["id"; "deliveryStatus"] () with
506 | Ok (Some submission) ->
507 Ok (Jmap_email.Submission.delivery_status submission)
508 | Ok None -> Ok None
509 | Error err -> Error err
510
511(** {1 Batch Operations} *)
512
513(** Cancel all pending submissions.
514
515 Queries for all pending submissions and cancels them.
516
517 @param env Eio environment for network operations
518 @param ctx Connection context
519 @return Number of submissions cancelled *)
520let cancel_all_pending env ctx =
521 match query_pending_submissions env ctx with
522 | Ok submission_ids ->
523 let cancelled = ref 0 in
524 List.iter (fun id ->
525 match cancel_submission env ctx ~submission_id:id with
526 | Ok () -> incr cancelled
527 | Error _ -> ()
528 ) submission_ids;
529 Ok !cancelled
530 | Error err -> Error err