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