this repo has no description
anil.recoil.org
1(* Unix-specific JMAP client implementation interface. *)
2
3open Jmap
4open Jmap.Types
5open Jmap.Error
6open Jmap.Session
7open Jmap.Wire
8
9(* Configuration options for a JMAP client context *)
10type client_config = {
11 connect_timeout : float option; (* Connection timeout in seconds *)
12 request_timeout : float option; (* Request timeout in seconds *)
13 max_concurrent_requests : int option; (* Maximum concurrent requests *)
14 max_request_size : int option; (* Maximum request size in bytes *)
15 user_agent : string option; (* User-Agent header value *)
16 authentication_header : string option; (* Custom Authentication header name *)
17}
18
19(* Authentication method options *)
20type auth_method =
21 | Basic of string * string (* Basic auth with username and password *)
22 | Bearer of string (* Bearer token auth *)
23 | Custom of (string * string) (* Custom header name and value *)
24 | Session_cookie of (string * string) (* Session cookie name and value *)
25 | No_auth (* No authentication *)
26
27(* The internal state of a JMAP client connection *)
28type context = {
29 config: client_config;
30 mutable session_url: Uri.t option;
31 mutable session: Session.t option;
32 mutable auth: auth_method;
33}
34
35(* Represents an active EventSource connection *)
36type event_source_connection = {
37 event_url: Uri.t;
38 mutable is_connected: bool;
39}
40
41(* A request builder for constructing and sending JMAP requests *)
42type request_builder = {
43 ctx: context;
44 mutable using: string list;
45 mutable method_calls: Invocation.t list;
46}
47
48(* Create default configuration options *)
49let default_config () = {
50 connect_timeout = Some 30.0;
51 request_timeout = Some 300.0;
52 max_concurrent_requests = Some 4;
53 max_request_size = Some (1024 * 1024 * 10); (* 10 MB *)
54 user_agent = Some "OCaml JMAP Unix Client/1.0";
55 authentication_header = None;
56}
57
58(* Create a client context with the specified configuration *)
59let create_client ?(config = default_config ()) () = {
60 config;
61 session_url = None;
62 session = None;
63 auth = No_auth;
64}
65
66(* Mock implementation for the Unix connection *)
67let connect ctx ?session_url ?username ~host ?port ?auth_method () =
68 (* In a real implementation, this would use Unix HTTP functions *)
69 let auth = match auth_method with
70 | Some auth -> auth
71 | None -> No_auth
72 in
73
74 (* Store the auth method for future requests *)
75 ctx.auth <- auth;
76
77 (* Set session URL, either directly or after discovery *)
78 let session_url = match session_url with
79 | Some url -> url
80 | None ->
81 (* In a real implementation, this would perform RFC 8620 discovery *)
82 let proto = "https" in
83 let host_with_port = match port with
84 | Some p -> host ^ ":" ^ string_of_int p
85 | None -> host
86 in
87 Uri.of_string (proto ^ "://" ^ host_with_port ^ "/.well-known/jmap")
88 in
89 ctx.session_url <- Some session_url;
90
91 (* Create a mock session object for this example *)
92 let caps = Hashtbl.create 4 in
93 Hashtbl.add caps Jmap.capability_core (`Assoc []);
94
95 let accounts = Hashtbl.create 1 in
96 let acct = Account.v
97 ~name:"user@example.com"
98 ~is_personal:true
99 ~is_read_only:false
100 ()
101 in
102 Hashtbl.add accounts "u1" acct;
103
104 let primary = Hashtbl.create 1 in
105 Hashtbl.add primary Jmap.capability_core "u1";
106
107 let api_url =
108 Uri.of_string ("https://" ^ host ^ "/api/jmap")
109 in
110
111 let session = Session.v
112 ~capabilities:caps
113 ~accounts
114 ~primary_accounts:primary
115 ~username:"user@example.com"
116 ~api_url
117 ~download_url:(Uri.of_string ("https://" ^ host ^ "/download/{accountId}/{blobId}"))
118 ~upload_url:(Uri.of_string ("https://" ^ host ^ "/upload/{accountId}"))
119 ~event_source_url:(Uri.of_string ("https://" ^ host ^ "/eventsource"))
120 ~state:"1"
121 ()
122 in
123
124 ctx.session <- Some session;
125 Ok (ctx, session)
126
127(* Create a request builder for constructing a JMAP request *)
128let build ctx = {
129 ctx;
130 using = [Jmap.capability_core]; (* Default to core capability *)
131 method_calls = [];
132}
133
134(* Set the using capabilities for a request *)
135let using builder capabilities =
136 { builder with using = capabilities }
137
138(* Add a method call to a request builder *)
139let add_method_call builder name args id =
140 let call = Invocation.v
141 ~method_name:name
142 ~arguments:args
143 ~method_call_id:id
144 ()
145 in
146 { builder with method_calls = builder.method_calls @ [call] }
147
148(* Create a reference to a previous method call result *)
149let create_reference result_of name =
150 Jmap.Wire.Result_reference.v
151 ~result_of
152 ~name
153 ~path:"" (* In a real implementation, this would include a JSON pointer *)
154 ()
155
156(* Execute a request and return the response *)
157let execute builder =
158 match builder.ctx.session with
159 | None -> Error (protocol_error "No active session")
160 | Some session ->
161 (* In a real implementation, this would create and send an HTTP request *)
162
163 (* Create a mock response for this implementation *)
164 let results = List.map (fun call ->
165 let method_name = Invocation.method_name call in
166 let call_id = Invocation.method_call_id call in
167 if method_name = "Core/echo" then
168 (* Echo method implementation *)
169 Ok call
170 else
171 (* For other methods, return a method error *)
172 Error (
173 Method_error.v
174 ~description:(Method_error_description.v
175 ~description:"Method not implemented in mock"
176 ())
177 `ServerUnavailable,
178 "Mock implementation"
179 )
180 ) builder.method_calls in
181
182 let resp = Response.v
183 ~method_responses:results
184 ~session_state:(session |> Session.state)
185 ()
186 in
187 Ok resp
188
189(* Perform a JMAP API request *)
190let request ctx req =
191 match ctx.session_url, ctx.session with
192 | None, _ -> Error (protocol_error "No session URL configured")
193 | _, None -> Error (protocol_error "No active session")
194 | Some url, Some session ->
195 (* In a real implementation, this would serialize the request and send it *)
196
197 (* Mock response implementation *)
198 let method_calls = Request.method_calls req in
199 let results = List.map (fun call ->
200 let method_name = Invocation.method_name call in
201 let call_id = Invocation.method_call_id call in
202 if method_name = "Core/echo" then
203 (* Echo method implementation *)
204 Ok call
205 else
206 (* For other methods, return a method error *)
207 Error (
208 Method_error.v
209 ~description:(Method_error_description.v
210 ~description:"Method not implemented in mock"
211 ())
212 `ServerUnavailable,
213 "Mock implementation"
214 )
215 ) method_calls in
216
217 let resp = Response.v
218 ~method_responses:results
219 ~session_state:(session |> Session.state)
220 ()
221 in
222 Ok resp
223
224(* Upload binary data *)
225let upload ctx ~account_id ~content_type ~data_stream =
226 match ctx.session with
227 | None -> Error (protocol_error "No active session")
228 | Some session ->
229 (* In a real implementation, would upload the data stream *)
230
231 (* Mock success response *)
232 let response = Jmap.Binary.Upload_response.v
233 ~account_id
234 ~blob_id:"b123456"
235 ~type_:content_type
236 ~size:1024 (* Mock size *)
237 ()
238 in
239 Ok response
240
241(* Download binary data *)
242let download ctx ~account_id ~blob_id ?content_type ?name =
243 match ctx.session with
244 | None -> Error (protocol_error "No active session")
245 | Some session ->
246 (* In a real implementation, would download the data and return a stream *)
247
248 (* Mock data stream - in real code, this would be read from the HTTP response *)
249 let mock_data = "This is mock downloaded data for blob " ^ blob_id in
250 let seq = Seq.cons mock_data Seq.empty in
251 Ok seq
252
253(* Copy blobs between accounts *)
254let copy_blobs ctx ~from_account_id ~account_id ~blob_ids =
255 match ctx.session with
256 | None -> Error (protocol_error "No active session")
257 | Some session ->
258 (* In a real implementation, would perform server-side copy *)
259
260 (* Mock success response with first blob copied and second failed *)
261 let copied = Hashtbl.create 1 in
262 Hashtbl.add copied (List.hd blob_ids) "b999999";
263
264 let response = Jmap.Binary.Blob_copy_response.v
265 ~from_account_id
266 ~account_id
267 ~copied
268 ()
269 in
270 Ok response
271
272(* Connect to the EventSource for push notifications *)
273let connect_event_source ctx ?types ?close_after ?ping =
274 match ctx.session with
275 | None -> Error (protocol_error "No active session")
276 | Some session ->
277 (* In a real implementation, would connect to EventSource URL *)
278
279 (* Create mock connection *)
280 let event_url = Session.event_source_url session in
281 let conn = { event_url; is_connected = true } in
282
283 (* Create a mock event sequence *)
284 let mock_state_change =
285 let changed = Hashtbl.create 1 in
286 let account_id = "u1" in
287 let state_map = Hashtbl.create 2 in
288 Hashtbl.add state_map "Email" "s123";
289 Hashtbl.add state_map "Mailbox" "s456";
290 Hashtbl.add changed account_id state_map;
291
292 Push.State_change.v ~changed ()
293 in
294
295 let ping_data =
296 Push.Event_source_ping_data.v ~interval:30 ()
297 in
298
299 (* Create a sequence with one state event and one ping event *)
300 let events = Seq.cons (`State mock_state_change)
301 (Seq.cons (`Ping ping_data) Seq.empty) in
302
303 Ok (conn, events)
304
305(* Create a websocket connection for JMAP over WebSocket *)
306let connect_websocket ctx =
307 match ctx.session with
308 | None -> Error (protocol_error "No active session")
309 | Some session ->
310 (* In a real implementation, would connect via WebSocket *)
311
312 (* Mock connection *)
313 let event_url = Session.api_url session in
314 let conn = { event_url; is_connected = true } in
315 Ok conn
316
317(* Send a message over a websocket connection *)
318let websocket_send conn req =
319 if not conn.is_connected then
320 Error (protocol_error "WebSocket not connected")
321 else
322 (* In a real implementation, would send over WebSocket *)
323
324 (* Mock response (same as request function) *)
325 let method_calls = Request.method_calls req in
326 let results = List.map (fun call ->
327 let method_name = Invocation.method_name call in
328 let call_id = Invocation.method_call_id call in
329 if method_name = "Core/echo" then
330 Ok call
331 else
332 Error (
333 Method_error.v
334 ~description:(Method_error_description.v
335 ~description:"Method not implemented in mock"
336 ())
337 `ServerUnavailable,
338 "Mock implementation"
339 )
340 ) method_calls in
341
342 let resp = Response.v
343 ~method_responses:results
344 ~session_state:"1"
345 ()
346 in
347 Ok resp
348
349(* Close an EventSource or WebSocket connection *)
350let close_connection conn =
351 if not conn.is_connected then
352 Error (protocol_error "Connection already closed")
353 else begin
354 conn.is_connected <- false;
355 Ok ()
356 end
357
358(* Close the JMAP connection context *)
359let close ctx =
360 ctx.session <- None;
361 ctx.session_url <- None;
362 Ok ()
363
364(* Helper functions for common tasks *)
365
366(* Helper to get a single object by ID *)
367let get_object ctx ~method_name ~account_id ~object_id ?properties =
368 let properties_param = match properties with
369 | Some props -> `List (List.map (fun p -> `String p) props)
370 | None -> `Null
371 in
372
373 let args = `Assoc [
374 ("accountId", `String account_id);
375 ("ids", `List [`String object_id]);
376 ("properties", properties_param);
377 ] in
378
379 let request_builder = build ctx
380 |> add_method_call method_name args "r1"
381 in
382
383 match execute request_builder with
384 | Error e -> Error e
385 | Ok response ->
386 (* Find the method response and extract the list with the object *)
387 match response |> Response.method_responses with
388 | [Ok invocation] when Invocation.method_name invocation = method_name ^ "/get" ->
389 let args = Invocation.arguments invocation in
390 begin match Yojson.Safe.Util.member "list" args with
391 | `List [obj] -> Ok obj
392 | _ -> Error (protocol_error "Object not found or invalid response")
393 end
394 | _ ->
395 Error (protocol_error "Method response not found")
396
397(* Helper to set up the connection with minimal options *)
398let quick_connect ~host ~username ~password =
399 let ctx = create_client () in
400 connect ctx ~host ~auth_method:(Basic(username, password)) ()
401
402(* Perform a Core/echo request to test connectivity *)
403let echo ctx ?data () =
404 let data = match data with
405 | Some d -> d
406 | None -> `Assoc [("hello", `String "world")]
407 in
408
409 let request_builder = build ctx
410 |> add_method_call "Core/echo" data "echo1"
411 in
412
413 match execute request_builder with
414 | Error e -> Error e
415 | Ok response ->
416 (* Find the Core/echo response and extract the echoed data *)
417 match response |> Response.method_responses with
418 | [Ok invocation] when Invocation.method_name invocation = "Core/echo" ->
419 Ok (Invocation.arguments invocation)
420 | _ ->
421 Error (protocol_error "Echo response not found")
422
423(* High-level email operations *)
424module Email = struct
425 open Jmap_email.Types
426
427 (* Get an email by ID *)
428 let get_email ctx ~account_id ~email_id ?properties () =
429 let props = match properties with
430 | Some p -> p
431 | None -> List.map email_property_to_string detailed_email_properties
432 in
433
434 match get_object ctx ~method_name:"Email/get" ~account_id ~object_id:email_id ~properties:props with
435 | Error e -> Error e
436 | Ok json ->
437 (* In a real implementation, would parse the JSON into an Email.t structure *)
438 let mock_email = Email.create
439 ~id:email_id
440 ~thread_id:"t12345"
441 ~mailbox_ids:(let h = Hashtbl.create 1 in Hashtbl.add h "inbox" true; h)
442 ~keywords:(Keywords.of_list [Keywords.Seen])
443 ~subject:"Mock Email Subject"
444 ~preview:"This is a mock email..."
445 ~from:[Email_address.v ~name:"Sender Name" ~email:"sender@example.com" ()]
446 ~to_:[Email_address.v ~email:"recipient@example.com" ()]
447 ()
448 in
449 Ok mock_email
450
451 (* Search for emails using a filter *)
452 let search_emails ctx ~account_id ~filter ?sort ?limit ?position ?properties () =
453 (* Create the query args *)
454 let args = `Assoc [
455 ("accountId", `String account_id);
456 ("filter", Jmap.Methods.Filter.to_json filter);
457 ("sort", match sort with
458 | Some s -> `List [] (* Would convert sort params *)
459 | None -> `List [`Assoc [("property", `String "receivedAt"); ("isAscending", `Bool false)]]);
460 ("limit", match limit with
461 | Some l -> `Int l
462 | None -> `Int 20);
463 ("position", match position with
464 | Some p -> `Int p
465 | None -> `Int 0);
466 ] in
467
468 let request_builder = build ctx
469 |> add_method_call "Email/query" args "q1"
470 in
471
472 (* If properties were provided, add a Email/get method call as well *)
473 let request_builder = match properties with
474 | Some _ ->
475 let get_args = `Assoc [
476 ("accountId", `String account_id);
477 ("#ids", `Assoc [
478 ("resultOf", `String "q1");
479 ("name", `String "Email/query");
480 ("path", `String "/ids")
481 ]);
482 ("properties", match properties with
483 | Some p -> `List (List.map (fun prop -> `String prop) p)
484 | None -> `Null);
485 ] in
486 add_method_call request_builder "Email/get" get_args "g1"
487 | None -> request_builder
488 in
489
490 match execute request_builder with
491 | Error e -> Error e
492 | Ok response ->
493 (* Find the query response and extract the IDs *)
494 match Response.method_responses response with
495 | [Ok q_inv; Ok g_inv]
496 when Invocation.method_name q_inv = "Email/query"
497 && Invocation.method_name g_inv = "Email/get" ->
498
499 (* Extract IDs from query response *)
500 let q_args = Invocation.arguments q_inv in
501 let ids = match Yojson.Safe.Util.member "ids" q_args with
502 | `List l -> List.map Yojson.Safe.Util.to_string l
503 | _ -> []
504 in
505
506 (* Extract emails from get response *)
507 let g_args = Invocation.arguments g_inv in
508 (* In a real implementation, would parse each email in the list *)
509 let emails = List.map (fun id ->
510 Email.create
511 ~id
512 ~thread_id:("t" ^ id)
513 ~subject:(Printf.sprintf "Mock Email %s" id)
514 ()
515 ) ids in
516
517 Ok (ids, Some emails)
518
519 | [Ok q_inv] when Invocation.method_name q_inv = "Email/query" ->
520 (* If only query was performed (no properties requested) *)
521 let q_args = Invocation.arguments q_inv in
522 let ids = match Yojson.Safe.Util.member "ids" q_args with
523 | `List l -> List.map Yojson.Safe.Util.to_string l
524 | _ -> []
525 in
526
527 Ok (ids, None)
528
529 | _ ->
530 Error (protocol_error "Query response not found")
531
532 (* Mark multiple emails with a keyword *)
533 let mark_emails ctx ~account_id ~email_ids ~keyword () =
534 (* Create the set args with a patch to add the keyword *)
535 let keyword_patch = Jmap_email.Keyword_ops.add_keyword_patch keyword in
536
537 (* Create patches map for each email *)
538 let update = Hashtbl.create (List.length email_ids) in
539 List.iter (fun id ->
540 Hashtbl.add update id keyword_patch
541 ) email_ids;
542
543 let args = `Assoc [
544 ("accountId", `String account_id);
545 ("update", `Assoc (
546 List.map (fun id ->
547 (id, `Assoc (List.map (fun (path, value) ->
548 (path, value)
549 ) keyword_patch))
550 ) email_ids
551 ));
552 ] in
553
554 let request_builder = build ctx
555 |> add_method_call "Email/set" args "s1"
556 in
557
558 match execute request_builder with
559 | Error e -> Error e
560 | Ok response ->
561 (* In a real implementation, would check for errors *)
562 Ok ()
563
564 (* Mark emails as seen/read *)
565 let mark_as_seen ctx ~account_id ~email_ids () =
566 mark_emails ctx ~account_id ~email_ids ~keyword:Keywords.Seen ()
567
568 (* Mark emails as unseen/unread *)
569 let mark_as_unseen ctx ~account_id ~email_ids () =
570 let keyword_patch = Jmap_email.Keyword_ops.mark_unseen_patch () in
571
572 (* Create patches map for each email *)
573 let update = Hashtbl.create (List.length email_ids) in
574 List.iter (fun id ->
575 Hashtbl.add update id keyword_patch
576 ) email_ids;
577
578 let args = `Assoc [
579 ("accountId", `String account_id);
580 ("update", `Assoc (
581 List.map (fun id ->
582 (id, `Assoc (List.map (fun (path, value) ->
583 (path, value)
584 ) keyword_patch))
585 ) email_ids
586 ));
587 ] in
588
589 let request_builder = build ctx
590 |> add_method_call "Email/set" args "s1"
591 in
592
593 match execute request_builder with
594 | Error e -> Error e
595 | Ok _response -> Ok ()
596
597 (* Move emails to a different mailbox *)
598 let move_emails ctx ~account_id ~email_ids ~mailbox_id ?remove_from_mailboxes () =
599 (* Create patch to add to destination mailbox *)
600 let add_patch = [("mailboxIds/" ^ mailbox_id, `Bool true)] in
601
602 (* If remove_from_mailboxes is specified, add patches to remove *)
603 let remove_patch = match remove_from_mailboxes with
604 | Some mailboxes ->
605 List.map (fun mbx -> ("mailboxIds/" ^ mbx, `Null)) mailboxes
606 | None -> []
607 in
608
609 (* Combine patches *)
610 let patches = add_patch @ remove_patch in
611
612 (* Create patches map for each email *)
613 let update = Hashtbl.create (List.length email_ids) in
614 List.iter (fun id ->
615 Hashtbl.add update id patches
616 ) email_ids;
617
618 let args = `Assoc [
619 ("accountId", `String account_id);
620 ("update", `Assoc (
621 List.map (fun id ->
622 (id, `Assoc (List.map (fun (path, value) ->
623 (path, value)
624 ) patches))
625 ) email_ids
626 ));
627 ] in
628
629 let request_builder = build ctx
630 |> add_method_call "Email/set" args "s1"
631 in
632
633 match execute request_builder with
634 | Error e -> Error e
635 | Ok _response -> Ok ()
636
637 (* Import an RFC822 message *)
638 let import_email ctx ~account_id ~rfc822 ~mailbox_ids ?keywords ?received_at () =
639 (* In a real implementation, would first upload the message as a blob *)
640 let mock_blob_id = "b9876" in
641
642 (* Create the Email/import call *)
643 let args = `Assoc [
644 ("accountId", `String account_id);
645 ("emails", `Assoc [
646 ("msg1", `Assoc [
647 ("blobId", `String mock_blob_id);
648 ("mailboxIds", `Assoc (
649 List.map (fun id -> (id, `Bool true)) mailbox_ids
650 ));
651 ("keywords", match keywords with
652 | Some kws ->
653 `Assoc (List.map (fun k ->
654 (Types.Keywords.to_string k, `Bool true)) kws)
655 | None -> `Null);
656 ("receivedAt", match received_at with
657 | Some d -> `String (string_of_float d) (* Would format as RFC3339 *)
658 | None -> `Null);
659 ])
660 ]);
661 ] in
662
663 let request_builder = build ctx
664 |> add_method_call "Email/import" args "i1"
665 in
666
667 match execute request_builder with
668 | Error e -> Error e
669 | Ok response ->
670 (* In a real implementation, would extract the created ID *)
671 Ok "e12345"
672end