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
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 match Brr.Json.decode s with
48 | Ok jv -> Ok (Obj.magic jv : Jsont.json) (* Jv.t and Jsont.json are compatible *)
49 | Error e -> Error e
50
51let encode_json json =
52 Ok (Brr.Json.encode (Obj.magic json : Jv.t))
53
54let pp_json ppf json =
55 match encode_json json with
56 | Ok s -> Format.pp_print_string ppf (Jstr.to_string s)
57 | Error _ -> Format.pp_print_string ppf "<json encoding error>"
58
59(* HTTP helpers *)
60
61let make_headers token =
62 Brr_io.Fetch.Headers.of_assoc [
63 Jstr.v "Authorization", Jstr.(v "Bearer " + token);
64 Jstr.v "Content-Type", Jstr.v "application/json";
65 Jstr.v "Accept", Jstr.v "application/json";
66 ]
67
68let fetch_json ~url ~meth ~headers ?body () =
69 Console.(log [str ">>> Request:"; str (Jstr.to_string meth); str (Jstr.to_string url)]);
70 (match body with
71 | Some b -> Console.(log [str ">>> Body:"; b])
72 | None -> Console.(log [str ">>> No body"]));
73 let init = Brr_io.Fetch.Request.init
74 ~method':meth
75 ~headers
76 ?body
77 ()
78 in
79 let req = Brr_io.Fetch.Request.v ~init url in
80 let* response = Brr_io.Fetch.request req in
81 match response with
82 | Error e ->
83 Console.(error [str "<<< Fetch error:"; e]);
84 Fut.return (Error e)
85 | Ok resp ->
86 let status = Brr_io.Fetch.Response.status resp in
87 Console.(log [str "<<< Response status:"; str (Jstr.of_int status)]);
88 if not (Brr_io.Fetch.Response.ok resp) then begin
89 let msg = Jstr.(v "HTTP error: " + of_int status) in
90 (* Try to get response body for error details *)
91 let body = Brr_io.Fetch.Response.as_body resp in
92 let* text = Brr_io.Fetch.Body.text body in
93 (match text with
94 | Ok t -> Console.(error [str "<<< Error body:"; str (Jstr.to_string t)])
95 | Error _ -> ());
96 Fut.return (Error (Jv.Error.v msg))
97 end else begin
98 let body = Brr_io.Fetch.Response.as_body resp in
99 let* text = Brr_io.Fetch.Body.text body in
100 match text with
101 | Error e ->
102 Console.(error [str "<<< Body read error:"; e]);
103 Fut.return (Error e)
104 | Ok text ->
105 Console.(log [str "<<< Response body:"; str (Jstr.to_string text)]);
106 Fut.return (Ok text)
107 end
108
109(* Session establishment *)
110
111let get_session ~url ~token =
112 Console.(log [str "get_session: token length ="; str (Jstr.of_int (Jstr.length token))]);
113 log_request "GET Session" (Printf.sprintf "{\"url\": \"%s\"}" (Jstr.to_string url));
114 let headers = make_headers token in
115 let* result = fetch_json ~url ~meth:(Jstr.v "GET") ~headers () in
116 match result with
117 | Error e -> Fut.return (Error e)
118 | Ok text ->
119 log_response "Session" (Jstr.to_string text);
120 match Jsont_brr.decode Jmap.Proto.Session.jsont text with
121 | Error e -> Fut.return (Error e)
122 | Ok session ->
123 let api_url = Jstr.v (Jmap.Proto.Session.api_url session) in
124 Fut.return (Ok { session; api_url; token })
125
126(* Making requests *)
127
128let request conn req =
129 let headers = make_headers conn.token in
130 match Jsont_brr.encode Jmap.Proto.Request.jsont req with
131 | Error e -> Fut.return (Error e)
132 | Ok body_str ->
133 log_request "JMAP Request" (Jstr.to_string body_str);
134 let body = Brr_io.Fetch.Body.of_jstr body_str in
135 let* result = fetch_json
136 ~url:conn.api_url
137 ~meth:(Jstr.v "POST")
138 ~headers
139 ~body
140 ()
141 in
142 match result with
143 | Error e -> Fut.return (Error e)
144 | Ok text ->
145 log_response "JMAP Response" (Jstr.to_string text);
146 match Jsont_brr.decode Jmap.Proto.Response.jsont text with
147 | Error e -> Fut.return (Error e)
148 | Ok response -> Fut.return (Ok response)
149
150let request_json conn json =
151 let headers = make_headers conn.token in
152 match encode_json json with
153 | Error e -> Fut.return (Error e)
154 | Ok body_str ->
155 let body = Brr_io.Fetch.Body.of_jstr body_str in
156 let* result = fetch_json
157 ~url:conn.api_url
158 ~meth:(Jstr.v "POST")
159 ~headers
160 ~body
161 ()
162 in
163 match result with
164 | Error e -> Fut.return (Error e)
165 | Ok text ->
166 match decode_json text with
167 | Error e -> Fut.return (Error e)
168 | Ok json -> Fut.return (Ok json)
169
170(* Toplevel support *)
171
172let install_printers () =
173 (* In browser context, printers are registered via the OCaml console *)
174 Console.(log [str "JMAP printers installed"])