objective categorical abstract machine language personal data server
1open Lwt.Syntax
2
3type t =
4 { service: Uri.t
5 ; mutable headers: (string * string) list
6 ; mutable session: Types.session option
7 ; on_request: (t -> unit Lwt.t) option
8 (* called before each request for token refresh *) }
9
10module type S = sig
11 val make : service:string -> unit -> t
12
13 val make_with_interceptor :
14 service:string -> on_request:(t -> unit Lwt.t) -> unit -> t
15
16 val set_session : t -> Types.session -> unit
17
18 val clear_session : t -> unit
19
20 val get_session : t -> Types.session option
21
22 val get_service : t -> Uri.t
23
24 val query :
25 t
26 -> string
27 -> Yojson.Safe.t
28 -> (Yojson.Safe.t -> ('a, string) result)
29 -> 'a Lwt.t
30
31 val procedure :
32 t
33 -> string
34 -> Yojson.Safe.t
35 -> Yojson.Safe.t option
36 -> (Yojson.Safe.t -> ('a, string) result)
37 -> 'a Lwt.t
38
39 val query_bytes : t -> string -> Yojson.Safe.t -> (bytes * string) Lwt.t
40
41 val procedure_bytes :
42 t
43 -> string
44 -> Yojson.Safe.t
45 -> bytes option
46 -> content_type:string
47 -> (bytes * string) option Lwt.t
48
49 val procedure_blob :
50 t
51 -> string
52 -> Yojson.Safe.t
53 -> bytes
54 -> content_type:string
55 -> (Yojson.Safe.t -> ('a, string) result)
56 -> 'a Lwt.t
57end
58
59module Make (Http : Http_backend.S) : S = struct
60 let make ~service () =
61 let service = Uri.of_string service in
62 {service; headers= []; session= None; on_request= None}
63
64 let make_with_interceptor ~service ~on_request () =
65 let service = Uri.of_string service in
66 {service; headers= []; session= None; on_request= Some on_request}
67
68 let set_session t session =
69 t.session <- Some session ;
70 t.headers <-
71 List.filter (fun (k, _) -> k <> "Authorization") t.headers
72 @ [("Authorization", "Bearer " ^ session.Types.access_jwt)]
73
74 let clear_session t =
75 t.session <- None ;
76 t.headers <- List.filter (fun (k, _) -> k <> "Authorization") t.headers
77
78 let get_session t = t.session
79
80 let get_service t = t.service
81
82 (* build query string from json params *)
83 let params_to_query (params : Yojson.Safe.t) : (string * string list) list =
84 match params with
85 | `Assoc pairs ->
86 List.filter_map
87 (fun (k, v) ->
88 match v with
89 | `Null ->
90 None
91 | `Bool b ->
92 Some (k, [string_of_bool b])
93 | `Int i ->
94 Some (k, [string_of_int i])
95 | `Float f ->
96 Some (k, [string_of_float f])
97 | `String s ->
98 Some (k, [s])
99 | `List items ->
100 let strs =
101 List.filter_map
102 (function
103 | `String s ->
104 Some s
105 | `Int i ->
106 Some (string_of_int i)
107 | `Bool b ->
108 Some (string_of_bool b)
109 | _ ->
110 None )
111 items
112 in
113 if strs = [] then None else Some (k, strs)
114 | _ ->
115 None )
116 pairs
117 | _ ->
118 []
119
120 let make_headers ?(extra = []) ?(accept = "application/json") t =
121 Cohttp.Header.of_list
122 ([("User-Agent", "hermes/1.0"); ("Accept", accept)] @ t.headers @ extra)
123
124 let query (t : t) (nsid : string) (params : Yojson.Safe.t)
125 (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
126 (* call interceptor if present for token refresh *)
127 let* () =
128 match t.on_request with Some f -> f t | None -> Lwt.return_unit
129 in
130 let query = params_to_query params in
131 let uri =
132 Uri.with_path t.service ("/xrpc/" ^ nsid)
133 |> fun u -> Uri.with_query u query
134 in
135 let headers = make_headers t in
136 let* resp, body =
137 Lwt.catch
138 (fun () -> Lwt_unix.with_timeout 30.0 (fun () -> Http.get ~headers uri))
139 (fun exn ->
140 Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
141 ~message:(Printexc.to_string exn) () )
142 in
143 let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
144 let* body_str = Cohttp_lwt.Body.to_string body in
145 if status >= 200 && status < 300 then
146 if String.length body_str = 0 then
147 (* empty response, try parsing empty object *)
148 match of_yojson (`Assoc []) with
149 | Ok v ->
150 Lwt.return v
151 | Error e ->
152 Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
153 else
154 let json = Yojson.Safe.from_string body_str in
155 match of_yojson json with
156 | Ok v ->
157 Lwt.return v
158 | Error e ->
159 Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
160 else
161 let payload =
162 try
163 let json = Yojson.Safe.from_string body_str in
164 match Types.xrpc_error_payload_of_yojson json with
165 | Ok p ->
166 p
167 | Error _ ->
168 {error= "UnknownError"; message= Some body_str}
169 with _ -> {error= "UnknownError"; message= Some body_str}
170 in
171 Types.raise_xrpc_error ~status payload
172
173 let procedure (t : t) (nsid : string) (params : Yojson.Safe.t)
174 (input : Yojson.Safe.t option)
175 (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
176 (* call interceptor if present for token refresh *)
177 let* () =
178 match t.on_request with Some f -> f t | None -> Lwt.return_unit
179 in
180 let query = params_to_query params in
181 let uri =
182 Uri.with_path t.service ("/xrpc/" ^ nsid)
183 |> fun u -> Uri.with_query u query
184 in
185 let body, content_type =
186 match input with
187 | Some json ->
188 ( Cohttp_lwt.Body.of_string (Yojson.Safe.to_string json)
189 , "application/json" )
190 | None ->
191 (Cohttp_lwt.Body.empty, "application/json")
192 in
193 let headers = make_headers ~extra:[("Content-Type", content_type)] t in
194 let* resp, resp_body =
195 Lwt.catch
196 (fun () ->
197 Lwt_unix.with_timeout 30.0 (fun () -> Http.post ~headers ~body uri) )
198 (fun exn ->
199 Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
200 ~message:(Printexc.to_string exn) () )
201 in
202 let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
203 let* body_str = Cohttp_lwt.Body.to_string resp_body in
204 if status >= 200 && status < 300 then
205 if String.length body_str = 0 then
206 match of_yojson (`Assoc []) with
207 | Ok v ->
208 Lwt.return v
209 | Error e ->
210 Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
211 else
212 let json = Yojson.Safe.from_string body_str in
213 match of_yojson json with
214 | Ok v ->
215 Lwt.return v
216 | Error e ->
217 Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
218 else
219 let payload =
220 try
221 let json = Yojson.Safe.from_string body_str in
222 match Types.xrpc_error_payload_of_yojson json with
223 | Ok p ->
224 p
225 | Error _ ->
226 {error= "UnknownError"; message= Some body_str}
227 with _ -> {error= "UnknownError"; message= Some body_str}
228 in
229 Types.raise_xrpc_error ~status payload
230
231 let query_bytes (t : t) (nsid : string) (params : Yojson.Safe.t) :
232 (bytes * string) Lwt.t =
233 (* call interceptor if present for token refresh *)
234 let* () =
235 match t.on_request with Some f -> f t | None -> Lwt.return_unit
236 in
237 let query = params_to_query params in
238 let uri =
239 Uri.with_path t.service ("/xrpc/" ^ nsid)
240 |> fun u -> Uri.with_query u query
241 in
242 let headers = make_headers ~accept:"*/*" t in
243 let* resp, body =
244 Lwt.catch
245 (fun () -> Lwt_unix.with_timeout 120.0 (fun () -> Http.get ~headers uri))
246 (fun exn ->
247 Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
248 ~message:(Printexc.to_string exn) () )
249 in
250 let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
251 let* body_str = Cohttp_lwt.Body.to_string body in
252 let body = Bytes.of_string body_str in
253 if status >= 200 && status < 300 then
254 let content_type =
255 Cohttp.Response.headers resp
256 |> fun h ->
257 Cohttp.Header.get h "content-type"
258 |> Option.value ~default:"application/octet-stream"
259 in
260 Lwt.return (body, content_type)
261 else
262 let payload =
263 try
264 let json = Yojson.Safe.from_string body_str in
265 match Types.xrpc_error_payload_of_yojson json with
266 | Ok p ->
267 p
268 | Error _ ->
269 {error= "UnknownError"; message= Some body_str}
270 with _ -> {error= "UnknownError"; message= Some body_str}
271 in
272 Types.raise_xrpc_error ~status payload
273
274 (* execute procedure with raw bytes input, returns raw bytes or none if no output *)
275 let procedure_bytes (t : t) (nsid : string) (params : Yojson.Safe.t)
276 (input : bytes option) ~(content_type : string) :
277 (bytes * string) option Lwt.t =
278 (* call interceptor if present for token refresh *)
279 let* () =
280 match t.on_request with Some f -> f t | None -> Lwt.return_unit
281 in
282 let query = params_to_query params in
283 let uri =
284 Uri.with_path t.service ("/xrpc/" ^ nsid)
285 |> fun u -> Uri.with_query u query
286 in
287 let body =
288 match input with
289 | Some data ->
290 Cohttp_lwt.Body.of_string (Bytes.to_string data)
291 | None ->
292 Cohttp_lwt.Body.empty
293 in
294 let headers =
295 make_headers ~extra:[("Content-Type", content_type)] ~accept:"*/*" t
296 in
297 let* resp, resp_body =
298 Lwt.catch
299 (fun () ->
300 Lwt_unix.with_timeout 120.0 (fun () -> Http.post ~headers ~body uri) )
301 (fun exn ->
302 Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
303 ~message:(Printexc.to_string exn) () )
304 in
305 let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
306 let* body_str = Cohttp_lwt.Body.to_string resp_body in
307 let body = Bytes.of_string body_str in
308 if status >= 200 && status < 300 then
309 if Bytes.length body = 0 then Lwt.return None
310 else
311 let resp_content_type =
312 Cohttp.Response.headers resp
313 |> fun h ->
314 Cohttp.Header.get h "content-type"
315 |> Option.value ~default:"application/octet-stream"
316 in
317 Lwt.return (Some (body, resp_content_type))
318 else
319 let payload =
320 try
321 let json = Yojson.Safe.from_string body_str in
322 match Types.xrpc_error_payload_of_yojson json with
323 | Ok p ->
324 p
325 | Error _ ->
326 {error= "UnknownError"; message= Some body_str}
327 with _ -> {error= "UnknownError"; message= Some body_str}
328 in
329 Types.raise_xrpc_error ~status payload
330
331 let procedure_blob (t : t) (nsid : string) (params : Yojson.Safe.t)
332 (blob_data : bytes) ~(content_type : string)
333 (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
334 (* call interceptor if present for token refresh *)
335 let* () =
336 match t.on_request with Some f -> f t | None -> Lwt.return_unit
337 in
338 let query = params_to_query params in
339 let uri =
340 Uri.with_path t.service ("/xrpc/" ^ nsid)
341 |> fun u -> Uri.with_query u query
342 in
343 let body = Cohttp_lwt.Body.of_string (Bytes.to_string blob_data) in
344 let headers = make_headers ~extra:[("Content-Type", content_type)] t in
345 let* resp, resp_body =
346 Lwt.catch
347 (fun () ->
348 Lwt_unix.with_timeout 120.0 (fun () -> Http.post ~headers ~body uri) )
349 (fun exn ->
350 Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
351 ~message:(Printexc.to_string exn) () )
352 in
353 let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
354 let* body_str = Cohttp_lwt.Body.to_string resp_body in
355 if status >= 200 && status < 300 then
356 let json = Yojson.Safe.from_string body_str in
357 match of_yojson json with
358 | Ok v ->
359 Lwt.return v
360 | Error e ->
361 Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
362 else
363 let payload =
364 try
365 let json = Yojson.Safe.from_string body_str in
366 match Types.xrpc_error_payload_of_yojson json with
367 | Ok p ->
368 p
369 | Error _ ->
370 {error= "UnknownError"; message= Some body_str}
371 with _ -> {error= "UnknownError"; message= Some body_str}
372 in
373 Types.raise_xrpc_error ~status payload
374end
375
376(* default client using real http backend *)
377include Make (Http_backend.Default)