···
1
-
(* Unix-specific JMAP client implementation interface. *)
9
-
(* Configuration options for a JMAP client context *)
10
-
type 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 *)
19
-
(* Authentication method options *)
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 *)
27
-
(* The internal state of a JMAP client connection *)
29
-
config: client_config;
30
-
mutable session_url: Uri.t option;
31
-
mutable session: Session.t option;
32
-
mutable auth: auth_method;
35
-
(* Represents an active EventSource connection *)
36
-
type event_source_connection = {
38
-
mutable is_connected: bool;
41
-
(* A request builder for constructing and sending JMAP requests *)
42
-
type request_builder = {
44
-
mutable using: string list;
45
-
mutable method_calls: Invocation.t list;
48
-
(* Create default configuration options *)
49
-
let 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;
58
-
(* Create a client context with the specified configuration *)
59
-
let create_client ?(config = default_config ()) () = {
66
-
(* Mock implementation for the Unix connection *)
67
-
let 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
74
-
(* Store the auth method for future requests *)
77
-
(* Set session URL, either directly or after discovery *)
78
-
let session_url = match session_url with
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
87
-
Uri.of_string (proto ^ "://" ^ host_with_port ^ "/.well-known/jmap")
89
-
ctx.session_url <- Some session_url;
91
-
(* Create a mock session object for this example *)
92
-
let caps = Hashtbl.create 4 in
93
-
Hashtbl.add caps Jmap.capability_core (`Assoc []);
95
-
let accounts = Hashtbl.create 1 in
96
-
let acct = Account.v
97
-
~name:"user@example.com"
102
-
Hashtbl.add accounts "u1" acct;
104
-
let primary = Hashtbl.create 1 in
105
-
Hashtbl.add primary Jmap.capability_core "u1";
108
-
Uri.of_string ("https://" ^ host ^ "/api/jmap")
111
-
let session = Session.v
114
-
~primary_accounts:primary
115
-
~username:"user@example.com"
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"))
124
-
ctx.session <- Some session;
127
-
(* Create a request builder for constructing a JMAP request *)
130
-
using = [Jmap.capability_core]; (* Default to core capability *)
134
-
(* Set the using capabilities for a request *)
135
-
let using builder capabilities =
136
-
{ builder with using = capabilities }
138
-
(* Add a method call to a request builder *)
139
-
let add_method_call builder name args id =
140
-
let call = Invocation.v
146
-
{ builder with method_calls = builder.method_calls @ [call] }
148
-
(* Create a reference to a previous method call result *)
149
-
let create_reference result_of name =
150
-
Jmap.Wire.Result_reference.v
153
-
~path:"" (* In a real implementation, this would include a JSON pointer *)
156
-
(* Execute a request and return the response *)
157
-
let execute builder =
158
-
match builder.ctx.session with
159
-
| None -> Error (protocol_error "No active session")
161
-
(* In a real implementation, this would create and send an HTTP request *)
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 *)
171
-
(* For other methods, return a method error *)
174
-
~description:(Method_error_description.v
175
-
~description:"Method not implemented in mock"
177
-
`ServerUnavailable,
178
-
"Mock implementation"
180
-
) builder.method_calls in
182
-
let resp = Response.v
183
-
~method_responses:results
184
-
~session_state:(session |> Session.state)
189
-
(* Perform a JMAP API request *)
190
-
let 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 *)
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 *)
206
-
(* For other methods, return a method error *)
209
-
~description:(Method_error_description.v
210
-
~description:"Method not implemented in mock"
212
-
`ServerUnavailable,
213
-
"Mock implementation"
217
-
let resp = Response.v
218
-
~method_responses:results
219
-
~session_state:(session |> Session.state)
224
-
(* Upload binary data *)
225
-
let upload ctx ~account_id ~content_type ~data_stream =
226
-
match ctx.session with
227
-
| None -> Error (protocol_error "No active session")
229
-
(* In a real implementation, would upload the data stream *)
231
-
(* Mock success response *)
232
-
let response = Jmap.Binary.Upload_response.v
235
-
~type_:content_type
236
-
~size:1024 (* Mock size *)
241
-
(* Download binary data *)
242
-
let download ctx ~account_id ~blob_id ?content_type ?name =
243
-
match ctx.session with
244
-
| None -> Error (protocol_error "No active session")
246
-
(* In a real implementation, would download the data and return a stream *)
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
253
-
(* Copy blobs between accounts *)
254
-
let copy_blobs ctx ~from_account_id ~account_id ~blob_ids =
255
-
match ctx.session with
256
-
| None -> Error (protocol_error "No active session")
258
-
(* In a real implementation, would perform server-side copy *)
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";
264
-
let response = Jmap.Binary.Blob_copy_response.v
272
-
(* Connect to the EventSource for push notifications *)
273
-
let connect_event_source ctx ?types ?close_after ?ping =
274
-
match ctx.session with
275
-
| None -> Error (protocol_error "No active session")
277
-
(* In a real implementation, would connect to EventSource URL *)
279
-
(* Create mock connection *)
280
-
let event_url = Session.event_source_url session in
281
-
let conn = { event_url; is_connected = true } in
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;
292
-
Push.State_change.v ~changed ()
296
-
Push.Event_source_ping_data.v ~interval:30 ()
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
305
-
(* Create a websocket connection for JMAP over WebSocket *)
306
-
let connect_websocket ctx =
307
-
match ctx.session with
308
-
| None -> Error (protocol_error "No active session")
310
-
(* In a real implementation, would connect via WebSocket *)
312
-
(* Mock connection *)
313
-
let event_url = Session.api_url session in
314
-
let conn = { event_url; is_connected = true } in
317
-
(* Send a message over a websocket connection *)
318
-
let websocket_send conn req =
319
-
if not conn.is_connected then
320
-
Error (protocol_error "WebSocket not connected")
322
-
(* In a real implementation, would send over WebSocket *)
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
334
-
~description:(Method_error_description.v
335
-
~description:"Method not implemented in mock"
337
-
`ServerUnavailable,
338
-
"Mock implementation"
342
-
let resp = Response.v
343
-
~method_responses:results
349
-
(* Close an EventSource or WebSocket connection *)
350
-
let close_connection conn =
351
-
if not conn.is_connected then
352
-
Error (protocol_error "Connection already closed")
354
-
conn.is_connected <- false;
358
-
(* Close the JMAP connection context *)
360
-
ctx.session <- None;
361
-
ctx.session_url <- None;
364
-
(* Helper functions for common tasks *)
366
-
(* Helper to get a single object by ID *)
367
-
let 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)
373
-
let args = `Assoc [
374
-
("accountId", `String account_id);
375
-
("ids", `List [`String object_id]);
376
-
("properties", properties_param);
379
-
let request_builder = build ctx
380
-
|> add_method_call method_name args "r1"
383
-
match execute request_builder with
384
-
| Error e -> Error e
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")
395
-
Error (protocol_error "Method response not found")
397
-
(* Helper to set up the connection with minimal options *)
398
-
let quick_connect ~host ~username ~password =
399
-
let ctx = create_client () in
400
-
connect ctx ~host ~auth_method:(Basic(username, password)) ()
402
-
(* Perform a Core/echo request to test connectivity *)
403
-
let echo ctx ?data () =
404
-
let data = match data with
406
-
| None -> `Assoc [("hello", `String "world")]
409
-
let request_builder = build ctx
410
-
|> add_method_call "Core/echo" data "echo1"
413
-
match execute request_builder with
414
-
| Error e -> Error e
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)
421
-
Error (protocol_error "Echo response not found")
423
-
(* High-level email operations *)
424
-
module Email = struct
425
-
open Jmap_email.Types
427
-
(* Get an email by ID *)
428
-
let get_email ctx ~account_id ~email_id ?properties () =
429
-
let props = match properties with
431
-
| None -> List.map email_property_to_string detailed_email_properties
434
-
match get_object ctx ~method_name:"Email/get" ~account_id ~object_id:email_id ~properties:props with
435
-
| Error e -> Error e
437
-
(* In a real implementation, would parse the JSON into an Email.t structure *)
438
-
let mock_email = Email.create
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" ()]
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
462
-
| None -> `Int 20);
463
-
("position", match position with
468
-
let request_builder = build ctx
469
-
|> add_method_call "Email/query" args "q1"
472
-
(* If properties were provided, add a Email/get method call as well *)
473
-
let request_builder = match properties with
475
-
let get_args = `Assoc [
476
-
("accountId", `String account_id);
478
-
("resultOf", `String "q1");
479
-
("name", `String "Email/query");
480
-
("path", `String "/ids")
482
-
("properties", match properties with
483
-
| Some p -> `List (List.map (fun prop -> `String prop) p)
486
-
add_method_call request_builder "Email/get" get_args "g1"
487
-
| None -> request_builder
490
-
match execute request_builder with
491
-
| Error e -> Error e
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" ->
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
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 ->
512
-
~thread_id:("t" ^ id)
513
-
~subject:(Printf.sprintf "Mock Email %s" id)
517
-
Ok (ids, Some emails)
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
530
-
Error (protocol_error "Query response not found")
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
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
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) ->
554
-
let request_builder = build ctx
555
-
|> add_method_call "Email/set" args "s1"
558
-
match execute request_builder with
559
-
| Error e -> Error e
561
-
(* In a real implementation, would check for errors *)
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 ()
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
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
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) ->
589
-
let request_builder = build ctx
590
-
|> add_method_call "Email/set" args "s1"
593
-
match execute request_builder with
594
-
| Error e -> Error e
595
-
| Ok _response -> Ok ()
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
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
609
-
(* Combine patches *)
610
-
let patches = add_patch @ remove_patch in
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
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) ->
629
-
let request_builder = build ctx
630
-
|> add_method_call "Email/set" args "s1"
633
-
match execute request_builder with
634
-
| Error e -> Error e
635
-
| Ok _response -> Ok ()
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
642
-
(* Create the Email/import call *)
643
-
let args = `Assoc [
644
-
("accountId", `String account_id);
645
-
("emails", `Assoc [
647
-
("blobId", `String mock_blob_id);
648
-
("mailboxIds", `Assoc (
649
-
List.map (fun id -> (id, `Bool true)) mailbox_ids
651
-
("keywords", match keywords with
653
-
`Assoc (List.map (fun k ->
654
-
(Types.Keywords.to_string k, `Bool true)) kws)
656
-
("receivedAt", match received_at with
657
-
| Some d -> `String (string_of_float d) (* Would format as RFC3339 *)
663
-
let request_builder = build ctx
664
-
|> add_method_call "Email/import" args "i1"
667
-
match execute request_builder with
668
-
| Error e -> Error e
670
-
(* In a real implementation, would extract the created ID *)
anil.recoil.org