ocaml http/1, http/2 and websocket client and server library
gdiazlo.tngl.sh
1(** Large Body Test Suite - Regression tests for multi-megabyte handling. Tests
2 HTTP/1.1, HTTP/2 (h2c), and WebSocket with large payloads. *)
3
4let generate_payload size = String.make size 'X'
5
6let generate_pattern_payload size =
7 let buf = Buffer.create size in
8 for i = 0 to size - 1 do
9 Buffer.add_char buf (Char.chr (i mod 256))
10 done;
11 Buffer.contents buf
12
13let error_to_string = function
14 | Hcs.Client.Connection_failed s -> "Connection_failed: " ^ s
15 | Hcs.Client.Tls_error s -> "Tls_error: " ^ s
16 | Hcs.Client.Protocol_error s -> "Protocol_error: " ^ s
17 | Hcs.Client.Timeout -> "Timeout"
18 | Hcs.Client.Invalid_response s -> "Invalid_response: " ^ s
19 | Hcs.Client.Too_many_redirects -> "Too_many_redirects"
20
21let ws_error_to_string = function
22 | Hcs.Websocket.Connection_closed -> "Connection_closed"
23 | Hcs.Websocket.Protocol_error s -> "Protocol_error: " ^ s
24 | Hcs.Websocket.Io_error s -> "Io_error: " ^ s
25 | Hcs.Websocket.Payload_too_large n -> "Payload_too_large: " ^ string_of_int n
26
27module H1_tests = struct
28 let test_post_size ~sw ~net ~clock ~port ~size_kb () =
29 let payload_size = size_kb * 1024 in
30 let payload = generate_payload payload_size in
31 let config =
32 Hcs.Client.
33 { default_config with read_timeout = 60.0; connect_timeout = 5.0 }
34 in
35 let url = Printf.sprintf "http://127.0.0.1:%d/upload" port in
36 Printf.printf " %6dKB... %!" size_kb;
37 match Hcs.Client.post ~sw ~net ~clock ~config url ~body:payload with
38 | Ok resp ->
39 if resp.status <> 200 then begin
40 Printf.printf "FAIL (status %d)\n%!" resp.status;
41 false
42 end
43 else begin
44 let received =
45 try
46 int_of_string
47 (String.sub resp.body 9 (String.length resp.body - 9))
48 with _ -> -1
49 in
50 if received <> payload_size then begin
51 Printf.printf "FAIL (sent %d, got %d)\n%!" payload_size received;
52 false
53 end
54 else begin
55 Printf.printf "OK\n%!";
56 true
57 end
58 end
59 | Error e ->
60 Printf.printf "FAIL (%s)\n%!" (error_to_string e);
61 false
62
63 let test_integrity ~sw ~net ~clock ~port ~size_kb () =
64 let payload_size = size_kb * 1024 in
65 let payload = generate_pattern_payload payload_size in
66 let config =
67 Hcs.Client.
68 { default_config with read_timeout = 60.0; connect_timeout = 5.0 }
69 in
70 let url = Printf.sprintf "http://127.0.0.1:%d/integrity" port in
71 Printf.printf " %6dKB integrity... %!" size_kb;
72 match Hcs.Client.post ~sw ~net ~clock ~config url ~body:payload with
73 | Ok resp ->
74 if resp.status = 200 && resp.body = "ok" then begin
75 Printf.printf "OK\n%!";
76 true
77 end
78 else begin
79 Printf.printf "FAIL (%s)\n%!" resp.body;
80 false
81 end
82 | Error e ->
83 Printf.printf "FAIL (%s)\n%!" (error_to_string e);
84 false
85
86 let test_max_body_size ~sw ~net ~clock () =
87 let port = 18301 in
88 let max_size = 1024L in
89 let payload = generate_payload 2048 in
90 let handler_called = ref false in
91 let handler (_req : Hcs.Server.request) =
92 handler_called := true;
93 Hcs.Server.respond "should not reach"
94 in
95 let config =
96 Hcs.Server.
97 {
98 default_config with
99 port;
100 max_body_size = Some max_size;
101 gc_tuning = None;
102 }
103 in
104 Eio.Fiber.fork_daemon ~sw (fun[@warning "-21"] () ->
105 Hcs.Server.run ~sw ~net ~config handler;
106 `Stop_daemon);
107 Eio.Time.sleep clock 0.1;
108 Printf.printf " max_body_size (1KB limit)... %!";
109 let url = Printf.sprintf "http://127.0.0.1:%d/upload" port in
110 match Hcs.Client.post ~sw ~net ~clock url ~body:payload with
111 | Ok resp ->
112 if resp.status = 413 && not !handler_called then begin
113 Printf.printf "OK (413)\n%!";
114 true
115 end
116 else begin
117 Printf.printf "FAIL (status %d)\n%!" resp.status;
118 false
119 end
120 | Error e ->
121 Printf.printf "FAIL (%s)\n%!" (error_to_string e);
122 false
123
124 let run_all ~sw ~net ~clock ~port () =
125 Printf.printf "\n POST sizes:\n%!";
126 let sizes = [ 1; 16; 32; 64; 128; 256; 512; 1024; 2048; 5120 ] in
127 let size_results =
128 List.map
129 (fun kb -> test_post_size ~sw ~net ~clock ~port ~size_kb:kb ())
130 sizes
131 in
132 Printf.printf "\n Data integrity:\n%!";
133 let integrity_results =
134 List.map
135 (fun kb -> test_integrity ~sw ~net ~clock ~port ~size_kb:kb ())
136 [ 64; 256; 1024 ]
137 in
138 Printf.printf "\n Limits:\n%!";
139 let max_body_ok = test_max_body_size ~sw ~net ~clock () in
140 List.for_all Fun.id size_results
141 && List.for_all Fun.id integrity_results
142 && max_body_ok
143end
144
145module H2_tests = struct
146 let test_post_size ~sw ~net ~clock ~port ~size_kb () =
147 let payload_size = size_kb * 1024 in
148 let payload = generate_payload payload_size in
149 let config =
150 Hcs.Client.
151 {
152 default_config with
153 read_timeout = 60.0;
154 connect_timeout = 5.0;
155 preferred_protocol = Some HTTP_2;
156 }
157 in
158 let url = Printf.sprintf "http://127.0.0.1:%d/upload" port in
159 Printf.printf " %6dKB... %!" size_kb;
160 match Hcs.Client.post ~sw ~net ~clock ~config url ~body:payload with
161 | Ok resp ->
162 if resp.status <> 200 then begin
163 Printf.printf "FAIL (status %d)\n%!" resp.status;
164 false
165 end
166 else begin
167 let received =
168 try
169 int_of_string
170 (String.sub resp.body 9 (String.length resp.body - 9))
171 with _ -> -1
172 in
173 if received <> payload_size then begin
174 Printf.printf "FAIL (sent %d, got %d)\n%!" payload_size received;
175 false
176 end
177 else begin
178 Printf.printf "OK\n%!";
179 true
180 end
181 end
182 | Error e ->
183 Printf.printf "FAIL (%s)\n%!" (error_to_string e);
184 false
185
186 let test_integrity ~sw ~net ~clock ~port ~size_kb () =
187 let payload_size = size_kb * 1024 in
188 let payload = generate_pattern_payload payload_size in
189 let config =
190 Hcs.Client.
191 {
192 default_config with
193 read_timeout = 60.0;
194 connect_timeout = 5.0;
195 preferred_protocol = Some HTTP_2;
196 }
197 in
198 let url = Printf.sprintf "http://127.0.0.1:%d/integrity" port in
199 Printf.printf " %6dKB integrity... %!" size_kb;
200 match Hcs.Client.post ~sw ~net ~clock ~config url ~body:payload with
201 | Ok resp ->
202 if resp.status = 200 && resp.body = "ok" then begin
203 Printf.printf "OK\n%!";
204 true
205 end
206 else begin
207 Printf.printf "FAIL (%s)\n%!" resp.body;
208 false
209 end
210 | Error e ->
211 Printf.printf "FAIL (%s)\n%!" (error_to_string e);
212 false
213
214 let run_all ~sw ~net ~clock ~port () =
215 Printf.printf "\n POST sizes (h2c):\n%!";
216 let sizes = [ 1; 16; 32; 64; 128; 256; 512; 1024; 2048; 5120 ] in
217 let size_results =
218 List.map
219 (fun kb -> test_post_size ~sw ~net ~clock ~port ~size_kb:kb ())
220 sizes
221 in
222 Printf.printf "\n Data integrity (h2c):\n%!";
223 let integrity_sizes = [ 64; 256; 1024 ] in
224 let integrity_results =
225 List.map
226 (fun kb -> test_integrity ~sw ~net ~clock ~port ~size_kb:kb ())
227 integrity_sizes
228 in
229 List.for_all Fun.id size_results && List.for_all Fun.id integrity_results
230end
231
232module Websocket_tests = struct
233 let test_large_message ~sw ~net ~port ~size_kb () =
234 let payload_size = size_kb * 1024 in
235 let payload = generate_payload payload_size in
236 Printf.printf " %6dKB message... %!" size_kb;
237 let url = Printf.sprintf "ws://127.0.0.1:%d/" port in
238 match Hcs.Websocket.connect ~sw ~net url with
239 | Ok ws -> (
240 match Hcs.Websocket.send_text ws payload with
241 | Ok () -> (
242 match Hcs.Websocket.recv_message ws with
243 | Ok (_, msg) ->
244 Hcs.Websocket.close ws;
245 let expected =
246 "echo:" ^ string_of_int (String.length payload)
247 in
248 if msg = expected then begin
249 Printf.printf "OK\n%!";
250 true
251 end
252 else begin
253 Printf.printf "FAIL (got '%s')\n%!"
254 (String.sub msg 0 (min 50 (String.length msg)));
255 false
256 end
257 | Error e ->
258 Hcs.Websocket.close ws;
259 Printf.printf "FAIL recv (%s)\n%!" (ws_error_to_string e);
260 false)
261 | Error e ->
262 Hcs.Websocket.close ws;
263 Printf.printf "FAIL send (%s)\n%!" (ws_error_to_string e);
264 false)
265 | Error e ->
266 Printf.printf "FAIL connect (%s)\n%!" (ws_error_to_string e);
267 false
268
269 let test_integrity ~sw ~net ~port ~size_kb () =
270 let payload_size = size_kb * 1024 in
271 let payload = generate_pattern_payload payload_size in
272 Printf.printf " %6dKB integrity... %!" size_kb;
273 let url = Printf.sprintf "ws://127.0.0.1:%d/" port in
274 match Hcs.Websocket.connect ~sw ~net url with
275 | Ok ws -> (
276 match Hcs.Websocket.send_binary ws payload with
277 | Ok () -> (
278 match Hcs.Websocket.recv_message ws with
279 | Ok (_, msg) ->
280 Hcs.Websocket.close ws;
281 if msg = "integrity:ok" then begin
282 Printf.printf "OK\n%!";
283 true
284 end
285 else begin
286 Printf.printf "FAIL (%s)\n%!" msg;
287 false
288 end
289 | Error e ->
290 Hcs.Websocket.close ws;
291 Printf.printf "FAIL recv (%s)\n%!" (ws_error_to_string e);
292 false)
293 | Error e ->
294 Hcs.Websocket.close ws;
295 Printf.printf "FAIL send (%s)\n%!" (ws_error_to_string e);
296 false)
297 | Error e ->
298 Printf.printf "FAIL connect (%s)\n%!" (ws_error_to_string e);
299 false
300
301 let run_all ~sw ~net ~port () =
302 Printf.printf "\n Message sizes:\n%!";
303 let sizes = [ 1; 8; 16; 32; 64 ] in
304 let size_results =
305 List.map
306 (fun kb -> test_large_message ~sw ~net ~port ~size_kb:kb ())
307 sizes
308 in
309 Printf.printf "\n Data integrity:\n%!";
310 let integrity_results =
311 List.map
312 (fun kb -> test_integrity ~sw ~net ~port ~size_kb:kb ())
313 [ 8; 32 ]
314 in
315 List.for_all Fun.id size_results && List.for_all Fun.id integrity_results
316end
317
318let () =
319 Eio_main.run @@ fun env ->
320 let net = Eio.Stdenv.net env in
321 let clock = Eio.Stdenv.clock env in
322
323 Printf.printf "=== Large Body Regression Tests ===\n%!";
324
325 let h1_ok =
326 Eio.Switch.run @@ fun sw ->
327 let port = 18300 in
328 let handler (req : Hcs.Server.request) =
329 let body_len = String.length req.body in
330 match req.target with
331 | "/upload" -> Hcs.Server.respond (Printf.sprintf "received:%d" body_len)
332 | "/integrity" -> (
333 let mismatch = ref None in
334 for i = 0 to body_len - 1 do
335 if !mismatch = None && Char.code req.body.[i] <> i mod 256 then
336 mismatch := Some i
337 done;
338 match !mismatch with
339 | Some i -> Hcs.Server.respond (Printf.sprintf "mismatch at %d" i)
340 | None -> Hcs.Server.respond "ok")
341 | _ -> Hcs.Server.respond ~status:`Not_found "not found"
342 in
343 let config = Hcs.Server.{ default_config with port; gc_tuning = None } in
344 Eio.Fiber.fork_daemon ~sw (fun[@warning "-21"] () ->
345 Hcs.Server.run ~sw ~net ~config handler;
346 `Stop_daemon);
347 Eio.Time.sleep clock 0.1;
348 Printf.printf "\n--- HTTP/1.1 Tests ---\n%!";
349 H1_tests.run_all ~sw ~net ~clock ~port ()
350 in
351
352 let h2_ok =
353 Eio.Switch.run @@ fun sw ->
354 let port = 18302 in
355 let handler (req : Hcs.Server.request) =
356 match req.target with
357 | "/upload" ->
358 let body_len = String.length req.body in
359 Hcs.Server.respond (Printf.sprintf "received:%d" body_len)
360 | "/integrity" -> (
361 let len = String.length req.body in
362 let mismatch = ref None in
363 for i = 0 to len - 1 do
364 if !mismatch = None && Char.code req.body.[i] <> i mod 256 then
365 mismatch := Some i
366 done;
367 match !mismatch with
368 | Some i ->
369 Hcs.Server.respond ~status:`Bad_request
370 (Printf.sprintf "mismatch at byte %d" i)
371 | None -> Hcs.Server.respond "ok")
372 | _ -> Hcs.Server.respond ~status:`Not_found "not found"
373 in
374 let config =
375 Hcs.Server.
376 { default_config with port; protocol = Http2_only; gc_tuning = None }
377 in
378 Eio.Fiber.fork_daemon ~sw (fun[@warning "-21"] () ->
379 Hcs.Server.run ~sw ~net ~config handler;
380 `Stop_daemon);
381 Eio.Time.sleep clock 0.1;
382 Printf.printf "\n--- HTTP/2 Tests ---\n%!";
383 H2_tests.run_all ~sw ~net ~clock ~port ()
384 in
385
386 let ws_ok =
387 Eio.Switch.run @@ fun sw ->
388 let port = 18303 in
389 let handler (_req : Hcs.Server.request) =
390 Hcs.Server.respond "use websocket"
391 in
392 let ws_handler ws =
393 let rec loop () =
394 match Hcs.Websocket.recv_message ws with
395 | Error Hcs.Websocket.Connection_closed -> ()
396 | Error _ -> ()
397 | Ok (opcode, msg) -> (
398 let response =
399 match opcode with
400 | Hcs.Websocket.Opcode.Text ->
401 "echo:" ^ string_of_int (String.length msg)
402 | Hcs.Websocket.Opcode.Binary -> (
403 let len = String.length msg in
404 let mismatch = ref None in
405 for i = 0 to len - 1 do
406 if !mismatch = None && Char.code msg.[i] <> i mod 256 then
407 mismatch := Some i
408 done;
409 match !mismatch with
410 | Some i -> Printf.sprintf "integrity:mismatch at %d" i
411 | None -> "integrity:ok")
412 | _ -> "unknown opcode"
413 in
414 match Hcs.Websocket.send_text ws response with
415 | Ok () -> loop ()
416 | Error _ -> ())
417 in
418 loop ()
419 in
420 let config =
421 Hcs.Server.
422 {
423 default_config with
424 port;
425 protocol = Auto_websocket;
426 gc_tuning = None;
427 }
428 in
429 Eio.Fiber.fork_daemon ~sw (fun[@warning "-21"] () ->
430 Hcs.Server.run ~sw ~net ~config ~ws_handler handler;
431 `Stop_daemon);
432 Eio.Time.sleep clock 0.1;
433 Printf.printf "\n--- WebSocket Tests ---\n%!";
434 Websocket_tests.run_all ~sw ~net ~port ()
435 in
436
437 Printf.printf "\n=== Summary ===\n%!";
438 Printf.printf "HTTP/1.1: %s\n%!" (if h1_ok then "PASS" else "FAIL");
439 Printf.printf "HTTP/2: %s\n%!" (if h2_ok then "PASS" else "FAIL");
440 Printf.printf "WebSocket: %s\n%!" (if ws_ok then "PASS" else "FAIL");
441
442 if h1_ok && h2_ok && ws_ok then Printf.printf "\n*** ALL TESTS PASSED ***\n%!"
443 else begin
444 Printf.printf "\n*** SOME TESTS FAILED ***\n%!";
445 exit 1
446 end