jon.recoil.org
forked from
anil.recoil.org/ocaml-jmap
this repo has no description
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6open Brr
7open Fut.Syntax
8
9type connection = {
10 session : Jmap.Proto.Session.t;
11 api_url : Jstr.t;
12 token : Jstr.t;
13}
14
15let session conn = conn.session
16let api_url conn = conn.api_url
17
18(* JSON logging callbacks *)
19let on_request : (string -> string -> unit) option ref = ref None
20let on_response : (string -> string -> unit) option ref = ref None
21
22let set_request_logger f = on_request := Some f
23let set_response_logger f = on_response := Some f
24
25let log_request label json =
26 match !on_request with
27 | Some f -> f label json
28 | None -> ()
29
30let log_response label json =
31 match !on_response with
32 | Some f -> f label json
33 | None -> ()
34
35(* JSON encoding/decoding using jsont.brr *)
36
37let encode_request req =
38 Jsont_brr.encode Jmap.Proto.Request.jsont req
39
40let encode_response resp =
41 Jsont_brr.encode Jmap.Proto.Response.jsont resp
42
43let encode_session session =
44 Jsont_brr.encode Jmap.Proto.Session.jsont session
45
46let decode_json s =
47 Jsont_brr.decode Jsont.json s
48
49let encode_json json =
50 Jsont_brr.encode Jsont.json json
51
52let pp_json ppf json =
53 match encode_json json with
54 | Ok s -> Format.pp_print_string ppf (Jstr.to_string s)
55 | Error _ -> Format.pp_print_string ppf "<json encoding error>"
56
57(* HTTP helpers *)
58
59let make_headers token =
60 Brr_io.Fetch.Headers.of_assoc [
61 Jstr.v "Authorization", Jstr.(v "Bearer " + token);
62 Jstr.v "Content-Type", Jstr.v "application/json";
63 Jstr.v "Accept", Jstr.v "application/json";
64 ]
65
66let fetch_json ~url ~meth ~headers ?body () =
67 Console.(log [str ">>> Request:"; str (Jstr.to_string meth); str (Jstr.to_string url)]);
68 (match body with
69 | Some b -> Console.(log [str ">>> Body:"; b])
70 | None -> Console.(log [str ">>> No body"]));
71 let init = Brr_io.Fetch.Request.init
72 ~method':meth
73 ~headers
74 ?body
75 ()
76 in
77 let req = Brr_io.Fetch.Request.v ~init url in
78 let* response = Brr_io.Fetch.request req in
79 match response with
80 | Error e ->
81 Console.(error [str "<<< Fetch error:"; e]);
82 Fut.return (Error e)
83 | Ok resp ->
84 let status = Brr_io.Fetch.Response.status resp in
85 Console.(log [str "<<< Response status:"; str (Jstr.of_int status)]);
86 if not (Brr_io.Fetch.Response.ok resp) then begin
87 let msg = Jstr.(v "HTTP error: " + of_int status) in
88 (* Try to get response body for error details *)
89 let body = Brr_io.Fetch.Response.as_body resp in
90 let* text = Brr_io.Fetch.Body.text body in
91 (match text with
92 | Ok t -> Console.(error [str "<<< Error body:"; str (Jstr.to_string t)])
93 | Error _ -> ());
94 Fut.return (Error (Jv.Error.v msg))
95 end else begin
96 let body = Brr_io.Fetch.Response.as_body resp in
97 let* text = Brr_io.Fetch.Body.text body in
98 match text with
99 | Error e ->
100 Console.(error [str "<<< Body read error:"; e]);
101 Fut.return (Error e)
102 | Ok text ->
103 Console.(log [str "<<< Response body:"; str (Jstr.to_string text)]);
104 Fut.return (Ok text)
105 end
106
107(* Session establishment *)
108
109let get_session ~url ~token =
110 Console.(log [str "get_session: token length ="; str (Jstr.of_int (Jstr.length token))]);
111 log_request "GET Session" (Printf.sprintf "{\"url\": \"%s\"}" (Jstr.to_string url));
112 let headers = make_headers token in
113 let* result = fetch_json ~url ~meth:(Jstr.v "GET") ~headers () in
114 match result with
115 | Error e -> Fut.return (Error e)
116 | Ok text ->
117 log_response "Session" (Jstr.to_string text);
118 match Jsont_brr.decode Jmap.Proto.Session.jsont text with
119 | Error e -> Fut.return (Error e)
120 | Ok session ->
121 let api_url = Jstr.v (Jmap.Proto.Session.api_url session) in
122 Fut.return (Ok { session; api_url; token })
123
124(* Making requests *)
125
126let request conn req =
127 let headers = make_headers conn.token in
128 match Jsont_brr.encode Jmap.Proto.Request.jsont req with
129 | Error e -> Fut.return (Error e)
130 | Ok body_str ->
131 log_request "JMAP Request" (Jstr.to_string body_str);
132 let body = Brr_io.Fetch.Body.of_jstr body_str in
133 let* result = fetch_json
134 ~url:conn.api_url
135 ~meth:(Jstr.v "POST")
136 ~headers
137 ~body
138 ()
139 in
140 match result with
141 | Error e -> Fut.return (Error e)
142 | Ok text ->
143 log_response "JMAP Response" (Jstr.to_string text);
144 match Jsont_brr.decode Jmap.Proto.Response.jsont text with
145 | Error e -> Fut.return (Error e)
146 | Ok response -> Fut.return (Ok response)
147
148let request_json conn json =
149 let headers = make_headers conn.token in
150 match encode_json json with
151 | Error e -> Fut.return (Error e)
152 | Ok body_str ->
153 let body = Brr_io.Fetch.Body.of_jstr body_str in
154 let* result = fetch_json
155 ~url:conn.api_url
156 ~meth:(Jstr.v "POST")
157 ~headers
158 ~body
159 ()
160 in
161 match result with
162 | Error e -> Fut.return (Error e)
163 | Ok text ->
164 match decode_json text with
165 | Error e -> Fut.return (Error e)
166 | Ok json -> Fut.return (Ok json)
167
168(* Toplevel support *)
169
170let install_printers () =
171 (* In browser context, printers are registered via the OCaml console *)
172 Console.(log [str "JMAP printers installed"])