this repo has no description
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6type error =
7 | Http_error of int * string
8 | Jmap_error of Jmap_proto.Error.Request_error.t
9 | Json_error of Jsont.Error.t
10 | Session_error of string
11 | Connection_error of string
12
13let pp_error fmt = function
14 | Http_error (code, msg) ->
15 Format.fprintf fmt "HTTP error %d: %s" code msg
16 | Jmap_error err ->
17 Format.fprintf fmt "JMAP error: %s"
18 (Jmap_proto.Error.Request_error.urn_to_string err.type_)
19 | Json_error err ->
20 Format.fprintf fmt "JSON error: %s" (Jsont.Error.to_string err)
21 | Session_error msg ->
22 Format.fprintf fmt "Session error: %s" msg
23 | Connection_error msg ->
24 Format.fprintf fmt "Connection error: %s" msg
25
26let error_to_string err =
27 Format.asprintf "%a" pp_error err
28
29exception Jmap_client_error of error
30
31type t = {
32 mutable session : Jmap_proto.Session.t;
33 requests : Requests.t;
34 auth : Requests.Auth.t option;
35 session_url : string;
36}
37
38let session t = t.session
39let api_url t = Jmap_proto.Session.api_url t.session
40let upload_url t = Jmap_proto.Session.upload_url t.session
41let download_url t = Jmap_proto.Session.download_url t.session
42
43let create ?auth ~session requests =
44 let session_url = Jmap_proto.Session.api_url session in
45 { session; requests; auth; session_url }
46
47let fetch_session ?auth requests url =
48 try
49 let response =
50 match auth with
51 | Some a -> Requests.get requests ~auth:a url
52 | None -> Requests.get requests url
53 in
54 if not (Requests.Response.ok response) then
55 Error (Http_error (Requests.Response.status_code response,
56 "Failed to fetch session"))
57 else
58 let body = Requests.Response.text response in
59 match Codec.decode_session body with
60 | Ok session -> Ok session
61 | Error e -> Error (Json_error e)
62 with
63 | Eio.Io (Requests.Error.E err, _) ->
64 Error (Connection_error (Requests.Error.to_string err))
65 | exn -> Error (Session_error (Printexc.to_string exn))
66
67let create_from_url ?auth requests url =
68 match fetch_session ?auth requests url with
69 | Ok session ->
70 Ok { session; requests; auth; session_url = url }
71 | Error e -> Error e
72
73let create_from_url_exn ?auth requests url =
74 match create_from_url ?auth requests url with
75 | Ok t -> t
76 | Error e -> raise (Jmap_client_error e)
77
78let refresh_session t =
79 match fetch_session ?auth:t.auth t.requests t.session_url with
80 | Ok session ->
81 t.session <- session;
82 Ok ()
83 | Error e -> Error e
84
85let refresh_session_exn t =
86 match refresh_session t with
87 | Ok () -> ()
88 | Error e -> raise (Jmap_client_error e)
89
90let request t req =
91 try
92 match Codec.encode_request req with
93 | Error e -> Error (Json_error e)
94 | Ok body_str ->
95 let body = Requests.Body.of_string Requests.Mime.json body_str in
96 let url = api_url t in
97 let response =
98 match t.auth with
99 | Some auth -> Requests.post t.requests ~auth ~body url
100 | None -> Requests.post t.requests ~body url
101 in
102 if not (Requests.Response.ok response) then
103 Error (Http_error (Requests.Response.status_code response,
104 Requests.Response.text response))
105 else
106 let response_body = Requests.Response.text response in
107 match Codec.decode_response response_body with
108 | Ok resp -> Ok resp
109 | Error e -> Error (Json_error e)
110 with
111 | Eio.Io (Requests.Error.E err, _) ->
112 Error (Connection_error (Requests.Error.to_string err))
113 | exn -> Error (Connection_error (Printexc.to_string exn))
114
115let request_exn t req =
116 match request t req with
117 | Ok resp -> resp
118 | Error e -> raise (Jmap_client_error e)
119
120let expand_upload_url t ~account_id =
121 let template = upload_url t in
122 let account_id_str = Jmap_proto.Id.to_string account_id in
123 (* Simple template expansion for {accountId} *)
124 let re = Str.regexp "{accountId}" in
125 Str.global_replace re account_id_str template
126
127let upload t ~account_id ~content_type ~data =
128 try
129 let url = expand_upload_url t ~account_id in
130 let mime = Requests.Mime.of_string content_type in
131 let body = Requests.Body.of_string mime data in
132 let response =
133 match t.auth with
134 | Some auth -> Requests.post t.requests ~auth ~body url
135 | None -> Requests.post t.requests ~body url
136 in
137 if not (Requests.Response.ok response) then
138 Error (Http_error (Requests.Response.status_code response,
139 Requests.Response.text response))
140 else
141 let response_body = Requests.Response.text response in
142 match Codec.decode_upload_response response_body with
143 | Ok upload_resp -> Ok upload_resp
144 | Error e -> Error (Json_error e)
145 with
146 | Eio.Io (Requests.Error.E err, _) ->
147 Error (Connection_error (Requests.Error.to_string err))
148 | exn -> Error (Connection_error (Printexc.to_string exn))
149
150let upload_exn t ~account_id ~content_type ~data =
151 match upload t ~account_id ~content_type ~data with
152 | Ok resp -> resp
153 | Error e -> raise (Jmap_client_error e)
154
155let expand_download_url t ~account_id ~blob_id ?name ?accept () =
156 let template = download_url t in
157 let account_id_str = Jmap_proto.Id.to_string account_id in
158 let blob_id_str = Jmap_proto.Id.to_string blob_id in
159 let name_str = Option.value name ~default:"download" in
160 let type_str = Option.value accept ~default:"application/octet-stream" in
161 (* Simple template expansion *)
162 template
163 |> Str.global_replace (Str.regexp "{accountId}") account_id_str
164 |> Str.global_replace (Str.regexp "{blobId}") blob_id_str
165 |> Str.global_replace (Str.regexp "{name}") (Uri.pct_encode name_str)
166 |> Str.global_replace (Str.regexp "{type}") (Uri.pct_encode type_str)
167
168let download t ~account_id ~blob_id ?name ?accept () =
169 try
170 let url = expand_download_url t ~account_id ~blob_id ?name ?accept () in
171 let response =
172 match t.auth with
173 | Some auth -> Requests.get t.requests ~auth url
174 | None -> Requests.get t.requests url
175 in
176 if not (Requests.Response.ok response) then
177 Error (Http_error (Requests.Response.status_code response,
178 Requests.Response.text response))
179 else
180 Ok (Requests.Response.text response)
181 with
182 | Eio.Io (Requests.Error.E err, _) ->
183 Error (Connection_error (Requests.Error.to_string err))
184 | exn -> Error (Connection_error (Printexc.to_string exn))
185
186let download_exn t ~account_id ~blob_id ?name ?accept () =
187 match download t ~account_id ~blob_id ?name ?accept () with
188 | Ok data -> data
189 | Error e -> raise (Jmap_client_error e)
190
191(* Convenience builders *)
192module Build = struct
193 open Jmap_proto
194
195 let json_of_id id =
196 Jsont.String (Id.to_string id, Jsont.Meta.none)
197
198 let json_of_id_list ids =
199 let items = List.map json_of_id ids in
200 Jsont.Array (items, Jsont.Meta.none)
201
202 let json_of_string_list strs =
203 let items = List.map (fun s -> Jsont.String (s, Jsont.Meta.none)) strs in
204 Jsont.Array (items, Jsont.Meta.none)
205
206 let json_of_int64 n =
207 Jsont.Number (Int64.to_float n, Jsont.Meta.none)
208
209 let json_of_bool b =
210 Jsont.Bool (b, Jsont.Meta.none)
211
212 let json_name s = (s, Jsont.Meta.none)
213
214 let json_obj fields =
215 let fields' = List.map (fun (k, v) -> (json_name k, v)) fields in
216 Jsont.Object (fields', Jsont.Meta.none)
217
218 let make_invocation ~name ~call_id args =
219 Invocation.create ~name ~arguments:(json_obj args) ~method_call_id:call_id
220
221 let echo ~call_id data =
222 make_invocation ~name:"Core/echo" ~call_id
223 [ ("data", data) ]
224
225 let mailbox_get ~call_id ~account_id ?ids ?properties () =
226 let args = [
227 ("accountId", json_of_id account_id);
228 ] in
229 let args = match ids with
230 | None -> args
231 | Some ids -> ("ids", json_of_id_list ids) :: args
232 in
233 let args = match properties with
234 | None -> args
235 | Some props -> ("properties", json_of_string_list props) :: args
236 in
237 make_invocation ~name:"Mailbox/get" ~call_id args
238
239 let mailbox_changes ~call_id ~account_id ~since_state ?max_changes () =
240 let args = [
241 ("accountId", json_of_id account_id);
242 ("sinceState", Jsont.String (since_state, Jsont.Meta.none));
243 ] in
244 let args = match max_changes with
245 | None -> args
246 | Some n -> ("maxChanges", json_of_int64 n) :: args
247 in
248 make_invocation ~name:"Mailbox/changes" ~call_id args
249
250 let encode_to_json jsont value =
251 match Jsont.Json.encode' jsont value with
252 | Ok j -> j
253 | Error _ -> json_obj []
254
255 let encode_list_to_json jsont values =
256 match Jsont.Json.encode' (Jsont.list jsont) values with
257 | Ok j -> j
258 | Error _ -> Jsont.Array ([], Jsont.Meta.none)
259
260 let mailbox_query ~call_id ~account_id ?filter ?sort ?position ?limit () =
261 let args = [
262 ("accountId", json_of_id account_id);
263 ] in
264 let args = match filter with
265 | None -> args
266 | Some f ->
267 ("filter", encode_to_json Jmap_mail.Mail_filter.mailbox_filter_jsont f) :: args
268 in
269 let args = match sort with
270 | None -> args
271 | Some comparators ->
272 ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
273 in
274 let args = match position with
275 | None -> args
276 | Some n -> ("position", json_of_int64 n) :: args
277 in
278 let args = match limit with
279 | None -> args
280 | Some n -> ("limit", json_of_int64 n) :: args
281 in
282 make_invocation ~name:"Mailbox/query" ~call_id args
283
284 let email_get ~call_id ~account_id ?ids ?properties ?body_properties
285 ?fetch_text_body_values ?fetch_html_body_values ?fetch_all_body_values
286 ?max_body_value_bytes () =
287 let args = [
288 ("accountId", json_of_id account_id);
289 ] in
290 let args = match ids with
291 | None -> args
292 | Some ids -> ("ids", json_of_id_list ids) :: args
293 in
294 let args = match properties with
295 | None -> args
296 | Some props -> ("properties", json_of_string_list props) :: args
297 in
298 let args = match body_properties with
299 | None -> args
300 | Some props -> ("bodyProperties", json_of_string_list props) :: args
301 in
302 let args = match fetch_text_body_values with
303 | None -> args
304 | Some b -> ("fetchTextBodyValues", json_of_bool b) :: args
305 in
306 let args = match fetch_html_body_values with
307 | None -> args
308 | Some b -> ("fetchHTMLBodyValues", json_of_bool b) :: args
309 in
310 let args = match fetch_all_body_values with
311 | None -> args
312 | Some b -> ("fetchAllBodyValues", json_of_bool b) :: args
313 in
314 let args = match max_body_value_bytes with
315 | None -> args
316 | Some n -> ("maxBodyValueBytes", json_of_int64 n) :: args
317 in
318 make_invocation ~name:"Email/get" ~call_id args
319
320 let email_changes ~call_id ~account_id ~since_state ?max_changes () =
321 let args = [
322 ("accountId", json_of_id account_id);
323 ("sinceState", Jsont.String (since_state, Jsont.Meta.none));
324 ] in
325 let args = match max_changes with
326 | None -> args
327 | Some n -> ("maxChanges", json_of_int64 n) :: args
328 in
329 make_invocation ~name:"Email/changes" ~call_id args
330
331 let email_query ~call_id ~account_id ?filter ?sort ?position ?limit
332 ?collapse_threads () =
333 let args = [
334 ("accountId", json_of_id account_id);
335 ] in
336 let args = match filter with
337 | None -> args
338 | Some f ->
339 ("filter", encode_to_json Jmap_mail.Mail_filter.email_filter_jsont f) :: args
340 in
341 let args = match sort with
342 | None -> args
343 | Some comparators ->
344 ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
345 in
346 let args = match position with
347 | None -> args
348 | Some n -> ("position", json_of_int64 n) :: args
349 in
350 let args = match limit with
351 | None -> args
352 | Some n -> ("limit", json_of_int64 n) :: args
353 in
354 let args = match collapse_threads with
355 | None -> args
356 | Some b -> ("collapseThreads", json_of_bool b) :: args
357 in
358 make_invocation ~name:"Email/query" ~call_id args
359
360 let thread_get ~call_id ~account_id ?ids () =
361 let args = [
362 ("accountId", json_of_id account_id);
363 ] in
364 let args = match ids with
365 | None -> args
366 | Some ids -> ("ids", json_of_id_list ids) :: args
367 in
368 make_invocation ~name:"Thread/get" ~call_id args
369
370 let thread_changes ~call_id ~account_id ~since_state ?max_changes () =
371 let args = [
372 ("accountId", json_of_id account_id);
373 ("sinceState", Jsont.String (since_state, Jsont.Meta.none));
374 ] in
375 let args = match max_changes with
376 | None -> args
377 | Some n -> ("maxChanges", json_of_int64 n) :: args
378 in
379 make_invocation ~name:"Thread/changes" ~call_id args
380
381 let identity_get ~call_id ~account_id ?ids ?properties () =
382 let args = [
383 ("accountId", json_of_id account_id);
384 ] in
385 let args = match ids with
386 | None -> args
387 | Some ids -> ("ids", json_of_id_list ids) :: args
388 in
389 let args = match properties with
390 | None -> args
391 | Some props -> ("properties", json_of_string_list props) :: args
392 in
393 make_invocation ~name:"Identity/get" ~call_id args
394
395 let email_submission_get ~call_id ~account_id ?ids ?properties () =
396 let args = [
397 ("accountId", json_of_id account_id);
398 ] in
399 let args = match ids with
400 | None -> args
401 | Some ids -> ("ids", json_of_id_list ids) :: args
402 in
403 let args = match properties with
404 | None -> args
405 | Some props -> ("properties", json_of_string_list props) :: args
406 in
407 make_invocation ~name:"EmailSubmission/get" ~call_id args
408
409 let email_submission_query ~call_id ~account_id ?filter ?sort ?position ?limit () =
410 let args = [
411 ("accountId", json_of_id account_id);
412 ] in
413 let args = match filter with
414 | None -> args
415 | Some f ->
416 ("filter", encode_to_json Jmap_mail.Mail_filter.submission_filter_jsont f) :: args
417 in
418 let args = match sort with
419 | None -> args
420 | Some comparators ->
421 ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
422 in
423 let args = match position with
424 | None -> args
425 | Some n -> ("position", json_of_int64 n) :: args
426 in
427 let args = match limit with
428 | None -> args
429 | Some n -> ("limit", json_of_int64 n) :: args
430 in
431 make_invocation ~name:"EmailSubmission/query" ~call_id args
432
433 let vacation_response_get ~call_id ~account_id () =
434 let args = [
435 ("accountId", json_of_id account_id);
436 ("ids", json_of_id_list [Jmap_mail.Vacation.singleton_id]);
437 ] in
438 make_invocation ~name:"VacationResponse/get" ~call_id args
439
440 let make_request ?created_ids ~capabilities invocations =
441 Request.create
442 ~using:capabilities
443 ~method_calls:invocations
444 ?created_ids
445 ()
446end
447
448(* Response parsing helpers *)
449module Parse = struct
450 open Jmap_proto
451
452 let decode_from_json jsont json =
453 Jsont.Json.decode' jsont json
454
455 let find_invocation ~call_id response =
456 List.find_opt
457 (fun inv -> Invocation.method_call_id inv = call_id)
458 (Response.method_responses response)
459
460 let get_invocation_exn ~call_id response =
461 match find_invocation ~call_id response with
462 | Some inv -> inv
463 | None -> failwith ("No invocation found with call_id: " ^ call_id)
464
465 let parse_invocation jsont inv =
466 decode_from_json jsont (Invocation.arguments inv)
467
468 let parse_response ~call_id jsont response =
469 let inv = get_invocation_exn ~call_id response in
470 parse_invocation jsont inv
471
472 (* Typed response parsers *)
473
474 let get_response obj_jsont =
475 Method.get_response_jsont obj_jsont
476
477 let query_response = Method.query_response_jsont
478
479 let changes_response = Method.changes_response_jsont
480
481 let set_response obj_jsont =
482 Method.set_response_jsont obj_jsont
483
484 (* Mail-specific parsers *)
485
486 let mailbox_get_response =
487 get_response Jmap_mail.Mailbox.jsont
488
489 let email_get_response =
490 get_response Jmap_mail.Email.jsont
491
492 let thread_get_response =
493 get_response Jmap_mail.Thread.jsont
494
495 let identity_get_response =
496 get_response Jmap_mail.Identity.jsont
497
498 (* Convenience functions *)
499
500 let parse_mailbox_get ~call_id response =
501 parse_response ~call_id mailbox_get_response response
502
503 let parse_email_get ~call_id response =
504 parse_response ~call_id email_get_response response
505
506 let parse_email_query ~call_id response =
507 parse_response ~call_id query_response response
508
509 let parse_thread_get ~call_id response =
510 parse_response ~call_id thread_get_response response
511
512 let parse_changes ~call_id response =
513 parse_response ~call_id changes_response response
514end