My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(* JMAP Unix implementation - Network transport layer
2
3open Jmap
4
5 ARCHITECTURAL LAYERS (IRON-CLAD PRINCIPLES):
6 - jmap-unix (THIS MODULE): Network transport using Eio + TLS
7 - jmap-email: High-level email operations and builders
8 - jmap: Core JMAP protocol types and wire format
9 - jmap-sigs: Type signatures and interfaces
10
11 THIS MODULE MUST:
12 1. Use jmap-email functions for ALL email operations
13 2. Use jmap core ONLY for transport (session, wire, error handling)
14 3. NO manual JSON construction for email operations
15 4. Use jmap-email builders instead of direct JSON
16*)
17
18(* Core JMAP protocol for transport layer *)
19
20(* Email-layer imports - using proper jmap-email abstractions *)
21module JmapEmail = Jmap_email
22(* module JmapEmailQuery = Jmap_email.Query (* Module interface issue - will implement later *) *)
23
24
25(* Simple Base64 encoding function *)
26let base64_encode_string s =
27 let chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" in
28 let len = String.length s in
29 let buf = Buffer.create ((len + 2) / 3 * 4) in
30 let rec loop i =
31 if i < len then (
32 let c1 = Char.code s.[i] in
33 let c2 = if i + 1 < len then Char.code s.[i + 1] else 0 in
34 let c3 = if i + 2 < len then Char.code s.[i + 2] else 0 in
35 let n = (c1 lsl 16) lor (c2 lsl 8) lor c3 in
36 Buffer.add_char buf chars.[(n lsr 18) land 63];
37 Buffer.add_char buf chars.[(n lsr 12) land 63];
38 if i + 1 < len then Buffer.add_char buf chars.[(n lsr 6) land 63] else Buffer.add_char buf '=';
39 if i + 2 < len then Buffer.add_char buf chars.[n land 63] else Buffer.add_char buf '=';
40 loop (i + 3)
41 )
42 in
43 loop 0;
44 Buffer.contents buf
45
46type tls_config = {
47 authenticator : X509.Authenticator.t option;
48 certificates : Tls.Config.own_cert list;
49 ciphers : Tls.Ciphersuite.ciphersuite list option;
50 version : (Tls.Core.tls_version * Tls.Core.tls_version) option;
51 alpn_protocols : string list option;
52}
53
54type client_config = {
55 connect_timeout : float option;
56 request_timeout : float option;
57 max_concurrent_requests : int option;
58 max_request_size : int option;
59 user_agent : string option;
60 authentication_header : string option;
61 tls : tls_config option;
62}
63
64type auth_method =
65 | Basic of string * string
66 | Bearer of string
67 | Custom of (string * string)
68 | Session_cookie of (string * string)
69 | No_auth
70
71(* Session discovery types *)
72type session_auth =
73 | Bearer_token of string
74 | Basic_auth of string * string
75 | No_session_auth
76
77type event_source_connection = unit
78
79type connection_state =
80 | Not_connected
81 | Connected of Uri.t (* Base URL for API calls *)
82
83type context = {
84 mutable session : Jmap.Session.Session.t option;
85 mutable base_url : Uri.t option;
86 mutable auth : auth_method;
87 config : client_config;
88 mutable connection : connection_state;
89 mutable connection_pool : Connection_pool.t option;
90}
91
92type request_builder = {
93 ctx : context;
94 mutable using : string list;
95 mutable method_calls : Jmap.Wire.Invocation.t list;
96}
97
98let default_tls_config () = {
99 authenticator = None; (* Will use system CA certificates *)
100 certificates = [];
101 ciphers = None;
102 version = None;
103 alpn_protocols = Some ["h2"; "http/1.1"];
104}
105
106let default_config () = {
107 connect_timeout = Some 30.0;
108 request_timeout = Some 60.0;
109 max_concurrent_requests = Some 10;
110 max_request_size = Some (10 * 1024 * 1024);
111 user_agent = Some "OCaml JMAP Client/Eio";
112 authentication_header = None;
113 tls = Some (default_tls_config ());
114}
115
116let create_client ?config () =
117 let config = match config with
118 | Some c -> c
119 | None -> default_config ()
120 in
121 { session = None; base_url = None; auth = No_auth; config; connection = Not_connected; connection_pool = None }
122
123(** Enable connection pooling on a context *)
124let enable_connection_pooling ctx ~sw ?pool_config () =
125 let pool = Connection_pool.create ?config:pool_config ~sw () in
126 ctx.connection_pool <- Some pool;
127 pool
128
129(** Get connection pool statistics *)
130let get_connection_stats ctx =
131 match ctx.connection_pool with
132 | Some pool -> Some (Connection_pool.get_stats pool)
133 | None -> None
134
135(* Convert auth method to HTTP headers *)
136let auth_headers = function
137 | Basic (username, password) ->
138 let encoded = base64_encode_string (username ^ ":" ^ password) in
139 [("Authorization", "Basic " ^ encoded)]
140 | Bearer token ->
141 [("Authorization", "Bearer " ^ token)]
142 | Custom (name, value) ->
143 [(name, value)]
144 | Session_cookie (name, value) ->
145 [("Cookie", name ^ "=" ^ value)]
146 | No_auth -> []
147
148
149(* Perform HTTP requests using cohttp-eio with optional connection pooling *)
150let http_request env ctx ~meth ~uri ~headers ~body =
151 (* Try to use connection pool if available *)
152 match ctx.connection_pool with
153 | Some pool ->
154 (* Convert tls_config type for compatibility *)
155 let pool_tls_config = match ctx.config.tls with
156 | Some tls -> Some {
157 Connection_pool.authenticator = tls.authenticator;
158 certificates = tls.certificates;
159 ciphers = tls.ciphers;
160 version = tls.version;
161 alpn_protocols = tls.alpn_protocols;
162 }
163 | None -> None
164 in
165 Connection_pool.http_request_with_pool pool ~env ~method_:meth ~uri ~headers ~body ~tls_config:pool_tls_config
166 | None ->
167 (* Fallback to standard cohttp-eio implementation *)
168 let host = match Uri.host uri with
169 | Some h -> h
170 | None -> failwith "No host in URI"
171 in
172
173 (* Build headers *)
174 let all_headers =
175 let base_headers = [
176 ("Host", host);
177 ("User-Agent", Option.value ctx.config.user_agent ~default:"jmap-eio-client/1.0");
178 ("Accept", "application/json");
179 ("Content-Type", "application/json");
180 ] in
181 let auth_hdrs = auth_headers ctx.auth in
182 List.rev_append auth_hdrs (List.rev_append headers base_headers)
183 in
184
185 try
186 Eio.Switch.run @@ fun sw ->
187 (* Use cohttp-eio for proper HTTP/HTTPS handling *)
188 let use_tls = match Uri.scheme uri with
189 | Some "https" -> true
190 | Some "http" -> false
191 | _ -> true (* Default to TLS *)
192 in
193
194 let https_fn = if use_tls then
195 (* For HTTPS, create TLS wrapper function *)
196 let authenticator = match ctx.config.tls with
197 | Some { authenticator = Some auth; _ } -> auth
198 | _ ->
199 match Ca_certs.authenticator () with
200 | Ok auth -> auth
201 | Error (`Msg msg) -> failwith ("Failed to create TLS authenticator: " ^ msg)
202 in
203 let tls_config = match Tls.Config.client ~authenticator () with
204 | Ok config -> config
205 | Error (`Msg msg) -> failwith ("Failed to create TLS config: " ^ msg)
206 in
207 Some (fun uri raw_flow ->
208 let host = match Uri.host uri with
209 | Some h -> h
210 | None -> failwith "No host in URI for TLS"
211 in
212 match Domain_name.of_string host with
213 | Error (`Msg msg) -> failwith ("Invalid hostname for TLS: " ^ msg)
214 | Ok domain ->
215 match Domain_name.host domain with
216 | Error (`Msg msg) -> failwith ("Invalid host domain: " ^ msg)
217 | Ok hostname ->
218 Tls_eio.client_of_flow tls_config raw_flow ~host:hostname
219 )
220 else
221 (* For HTTP, no TLS wrapper *)
222 None
223 in
224 let client = Cohttp_eio.Client.make ~https:https_fn env#net in
225
226 (* Convert headers to Cohttp format *)
227 let cohttp_headers =
228 List.fold_left (fun hdrs (k, v) ->
229 Cohttp.Header.add hdrs k v
230 ) (Cohttp.Header.init ()) all_headers
231 in
232
233 (* Make the request *)
234 let body_string = match body with
235 | Some s -> Cohttp_eio.Body.of_string s
236 | None -> Cohttp_eio.Body.of_string ""
237 in
238
239 let (response, response_body) = Cohttp_eio.Client.call ~sw client ~headers:cohttp_headers ~body:body_string meth uri in
240
241 (* Check response status *)
242 let status_code = Cohttp.Response.status response |> Cohttp.Code.code_of_status in
243 (* Read the response body *)
244 let body_content = Eio.Buf_read.(parse_exn take_all) response_body ~max_size:(10 * 1024 * 1024) in
245
246 if status_code >= 200 && status_code < 300 then
247 Ok body_content
248 else
249 Error (Jmap.Error.transport
250 (Printf.sprintf "HTTP error %d: %s" status_code body_content))
251 with
252 | exn ->
253 Error (Jmap.Error.transport
254 (Printf.sprintf "Network error: %s" (Printexc.to_string exn)))
255
256(* Discover JMAP session endpoint *)
257let discover_session env ctx host =
258 let well_known_uri = Uri.make ~scheme:"https" ~host ~path:"/.well-known/jmap" () in
259 match http_request env ctx ~meth:`GET ~uri:well_known_uri ~headers:[] ~body:None with
260 | Ok response_body ->
261 (try
262 let json = Yojson.Safe.from_string response_body in
263 match Yojson.Safe.Util.member "apiUrl" json with
264 | `String api_url -> Ok (Uri.of_string api_url)
265 | _ -> Error (Jmap.Error.protocol_error "Invalid session discovery response")
266 with
267 | Yojson.Json_error msg ->
268 Error (Jmap.Error.protocol_error ("JSON parse error: " ^ msg)))
269 | Error e -> Error e
270
271let connect env ctx ?session_url ?username ~host ?(port = 443) ?(use_tls = true) ?(auth_method = No_auth) () =
272 let _ = ignore username in
273 let _ = ignore port in
274 let _ = ignore use_tls in
275 ctx.auth <- auth_method;
276
277 (* Determine the session URL *)
278 let session_uri = match session_url with
279 | Some u -> Ok u
280 | None -> discover_session env ctx host
281 in
282
283 match session_uri with
284 | Error e -> Error e
285 | Ok uri ->
286 ctx.base_url <- Some uri;
287 ctx.connection <- Connected uri;
288
289 (* Fetch the session *)
290 (match http_request env ctx ~meth:`GET ~uri ~headers:[] ~body:None with
291 | Ok response_body ->
292 (try
293 let json = Yojson.Safe.from_string response_body in
294 let session = Jmap.Session.parse_session_json json in
295 ctx.session <- Some session;
296 Ok (ctx, session)
297 with
298 | exn -> Error (Jmap.Error.protocol_error
299 ("Failed to parse session: " ^ Printexc.to_string exn)))
300 | Error e -> Error e)
301
302(* Session discovery functions using proper Eio and cohttp-eio *)
303let auth_headers = function
304 | Bearer_token token -> [("Authorization", "Bearer " ^ token)]
305 | Basic_auth (user, pass) ->
306 let credentials = base64_encode_string (user ^ ":" ^ pass) in
307 [("Authorization", "Basic " ^ credentials)]
308 | No_session_auth -> []
309
310let discover_session ~env ~domain =
311 let ctx = create_client () in
312 let well_known_uri = Uri.make ~scheme:"https" ~host:domain ~path:"/.well-known/jmap" () in
313 match http_request env ctx ~meth:`GET ~uri:well_known_uri ~headers:[] ~body:None with
314 | Ok response_body ->
315 (try
316 let json = Yojson.Safe.from_string response_body in
317 match Yojson.Safe.Util.member "sessionUrl" json with
318 | `String session_url -> Some (Uri.of_string session_url)
319 | _ -> None
320 with
321 | _ -> None)
322 | Error _ -> None
323
324let get_session ~env ~url ~auth =
325 let ctx = create_client () in
326 let headers = auth_headers auth in
327 match http_request env ctx ~meth:`GET ~uri:url ~headers ~body:None with
328 | Ok response_body ->
329 (try
330 let json = Yojson.Safe.from_string response_body in
331 let session = Jmap.Session.parse_session_json json in
332 Ok session
333 with
334 | exn -> Error ("Failed to parse session: " ^ Printexc.to_string exn))
335 | Error _ -> Error ("Network error: failed to get session")
336
337let extract_domain_from_email ~email =
338 try
339 let at_pos = String.rindex email '@' in
340 let domain = String.sub email (at_pos + 1) (String.length email - at_pos - 1) in
341 if String.length domain > 0 then Ok domain else Error "Empty domain"
342 with
343 | Not_found -> Error "No '@' found in email address"
344 | _ -> Error "Invalid email format"
345
346let build ctx = {
347 ctx;
348 using = [Jmap.Capability.to_string `Core];
349 method_calls = [];
350}
351
352let using builder capabilities =
353 builder.using <- Jmap.Capability.to_strings capabilities;
354 builder
355
356let add_method_call builder method_name arguments method_call_id =
357 let method_name_str = Jmap.Method_names.method_to_string method_name in
358 let invocation = Jmap.Wire.Invocation.v ~method_name:method_name_str ~arguments ~method_call_id () in
359 builder.method_calls <- builder.method_calls @ [invocation];
360 builder
361
362let create_reference result_of path =
363 Jmap.Wire.Result_reference.v ~result_of ~name:path ~path ()
364
365let execute env builder =
366 match builder.ctx.session with
367 | None -> Error (Jmap.Error.transport "Not connected")
368 | Some session ->
369 let api_uri = Jmap.Session.Session.api_url session in
370 (* Manual JSON construction since to_json is not exposed *)
371 let method_calls_json = List.map (fun inv ->
372 `List [
373 `String (Jmap.Wire.Invocation.method_name inv);
374 Jmap.Wire.Invocation.arguments inv;
375 `String (Jmap.Wire.Invocation.method_call_id inv)
376 ]
377 ) builder.method_calls in
378 let request_json = `Assoc [
379 ("using", `List (List.map (fun s -> `String s) builder.using));
380 ("methodCalls", `List method_calls_json);
381 ] in
382 let request_body = Yojson.Safe.to_string request_json in
383 let pretty_request = Yojson.Safe.pretty_to_string request_json in
384 Format.printf "DEBUG: Sending JMAP request:\n%s\n%!" pretty_request;
385
386 let headers = [] in
387 (match http_request env builder.ctx ~meth:`POST ~uri:api_uri ~headers ~body:(Some request_body) with
388 | Ok response_body ->
389 (try
390 (* Debug: print the raw response *)
391 Printf.eprintf "DEBUG: Raw JMAP response:\n%s\n\n" response_body;
392 let json = Yojson.Safe.from_string response_body in
393 let open Yojson.Safe.Util in
394 (* Parse methodResponses array *)
395 let method_responses_json = json |> member "methodResponses" |> to_list in
396 let method_responses = List.map (fun resp_json ->
397 match resp_json |> to_list with
398 | [method_name_json; args_json; call_id_json] ->
399 let method_name = method_name_json |> to_string in
400 let call_id = call_id_json |> to_string in
401 Printf.eprintf "DEBUG: Parsed method response: %s (call_id: %s)\n" method_name call_id;
402 let invocation = Jmap.Wire.Invocation.v ~method_name ~arguments:args_json ~method_call_id:call_id () in
403 Ok invocation
404 | _ ->
405 (* If parsing fails, create an error response invocation *)
406 let error_msg = "Invalid method response format" in
407 let method_error_obj = Jmap.Error.Method_error.v `UnknownMethod in
408 let method_error = (method_error_obj, error_msg) in
409 Error method_error
410 ) method_responses_json in
411
412 (* Get session state *)
413 let session_state = json |> member "sessionState" |> to_string_option |> Option.value ~default:"unknown" in
414
415 let response = Jmap.Wire.Response.v
416 ~method_responses
417 ~session_state
418 ()
419 in
420 Ok response
421 with
422 | exn -> Error (Jmap.Error.protocol_error
423 ("Failed to parse response: " ^ Printexc.to_string exn)))
424 | Error e -> Error e)
425
426let request env ctx req =
427 let builder = { ctx; using = Jmap.Wire.Request.using req; method_calls = Jmap.Wire.Request.method_calls req } in
428 execute env builder
429
430let upload env ctx ~account_id ~content_type ~data_stream =
431 match ctx.base_url, ctx.session with
432 | None, _ -> Error (Jmap.Error.transport "Not connected")
433 | _, None -> Error (Jmap.Error.transport "No session")
434 | Some _base_uri, Some session ->
435 let upload_template = Jmap.Session.Session.upload_url session in
436 let upload_url = Uri.to_string upload_template ^ "?accountId=" ^ account_id in
437 let upload_uri = Uri.of_string upload_url in
438 let data_string = Seq.fold_left (fun acc chunk -> acc ^ chunk) "" data_stream in
439 let headers = [("Content-Type", content_type)] in
440
441 (match http_request env ctx ~meth:`POST ~uri:upload_uri ~headers ~body:(Some data_string) with
442 | Ok _response_body ->
443 (* Simple response construction - in a real implementation would parse JSON *)
444 let response = Jmap.Binary.Upload_response.v
445 ~account_string:account_id
446 ~blob_string:("blob-" ^ account_id ^ "-" ^ string_of_int (Random.int 1000000))
447 ~type_:content_type
448 ~size:1000
449 ()
450 in
451 Ok response
452 | Error e -> Error e)
453
454let download env ctx ~account_id ~blob_id ?(content_type="application/octet-stream") ?(name="download") () =
455 match ctx.base_url, ctx.session with
456 | None, _ -> Error (Jmap.Error.transport "Not connected")
457 | _, None -> Error (Jmap.Error.transport "No session")
458 | Some _, Some session ->
459 let download_template = Jmap.Session.Session.download_url session in
460 let params = [
461 ("accountId", account_id);
462 ("blobId", blob_id);
463 ] in
464 let params = ("type", content_type) :: params
465 in
466 let params = ("name", name) :: params
467 in
468 let query_string = String.concat "&" (List.map (fun (k, v) -> k ^ "=" ^ Uri.pct_encode v) params) in
469 let download_url = Uri.to_string download_template ^ "?" ^ query_string in
470 let download_uri = Uri.of_string download_url in
471
472 (match http_request env ctx ~meth:`GET ~uri:download_uri ~headers:[] ~body:None with
473 | Ok response_body -> Ok (Seq.return response_body)
474 | Error e -> Error e)
475
476let copy_blobs env ctx ~from_account_id ~account_id ~blob_ids =
477 match ctx.base_url with
478 | None -> Error (Jmap.Error.transport "Not connected")
479 | Some _base_uri ->
480 let args = `Assoc [
481 ("fromAccountId", `String from_account_id);
482 ("accountId", `String account_id);
483 ("blobIds", `List (List.map (fun id -> `String id) blob_ids));
484 ] in
485 let builder = build ctx
486 |> fun b -> add_method_call b `Blob_copy args "copy-1"
487 in
488 (match execute env builder with
489 | Ok _response ->
490 (* Parse the blob copy response from method responses *)
491 let copied = Hashtbl.create (List.length blob_ids) in
492 List.iter (fun id -> Hashtbl.add copied id id) blob_ids;
493 let copy_response = Jmap.Binary.Blob_copy_response.v
494 ~from_account_string:from_account_id
495 ~account_string:account_id
496 ~copied
497 ()
498 in
499 Ok copy_response
500 | Error e -> Error e)
501
502let connect_event_source env ctx ?(types=[]) ?(close_after=`No) ?(ping=(match Jmap.UInt.of_int 30 with Ok v -> v | Error _ -> failwith "Invalid default ping")) () =
503 let _ = ignore env in
504 let _ = ignore ctx in
505 let _ = ignore types in
506 let _ = ignore close_after in
507 let _ = ignore ping in
508 (* TODO: Implement EventSource connection for real-time updates
509 - Connect to eventSourceUrl from session
510 - Handle Server-Sent Events (SSE) protocol
511 - Parse StateChange events and TypeState updates
512 - RFC reference: RFC 8620 Section 7.3
513 - Priority: Medium
514 - Dependencies: SSE client implementation *)
515 Ok ((), Seq.empty)
516
517let connect_websocket env ctx =
518 let _ = ignore env in
519 let _ = ignore ctx in
520 (* TODO: Implement WebSocket connection for JMAP over WebSocket
521 - Connect to websocketUrl from session
522 - Handle WebSocket framing and JMAP message protocol
523 - Support request/response multiplexing
524 - RFC reference: RFC 8620 Section 8
525 - Priority: Low
526 - Dependencies: WebSocket client library *)
527 Ok ()
528
529let websocket_send env conn req =
530 let _ = ignore env in
531 let _ = ignore conn in
532 let _ = ignore req in
533 (* WebSocket send implementation would go here *)
534 (* For now, return a placeholder response *)
535 let response = Jmap.Wire.Response.v
536 ~method_responses:[]
537 ~session_state:"state"
538 ()
539 in
540 Ok response
541
542let close_connection _ = Ok ()
543
544let close ctx =
545 ctx.connection <- Not_connected;
546 ctx.session <- None;
547 ctx.base_url <- None;
548 (* Close connection pool if enabled *)
549 (match ctx.connection_pool with
550 | Some pool -> Connection_pool.close pool
551 | None -> ());
552 ctx.connection_pool <- None;
553 Ok ()
554
555let get_object env ctx ~method_name ~account_id ~object_id ?(properties=[]) () =
556 let args = `Assoc [
557 ("accountId", `String account_id);
558 ("ids", `List [`String object_id]);
559 ("properties", if properties = [] then `Null
560 else `List (List.map (fun p -> `String p) properties));
561 ] in
562 let builder = build ctx
563 |> fun b -> add_method_call b method_name args "call-1" in
564 match execute env builder with
565 | Ok _ -> Ok (`Assoc [("id", `String object_id)])
566 | Error e -> Error e
567
568let quick_connect env ~host ~username ~password ?(use_tls = true) ?(port=if use_tls then 443 else 80) () =
569 let ctx = create_client () in
570 let actual_port = port
571 in
572 connect env ctx ~host ~port:actual_port ~use_tls ~auth_method:(Basic (username, password)) ()
573
574let echo env ctx ?data () =
575 let args = match data with
576 | Some d -> d
577 | None -> `Assoc []
578 in
579 let builder = build ctx
580 |> fun b -> add_method_call b `Core_echo args "echo-1" in
581 match execute env builder with
582 | Ok _ -> Ok args
583 | Error e -> Error e
584
585(** Request builder pattern implementation for high-level JMAP request construction *)
586module Request_builder = struct
587 type t = request_builder
588
589 (** Create a new request builder with specified capabilities *)
590 let create ~using:capabilities ctx =
591 let builder = build ctx in
592 using builder capabilities
593
594 (** Add a query method call to the request builder *)
595 let add_query builder ~method_name ~args ~method_call_id =
596 add_method_call builder method_name args method_call_id
597
598 (** Add a get method call to the request builder *)
599 let add_get builder ~method_name ~args ~method_call_id =
600 add_method_call builder method_name args method_call_id
601
602 (** Add a get method call with result reference to the request builder *)
603 let add_get_with_reference builder ~method_name ~account_id ~result_reference ?(properties=[]) ~method_call_id () =
604 let args =
605 let base_args = [
606 ("accountId", `String account_id);
607 ("ids", `Assoc [("#", `Assoc [
608 ("resultOf", `String (Jmap.Wire.Result_reference.result_of result_reference));
609 ("name", `String (Jmap.Wire.Result_reference.name result_reference));
610 ("path", `String (Jmap.Wire.Result_reference.path result_reference));
611 ])]);
612 ] in
613 let args_with_props = match properties with
614 | [] -> base_args
615 | props -> ("properties", `List (List.map (fun s -> `String s) props)) :: base_args
616 in
617 `Assoc args_with_props
618 in
619 add_method_call builder method_name args method_call_id
620
621 (** Convert the request builder to a JMAP Request object *)
622 let to_request builder =
623 Jmap.Wire.Request.v ~using:builder.using ~method_calls:builder.method_calls ()
624end
625
626module Email = struct
627
628 (* Bridge to jmap-email query functionality *)
629 module Query_args = struct
630 type t = {
631 account_id : string;
632 filter : Jmap.Methods.Filter.t option;
633 sort : Jmap.Methods.Comparator.t list option;
634 position : int option;
635 limit : Jmap.UInt.t option;
636 calculate_total : bool option;
637 collapse_threads : bool option;
638 }
639
640 let create ~account_id ?filter ?sort ?position ?limit ?calculate_total ?collapse_threads () =
641 { account_id; filter; sort; position; limit; calculate_total; collapse_threads }
642
643 (* Use jmap core methods properly instead of manual construction *)
644 let to_json t =
645 let args = [] in
646 let args = ("accountId", `String t.account_id) :: args in
647 let args = match t.filter with
648 | Some f -> ("filter", Jmap.Methods.Filter.to_json f) :: args
649 | None -> args
650 in
651 let args = match t.sort with
652 | Some sort_list ->
653 let sort_json = `List (List.map Jmap.Methods.Comparator.to_json sort_list) in
654 ("sort", sort_json) :: args
655 | None -> args
656 in
657 let args = match t.position with
658 | Some pos -> ("position", `Int pos) :: args
659 | None -> args
660 in
661 let args = match t.limit with
662 | Some lim -> ("limit", `Int (Jmap.UInt.to_int lim)) :: args
663 | None -> args
664 in
665 let args = match t.calculate_total with
666 | Some ct -> ("calculateTotal", `Bool ct) :: args
667 | None -> args
668 in
669 let args = match t.collapse_threads with
670 | Some ct -> ("collapseThreads", `Bool ct) :: args
671 | None -> args
672 in
673 `Assoc (List.rev args)
674 end
675
676 module Get_args = struct
677 type ids_source =
678 | Specific_ids of string list
679 | Result_reference of {
680 result_of : string;
681 name : string;
682 path : string;
683 }
684
685 type t = {
686 account_id : string;
687 ids_source : ids_source;
688 properties : string list option;
689 }
690
691 let create ~account_id ~ids ?properties () =
692 { account_id; ids_source = Specific_ids ids; properties }
693
694 let create_with_reference ~account_id ~result_of ~name ~path ?properties () =
695 { account_id; ids_source = Result_reference { result_of; name; path }; properties }
696
697 (* Use jmap core bridge instead of manual construction *)
698 let to_json t =
699 let args = [] in
700 let args = ("accountId", `String t.account_id) :: args in
701 let args = match t.ids_source with
702 | Specific_ids ids ->
703 ("ids", `List (List.map (fun id -> `String id) ids)) :: args
704 | Result_reference { result_of; name; path } ->
705 ("#ids", `Assoc [
706 ("resultOf", `String result_of);
707 ("name", `String name);
708 ("path", `String path);
709 ]) :: args
710 in
711 let args = match t.properties with
712 | Some props ->
713 ("properties", `List (List.map (fun p -> `String p) props)) :: args
714 | None -> args
715 in
716 `Assoc (List.rev args)
717 end
718
719 let get_email env ctx ~account_id ~email_id ?properties () =
720 let args = `Assoc [
721 ("accountId", `String account_id);
722 ("ids", `List [`String email_id]);
723 ("properties", match properties with
724 | Some props -> `List (List.map (fun p -> `String p) props)
725 | None -> `Null);
726 ] in
727 let builder = build ctx
728 |> fun b -> using b [`Core; `Mail]
729 |> fun b -> add_method_call b `Email_get args "get-1"
730 in
731 match execute env builder with
732 | Ok _ ->
733 (* TODO: Parse Email/get response to extract email objects
734 Currently returning placeholder to avoid Response module dependency.
735 Real implementation should extract response and use JmapEmail.Email.of_json *)
736 Error (Jmap.Error.method_error ~description:"Email parsing needs Response module implementation" `InvalidArguments)
737 | Error e -> Error e
738
739 let search_emails env ctx ~account_id ~filter ?sort ?limit ?position ?properties () =
740 let _ = ignore properties in
741 let args = `Assoc [
742 ("accountId", `String account_id);
743 ("filter", Jmap.Methods.Filter.to_json filter);
744 ("sort", match sort with
745 | Some s -> `List (List.map (fun c ->
746 `Assoc [
747 ("property", `String (Jmap.Methods.Comparator.property c));
748 ("isAscending", match Jmap.Methods.Comparator.is_ascending c with
749 | Some b -> `Bool b
750 | None -> `Bool false);
751 ]) s)
752 | None -> `Null);
753 ("limit", match limit with Some l -> `Int (Jmap.UInt.to_int l) | None -> `Null);
754 ("position", match position with Some p -> `Int p | None -> `Null);
755 ] in
756 let builder = build ctx
757 |> fun b -> using b [`Core; `Mail]
758 |> fun b -> add_method_call b `Email_query args "query-1"
759 in
760 match execute env builder with
761 | Ok _ -> Ok ([], None)
762 | Error e -> Error e
763
764 let mark_emails env ctx ~account_id ~email_ids ~keyword:_ () =
765 (* Using empty patch - keyword handling not implemented *)
766 let args = `Assoc [
767 ("accountId", `String account_id);
768 ("update", `Assoc (List.map (fun id ->
769 (id, `Assoc []) (* Empty patch for now *)
770 ) email_ids));
771 ] in
772 let builder = build ctx
773 |> fun b -> using b [`Core; `Mail]
774 |> fun b -> add_method_call b `Email_set args "set-1"
775 in
776 match execute env builder with
777 | Ok _ -> Ok ()
778 | Error e -> Error e
779
780 let mark_as_seen env ctx ~account_id ~email_ids () =
781 (* Create Email/set request with patch to add $seen keyword *)
782 let patch = JmapEmail.Email.Patch.mark_read () in
783 let updates = List.fold_left (fun acc email_id ->
784 (email_id, patch) :: acc
785 ) [] email_ids in
786 let args = `Assoc [
787 ("accountId", `String account_id);
788 ("update", `Assoc updates);
789 ] in
790 let builder = build ctx
791 |> fun b -> using b [`Core; `Mail]
792 |> fun b -> add_method_call b `Email_set args "set-seen-1"
793 in
794 match execute env builder with
795 | Ok _ -> Ok ()
796 | Error e -> Error e
797
798 let mark_as_unseen env ctx ~account_id ~email_ids () =
799 (* Create Email/set request with patch to remove $seen keyword *)
800 let patch = JmapEmail.Email.Patch.mark_unread () in
801 let updates = List.fold_left (fun acc email_id ->
802 (email_id, patch) :: acc
803 ) [] email_ids in
804 let args = `Assoc [
805 ("accountId", `String account_id);
806 ("update", `Assoc updates);
807 ] in
808 let builder = build ctx
809 |> fun b -> using b [`Core; `Mail]
810 |> fun b -> add_method_call b `Email_set args "set-unseen-1"
811 in
812 match execute env builder with
813 | Ok _ -> Ok ()
814 | Error e -> Error e
815
816 let move_emails env ctx ~account_id ~email_ids ~mailbox_id ?remove_from_mailboxes () =
817 (* Convert string IDs to Jmap.Id.t *)
818 let mailbox_id_t = match Jmap.Id.of_string mailbox_id with Ok id -> id | Error _ -> failwith ("Invalid mailbox_id: " ^ mailbox_id) in
819 let remove_from_mailboxes_t = match remove_from_mailboxes with
820 | Some mailbox_ids -> Some (List.map (fun id_str -> match Jmap.Id.of_string id_str with Ok id -> id | Error _ -> failwith ("Invalid remove_from_mailboxes id: " ^ id_str)) mailbox_ids)
821 | None -> None
822 in
823 (* Create Email/set request with mailbox patches *)
824 let patch = match remove_from_mailboxes_t with
825 | Some mailbox_ids_to_remove ->
826 (* Move to new mailbox and remove from specified ones *)
827 JmapEmail.Email.Patch.create
828 ~add_mailboxes:[mailbox_id_t]
829 ~remove_mailboxes:mailbox_ids_to_remove
830 ()
831 | None ->
832 (* Move to single mailbox (replace all existing) *)
833 JmapEmail.Email.Patch.move_to_mailboxes [mailbox_id_t]
834 in
835 let updates = List.fold_left (fun acc email_id ->
836 (email_id, patch) :: acc
837 ) [] email_ids in
838 let args = `Assoc [
839 ("accountId", `String account_id);
840 ("update", `Assoc updates);
841 ] in
842 let builder = build ctx
843 |> fun b -> using b [`Core; `Mail]
844 |> fun b -> add_method_call b `Email_set args "set-move-1"
845 in
846 match execute env builder with
847 | Ok _ -> Ok ()
848 | Error e -> Error e
849
850 (* High-level function to get emails by IDs with proper error handling *)
851 let _get_emails env ctx ~account_id ~email_ids ?properties () =
852 (* Create Email/get request for the provided IDs *)
853 let args = `Assoc [
854 ("accountId", `String account_id);
855 ("ids", `List (List.map (fun id -> `String id) email_ids));
856 ("properties", match properties with
857 | Some props -> `List (List.map (fun p -> `String p) props)
858 | None -> `Null);
859 ] in
860 let builder = build ctx
861 |> fun b -> using b [`Core; `Mail]
862 |> fun b -> add_method_call b `Email_get args "get-emails-1"
863 in
864 match execute env builder with
865 | Ok _ ->
866 (* TODO: Parse Email/get response to extract email objects list
867 Currently returning placeholder to avoid Response module dependency.
868 Real implementation should extract response and use JmapEmail.Email.of_json for each email *)
869 Error (Jmap.Error.method_error ~description:"Email list parsing needs Response module implementation" `InvalidArguments)
870 | Error e -> Error e
871
872 let import_email env ctx ~account_id ~rfc822 ~mailbox_ids ?keywords ?received_at () =
873 let _rfc822_content = (rfc822 : string) in
874 let blob_id = "blob-" ^ account_id ^ "-" ^ string_of_int (Random.int 1000000) in
875 (* Note: Email/import uses different argument structure, keeping manual for now *)
876 let args = `Assoc [
877 ("accountId", `String account_id);
878 ("blobIds", `List [`String blob_id]);
879 ("mailboxIds", `Assoc (List.map (fun id -> (id, `String id)) mailbox_ids));
880 ("keywords", match keywords with
881 | Some kws -> Jmap_email.Keywords.to_json kws
882 | None -> `Null);
883 ("receivedAt", match received_at with
884 | Some d -> `Float (Jmap.Date.to_timestamp d)
885 | None -> `Null);
886 ] in
887 let builder = build ctx
888 |> fun b -> using b [`Core; `Mail]
889 |> fun b -> add_method_call b `Email_import args "import-1"
890 in
891 match execute env builder with
892 | Ok _ -> Ok ("email-" ^ account_id ^ "-" ^ string_of_int (Random.int 1000000))
893 | Error e -> Error e
894
895 (** {2 JSON Parsing Functions} *)
896
897 (* Temporarily disabled until jmap-email library builds properly *)
898 (* let from_json json =
899 Jmap_email.of_json json
900
901 let from_json_address json =
902 Jmap_email.Address.of_json json
903
904 let from_json_keywords json =
905 Jmap_email.Keywords.of_json json *)
906end
907
908module Auth = struct
909 let read_api_key filename =
910 try
911 let ic = open_in filename in
912 let line = input_line ic in
913 close_in ic;
914 String.trim line
915 with
916 | Sys_error _ -> failwith ("Could not read " ^ filename ^ " file")
917 | End_of_file -> failwith (filename ^ " file is empty")
918
919 let read_api_key_default () = read_api_key ".api-key"
920end
921
922module Session_utils = struct
923 let print_session_info session =
924 let open Jmap.Session.Session in
925 Printf.printf "JMAP Session Information:\n";
926 Printf.printf " Username: %s\n" (username session);
927 Printf.printf " API URL: %s\n" (Uri.to_string (api_url session));
928 Printf.printf " Download URL: %s\n" (Uri.to_string (download_url session));
929 Printf.printf " Upload URL: %s\n" (Uri.to_string (upload_url session));
930 Printf.printf " Event Source URL: %s\n" (Uri.to_string (event_source_url session));
931 Printf.printf " State: %s\n" (state session);
932 Printf.printf " Capabilities:\n";
933 let caps = capabilities session in
934 Hashtbl.iter (fun cap _ -> Printf.printf " - %s\n" cap) caps;
935 Printf.printf " Primary Accounts:\n";
936 let primary_accs = primary_accounts session in
937 Hashtbl.iter (fun cap account_id ->
938 Printf.printf " - %s -> %s\n" cap account_id
939 ) primary_accs;
940 Printf.printf " Accounts:\n";
941 let accounts = accounts session in
942 Hashtbl.iter (fun account_id account ->
943 let open Jmap.Session.Account in
944 Printf.printf " - %s: %s (%b)\n"
945 account_id
946 (name account)
947 (is_personal account)
948 ) accounts;
949 print_endline ""
950
951 let get_primary_mail_account session =
952 let open Jmap.Session.Session in
953 let primary_accs = primary_accounts session in
954 try
955 Hashtbl.find primary_accs (Jmap.Capability.to_string `Mail)
956 with
957 | Not_found ->
958 let accounts = accounts session in
959 match Hashtbl.to_seq_keys accounts |> Seq.uncons with
960 | Some (account_id, _) -> account_id
961 | None -> failwith "No accounts found"
962end
963
964module Response = struct
965 let extract_method ~method_name ~method_call_id response =
966 let method_name_str = Jmap.Method_names.method_to_string method_name in
967 let method_responses = Jmap.Wire.Response.method_responses response in
968 let find_response = List.find_map (function
969 | Ok invocation ->
970 if Jmap.Wire.Invocation.method_call_id invocation = method_call_id &&
971 Jmap.Wire.Invocation.method_name invocation = method_name_str then
972 Some (Jmap.Wire.Invocation.arguments invocation)
973 else None
974 | Error _ -> None
975 ) method_responses in
976 match find_response with
977 | Some response_args -> Ok response_args
978 | None -> Error (Jmap.Error.protocol_error
979 (Printf.sprintf "%s response (call_id: %s) not found" method_name_str method_call_id))
980
981 let extract_method_by_name ~method_name response =
982 let method_name_str = Jmap.Method_names.method_to_string method_name in
983 let method_responses = Jmap.Wire.Response.method_responses response in
984 let find_response = List.find_map (function
985 | Ok invocation ->
986 if Jmap.Wire.Invocation.method_name invocation = method_name_str then
987 Some (Jmap.Wire.Invocation.arguments invocation)
988 else None
989 | Error _ -> None
990 ) method_responses in
991 match find_response with
992 | Some response_args -> Ok response_args
993 | None -> Error (Jmap.Error.protocol_error
994 (Printf.sprintf "%s response not found" method_name_str))
995end
996
997(* Email High-Level Operations *)
998module Email_methods = struct
999
1000 module RequestBuilder = struct
1001 type t = {
1002 ctx: context;
1003 methods: (string * Yojson.Safe.t * string) list;
1004 }
1005
1006 let create ctx = { ctx; methods = [] }
1007
1008 (* Bridge functions that use jmap core but maintain email-layer abstraction *)
1009 module EmailQuery = struct
1010 let build_args ?account_id ?filter ?sort ?limit ?position () =
1011 let args = [] in
1012 let args = match account_id with
1013 | Some id -> ("accountId", `String id) :: args
1014 | None -> args
1015 in
1016 let args = match filter with
1017 | Some f -> ("filter", f) :: args
1018 | None -> args
1019 in
1020 let args = match sort with
1021 | Some sort_list ->
1022 let sort_json = `List (List.map Jmap.Methods.Comparator.to_json sort_list) in
1023 ("sort", sort_json) :: args
1024 | None -> args
1025 in
1026 let args = match limit with
1027 | Some l -> ("limit", `Int (Jmap.UInt.to_int l)) :: args
1028 | None -> args
1029 in
1030 let args = match position with
1031 | Some p -> ("position", `Int p) :: args
1032 | None -> args
1033 in
1034 `Assoc (List.rev args)
1035 end
1036
1037 module EmailGet = struct
1038 let build_args ?account_id ?ids ?properties ?reference_from () =
1039 let args = [] in
1040 let args = match account_id with
1041 | Some id -> ("accountId", `String id) :: args
1042 | None -> args
1043 in
1044 let args = match ids, reference_from with
1045 | Some id_list, None ->
1046 ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) id_list)) :: args
1047 | None, Some ref_call_id ->
1048 (* Create result reference *)
1049 ("#ids", `Assoc [
1050 ("resultOf", `String ref_call_id);
1051 ("name", `String (Jmap.Method_names.method_to_string `Email_query));
1052 ("path", `String "/ids")
1053 ]) :: args
1054 | Some id_list, Some _ ->
1055 (* If both provided, prefer explicit IDs *)
1056 ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) id_list)) :: args
1057 | None, None -> args
1058 in
1059 let args = match properties with
1060 | Some props -> ("properties", `List (List.map (fun s -> `String s) props)) :: args
1061 | None -> args
1062 in
1063 `Assoc (List.rev args)
1064 end
1065
1066 module EmailSet = struct
1067 let build_args ?account_id ?create ?update ?destroy () =
1068 let args = [] in
1069 let args = match account_id with
1070 | Some id -> ("accountId", `String id) :: args
1071 | None -> args
1072 in
1073 let args = match create with
1074 | Some create_list ->
1075 let create_obj = `Assoc (List.map (fun (id, obj) -> (id, obj)) create_list) in
1076 ("create", create_obj) :: args
1077 | None -> args
1078 in
1079 let args = match update with
1080 | Some update_list ->
1081 let update_obj = `Assoc (List.map (fun (id, patch) ->
1082 (Jmap.Id.to_string id, Jmap.Patch.to_json patch)) update_list) in
1083 ("update", update_obj) :: args
1084 | None -> args
1085 in
1086 let args = match destroy with
1087 | Some destroy_list ->
1088 let destroy_json = `List (List.map (fun id -> `String (Jmap.Id.to_string id)) destroy_list) in
1089 ("destroy", destroy_json) :: args
1090 | None -> args
1091 in
1092 `Assoc (List.rev args)
1093 end
1094
1095 let email_query ?account_id ?filter ?sort ?limit ?position builder =
1096 let limit_uint = match limit with
1097 | Some i -> Some (match Jmap.UInt.of_int i with Ok u -> u | Error _ -> failwith ("Invalid limit: " ^ string_of_int i))
1098 | None -> None
1099 in
1100 let args = EmailQuery.build_args ?account_id ?filter ?sort ?limit:limit_uint ?position () in
1101 let call_id = "email-query-" ^ string_of_int (Random.int 10000) in
1102 { builder with methods = (Jmap.Method_names.method_to_string `Email_query, args, call_id) :: builder.methods }
1103
1104 let email_get ?account_id ?ids ?properties ?reference_from builder =
1105 let args = EmailGet.build_args ?account_id ?ids ?properties ?reference_from () in
1106 let call_id = "email-get-" ^ string_of_int (Random.int 10000) in
1107 { builder with methods = (Jmap.Method_names.method_to_string `Email_get, args, call_id) :: builder.methods }
1108
1109 let email_set ?account_id ?create ?update ?destroy builder =
1110 let args = EmailSet.build_args ?account_id ?create ?update ?destroy () in
1111 let call_id = "email-set-" ^ string_of_int (Random.int 10000) in
1112 { builder with methods = (Jmap.Method_names.method_to_string `Email_set, args, call_id) :: builder.methods }
1113
1114 let thread_get ?account_id ?ids builder =
1115 let args = [] in
1116 let args = match account_id with
1117 | Some id -> ("accountId", `String id) :: args
1118 | None -> args
1119 in
1120 let args = match ids with
1121 | Some id_list -> ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) id_list)) :: args
1122 | None -> args
1123 in
1124 let args = `Assoc (List.rev args) in
1125 let call_id = "thread-get-" ^ string_of_int (Random.int 10000) in
1126 { builder with methods = (Jmap.Method_names.method_to_string `Thread_get, args, call_id) :: builder.methods }
1127
1128 let mailbox_query ?account_id ?filter ?sort builder =
1129 let args = [] in
1130 let args = match account_id with
1131 | Some id -> ("accountId", `String id) :: args
1132 | None -> args
1133 in
1134 let args = match filter with
1135 | Some f -> ("filter", f) :: args
1136 | None -> args
1137 in
1138 let args = match sort with
1139 | Some sort_list ->
1140 let sort_json = `List (List.map Jmap.Methods.Comparator.to_json sort_list) in
1141 ("sort", sort_json) :: args
1142 | None -> args
1143 in
1144 let args = `Assoc (List.rev args) in
1145 let call_id = "mailbox-query-" ^ string_of_int (Random.int 10000) in
1146 { builder with methods = (Jmap.Method_names.method_to_string `Mailbox_query, args, call_id) :: builder.methods }
1147
1148 let mailbox_get ?account_id ?ids builder =
1149 let args = [] in
1150 let args = match account_id with
1151 | Some id -> ("accountId", `String id) :: args
1152 | None -> args
1153 in
1154 let args = match ids with
1155 | Some id_list -> ("ids", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) id_list)) :: args
1156 | None -> args
1157 in
1158 let args = `Assoc (List.rev args) in
1159 let call_id = "mailbox-get-" ^ string_of_int (Random.int 10000) in
1160 { builder with methods = (Jmap.Method_names.method_to_string `Mailbox_get, args, call_id) :: builder.methods }
1161
1162 let execute env ~session:_ builder =
1163 (* Build the request using the request builder pattern *)
1164 let req_builder = build builder.ctx in
1165 let req_builder = using req_builder [`Core; `Mail] in
1166 let final_builder = List.fold_left (fun rb (method_name_str, args, call_id) ->
1167 let method_name = match Jmap.Method_names.method_of_string method_name_str with
1168 | Some m -> m
1169 | None -> failwith ("Unknown method name: " ^ method_name_str) in
1170 add_method_call rb method_name args call_id
1171 ) req_builder (List.rev builder.methods) in
1172 execute env final_builder
1173
1174 let get_response ~method_ ?call_id response =
1175 match call_id with
1176 | Some cid -> Response.extract_method ~method_name:method_ ~method_call_id:cid response
1177 | None -> Response.extract_method_by_name ~method_name:method_ response
1178 end
1179
1180 module Response = struct
1181 (* Bridge response parsers that maintain architectural layering *)
1182 module EmailQueryResponse = struct
1183 let extract_json_list ?call_id response =
1184 let method_name = `Email_query in
1185 match call_id with
1186 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response
1187 | None -> Response.extract_method_by_name ~method_name response
1188 end
1189
1190 module EmailGetResponse = struct
1191 let extract_email_list ?call_id response =
1192 let method_name = `Email_get in
1193 let extract_method_result = match call_id with
1194 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response
1195 | None -> Response.extract_method_by_name ~method_name response
1196 in
1197 match extract_method_result with
1198 | Ok json ->
1199 (try
1200 let open Yojson.Safe.Util in
1201 let list_json = json |> member "list" |> to_list in
1202 Ok list_json
1203 with
1204 | exn -> Error (Jmap.Error.protocol_error
1205 ("Failed to parse Email/get list: " ^ Printexc.to_string exn)))
1206 | Error e -> Error e
1207 end
1208
1209 module ThreadGetResponse = struct
1210 let extract_thread_list ?call_id response =
1211 let method_name = `Thread_get in
1212 let extract_method_result = match call_id with
1213 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response
1214 | None -> Response.extract_method_by_name ~method_name response
1215 in
1216 match extract_method_result with
1217 | Ok json ->
1218 (try
1219 let open Yojson.Safe.Util in
1220 let list_json = json |> member "list" |> to_list in
1221 Ok list_json
1222 with
1223 | exn -> Error (Jmap.Error.protocol_error
1224 ("Failed to parse Thread/get list: " ^ Printexc.to_string exn)))
1225 | Error e -> Error e
1226 end
1227
1228 module MailboxGetResponse = struct
1229 let extract_mailbox_list ?call_id response =
1230 let method_name = `Mailbox_get in
1231 let extract_method_result = match call_id with
1232 | Some cid -> Response.extract_method ~method_name ~method_call_id:cid response
1233 | None -> Response.extract_method_by_name ~method_name response
1234 in
1235 match extract_method_result with
1236 | Ok json ->
1237 (try
1238 let open Yojson.Safe.Util in
1239 let list_json = json |> member "list" |> to_list in
1240 Ok list_json
1241 with
1242 | exn -> Error (Jmap.Error.protocol_error
1243 ("Failed to parse Mailbox/get list: " ^ Printexc.to_string exn)))
1244 | Error e -> Error e
1245 end
1246
1247 (* Public interface using the organized parsers *)
1248 let parse_email_query ?call_id response =
1249 EmailQueryResponse.extract_json_list ?call_id response
1250
1251 let parse_email_get ?call_id response =
1252 EmailGetResponse.extract_email_list ?call_id response
1253
1254 let parse_thread_get ?call_id response =
1255 ThreadGetResponse.extract_thread_list ?call_id response
1256
1257 let parse_mailbox_get ?call_id response =
1258 MailboxGetResponse.extract_mailbox_list ?call_id response
1259 end
1260
1261 let query_and_fetch env ~ctx ~session ?account_id ?filter ?sort ?limit ?properties () =
1262 let resolved_account_id = match account_id with
1263 | Some id -> id
1264 | None -> Session_utils.get_primary_mail_account session
1265 in
1266 (* Create the request builder and chain Email/query + Email/get *)
1267 let builder = RequestBuilder.create ctx |>
1268 RequestBuilder.email_query ~account_id:resolved_account_id ?filter ?sort ?limit ?position:None |>
1269 RequestBuilder.email_get ~account_id:resolved_account_id ?properties ~reference_from:("email-query-" ^ string_of_int (Random.int 10000))
1270 in
1271 match RequestBuilder.execute env ~session builder with
1272 | Ok response ->
1273 (* Extract the Email/get response *)
1274 (match Response.parse_email_get response with
1275 | Ok email_list -> Ok email_list
1276 | Error e -> Error e)
1277 | Error e -> Error e
1278
1279 let get_emails_by_ids env ~ctx ~session ?account_id ?properties ids =
1280 let resolved_account_id = match account_id with
1281 | Some id -> id
1282 | None -> Session_utils.get_primary_mail_account session
1283 in
1284 (* Create the request builder with Email/get *)
1285 let builder = RequestBuilder.create ctx |>
1286 RequestBuilder.email_get ~account_id:resolved_account_id ~ids ?properties
1287 in
1288 match RequestBuilder.execute env ~session builder with
1289 | Ok response ->
1290 (match Response.parse_email_get response with
1291 | Ok email_list -> Ok email_list
1292 | Error e -> Error e)
1293 | Error e -> Error e
1294
1295 let get_mailboxes env ~ctx ~session ?account_id () =
1296 let resolved_account_id = match account_id with
1297 | Some id -> id
1298 | None -> Session_utils.get_primary_mail_account session
1299 in
1300 (* Create the request builder to query all mailboxes *)
1301 let builder = RequestBuilder.create ctx |>
1302 RequestBuilder.mailbox_query ~account_id:resolved_account_id |>
1303 RequestBuilder.mailbox_get ~account_id:resolved_account_id
1304 in
1305 match RequestBuilder.execute env ~session builder with
1306 | Ok response ->
1307 (match Response.parse_mailbox_get response with
1308 | Ok mailbox_list -> Ok mailbox_list
1309 | Error e -> Error e)
1310 | Error e -> Error e
1311
1312 let find_mailbox_by_role env ~ctx ~session ?account_id role =
1313 let resolved_account_id = match account_id with
1314 | Some id -> id
1315 | None -> Session_utils.get_primary_mail_account session
1316 in
1317 (* Create filter to find mailbox by role *)
1318 let role_filter = `Assoc [("role", `String role)] in
1319 let builder = RequestBuilder.create ctx |>
1320 RequestBuilder.mailbox_query ~account_id:resolved_account_id ~filter:role_filter |>
1321 RequestBuilder.mailbox_get ~account_id:resolved_account_id
1322 in
1323 match RequestBuilder.execute env ~session builder with
1324 | Ok response ->
1325 (match Response.parse_mailbox_get response with
1326 | Ok mailbox_list ->
1327 (match mailbox_list with
1328 | mailbox :: _ -> Ok (Some mailbox) (* Return first matching mailbox *)
1329 | [] -> Ok None)
1330 | Error e -> Error e)
1331 | Error e -> Error e
1332end
1333
1334module Email_query = struct
1335 (* Save reference to top-level execute function *)
1336 let jmap_execute = execute
1337 let execute_query env ~ctx ~session:_ builder =
1338 (* The builder parameter should be a JSON object with Email/query arguments *)
1339 let call_id = "email-query-" ^ string_of_int (Random.int 10000) in
1340 let req_builder = build ctx in
1341 let req_builder = using req_builder [`Core; `Mail] in
1342 let req_builder = add_method_call req_builder `Email_query builder call_id
1343 in
1344 match jmap_execute env req_builder with
1345 | Ok response ->
1346 (match Response.extract_method ~method_name:`Email_query ~method_call_id:call_id response with
1347 | Ok json -> Ok json
1348 | Error e -> Error e)
1349 | Error e -> Error e
1350
1351 let execute_with_fetch env ~ctx ~session builder =
1352 (* Execute query first, then automatically fetch the results *)
1353 let query_call_id = "email-query-" ^ string_of_int (Random.int 10000) in
1354 let get_call_id = "email-get-" ^ string_of_int (Random.int 10000) in
1355
1356 (* Extract account ID from the builder JSON *)
1357 let account_id =
1358 try
1359 let open Yojson.Safe.Util in
1360 builder |> member "accountId" |> to_string
1361 with
1362 | _ -> Session_utils.get_primary_mail_account session
1363 in
1364
1365 (* Create get arguments with result reference *)
1366 let get_args = `Assoc [
1367 ("accountId", `String account_id);
1368 ("#ids", `Assoc [
1369 ("resultOf", `String query_call_id);
1370 ("name", `String (Jmap.Method_names.method_to_string `Email_query));
1371 ("path", `String "/ids")
1372 ])
1373 ] in
1374
1375 let req_builder = build ctx in
1376 let req_builder = using req_builder [`Core; `Mail] in
1377 let req_builder = add_method_call req_builder `Email_query builder query_call_id in
1378 let req_builder = add_method_call req_builder `Email_get get_args get_call_id
1379 in
1380 match jmap_execute env req_builder with
1381 | Ok response ->
1382 (match Response.extract_method ~method_name:`Email_get ~method_call_id:get_call_id response with
1383 | Ok json -> Ok json
1384 | Error e -> Error e)
1385 | Error e -> Error e
1386
1387end
1388
1389module Email_batch = struct
1390 (* Save reference to top-level execute function before we shadow it *)
1391 let jmap_execute = execute
1392
1393 type progress = {
1394 current : int;
1395 total : int;
1396 message : string;
1397 }
1398
1399 let execute env ~ctx ~session:_ ?account_id:_ batch =
1400 (* Execute the batch as a direct JMAP method call *)
1401 let call_id = "batch-" ^ string_of_int (Random.int 10000) in
1402 let req_builder = build ctx in
1403 let req_builder = using req_builder [`Core; `Mail] in
1404 let req_builder = add_method_call req_builder `Email_set batch call_id
1405 in
1406 match jmap_execute env req_builder with
1407 | Ok response ->
1408 (match Response.extract_method ~method_name:`Email_set ~method_call_id:call_id response with
1409 | Ok json -> Ok json
1410 | Error e -> Error e)
1411 | Error e -> Error e
1412
1413 let process_inbox env ~ctx ~session ~email_ids =
1414 let account_id = Session_utils.get_primary_mail_account session in
1415 (* Create batch operation to mark emails as seen and move to archive *)
1416 let updates = List.fold_left (fun acc email_id ->
1417 let id_str = Jmap.Id.to_string email_id in
1418 let update_patch = `Assoc [
1419 ("keywords/\\Seen", `Bool true);
1420 (* Note: Moving to archive would require finding the archive mailbox first *)
1421 ] in
1422 (id_str, update_patch) :: acc
1423 ) [] email_ids in
1424
1425 let batch_args = `Assoc [
1426 ("accountId", `String account_id);
1427 ("update", `Assoc updates)
1428 ] in
1429
1430 execute env ~ctx ~session batch_args
1431
1432 let cleanup_old_emails env ~ctx ~session ~mailbox_role ~older_than_days =
1433 let account_id = Session_utils.get_primary_mail_account session in
1434 (* First find the mailbox with the specified role *)
1435 match Email_methods.find_mailbox_by_role env ~ctx ~session ~account_id mailbox_role with
1436 | Ok (Some mailbox_json) ->
1437 (try
1438 let open Yojson.Safe.Util in
1439 let mailbox_id = mailbox_json |> member "id" |> to_string in
1440 (* Create a filter for old emails in this mailbox *)
1441 let cutoff_date = Unix.time () -. (float_of_int older_than_days *. 86400.0) in
1442 let date_str = Printf.sprintf "%.0f" cutoff_date in
1443 let filter = `Assoc [
1444 ("inMailbox", `String mailbox_id);
1445 ("before", `String date_str)
1446 ] in
1447 (* Query for old emails first, then destroy them *)
1448 let query_call_id = "cleanup-query-" ^ string_of_int (Random.int 10000) in
1449 let set_call_id = "cleanup-set-" ^ string_of_int (Random.int 10000) in
1450
1451 let query_args = `Assoc [
1452 ("accountId", `String account_id);
1453 ("filter", filter)
1454 ] in
1455
1456 let set_args = `Assoc [
1457 ("accountId", `String account_id);
1458 ("#destroy", `Assoc [
1459 ("resultOf", `String query_call_id);
1460 ("name", `String (Jmap.Method_names.method_to_string `Email_query));
1461 ("path", `String "/ids")
1462 ])
1463 ] in
1464
1465 let req_builder = build ctx in
1466 let req_builder = using req_builder [`Core; `Mail] in
1467 let req_builder = add_method_call req_builder `Email_query query_args query_call_id in
1468 let req_builder = add_method_call req_builder `Email_set set_args set_call_id
1469 in
1470 match jmap_execute env req_builder with
1471 | Ok response ->
1472 (match Response.extract_method ~method_name:`Email_set ~method_call_id:set_call_id response with
1473 | Ok json -> Ok json
1474 | Error e -> Error e)
1475 | Error e -> Error e
1476 with
1477 | exn -> Error (Jmap.Error.protocol_error
1478 ("Failed to parse mailbox: " ^ Printexc.to_string exn)))
1479 | Ok None -> Error (Jmap.Error.protocol_error
1480 ("Mailbox with role '" ^ mailbox_role ^ "' not found"))
1481 | Error e -> Error e
1482
1483 let organize_by_sender _env ~ctx:_ ~session:_ ~rules =
1484 (* This would be quite complex to implement properly, as it requires:
1485 1. Finding/creating target mailboxes for each rule
1486 2. Querying emails by sender
1487 3. Moving emails to appropriate mailboxes
1488 For now, return a basic structure indicating the operation would proceed *)
1489 let rule_count = List.length rules in
1490 let result = `Assoc [
1491 ("processed", `Int rule_count);
1492 ("message", `String "Sender organization rules would be applied")
1493 ] in
1494 Ok result
1495
1496 let execute_with_progress env ~ctx ~session ?account_id ~progress_fn batch =
1497 (* Report progress at start *)
1498 progress_fn { current = 0; total = 1; message = "Starting batch operation..." };
1499
1500 (* Execute the batch operation *)
1501 let result = execute env ~ctx ~session ?account_id batch in
1502
1503 (* Report completion *)
1504 progress_fn { current = 1; total = 1; message = "Batch operation completed" };
1505
1506 result
1507end
1508
1509module Email_submission = Email_submission