this repo has no description
anil.recoil.org
1(**
2 * JMAP protocol implementation based on RFC8620
3 * https://datatracker.ietf.org/doc/html/rfc8620
4 *)
5
6module Types = struct
7 (** Id string as per Section 1.2 *)
8 type id = string
9
10 (** Int bounded within the range -2^53+1 to 2^53-1 as per Section 1.3 *)
11 type int_t = int
12
13 (** UnsignedInt bounded within the range 0 to 2^53-1 as per Section 1.3 *)
14 type unsigned_int = int
15
16 (** Date string in RFC3339 format as per Section 1.4 *)
17 type date = string
18
19 (** UTCDate is a Date with 'Z' time zone as per Section 1.4 *)
20 type utc_date = string
21
22 (** Error object as per Section 3.6.2 *)
23 type error = {
24 type_: string;
25 description: string option;
26 }
27
28 (** Set error object as per Section 5.3 *)
29 type set_error = {
30 type_: string;
31 description: string option;
32 properties: string list option;
33 (* Additional properties for specific error types *)
34 existing_id: id option; (* For alreadyExists error *)
35 }
36
37 (** Invocation object as per Section 3.2 *)
38 type 'a invocation = {
39 name: string;
40 arguments: 'a;
41 method_call_id: string;
42 }
43
44 (** ResultReference object as per Section 3.7 *)
45 type result_reference = {
46 result_of: string;
47 name: string;
48 path: string;
49 }
50
51 (** FilterOperator, FilterCondition and Filter as per Section 5.5 *)
52 type filter_operator = {
53 operator: string; (* "AND", "OR", "NOT" *)
54 conditions: filter list;
55 }
56 and filter_condition = (string * Ezjsonm.value) list
57 and filter =
58 | Operator of filter_operator
59 | Condition of filter_condition
60
61 (** Comparator object for sorting as per Section 5.5 *)
62 type comparator = {
63 property: string;
64 is_ascending: bool option; (* Optional, defaults to true *)
65 collation: string option; (* Optional, server-dependent default *)
66 }
67
68 (** PatchObject as per Section 5.3 *)
69 type patch_object = (string * Ezjsonm.value) list
70
71 (** AddedItem structure as per Section 5.6 *)
72 type added_item = {
73 id: id;
74 index: unsigned_int;
75 }
76
77 (** Account object as per Section 1.6.2 *)
78 type account = {
79 name: string;
80 is_personal: bool;
81 is_read_only: bool;
82 account_capabilities: (string * Ezjsonm.value) list;
83 }
84
85 (** Core capability object as per Section 2 *)
86 type core_capability = {
87 max_size_upload: unsigned_int;
88 max_concurrent_upload: unsigned_int;
89 max_size_request: unsigned_int;
90 max_concurrent_requests: unsigned_int;
91 max_calls_in_request: unsigned_int;
92 max_objects_in_get: unsigned_int;
93 max_objects_in_set: unsigned_int;
94 collation_algorithms: string list;
95 }
96
97 (** PushSubscription keys object as per Section 7.2 *)
98 type push_keys = {
99 p256dh: string;
100 auth: string;
101 }
102
103 (** Session object as per Section 2 *)
104 type session = {
105 capabilities: (string * Ezjsonm.value) list;
106 accounts: (id * account) list;
107 primary_accounts: (string * id) list;
108 username: string;
109 api_url: string;
110 download_url: string;
111 upload_url: string;
112 event_source_url: string option;
113 state: string;
114 }
115
116 (** TypeState for state changes as per Section 7.1 *)
117 type type_state = (string * string) list
118
119 (** StateChange object as per Section 7.1 *)
120 type state_change = {
121 changed: (id * type_state) list;
122 }
123
124 (** PushVerification object as per Section 7.2.2 *)
125 type push_verification = {
126 push_subscription_id: id;
127 verification_code: string;
128 }
129
130 (** PushSubscription object as per Section 7.2 *)
131 type push_subscription = {
132 id: id;
133 device_client_id: string;
134 url: string;
135 keys: push_keys option;
136 verification_code: string option;
137 expires: utc_date option;
138 types: string list option;
139 }
140
141 (** Request object as per Section 3.3 *)
142 type request = {
143 using: string list;
144 method_calls: Ezjsonm.value invocation list;
145 created_ids: (id * id) list option;
146 }
147
148 (** Response object as per Section 3.4 *)
149 type response = {
150 method_responses: Ezjsonm.value invocation list;
151 created_ids: (id * id) list option;
152 session_state: string;
153 }
154
155 (** Standard method arguments and responses *)
156
157 (** Arguments for Foo/get method as per Section 5.1 *)
158 type 'a get_arguments = {
159 account_id: id;
160 ids: id list option;
161 properties: string list option;
162 }
163
164 (** Response for Foo/get method as per Section 5.1 *)
165 type 'a get_response = {
166 account_id: id;
167 state: string;
168 list: 'a list;
169 not_found: id list;
170 }
171
172 (** Arguments for Foo/changes method as per Section 5.2 *)
173 type changes_arguments = {
174 account_id: id;
175 since_state: string;
176 max_changes: unsigned_int option;
177 }
178
179 (** Response for Foo/changes method as per Section 5.2 *)
180 type changes_response = {
181 account_id: id;
182 old_state: string;
183 new_state: string;
184 has_more_changes: bool;
185 created: id list;
186 updated: id list;
187 destroyed: id list;
188 }
189
190 (** Arguments for Foo/set method as per Section 5.3 *)
191 type 'a set_arguments = {
192 account_id: id;
193 if_in_state: string option;
194 create: (id * 'a) list option;
195 update: (id * patch_object) list option;
196 destroy: id list option;
197 }
198
199 (** Response for Foo/set method as per Section 5.3 *)
200 type 'a set_response = {
201 account_id: id;
202 old_state: string option;
203 new_state: string;
204 created: (id * 'a) list option;
205 updated: (id * 'a option) list option;
206 destroyed: id list option;
207 not_created: (id * set_error) list option;
208 not_updated: (id * set_error) list option;
209 not_destroyed: (id * set_error) list option;
210 }
211
212 (** Arguments for Foo/copy method as per Section 5.4 *)
213 type 'a copy_arguments = {
214 from_account_id: id;
215 if_from_in_state: string option;
216 account_id: id;
217 if_in_state: string option;
218 create: (id * 'a) list;
219 on_success_destroy_original: bool option;
220 destroy_from_if_in_state: string option;
221 }
222
223 (** Response for Foo/copy method as per Section 5.4 *)
224 type 'a copy_response = {
225 from_account_id: id;
226 account_id: id;
227 old_state: string option;
228 new_state: string;
229 created: (id * 'a) list option;
230 not_created: (id * set_error) list option;
231 }
232
233 (** Arguments for Foo/query method as per Section 5.5 *)
234 type query_arguments = {
235 account_id: id;
236 filter: filter option;
237 sort: comparator list option;
238 position: int_t option;
239 anchor: id option;
240 anchor_offset: int_t option;
241 limit: unsigned_int option;
242 calculate_total: bool option;
243 }
244
245 (** Response for Foo/query method as per Section 5.5 *)
246 type query_response = {
247 account_id: id;
248 query_state: string;
249 can_calculate_changes: bool;
250 position: unsigned_int;
251 ids: id list;
252 total: unsigned_int option;
253 limit: unsigned_int option;
254 }
255
256 (** Arguments for Foo/queryChanges method as per Section 5.6 *)
257 type query_changes_arguments = {
258 account_id: id;
259 filter: filter option;
260 sort: comparator list option;
261 since_query_state: string;
262 max_changes: unsigned_int option;
263 up_to_id: id option;
264 calculate_total: bool option;
265 }
266
267 (** Response for Foo/queryChanges method as per Section 5.6 *)
268 type query_changes_response = {
269 account_id: id;
270 old_query_state: string;
271 new_query_state: string;
272 total: unsigned_int option;
273 removed: id list;
274 added: added_item list option;
275 }
276
277 (** Arguments for Blob/copy method as per Section 6.3 *)
278 type blob_copy_arguments = {
279 from_account_id: id;
280 account_id: id;
281 blob_ids: id list;
282 }
283
284 (** Response for Blob/copy method as per Section 6.3 *)
285 type blob_copy_response = {
286 from_account_id: id;
287 account_id: id;
288 copied: (id * id) list option;
289 not_copied: (id * set_error) list option;
290 }
291
292 (** Upload response as per Section 6.1 *)
293 type upload_response = {
294 account_id: id;
295 blob_id: id;
296 type_: string;
297 size: unsigned_int;
298 }
299
300 (** Problem details object as per RFC7807 and Section 3.6.1 *)
301 type problem_details = {
302 type_: string;
303 status: int option;
304 detail: string option;
305 limit: string option; (* For "limit" error *)
306 }
307end
308
309module Api = struct
310 open Lwt.Syntax
311 open Types
312
313 (** Error that may occur during API requests *)
314 type error =
315 | Connection_error of string
316 | HTTP_error of int * string
317 | Parse_error of string
318 | Authentication_error
319
320 (** Result type for API operations *)
321 type 'a result = ('a, error) Stdlib.result
322
323 (** Configuration for a JMAP API client *)
324 type config = {
325 api_uri: Uri.t;
326 username: string;
327 authentication_token: string;
328 }
329
330 (** Convert Ezjsonm.value to string *)
331 let json_to_string json =
332 Ezjsonm.value_to_string ~minify:false json
333
334 (** Parse response string as JSON value *)
335 let parse_json_string str =
336 try Ok (Ezjsonm.from_string str)
337 with e -> Error (Parse_error (Printexc.to_string e))
338
339 (** Parse JSON response as a JMAP response object *)
340 let parse_response json =
341 try
342 let method_responses =
343 match Ezjsonm.find json ["methodResponses"] with
344 | `A items ->
345 List.map (fun json ->
346 match json with
347 | `A [`String name; args; `String method_call_id] ->
348 { name; arguments = args; method_call_id }
349 | _ -> raise (Invalid_argument "Invalid invocation format in response")
350 ) items
351 | _ -> raise (Invalid_argument "methodResponses is not an array")
352 in
353 let created_ids_opt =
354 try
355 let obj = Ezjsonm.find json ["createdIds"] in
356 match obj with
357 | `O items -> Some (List.map (fun (k, v) ->
358 match v with
359 | `String id -> (k, id)
360 | _ -> raise (Invalid_argument "createdIds value is not a string")
361 ) items)
362 | _ -> None
363 with Not_found -> None
364 in
365 let session_state =
366 match Ezjsonm.find json ["sessionState"] with
367 | `String s -> s
368 | _ -> raise (Invalid_argument "sessionState is not a string")
369 in
370 Ok { method_responses; created_ids = created_ids_opt; session_state }
371 with
372 | Not_found -> Error (Parse_error "Required field not found in response")
373 | Invalid_argument msg -> Error (Parse_error msg)
374 | e -> Error (Parse_error (Printexc.to_string e))
375
376 (** Serialize a JMAP request object to JSON *)
377 let serialize_request req =
378 let method_calls_json =
379 `A (List.map (fun (inv : 'a invocation) ->
380 `A [`String inv.name; inv.arguments; `String inv.method_call_id]
381 ) req.method_calls)
382 in
383 let using_json = `A (List.map (fun s -> `String s) req.using) in
384 let json = `O [
385 ("using", using_json);
386 ("methodCalls", method_calls_json)
387 ] in
388 let json = match req.created_ids with
389 | Some ids ->
390 let created_ids_json = `O (List.map (fun (k, v) -> (k, `String v)) ids) in
391 Ezjsonm.update json ["createdIds"] (Some created_ids_json)
392 | None -> json
393 in
394 json_to_string json
395
396 (** Make a raw HTTP request *)
397 let make_http_request ~method_ ~headers ~body uri =
398 let open Cohttp in
399 let open Cohttp_lwt_unix in
400 let headers = Header.add_list (Header.init ()) headers in
401
402 (* Debug: print request details *)
403 Printf.printf "\n===== HTTP REQUEST =====\n";
404 Printf.printf "URI: %s\n" (Uri.to_string uri);
405 Printf.printf "METHOD: %s\n" method_;
406 Printf.printf "HEADERS:\n";
407 Header.iter (fun k v -> Printf.printf " %s: %s\n" k v) headers;
408 Printf.printf "BODY:\n%s\n" body;
409 Printf.printf "======================\n\n";
410
411 Lwt.catch
412 (fun () ->
413 let* resp, body =
414 match method_ with
415 | "GET" -> Client.get ~headers uri
416 | "POST" -> Client.post ~headers ~body:(Cohttp_lwt.Body.of_string body) uri
417 | _ -> failwith (Printf.sprintf "Unsupported HTTP method: %s" method_)
418 in
419 let* body_str = Cohttp_lwt.Body.to_string body in
420 let status = Response.status resp |> Code.code_of_status in
421
422 (* Debug: print response details *)
423 Printf.printf "\n===== HTTP RESPONSE =====\n";
424 Printf.printf "STATUS: %d\n" status;
425 Printf.printf "HEADERS:\n";
426 Response.headers resp |> Header.iter (fun k v -> Printf.printf " %s: %s\n" k v);
427 Printf.printf "BODY:\n%s\n" body_str;
428 Printf.printf "========================\n\n";
429
430 if status >= 200 && status < 300 then
431 Lwt.return (Ok body_str)
432 else
433 Lwt.return (Error (HTTP_error (status, body_str))))
434 (fun e ->
435 let error_msg = Printexc.to_string e in
436 Printf.printf "\n===== HTTP ERROR =====\n%s\n======================\n\n" error_msg;
437 Lwt.return (Error (Connection_error error_msg)))
438
439 (** Make a raw JMAP API request
440
441 TODO:claude *)
442 let make_request config req =
443 let body = serialize_request req in
444 (* Choose appropriate authorization header based on whether it's a bearer token or basic auth *)
445 let auth_header =
446 if String.length config.username > 0 then
447 (* Standard username/password authentication *)
448 "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token)
449 else
450 (* API token (bearer authentication) *)
451 "Bearer " ^ config.authentication_token
452 in
453 Printf.printf "Using authorization header: %s\n" auth_header;
454 let headers = [
455 ("Content-Type", "application/json");
456 ("Content-Length", string_of_int (String.length body));
457 ("Authorization", auth_header)
458 ] in
459 let* result = make_http_request ~method_:"POST" ~headers ~body config.api_uri in
460 match result with
461 | Ok response_body ->
462 (match parse_json_string response_body with
463 | Ok json -> Lwt.return (parse_response json)
464 | Error e -> Lwt.return (Error e))
465 | Error e -> Lwt.return (Error e)
466
467 (** Parse a JSON object as a Session object *)
468 let parse_session_object json =
469 try
470 let capabilities =
471 match Ezjsonm.find json ["capabilities"] with
472 | `O items -> items
473 | _ -> raise (Invalid_argument "capabilities is not an object")
474 in
475
476 let accounts =
477 match Ezjsonm.find json ["accounts"] with
478 | `O items -> List.map (fun (id, json) ->
479 match json with
480 | `O _ ->
481 let name = Ezjsonm.get_string (Ezjsonm.find json ["name"]) in
482 let is_personal = Ezjsonm.get_bool (Ezjsonm.find json ["isPersonal"]) in
483 let is_read_only = Ezjsonm.get_bool (Ezjsonm.find json ["isReadOnly"]) in
484 let account_capabilities =
485 match Ezjsonm.find json ["accountCapabilities"] with
486 | `O items -> items
487 | _ -> raise (Invalid_argument "accountCapabilities is not an object")
488 in
489 (id, { name; is_personal; is_read_only; account_capabilities })
490 | _ -> raise (Invalid_argument "account value is not an object")
491 ) items
492 | _ -> raise (Invalid_argument "accounts is not an object")
493 in
494
495 let primary_accounts =
496 match Ezjsonm.find_opt json ["primaryAccounts"] with
497 | Some (`O items) -> List.map (fun (k, v) ->
498 match v with
499 | `String id -> (k, id)
500 | _ -> raise (Invalid_argument "primaryAccounts value is not a string")
501 ) items
502 | Some _ -> raise (Invalid_argument "primaryAccounts is not an object")
503 | None -> []
504 in
505
506 let username = Ezjsonm.get_string (Ezjsonm.find json ["username"]) in
507 let api_url = Ezjsonm.get_string (Ezjsonm.find json ["apiUrl"]) in
508 let download_url = Ezjsonm.get_string (Ezjsonm.find json ["downloadUrl"]) in
509 let upload_url = Ezjsonm.get_string (Ezjsonm.find json ["uploadUrl"]) in
510 let event_source_url =
511 try Some (Ezjsonm.get_string (Ezjsonm.find json ["eventSourceUrl"]))
512 with Not_found -> None
513 in
514 let state = Ezjsonm.get_string (Ezjsonm.find json ["state"]) in
515
516 Ok { capabilities; accounts; primary_accounts; username;
517 api_url; download_url; upload_url; event_source_url; state }
518 with
519 | Not_found -> Error (Parse_error "Required field not found in session object")
520 | Invalid_argument msg -> Error (Parse_error msg)
521 | e -> Error (Parse_error (Printexc.to_string e))
522
523 (** Fetch a Session object from a JMAP server
524
525 TODO:claude *)
526 let get_session uri ?username ?authentication_token ?api_token () =
527 let headers =
528 match (username, authentication_token, api_token) with
529 | (Some u, Some t, _) ->
530 let auth = "Basic " ^ Base64.encode_string (u ^ ":" ^ t) in
531 Printf.printf "Session using Basic auth: %s\n" auth;
532 [
533 ("Content-Type", "application/json");
534 ("Authorization", auth)
535 ]
536 | (_, _, Some token) ->
537 let auth = "Bearer " ^ token in
538 Printf.printf "Session using Bearer auth: %s\n" auth;
539 [
540 ("Content-Type", "application/json");
541 ("Authorization", auth)
542 ]
543 | _ -> [("Content-Type", "application/json")]
544 in
545
546 let* result = make_http_request ~method_:"GET" ~headers ~body:"" uri in
547 match result with
548 | Ok response_body ->
549 (match parse_json_string response_body with
550 | Ok json -> Lwt.return (parse_session_object json)
551 | Error e -> Lwt.return (Error e))
552 | Error e -> Lwt.return (Error e)
553
554 (** Upload a binary blob to the server
555
556 TODO:claude *)
557 let upload_blob config ~account_id ~content_type data =
558 let upload_url_template = config.api_uri |> Uri.to_string in
559 (* Replace {accountId} with the actual account ID *)
560 let upload_url = Str.global_replace (Str.regexp "{accountId}") account_id upload_url_template in
561 let upload_uri = Uri.of_string upload_url in
562
563 let headers = [
564 ("Content-Type", content_type);
565 ("Content-Length", string_of_int (String.length data));
566 ("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
567 ] in
568
569 let* result = make_http_request ~method_:"POST" ~headers ~body:data upload_uri in
570 match result with
571 | Ok response_body ->
572 (match parse_json_string response_body with
573 | Ok json ->
574 (try
575 let account_id = Ezjsonm.get_string (Ezjsonm.find json ["accountId"]) in
576 let blob_id = Ezjsonm.get_string (Ezjsonm.find json ["blobId"]) in
577 let type_ = Ezjsonm.get_string (Ezjsonm.find json ["type"]) in
578 let size = Ezjsonm.get_int (Ezjsonm.find json ["size"]) in
579 Lwt.return (Ok { account_id; blob_id; type_; size })
580 with
581 | Not_found -> Lwt.return (Error (Parse_error "Required field not found in upload response"))
582 | e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
583 | Error e -> Lwt.return (Error e))
584 | Error e -> Lwt.return (Error e)
585
586 (** Download a binary blob from the server
587
588 TODO:claude *)
589 let download_blob config ~account_id ~blob_id ?type_ ?name () =
590 let download_url_template = config.api_uri |> Uri.to_string in
591
592 (* Replace template variables with actual values *)
593 let url = Str.global_replace (Str.regexp "{accountId}") account_id download_url_template in
594 let url = Str.global_replace (Str.regexp "{blobId}") blob_id url in
595
596 let url = match type_ with
597 | Some t -> Str.global_replace (Str.regexp "{type}") (Uri.pct_encode t) url
598 | None -> Str.global_replace (Str.regexp "{type}") "" url
599 in
600
601 let url = match name with
602 | Some n -> Str.global_replace (Str.regexp "{name}") (Uri.pct_encode n) url
603 | None -> Str.global_replace (Str.regexp "{name}") "file" url
604 in
605
606 let download_uri = Uri.of_string url in
607
608 let headers = [
609 ("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
610 ] in
611
612 let* result = make_http_request ~method_:"GET" ~headers ~body:"" download_uri in
613 Lwt.return result
614end