anil.recoil.org
Matrix protocol in OCaml, Eio specialised
1let src = Logs.Src.create "matrix.client" ~doc:"Matrix client HTTP"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4type config = {
5 homeserver : Uri.t;
6 user_agent : string option;
7}
8
9type session = {
10 user_id : Matrix_proto.Id.User_id.t;
11 access_token : string;
12 device_id : Matrix_proto.Id.Device_id.t;
13 refresh_token : string option;
14}
15
16type t = {
17 http : Requests.t;
18 config : config;
19 session : session option;
20}
21
22let create ~sw ~config env =
23 let http = Requests.create ~sw env in
24 { http; config; session = None }
25
26let with_session t session =
27 { t with session = Some session }
28
29let session t = t.session
30let homeserver t = t.config.homeserver
31let is_logged_in t = Option.is_some t.session
32let access_token t = Option.map (fun s -> s.access_token) t.session
33let user_id t = Option.map (fun s -> s.user_id) t.session
34let device_id t = Option.map (fun s -> s.device_id) t.session
35
36(* Matrix API base path *)
37let api_base = "/_matrix/client/v3"
38
39let make_url t path query =
40 let base = t.config.homeserver in
41 let path = api_base ^ path in
42 let uri = Uri.with_path base path in
43 match query with
44 | None | Some [] -> uri
45 | Some q -> Uri.with_query' uri q
46
47let auth_headers t =
48 match t.session with
49 | Some s ->
50 Requests.Headers.(empty |> bearer s.access_token)
51 | None ->
52 Requests.Headers.empty
53
54let add_user_agent t headers =
55 match t.config.user_agent with
56 | Some ua -> Requests.Headers.user_agent ua headers
57 | None -> headers
58
59let json_content_type headers =
60 Requests.Headers.content_type Requests.Mime.json headers
61
62let handle_response response =
63 let status = Requests.Response.status_code response in
64 let body = Requests.Response.text response in
65 Log.debug (fun m -> m "Response: status=%d" status);
66 Log.debug (fun m -> m "Response body: %s" body);
67 if status >= 200 && status < 300 then
68 Ok body
69 else begin
70 Log.warn (fun m -> m "HTTP error: status=%d body=%s" status body);
71 (* Try to parse as Matrix error *)
72 match Jsont_bytesrw.decode_string Error.matrix_error_jsont body with
73 | Ok matrix_err -> Error (Error.Matrix_error matrix_err)
74 | Error _ -> Error (Error.Http_error { status; body })
75 end
76
77let get t ~path ?query () =
78 try
79 let url = make_url t path query |> Uri.to_string in
80 Log.debug (fun m -> m "GET %s" url);
81 let headers = auth_headers t |> add_user_agent t in
82 let response = Requests.get t.http ~headers url in
83 handle_response response
84 with
85 | exn ->
86 Log.err (fun m -> m "GET %s failed: %s" path (Printexc.to_string exn));
87 Error (Error.Network_error (Printexc.to_string exn))
88
89let post t ~path ?query ~body () =
90 try
91 let url = make_url t path query |> Uri.to_string in
92 Log.debug (fun m -> m "POST %s" url);
93 Log.debug (fun m -> m "Request body: %s" body);
94 let headers = auth_headers t |> add_user_agent t |> json_content_type in
95 let body = Requests.Body.of_string Requests.Mime.json body in
96 let response = Requests.post t.http ~headers ~body url in
97 handle_response response
98 with
99 | exn ->
100 Log.err (fun m -> m "POST %s failed: %s" path (Printexc.to_string exn));
101 Error (Error.Network_error (Printexc.to_string exn))
102
103let put t ~path ?query ~body () =
104 try
105 let url = make_url t path query |> Uri.to_string in
106 Log.debug (fun m -> m "PUT %s" url);
107 Log.debug (fun m -> m "Request body: %s" body);
108 let headers = auth_headers t |> add_user_agent t |> json_content_type in
109 let body = Requests.Body.of_string Requests.Mime.json body in
110 let response = Requests.put t.http ~headers ~body url in
111 handle_response response
112 with
113 | exn ->
114 Log.err (fun m -> m "PUT %s failed: %s" path (Printexc.to_string exn));
115 Error (Error.Network_error (Printexc.to_string exn))
116
117let delete t ~path ?query ?body () =
118 try
119 let url = make_url t path query |> Uri.to_string in
120 Log.debug (fun m -> m "DELETE %s" url);
121 let headers = auth_headers t |> add_user_agent t in
122 let headers, body =
123 match body with
124 | Some b ->
125 Log.debug (fun m -> m "Request body: %s" b);
126 (json_content_type headers,
127 Some (Requests.Body.of_string Requests.Mime.json b))
128 | None -> (headers, None)
129 in
130 let response = Requests.request t.http ~headers ?body ~method_:`DELETE url in
131 handle_response response
132 with
133 | exn ->
134 Log.err (fun m -> m "DELETE %s failed: %s" path (Printexc.to_string exn));
135 Error (Error.Network_error (Printexc.to_string exn))
136
137let post_unauthenticated t ~path ?query ~body () =
138 try
139 let url = make_url t path query |> Uri.to_string in
140 Log.debug (fun m -> m "POST (unauth) %s" url);
141 Log.debug (fun m -> m "Request body: %s" body);
142 let headers =
143 Requests.Headers.empty
144 |> add_user_agent t
145 |> json_content_type
146 in
147 let body = Requests.Body.of_string Requests.Mime.json body in
148 let response = Requests.post t.http ~headers ~body url in
149 handle_response response
150 with
151 | exn ->
152 Log.err (fun m -> m "POST (unauth) %s failed: %s" path (Printexc.to_string exn));
153 Error (Error.Network_error (Printexc.to_string exn))
154
155let decode_response jsont body =
156 match Jsont_bytesrw.decode_string jsont body with
157 | Ok v -> Ok v
158 | Error e ->
159 Log.err (fun m -> m "JSON decode error: %s" e);
160 Error (Error.Json_error e)
161
162let encode_body jsont value =
163 match Jsont_bytesrw.encode_string jsont value with
164 | Ok s -> Ok s
165 | Error e ->
166 Log.err (fun m -> m "JSON encode error: %s" e);
167 Error (Error.Json_error e)