futur.blue
objective categorical abstract machine language personal data server
1open Alcotest
2open Lwt.Syntax
3open Test_support
4
5let run_lwt f = Lwt_main.run (f ())
6
7(* helpers *)
8let test_string = testable Fmt.string String.equal
9
10let test_bytes =
11 testable
12 (Fmt.of_to_string (fun b -> String.sub (Bytes.to_string b) 0 10))
13 Bytes.equal
14
15(** query tests *)
16
17let test_query_success () =
18 run_lwt
19 @@ fun () ->
20 let response =
21 Mock_http.json_response
22 (`Assoc
23 [("did", `String "did:plc:123"); ("handle", `String "test.bsky.social")]
24 )
25 in
26 let* result, requests =
27 Test_utils.with_mock_responses [response] (fun (module C) client ->
28 C.query client "com.atproto.identity.resolveHandle"
29 (`Assoc [("handle", `String "test.bsky.social")])
30 (fun json ->
31 let open Yojson.Safe.Util in
32 Ok (json |> member "did" |> to_string) ) )
33 in
34 check test_string "result" "did:plc:123" result ;
35 check int "request count" 1 (List.length requests) ;
36 let req = List.hd requests in
37 Test_utils.assert_request_path "/xrpc/com.atproto.identity.resolveHandle" req ;
38 Test_utils.assert_request_method `GET req ;
39 Test_utils.assert_request_query_param "handle" "test.bsky.social" req ;
40 Lwt.return_unit
41
42let test_query_with_multiple_params () =
43 run_lwt
44 @@ fun () ->
45 let response = Mock_http.json_response (`Assoc [("followers", `List [])]) in
46 let* _, requests =
47 Test_utils.with_mock_responses [response] (fun (module C) client ->
48 C.query client "app.bsky.graph.getFollowers"
49 (`Assoc
50 [ ("actor", `String "did:plc:123")
51 ; ("limit", `Int 50)
52 ; ("cursor", `String "abc123") ] )
53 (fun _ -> Ok ()) )
54 in
55 let req = List.hd requests in
56 Test_utils.assert_request_query_param "actor" "did:plc:123" req ;
57 Test_utils.assert_request_query_param "limit" "50" req ;
58 Test_utils.assert_request_query_param "cursor" "abc123" req ;
59 Lwt.return_unit
60
61let test_query_error_response () =
62 run_lwt
63 @@ fun () ->
64 let response =
65 Mock_http.error_response ~status:`Bad_request ~error:"InvalidHandle"
66 ~message:"Handle not found" ()
67 in
68 let* () =
69 Test_utils.with_mock_responses [response] (fun (module C) client ->
70 Lwt.catch
71 (fun () ->
72 let* _ =
73 C.query client "com.atproto.identity.resolveHandle"
74 (`Assoc [("handle", `String "invalid")])
75 (fun _ -> Ok ())
76 in
77 fail "should have raised Xrpc_error" )
78 (function
79 | Hermes.Xrpc_error {status; error; message} ->
80 check int "status" 400 status ;
81 check test_string "error" "InvalidHandle" error ;
82 check (option test_string) "message" (Some "Handle not found")
83 message ;
84 Lwt.return_unit
85 | e ->
86 Lwt.reraise e ) )
87 |> Lwt.map fst
88 in
89 Lwt.return_unit
90
91let test_query_empty_response () =
92 run_lwt
93 @@ fun () ->
94 let response = Mock_http.empty_response () in
95 let* result, _ =
96 Test_utils.with_mock_responses [response] (fun (module C) client ->
97 C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok "empty") )
98 in
99 check test_string "result" "empty" result ;
100 Lwt.return_unit
101
102let test_query_bytes () =
103 run_lwt
104 @@ fun () ->
105 let response =
106 Mock_http.bytes_response ~content_type:"image/jpeg" "fake-image-data"
107 in
108 let* (data, content_type), requests =
109 Test_utils.with_mock_responses [response] (fun (module C) client ->
110 C.query_bytes client "com.atproto.sync.getBlob"
111 (`Assoc [("did", `String "did:plc:123"); ("cid", `String "bafyabc")]) )
112 in
113 check test_bytes "data" (Bytes.of_string "fake-image-data") data ;
114 check test_string "content_type" "image/jpeg" content_type ;
115 let req = List.hd requests in
116 Test_utils.assert_request_has_header "accept" "*/*" req ;
117 Lwt.return_unit
118
119(** procedure tests *)
120
121let test_procedure_success () =
122 run_lwt
123 @@ fun () ->
124 let response =
125 Mock_http.json_response
126 (`Assoc [("uri", `String "at://did:plc:123/app.bsky.feed.post/abc")])
127 in
128 let* result, requests =
129 Test_utils.with_mock_responses [response] (fun (module C) client ->
130 C.procedure client "com.atproto.repo.createRecord" (`Assoc [])
131 (Some
132 (`Assoc
133 [ ("repo", `String "did:plc:123")
134 ; ("collection", `String "app.bsky.feed.post")
135 ; ( "record"
136 , `Assoc [("text", `String "This post was sent from PDSls")]
137 ) ] ) )
138 (fun json ->
139 let open Yojson.Safe.Util in
140 Ok (json |> member "uri" |> to_string) ) )
141 in
142 check test_string "uri" "at://did:plc:123/app.bsky.feed.post/abc" result ;
143 let req = List.hd requests in
144 Test_utils.assert_request_method `POST req ;
145 Test_utils.assert_request_path "/xrpc/com.atproto.repo.createRecord" req ;
146 Test_utils.assert_request_has_header "content-type" "application/json" req ;
147 Test_utils.assert_request_body_contains "This post was sent from PDSls" req ;
148 Lwt.return_unit
149
150let test_procedure_no_input () =
151 run_lwt
152 @@ fun () ->
153 let response = Mock_http.empty_response () in
154 let* _, requests =
155 Test_utils.with_mock_responses [response] (fun (module C) client ->
156 C.procedure client "com.atproto.server.deleteSession" (`Assoc []) None
157 (fun _ -> Ok () ) )
158 in
159 let req = List.hd requests in
160 Test_utils.assert_request_method `POST req ;
161 check (option test_string) "body" (Some "") req.body ;
162 Lwt.return_unit
163
164let test_procedure_bytes () =
165 run_lwt
166 @@ fun () ->
167 let response = Mock_http.empty_response () in
168 let* result, requests =
169 Test_utils.with_mock_responses [response] (fun (module C) client ->
170 C.procedure_bytes client "com.atproto.repo.importRepo" (`Assoc [])
171 (Some (Bytes.of_string "fake-car-data"))
172 ~content_type:"application/vnd.ipld.car" )
173 in
174 check (option (pair test_bytes test_string)) "result" None result ;
175 let req = List.hd requests in
176 Test_utils.assert_request_has_header "content-type" "application/vnd.ipld.car"
177 req ;
178 Test_utils.assert_request_has_header "accept" "*/*" req ;
179 check (option test_string) "body" (Some "fake-car-data") req.body ;
180 Lwt.return_unit
181
182let test_procedure_blob () =
183 run_lwt
184 @@ fun () ->
185 let response =
186 Mock_http.json_response
187 (`Assoc
188 [ ( "blob"
189 , `Assoc
190 [ ("$type", `String "blob")
191 ; ("ref", `Assoc [("$link", `String "bafyabc")])
192 ; ("mimeType", `String "image/jpeg")
193 ; ("size", `Int 1234) ] ) ] )
194 in
195 let* result, requests =
196 Test_utils.with_mock_responses [response] (fun (module C) client ->
197 C.procedure_blob client "com.atproto.repo.uploadBlob" (`Assoc [])
198 (Bytes.of_string "fake-image-bytes") ~content_type:"image/jpeg"
199 (fun json ->
200 let open Yojson.Safe.Util in
201 Ok (json |> member "blob" |> member "mimeType" |> to_string) ) )
202 in
203 check test_string "mimeType" "image/jpeg" result ;
204 let req = List.hd requests in
205 Test_utils.assert_request_has_header "content-type" "image/jpeg" req ;
206 check (option test_string) "body" (Some "fake-image-bytes") req.body ;
207 Lwt.return_unit
208
209(** authentication tests *)
210
211let test_auth_header_added () =
212 run_lwt
213 @@ fun () ->
214 let response = Mock_http.json_response (`Assoc []) in
215 let* _, requests =
216 Test_utils.with_mock_responses [response] (fun (module C) client ->
217 let session = Test_utils.make_test_session () in
218 C.set_session client session ;
219 C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ()) )
220 in
221 let req = List.hd requests in
222 Test_utils.assert_request_has_auth_header req ;
223 Lwt.return_unit
224
225let test_session_can_be_cleared () =
226 run_lwt
227 @@ fun () ->
228 let response = Mock_http.json_response (`Assoc []) in
229 let* _, requests =
230 Test_utils.with_mock_responses [response] (fun (module C) client ->
231 let session = Test_utils.make_test_session () in
232 C.set_session client session ;
233 C.clear_session client ;
234 C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ()) )
235 in
236 let req = List.hd requests in
237 let has_auth = Cohttp.Header.get req.headers "authorization" in
238 check (option test_string) "no auth header" None has_auth ;
239 Lwt.return_unit
240
241(** error handling tests *)
242
243let test_401_unauthorized () =
244 run_lwt
245 @@ fun () ->
246 let response =
247 Mock_http.error_response ~status:`Unauthorized ~error:"AuthRequired"
248 ~message:"Authentication required" ()
249 in
250 let* () =
251 Test_utils.with_mock_responses [response] (fun (module C) client ->
252 Lwt.catch
253 (fun () ->
254 let* _ =
255 C.query client "some.protected.endpoint" (`Assoc []) (fun _ ->
256 Ok () )
257 in
258 fail "should have raised" )
259 (function
260 | Hermes.Xrpc_error {status= 401; error= "AuthRequired"; _} ->
261 Lwt.return_unit
262 | e ->
263 Lwt.reraise e ) )
264 |> Lwt.map fst
265 in
266 Lwt.return_unit
267
268let test_500_server_error () =
269 run_lwt
270 @@ fun () ->
271 let response =
272 Mock_http.error_response ~status:`Internal_server_error
273 ~error:"InternalServerError" ()
274 in
275 let* () =
276 Test_utils.with_mock_responses [response] (fun (module C) client ->
277 Lwt.catch
278 (fun () ->
279 let* _ =
280 C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ())
281 in
282 fail "Should have raised" )
283 (function
284 | Hermes.Xrpc_error {status= 500; _} ->
285 Lwt.return_unit
286 | e ->
287 Lwt.reraise e ) )
288 |> Lwt.map fst
289 in
290 Lwt.return_unit
291
292let test_malformed_error_response () =
293 run_lwt
294 @@ fun () ->
295 let response =
296 { Mock_http.status= `Bad_request
297 ; headers= [("content-type", "application/json")]
298 ; body= "not valid json" }
299 in
300 let* () =
301 Test_utils.with_mock_responses [response] (fun (module C) client ->
302 Lwt.catch
303 (fun () ->
304 let* _ =
305 C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ())
306 in
307 fail "should have raised" )
308 (function
309 | Hermes.Xrpc_error {status= 400; error= "UnknownError"; _} ->
310 Lwt.return_unit
311 | e ->
312 Lwt.reraise e ) )
313 |> Lwt.map fst
314 in
315 Lwt.return_unit
316
317(** client creation tests *)
318
319let test_make_client () =
320 let client = Hermes.make_client ~service:"https://api.bsky.app" () in
321 let service = Hermes.get_service client in
322 check (option test_string) "host" (Some "api.bsky.app") (Uri.host service)
323
324let test_client_service_urls () =
325 let urls =
326 [ "https://bsky.social"
327 ; "https://api.bsky.app"
328 ; "http://localhost:3000"
329 ; "https://pds.example.com:8080" ]
330 in
331 List.iter
332 (fun url ->
333 let client = Hermes.make_client ~service:url () in
334 let service = Hermes.get_service client in
335 check bool "service set" true (String.length (Uri.to_string service) > 0) )
336 urls
337
338let test_get_session_unauthenticated () =
339 let client = Hermes.make_client ~service:"https://example.com" () in
340 check (option reject) "no session" None (Hermes.get_session client)
341
342(** tests *)
343
344let query_tests =
345 [ ("query success", `Quick, test_query_success)
346 ; ("query with multiple params", `Quick, test_query_with_multiple_params)
347 ; ("query error response", `Quick, test_query_error_response)
348 ; ("query empty response", `Quick, test_query_empty_response)
349 ; ("query bytes", `Quick, test_query_bytes) ]
350
351let procedure_tests =
352 [ ("procedure success", `Quick, test_procedure_success)
353 ; ("procedure no input", `Quick, test_procedure_no_input)
354 ; ("procedure bytes", `Quick, test_procedure_bytes)
355 ; ("procedure blob", `Quick, test_procedure_blob) ]
356
357let auth_tests =
358 [ ("auth header added", `Quick, test_auth_header_added)
359 ; ("session can be cleared", `Quick, test_session_can_be_cleared) ]
360
361let error_tests =
362 [ ("401 unauthorized", `Quick, test_401_unauthorized)
363 ; ("500 server error", `Quick, test_500_server_error)
364 ; ("malformed error response", `Quick, test_malformed_error_response) ]
365
366let creation_tests =
367 [ ("make_client", `Quick, test_make_client)
368 ; ("service URLs", `Quick, test_client_service_urls)
369 ; ("get_session unauthenticated", `Quick, test_get_session_unauthenticated) ]
370
371let () =
372 run "Client"
373 [ ("query", query_tests)
374 ; ("procedure", procedure_tests)
375 ; ("auth", auth_tests)
376 ; ("errors", error_tests)
377 ; ("creation", creation_tests) ]