ocaml http/1, http/2 and websocket client and server library
bench: add pubsub and channel benchmarks
- bench_pubsub.ml: throughput, memory per subscription, parallel broadcast
- bench_channel.ml: parse/serialize event performance
- test_plug.ml: add tests for compress, cors, csrf, basic_auth, retry, static
+1265
+218
bench/hcs/bench_channel.ml
+218
bench/hcs/bench_channel.ml
···
1
+
type config = { num_events : int; payload_size : int; warmup_events : int }
2
+
3
+
let _default_config =
4
+
{ num_events = 1_000_000; payload_size = 64; warmup_events = 10_000 }
5
+
6
+
let make_payload size = String.init size (fun i -> Char.chr (65 + (i mod 26)))
7
+
8
+
let get_gc_memory_kb () =
9
+
let stat = Gc.quick_stat () in
10
+
stat.Gc.heap_words * (Sys.word_size / 8) / 1024
11
+
12
+
type result = {
13
+
name : string;
14
+
duration_sec : float;
15
+
operations : int;
16
+
ops_per_sec : float;
17
+
ns_per_op : float;
18
+
memory_delta_kb : int;
19
+
}
20
+
21
+
let print_result r =
22
+
Printf.printf "\n=== %s ===\n" r.name;
23
+
Printf.printf "Duration: %.3f sec\n" r.duration_sec;
24
+
Printf.printf "Operations: %d\n" r.operations;
25
+
Printf.printf "Throughput: %.0f ops/sec\n" r.ops_per_sec;
26
+
Printf.printf "Latency: %.1f ns/op\n" r.ns_per_op;
27
+
Printf.printf "Memory delta: %d KB\n" r.memory_delta_kb
28
+
29
+
let print_json_result r =
30
+
Printf.printf
31
+
{|{"name":"%s","duration_sec":%.6f,"operations":%d,"ops_per_sec":%.2f,"ns_per_op":%.2f,"memory_delta_kb":%d}|}
32
+
r.name r.duration_sec r.operations r.ops_per_sec r.ns_per_op
33
+
r.memory_delta_kb
34
+
35
+
let bench_parse_event config =
36
+
let payload = make_payload config.payload_size in
37
+
let json =
38
+
Printf.sprintf {|{"t":"room:lobby","e":"msg","p":"%s","r":42}|} payload
39
+
in
40
+
41
+
for _ = 1 to config.warmup_events do
42
+
ignore (Hcs.Channel.parse_event json)
43
+
done;
44
+
45
+
Gc.full_major ();
46
+
let mem_before = get_gc_memory_kb () in
47
+
let t0 = Unix.gettimeofday () in
48
+
49
+
for _ = 1 to config.num_events do
50
+
ignore (Hcs.Channel.parse_event json)
51
+
done;
52
+
53
+
let t1 = Unix.gettimeofday () in
54
+
let mem_after = get_gc_memory_kb () in
55
+
let duration = t1 -. t0 in
56
+
57
+
{
58
+
name = Printf.sprintf "parse_event_%d_byte_payload" config.payload_size;
59
+
duration_sec = duration;
60
+
operations = config.num_events;
61
+
ops_per_sec = Float.of_int config.num_events /. duration;
62
+
ns_per_op = duration /. Float.of_int config.num_events *. 1e9;
63
+
memory_delta_kb = mem_after - mem_before;
64
+
}
65
+
66
+
let bench_serialize_event config =
67
+
let payload = make_payload config.payload_size in
68
+
let ev : Hcs.Channel.event =
69
+
{ topic = "room:lobby"; event = "msg"; payload; ref = Some 42 }
70
+
in
71
+
72
+
for _ = 1 to config.warmup_events do
73
+
ignore (Hcs.Channel.serialize_event ev)
74
+
done;
75
+
76
+
Gc.full_major ();
77
+
let mem_before = get_gc_memory_kb () in
78
+
let t0 = Unix.gettimeofday () in
79
+
80
+
for _ = 1 to config.num_events do
81
+
ignore (Hcs.Channel.serialize_event ev)
82
+
done;
83
+
84
+
let t1 = Unix.gettimeofday () in
85
+
let mem_after = get_gc_memory_kb () in
86
+
let duration = t1 -. t0 in
87
+
88
+
{
89
+
name = Printf.sprintf "serialize_event_%d_byte_payload" config.payload_size;
90
+
duration_sec = duration;
91
+
operations = config.num_events;
92
+
ops_per_sec = Float.of_int config.num_events /. duration;
93
+
ns_per_op = duration /. Float.of_int config.num_events *. 1e9;
94
+
memory_delta_kb = mem_after - mem_before;
95
+
}
96
+
97
+
let bench_roundtrip config =
98
+
let payload = make_payload config.payload_size in
99
+
let ev : Hcs.Channel.event =
100
+
{ topic = "room:lobby"; event = "msg"; payload; ref = Some 42 }
101
+
in
102
+
103
+
for _ = 1 to config.warmup_events do
104
+
let json = Hcs.Channel.serialize_event ev in
105
+
ignore (Hcs.Channel.parse_event json)
106
+
done;
107
+
108
+
Gc.full_major ();
109
+
let mem_before = get_gc_memory_kb () in
110
+
let t0 = Unix.gettimeofday () in
111
+
112
+
for _ = 1 to config.num_events do
113
+
let json = Hcs.Channel.serialize_event ev in
114
+
ignore (Hcs.Channel.parse_event json)
115
+
done;
116
+
117
+
let t1 = Unix.gettimeofday () in
118
+
let mem_after = get_gc_memory_kb () in
119
+
let duration = t1 -. t0 in
120
+
121
+
{
122
+
name = Printf.sprintf "roundtrip_%d_byte_payload" config.payload_size;
123
+
duration_sec = duration;
124
+
operations = config.num_events;
125
+
ops_per_sec = Float.of_int config.num_events /. duration;
126
+
ns_per_op = duration /. Float.of_int config.num_events *. 1e9;
127
+
memory_delta_kb = mem_after - mem_before;
128
+
}
129
+
130
+
let bench_parse_invalid config =
131
+
let invalid_inputs =
132
+
[|
133
+
"not json at all";
134
+
{|{"e":"msg","p":"no topic"}|};
135
+
{|{"t":"topic"}|};
136
+
"";
137
+
"{}";
138
+
|]
139
+
in
140
+
let n = Array.length invalid_inputs in
141
+
142
+
Gc.full_major ();
143
+
let t0 = Unix.gettimeofday () in
144
+
145
+
for i = 1 to config.num_events do
146
+
ignore (Hcs.Channel.parse_event invalid_inputs.(i mod n))
147
+
done;
148
+
149
+
let t1 = Unix.gettimeofday () in
150
+
let duration = t1 -. t0 in
151
+
152
+
{
153
+
name = "parse_invalid_input";
154
+
duration_sec = duration;
155
+
operations = config.num_events;
156
+
ops_per_sec = Float.of_int config.num_events /. duration;
157
+
ns_per_op = duration /. Float.of_int config.num_events *. 1e9;
158
+
memory_delta_kb = 0;
159
+
}
160
+
161
+
let _bench_varying_payload_sizes config =
162
+
let sizes = [| 16; 64; 256; 1024; 4096 |] in
163
+
Array.map
164
+
(fun size ->
165
+
let cfg = { config with payload_size = size } in
166
+
bench_roundtrip cfg)
167
+
sizes
168
+
|> Array.to_list
169
+
170
+
let run_all config ~json =
171
+
let results =
172
+
[
173
+
bench_parse_event config;
174
+
bench_parse_event { config with payload_size = 16 };
175
+
bench_parse_event { config with payload_size = 1024 };
176
+
bench_serialize_event config;
177
+
bench_serialize_event { config with payload_size = 16 };
178
+
bench_serialize_event { config with payload_size = 1024 };
179
+
bench_roundtrip config;
180
+
bench_parse_invalid config;
181
+
]
182
+
in
183
+
184
+
if json then begin
185
+
print_string "[";
186
+
List.iteri
187
+
(fun i r ->
188
+
if i > 0 then print_string ",";
189
+
print_json_result r)
190
+
results;
191
+
print_endline "]"
192
+
end
193
+
else List.iter print_result results
194
+
195
+
let () =
196
+
let open Climate.Arg_parser in
197
+
let command =
198
+
Climate.Command.singleton ~doc:"Channel benchmark"
199
+
@@
200
+
let+ json = flag [ "json" ] ~doc:"Output results as JSON"
201
+
and+ events =
202
+
named_with_default [ "n"; "events" ] int ~default:1_000_000
203
+
~doc:"Number of events"
204
+
and+ payload_size =
205
+
named_with_default [ "size" ] int ~default:64 ~doc:"Payload size in bytes"
206
+
in
207
+
fun () ->
208
+
let config =
209
+
{ num_events = events; payload_size; warmup_events = 10_000 }
210
+
in
211
+
Printf.printf "Channel Benchmark\n";
212
+
Printf.printf "=================\n";
213
+
Printf.printf "Config: %d events, %d byte payloads\n" config.num_events
214
+
config.payload_size;
215
+
216
+
run_all config ~json
217
+
in
218
+
Climate.Command.run command ()
+364
bench/hcs/bench_pubsub.ml
+364
bench/hcs/bench_pubsub.ml
···
1
+
(** Benchmark for Hcs.Pubsub module
2
+
3
+
Measures:
4
+
- Messages per second throughput
5
+
- Memory per subscription
6
+
- Scalability with subscribers/topics
7
+
8
+
Run with: dune exec bench/hcs/bench_pubsub.exe -- [options]
9
+
10
+
For memory profiling: valgrind --tool=massif dune exec
11
+
bench/hcs/bench_pubsub.exe -- --memory
12
+
13
+
For CPU profiling: perf stat dune exec bench/hcs/bench_pubsub.exe --
14
+
--throughput *)
15
+
16
+
type config = {
17
+
num_subscribers : int;
18
+
num_topics : int;
19
+
num_messages : int;
20
+
message_size : int;
21
+
warmup_messages : int;
22
+
}
23
+
(** Configuration for benchmark runs *)
24
+
25
+
let _default_config =
26
+
{
27
+
num_subscribers = 100;
28
+
num_topics = 10;
29
+
num_messages = 1_000_000;
30
+
message_size = 64;
31
+
warmup_messages = 10_000;
32
+
}
33
+
34
+
(** Generate a message of specified size *)
35
+
let make_message size = String.init size (fun i -> Char.chr (65 + (i mod 26)))
36
+
37
+
(** Get current memory usage via /proc/self/statm *)
38
+
let _get_memory_kb () =
39
+
try
40
+
let ic = open_in "/proc/self/statm" in
41
+
let line = input_line ic in
42
+
close_in ic;
43
+
match String.split_on_char ' ' line with
44
+
| _ :: resident :: _ ->
45
+
(* resident is in pages, typically 4KB *)
46
+
int_of_string resident * 4
47
+
| _ -> 0
48
+
with _ -> 0
49
+
50
+
(** Get current memory via Gc stats (more portable) *)
51
+
let get_gc_memory_kb () =
52
+
let stat = Gc.quick_stat () in
53
+
stat.Gc.heap_words * (Sys.word_size / 8) / 1024
54
+
55
+
type result = {
56
+
name : string;
57
+
duration_sec : float;
58
+
messages : int;
59
+
msg_per_sec : float;
60
+
memory_before_kb : int;
61
+
memory_after_kb : int;
62
+
memory_delta_kb : int;
63
+
latency_ns : float;
64
+
}
65
+
(** Benchmark result *)
66
+
67
+
let print_result r =
68
+
Printf.printf "\n=== %s ===\n" r.name;
69
+
Printf.printf "Duration: %.3f sec\n" r.duration_sec;
70
+
Printf.printf "Messages: %d\n" r.messages;
71
+
Printf.printf "Throughput: %.0f msg/sec\n" r.msg_per_sec;
72
+
Printf.printf "Latency: %.0f ns/msg\n" r.latency_ns;
73
+
Printf.printf "Memory before: %d KB\n" r.memory_before_kb;
74
+
Printf.printf "Memory after: %d KB\n" r.memory_after_kb;
75
+
Printf.printf "Memory delta: %d KB\n" r.memory_delta_kb
76
+
77
+
let print_json_result r =
78
+
Printf.printf
79
+
{|{"name":"%s","duration_sec":%.6f,"messages":%d,"msg_per_sec":%.2f,"latency_ns":%.2f,"memory_before_kb":%d,"memory_after_kb":%d,"memory_delta_kb":%d}|}
80
+
r.name r.duration_sec r.messages r.msg_per_sec r.latency_ns
81
+
r.memory_before_kb r.memory_after_kb r.memory_delta_kb
82
+
83
+
(** Benchmark: Single topic, varying subscribers *)
84
+
let bench_single_topic_broadcast config =
85
+
let ps = Hcs.Pubsub.create () in
86
+
let msg = make_message config.message_size in
87
+
let received = Atomic.make 0 in
88
+
89
+
(* Subscribe *)
90
+
let _subs =
91
+
List.init config.num_subscribers (fun _ ->
92
+
Hcs.Pubsub.subscribe ps "bench:topic" (fun _ -> Atomic.incr received))
93
+
in
94
+
95
+
(* Warmup *)
96
+
for _ = 1 to config.warmup_messages do
97
+
Hcs.Pubsub.broadcast ps "bench:topic" msg
98
+
done;
99
+
Atomic.set received 0;
100
+
101
+
Gc.full_major ();
102
+
let mem_before = get_gc_memory_kb () in
103
+
let t0 = Unix.gettimeofday () in
104
+
105
+
(* Benchmark *)
106
+
for _ = 1 to config.num_messages do
107
+
Hcs.Pubsub.broadcast ps "bench:topic" msg
108
+
done;
109
+
110
+
let t1 = Unix.gettimeofday () in
111
+
let mem_after = get_gc_memory_kb () in
112
+
let duration = t1 -. t0 in
113
+
let total_deliveries = Atomic.get received in
114
+
115
+
{
116
+
name = Printf.sprintf "single_topic_%d_subs" config.num_subscribers;
117
+
duration_sec = duration;
118
+
messages = total_deliveries;
119
+
msg_per_sec = Float.of_int total_deliveries /. duration;
120
+
memory_before_kb = mem_before;
121
+
memory_after_kb = mem_after;
122
+
memory_delta_kb = mem_after - mem_before;
123
+
latency_ns = duration /. Float.of_int config.num_messages *. 1e9;
124
+
}
125
+
126
+
(** Benchmark: Multiple topics, one subscriber each *)
127
+
let bench_multi_topic_broadcast config =
128
+
let ps = Hcs.Pubsub.create () in
129
+
let msg = make_message config.message_size in
130
+
let received = Atomic.make 0 in
131
+
132
+
(* Subscribe one per topic *)
133
+
let topics =
134
+
List.init config.num_topics (fun i -> Printf.sprintf "topic:%d" i)
135
+
in
136
+
let _subs =
137
+
List.map
138
+
(fun topic ->
139
+
Hcs.Pubsub.subscribe ps topic (fun _ -> Atomic.incr received))
140
+
topics
141
+
in
142
+
143
+
(* Warmup *)
144
+
for _ = 1 to config.warmup_messages do
145
+
List.iter (fun topic -> Hcs.Pubsub.broadcast ps topic msg) topics
146
+
done;
147
+
Atomic.set received 0;
148
+
149
+
Gc.full_major ();
150
+
let mem_before = get_gc_memory_kb () in
151
+
let t0 = Unix.gettimeofday () in
152
+
153
+
(* Benchmark: round-robin across topics *)
154
+
let topics_arr = Array.of_list topics in
155
+
let n_topics = Array.length topics_arr in
156
+
for i = 1 to config.num_messages do
157
+
let topic = topics_arr.(i mod n_topics) in
158
+
Hcs.Pubsub.broadcast ps topic msg
159
+
done;
160
+
161
+
let t1 = Unix.gettimeofday () in
162
+
let mem_after = get_gc_memory_kb () in
163
+
let duration = t1 -. t0 in
164
+
165
+
{
166
+
name = Printf.sprintf "multi_topic_%d_topics" config.num_topics;
167
+
duration_sec = duration;
168
+
messages = Atomic.get received;
169
+
msg_per_sec = Float.of_int config.num_messages /. duration;
170
+
memory_before_kb = mem_before;
171
+
memory_after_kb = mem_after;
172
+
memory_delta_kb = mem_after - mem_before;
173
+
latency_ns = duration /. Float.of_int config.num_messages *. 1e9;
174
+
}
175
+
176
+
(** Benchmark: Subscribe/unsubscribe churn *)
177
+
let bench_subscription_churn config =
178
+
let ps = Hcs.Pubsub.create () in
179
+
let num_ops = config.num_messages / 10 in
180
+
(* fewer ops, they're heavier *)
181
+
182
+
Gc.full_major ();
183
+
let mem_before = get_gc_memory_kb () in
184
+
let t0 = Unix.gettimeofday () in
185
+
186
+
for i = 1 to num_ops do
187
+
let topic = Printf.sprintf "topic:%d" (i mod config.num_topics) in
188
+
let sub = Hcs.Pubsub.subscribe ps topic (fun _ -> ()) in
189
+
(* Immediately unsubscribe half the time *)
190
+
if i mod 2 = 0 then Hcs.Pubsub.unsubscribe ps sub
191
+
done;
192
+
193
+
let t1 = Unix.gettimeofday () in
194
+
let mem_after = get_gc_memory_kb () in
195
+
let duration = t1 -. t0 in
196
+
197
+
{
198
+
name = "subscription_churn";
199
+
duration_sec = duration;
200
+
messages = num_ops;
201
+
msg_per_sec = Float.of_int num_ops /. duration;
202
+
memory_before_kb = mem_before;
203
+
memory_after_kb = mem_after;
204
+
memory_delta_kb = mem_after - mem_before;
205
+
latency_ns = duration /. Float.of_int num_ops *. 1e9;
206
+
}
207
+
208
+
(** Benchmark: Memory per subscription *)
209
+
let bench_memory_per_subscription () =
210
+
Gc.full_major ();
211
+
let mem_baseline = get_gc_memory_kb () in
212
+
213
+
let ps = Hcs.Pubsub.create () in
214
+
Gc.full_major ();
215
+
let mem_empty = get_gc_memory_kb () in
216
+
217
+
let num_subs = 10_000 in
218
+
let subs = ref [] in
219
+
for i = 1 to num_subs do
220
+
let topic = Printf.sprintf "topic:%d" (i mod 100) in
221
+
subs := Hcs.Pubsub.subscribe ps topic (fun _ -> ()) :: !subs
222
+
done;
223
+
224
+
Gc.full_major ();
225
+
let mem_with_subs = get_gc_memory_kb () in
226
+
227
+
let mem_per_sub =
228
+
Float.of_int (mem_with_subs - mem_empty) /. Float.of_int num_subs
229
+
in
230
+
231
+
Printf.printf "\n=== Memory per Subscription ===\n";
232
+
Printf.printf "Baseline memory: %d KB\n" mem_baseline;
233
+
Printf.printf "Empty pubsub: %d KB (+%d)\n" mem_empty
234
+
(mem_empty - mem_baseline);
235
+
Printf.printf "With %d subs: %d KB\n" num_subs mem_with_subs;
236
+
Printf.printf "Memory per sub: %.2f bytes\n" (mem_per_sub *. 1024.0);
237
+
238
+
(* Cleanup *)
239
+
List.iter (fun sub -> Hcs.Pubsub.unsubscribe ps sub) !subs;
240
+
mem_per_sub
241
+
242
+
(** Benchmark: Parallel broadcast (Eio) *)
243
+
let bench_parallel_broadcast _env config =
244
+
let ps = Hcs.Pubsub.create () in
245
+
let msg = make_message config.message_size in
246
+
let received = Atomic.make 0 in
247
+
let num_domains = Domain.recommended_domain_count () in
248
+
249
+
(* Subscribe *)
250
+
let _subs =
251
+
List.init config.num_subscribers (fun _ ->
252
+
Hcs.Pubsub.subscribe ps "bench:parallel" (fun _ -> Atomic.incr received))
253
+
in
254
+
255
+
Gc.full_major ();
256
+
let mem_before = get_gc_memory_kb () in
257
+
let t0 = Unix.gettimeofday () in
258
+
259
+
let msgs_per_domain = config.num_messages / num_domains in
260
+
261
+
Eio.Fiber.all
262
+
(List.init num_domains (fun _ () ->
263
+
for _ = 1 to msgs_per_domain do
264
+
Hcs.Pubsub.broadcast ps "bench:parallel" msg
265
+
done));
266
+
267
+
let t1 = Unix.gettimeofday () in
268
+
let mem_after = get_gc_memory_kb () in
269
+
let duration = t1 -. t0 in
270
+
let total = Atomic.get received in
271
+
272
+
{
273
+
name = Printf.sprintf "parallel_%d_fibers" num_domains;
274
+
duration_sec = duration;
275
+
messages = total;
276
+
msg_per_sec = Float.of_int total /. duration;
277
+
memory_before_kb = mem_before;
278
+
memory_after_kb = mem_after;
279
+
memory_delta_kb = mem_after - mem_before;
280
+
latency_ns = duration /. Float.of_int (msgs_per_domain * num_domains) *. 1e9;
281
+
}
282
+
283
+
(** Run all benchmarks *)
284
+
let run_all env config ~json =
285
+
let results = ref [] in
286
+
287
+
(* Run benchmarks *)
288
+
results := bench_single_topic_broadcast config :: !results;
289
+
results :=
290
+
bench_single_topic_broadcast { config with num_subscribers = 1 } :: !results;
291
+
results :=
292
+
bench_single_topic_broadcast { config with num_subscribers = 10 }
293
+
:: !results;
294
+
results :=
295
+
bench_single_topic_broadcast { config with num_subscribers = 1000 }
296
+
:: !results;
297
+
results := bench_multi_topic_broadcast config :: !results;
298
+
results := bench_subscription_churn config :: !results;
299
+
results := bench_parallel_broadcast env config :: !results;
300
+
301
+
let results = List.rev !results in
302
+
303
+
if json then begin
304
+
print_string "[";
305
+
List.iteri
306
+
(fun i r ->
307
+
if i > 0 then print_string ",";
308
+
print_json_result r)
309
+
results;
310
+
print_endline "]"
311
+
end
312
+
else begin
313
+
List.iter print_result results;
314
+
ignore (bench_memory_per_subscription ())
315
+
end
316
+
317
+
let () =
318
+
let open Climate.Arg_parser in
319
+
let command =
320
+
Climate.Command.singleton ~doc:"Pubsub benchmark"
321
+
@@
322
+
let+ json = flag [ "json" ] ~doc:"Output results as JSON"
323
+
and+ subscribers =
324
+
named_with_default [ "s"; "subscribers" ] int ~default:100
325
+
~doc:"Number of subscribers"
326
+
and+ topics =
327
+
named_with_default [ "t"; "topics" ] int ~default:10
328
+
~doc:"Number of topics"
329
+
and+ messages =
330
+
named_with_default [ "n"; "messages" ] int ~default:1_000_000
331
+
~doc:"Number of messages to send"
332
+
and+ msg_size =
333
+
named_with_default [ "size" ] int ~default:64 ~doc:"Message size in bytes"
334
+
and+ memory_only = flag [ "memory" ] ~doc:"Run memory benchmark only"
335
+
and+ throughput_only =
336
+
flag [ "throughput" ] ~doc:"Run throughput benchmark only"
337
+
in
338
+
fun () ->
339
+
let config =
340
+
{
341
+
num_subscribers = subscribers;
342
+
num_topics = topics;
343
+
num_messages = messages;
344
+
message_size = msg_size;
345
+
warmup_messages = 10_000;
346
+
}
347
+
in
348
+
Eio_main.run @@ fun env ->
349
+
Printf.printf "Pubsub Benchmark\n";
350
+
Printf.printf "================\n";
351
+
Printf.printf
352
+
"Config: %d subscribers, %d topics, %d messages, %d byte msgs\n"
353
+
config.num_subscribers config.num_topics config.num_messages
354
+
config.message_size;
355
+
Printf.printf "Domains: %d\n" (Domain.recommended_domain_count ());
356
+
357
+
if memory_only then ignore (bench_memory_per_subscription ())
358
+
else if throughput_only then begin
359
+
let r = bench_single_topic_broadcast config in
360
+
if json then print_json_result r else print_result r
361
+
end
362
+
else run_all env config ~json
363
+
in
364
+
Climate.Command.run command ()
+10
bench/hcs/dune
+10
bench/hcs/dune
···
17
17
(name bench_server_unified)
18
18
(public_name bench-hcs-unified)
19
19
(libraries hcs eio_main yojson climate bigstringaf))
20
+
21
+
(executable
22
+
(name bench_pubsub)
23
+
(public_name bench-pubsub)
24
+
(libraries hcs eio_main climate unix))
25
+
26
+
(executable
27
+
(name bench_channel)
28
+
(public_name bench-channel)
29
+
(libraries hcs climate unix))
+1
hcs.opam
+1
hcs.opam
+672
test/test_plug.ml
+672
test/test_plug.ml
···
868
868
]
869
869
end
870
870
871
+
module Test_compress = struct
872
+
open Hcs.Plug.Compress
873
+
874
+
let test_gzip_roundtrip () =
875
+
let original = "Hello, this is a test string for gzip compression!" in
876
+
let compressed = gzip_compress original in
877
+
let decompressed = gzip_decompress compressed in
878
+
check string "gzip roundtrip" original decompressed
879
+
880
+
let test_zstd_roundtrip () =
881
+
let original = "Hello, this is a test string for zstd compression!" in
882
+
let compressed = zstd_compress original in
883
+
let decompressed = zstd_decompress compressed in
884
+
check string "zstd roundtrip" original decompressed
885
+
886
+
let test_gzip_compression_ratio () =
887
+
let original = String.make 1000 'a' in
888
+
let compressed = gzip_compress original in
889
+
check bool "compressed smaller" true
890
+
(String.length compressed < String.length original)
891
+
892
+
let test_zstd_compression_ratio () =
893
+
let original = String.make 1000 'a' in
894
+
let compressed = zstd_compress original in
895
+
check bool "compressed smaller" true
896
+
(String.length compressed < String.length original)
897
+
898
+
let make_request ?(headers = []) () : Hcs.Server.request =
899
+
{
900
+
meth = `GET;
901
+
target = "/";
902
+
headers;
903
+
body = "";
904
+
version = Hcs.Server.HTTP_1_1;
905
+
}
906
+
907
+
let test_parse_accept_encoding_gzip () =
908
+
let req = make_request ~headers:[ ("Accept-Encoding", "gzip") ] () in
909
+
let encodings = parse_accept_encoding req in
910
+
check bool "has gzip" true (List.exists (fun e -> e = Gzip) encodings)
911
+
912
+
let test_parse_accept_encoding_zstd () =
913
+
let req = make_request ~headers:[ ("Accept-Encoding", "zstd") ] () in
914
+
let encodings = parse_accept_encoding req in
915
+
check bool "has zstd" true (List.exists (fun e -> e = Zstd) encodings)
916
+
917
+
let test_parse_accept_encoding_multiple () =
918
+
let req =
919
+
make_request ~headers:[ ("Accept-Encoding", "gzip, zstd, br") ] ()
920
+
in
921
+
let encodings = parse_accept_encoding req in
922
+
check bool "has gzip" true (List.exists (fun e -> e = Gzip) encodings);
923
+
check bool "has zstd" true (List.exists (fun e -> e = Zstd) encodings)
924
+
925
+
let test_parse_accept_encoding_with_quality () =
926
+
let req =
927
+
make_request ~headers:[ ("Accept-Encoding", "gzip;q=0.8, zstd;q=1.0") ] ()
928
+
in
929
+
let encodings = parse_accept_encoding req in
930
+
check bool "has gzip" true (List.exists (fun e -> e = Gzip) encodings);
931
+
check bool "has zstd" true (List.exists (fun e -> e = Zstd) encodings)
932
+
933
+
let test_accepts_gzip () =
934
+
let req =
935
+
make_request ~headers:[ ("Accept-Encoding", "gzip, deflate") ] ()
936
+
in
937
+
check bool "accepts gzip" true (accepts_gzip req)
938
+
939
+
let test_accepts_zstd () =
940
+
let req = make_request ~headers:[ ("Accept-Encoding", "zstd, gzip") ] () in
941
+
check bool "accepts zstd" true (accepts_zstd req)
942
+
943
+
let test_select_encoding_prefers_zstd () =
944
+
let encodings = [ Gzip; Zstd; Identity ] in
945
+
match select_encoding encodings with
946
+
| Some Zstd -> ()
947
+
| Some Gzip -> ()
948
+
| _ -> fail "expected zstd or gzip"
949
+
950
+
let test_select_encoding_identity_stops () =
951
+
let encodings = [ Identity; Gzip; Zstd ] in
952
+
match select_encoding encodings with
953
+
| None -> ()
954
+
| Some _ -> fail "expected None after identity"
955
+
956
+
let tests =
957
+
[
958
+
test_case "gzip roundtrip" `Quick test_gzip_roundtrip;
959
+
test_case "zstd roundtrip" `Quick test_zstd_roundtrip;
960
+
test_case "gzip compression ratio" `Quick test_gzip_compression_ratio;
961
+
test_case "zstd compression ratio" `Quick test_zstd_compression_ratio;
962
+
test_case "parse accept-encoding gzip" `Quick
963
+
test_parse_accept_encoding_gzip;
964
+
test_case "parse accept-encoding zstd" `Quick
965
+
test_parse_accept_encoding_zstd;
966
+
test_case "parse accept-encoding multiple" `Quick
967
+
test_parse_accept_encoding_multiple;
968
+
test_case "parse accept-encoding with quality" `Quick
969
+
test_parse_accept_encoding_with_quality;
970
+
test_case "accepts gzip" `Quick test_accepts_gzip;
971
+
test_case "accepts zstd" `Quick test_accepts_zstd;
972
+
test_case "select encoding prefers zstd" `Quick
973
+
test_select_encoding_prefers_zstd;
974
+
test_case "select encoding identity stops" `Quick
975
+
test_select_encoding_identity_stops;
976
+
]
977
+
end
978
+
979
+
module Test_cors = struct
980
+
open Hcs.Plug.Cors
981
+
982
+
let make_request ?(headers = []) ?(meth = `GET) () : Hcs.Server.request =
983
+
{ meth; target = "/"; headers; body = ""; version = Hcs.Server.HTTP_1_1 }
984
+
985
+
let echo_handler _req = Hcs.Server.respond "ok"
986
+
987
+
let test_default_allows_all_origins () =
988
+
let cors = create () in
989
+
let req = make_request ~headers:[ ("Origin", "https://example.com") ] () in
990
+
let resp = cors echo_handler req in
991
+
let acao =
992
+
List.find_opt
993
+
(fun (n, _) -> String.lowercase_ascii n = "access-control-allow-origin")
994
+
resp.Hcs.Server.headers
995
+
|> Option.map snd
996
+
in
997
+
check (option string) "allow all" (Some "*") acao
998
+
999
+
let test_specific_origin_matching () =
1000
+
let config = { default_config with origins = [ "https://allowed.com" ] } in
1001
+
let cors = create ~config () in
1002
+
let req = make_request ~headers:[ ("Origin", "https://allowed.com") ] () in
1003
+
let resp = cors echo_handler req in
1004
+
let acao =
1005
+
List.find_opt
1006
+
(fun (n, _) -> String.lowercase_ascii n = "access-control-allow-origin")
1007
+
resp.Hcs.Server.headers
1008
+
|> Option.map snd
1009
+
in
1010
+
check (option string) "specific origin" (Some "https://allowed.com") acao
1011
+
1012
+
let test_origin_not_allowed () =
1013
+
let config = { default_config with origins = [ "https://allowed.com" ] } in
1014
+
let cors = create ~config () in
1015
+
let req =
1016
+
make_request ~headers:[ ("Origin", "https://notallowed.com") ] ()
1017
+
in
1018
+
let resp = cors echo_handler req in
1019
+
let acao =
1020
+
List.find_opt
1021
+
(fun (n, _) -> String.lowercase_ascii n = "access-control-allow-origin")
1022
+
resp.Hcs.Server.headers
1023
+
|> Option.map snd
1024
+
in
1025
+
check (option string) "no origin header" None acao
1026
+
1027
+
let test_preflight_options () =
1028
+
let cors = create () in
1029
+
let req =
1030
+
make_request ~meth:`OPTIONS
1031
+
~headers:[ ("Origin", "https://example.com") ]
1032
+
()
1033
+
in
1034
+
let resp = cors echo_handler req in
1035
+
check bool "204 status" true (resp.status = `No_content);
1036
+
let methods =
1037
+
List.find_opt
1038
+
(fun (n, _) ->
1039
+
String.lowercase_ascii n = "access-control-allow-methods")
1040
+
resp.headers
1041
+
|> Option.map snd
1042
+
in
1043
+
check bool "has methods" true (Option.is_some methods)
1044
+
1045
+
let test_credentials_header () =
1046
+
let config = { default_config with credentials = true } in
1047
+
let cors = create ~config () in
1048
+
let req = make_request ~headers:[ ("Origin", "https://example.com") ] () in
1049
+
let resp = cors echo_handler req in
1050
+
let acac =
1051
+
List.find_opt
1052
+
(fun (n, _) ->
1053
+
String.lowercase_ascii n = "access-control-allow-credentials")
1054
+
resp.Hcs.Server.headers
1055
+
|> Option.map snd
1056
+
in
1057
+
check (option string) "credentials true" (Some "true") acac
1058
+
1059
+
let test_max_age_header () =
1060
+
let config = { default_config with max_age = Some 3600 } in
1061
+
let cors = create ~config () in
1062
+
let req =
1063
+
make_request ~meth:`OPTIONS
1064
+
~headers:[ ("Origin", "https://example.com") ]
1065
+
()
1066
+
in
1067
+
let resp = cors echo_handler req in
1068
+
let max_age =
1069
+
List.find_opt
1070
+
(fun (n, _) -> String.lowercase_ascii n = "access-control-max-age")
1071
+
resp.Hcs.Server.headers
1072
+
|> Option.map snd
1073
+
in
1074
+
check (option string) "max age" (Some "3600") max_age
1075
+
1076
+
let tests =
1077
+
[
1078
+
test_case "default allows all origins" `Quick
1079
+
test_default_allows_all_origins;
1080
+
test_case "specific origin matching" `Quick test_specific_origin_matching;
1081
+
test_case "origin not allowed" `Quick test_origin_not_allowed;
1082
+
test_case "preflight OPTIONS" `Quick test_preflight_options;
1083
+
test_case "credentials header" `Quick test_credentials_header;
1084
+
test_case "max age header" `Quick test_max_age_header;
1085
+
]
1086
+
end
1087
+
1088
+
module Test_csrf = struct
1089
+
open Hcs.Plug.Csrf
1090
+
1091
+
let make_request ?(headers = []) ?(meth = `GET) ?(body = "") () :
1092
+
Hcs.Server.request =
1093
+
{ meth; target = "/"; headers; body; version = Hcs.Server.HTTP_1_1 }
1094
+
1095
+
let echo_handler _req = Hcs.Server.respond "ok"
1096
+
1097
+
let test_generate_token_format () =
1098
+
let token = generate_token () in
1099
+
check bool "non-empty" true (String.length token > 0);
1100
+
check bool "no plus" false (String.contains token '+');
1101
+
check bool "no slash" false (String.contains token '/')
1102
+
1103
+
let test_get_cookie_token () =
1104
+
let req =
1105
+
make_request ~headers:[ ("Cookie", "_csrf=abc123; other=val") ] ()
1106
+
in
1107
+
let token = get_cookie_token ~cookie_name:"_csrf" req in
1108
+
check (option string) "csrf token" (Some "abc123") token
1109
+
1110
+
let test_get_cookie_token_not_found () =
1111
+
let req = make_request ~headers:[ ("Cookie", "other=val") ] () in
1112
+
let token = get_cookie_token ~cookie_name:"_csrf" req in
1113
+
check (option string) "no token" None token
1114
+
1115
+
let test_get_header_token () =
1116
+
let req = make_request ~headers:[ ("X-CSRF-Token", "headertoken") ] () in
1117
+
let token = get_header_token ~header_name:"X-CSRF-Token" req in
1118
+
check (option string) "header token" (Some "headertoken") token
1119
+
1120
+
let test_get_form_token () =
1121
+
let req =
1122
+
make_request
1123
+
~headers:[ ("Content-Type", "application/x-www-form-urlencoded") ]
1124
+
~body:"_csrf=formtoken&other=val" ()
1125
+
in
1126
+
let token = get_form_token ~field_name:"_csrf" req in
1127
+
check (option string) "form token" (Some "formtoken") token
1128
+
1129
+
let test_safe_method_sets_cookie () =
1130
+
let csrf = create () in
1131
+
let req = make_request ~meth:`GET () in
1132
+
let resp = csrf echo_handler req in
1133
+
let has_cookie =
1134
+
List.exists
1135
+
(fun (n, _) -> String.lowercase_ascii n = "set-cookie")
1136
+
resp.Hcs.Server.headers
1137
+
in
1138
+
check bool "sets csrf cookie" true has_cookie
1139
+
1140
+
let test_safe_method_existing_cookie () =
1141
+
let csrf = create () in
1142
+
let req =
1143
+
make_request ~meth:`GET ~headers:[ ("Cookie", "_csrf=existing") ] ()
1144
+
in
1145
+
let resp = csrf echo_handler req in
1146
+
let has_new_cookie =
1147
+
List.exists
1148
+
(fun (n, _) -> String.lowercase_ascii n = "set-cookie")
1149
+
resp.Hcs.Server.headers
1150
+
in
1151
+
check bool "no new cookie" false has_new_cookie
1152
+
1153
+
let test_unsafe_method_valid_token () =
1154
+
let csrf = create () in
1155
+
let req =
1156
+
make_request ~meth:`POST
1157
+
~headers:
1158
+
[ ("Cookie", "_csrf=validtoken"); ("X-CSRF-Token", "validtoken") ]
1159
+
()
1160
+
in
1161
+
let resp = csrf echo_handler req in
1162
+
check bool "200 status" true (resp.status = `OK)
1163
+
1164
+
let test_unsafe_method_missing_token () =
1165
+
let csrf = create () in
1166
+
let req = make_request ~meth:`POST () in
1167
+
let resp = csrf echo_handler req in
1168
+
check bool "403 status" true (resp.status = `Forbidden)
1169
+
1170
+
let test_unsafe_method_mismatched_token () =
1171
+
let csrf = create () in
1172
+
let req =
1173
+
make_request ~meth:`POST
1174
+
~headers:
1175
+
[
1176
+
("Cookie", "_csrf=cookietoken"); ("X-CSRF-Token", "differenttoken");
1177
+
]
1178
+
()
1179
+
in
1180
+
let resp = csrf echo_handler req in
1181
+
check bool "403 status" true (resp.status = `Forbidden)
1182
+
1183
+
let test_is_safe_method () =
1184
+
check bool "GET is safe" true (is_safe_method `GET);
1185
+
check bool "HEAD is safe" true (is_safe_method `HEAD);
1186
+
check bool "OPTIONS is safe" true (is_safe_method `OPTIONS);
1187
+
check bool "POST not safe" false (is_safe_method `POST);
1188
+
check bool "PUT not safe" false (is_safe_method `PUT);
1189
+
check bool "DELETE not safe" false (is_safe_method `DELETE)
1190
+
1191
+
let tests =
1192
+
[
1193
+
test_case "generate token format" `Quick test_generate_token_format;
1194
+
test_case "get cookie token" `Quick test_get_cookie_token;
1195
+
test_case "get cookie token not found" `Quick
1196
+
test_get_cookie_token_not_found;
1197
+
test_case "get header token" `Quick test_get_header_token;
1198
+
test_case "get form token" `Quick test_get_form_token;
1199
+
test_case "safe method sets cookie" `Quick test_safe_method_sets_cookie;
1200
+
test_case "safe method existing cookie" `Quick
1201
+
test_safe_method_existing_cookie;
1202
+
test_case "unsafe method valid token" `Quick
1203
+
test_unsafe_method_valid_token;
1204
+
test_case "unsafe method missing token" `Quick
1205
+
test_unsafe_method_missing_token;
1206
+
test_case "unsafe method mismatched token" `Quick
1207
+
test_unsafe_method_mismatched_token;
1208
+
test_case "is safe method" `Quick test_is_safe_method;
1209
+
]
1210
+
end
1211
+
1212
+
module Test_basic_auth = struct
1213
+
open Hcs.Plug.Basic_auth
1214
+
1215
+
let make_request ?(headers = []) () : Hcs.Server.request =
1216
+
{
1217
+
meth = `GET;
1218
+
target = "/";
1219
+
headers;
1220
+
body = "";
1221
+
version = Hcs.Server.HTTP_1_1;
1222
+
}
1223
+
1224
+
let echo_handler _req = Hcs.Server.respond "ok"
1225
+
1226
+
let test_decode_valid_credentials () =
1227
+
let auth_header = "Basic dXNlcjpwYXNz" in
1228
+
match decode_credentials auth_header with
1229
+
| Some (user, pass) ->
1230
+
check string "user" "user" user;
1231
+
check string "pass" "pass" pass
1232
+
| None -> fail "expected valid credentials"
1233
+
1234
+
let test_decode_invalid_base64 () =
1235
+
let auth_header = "Basic not-valid-base64!!!" in
1236
+
check
1237
+
(option (pair string string))
1238
+
"invalid" None
1239
+
(decode_credentials auth_header)
1240
+
1241
+
let test_decode_missing_colon () =
1242
+
let auth_header = "Basic dXNlcnBhc3M=" in
1243
+
check
1244
+
(option (pair string string))
1245
+
"no colon" None
1246
+
(decode_credentials auth_header)
1247
+
1248
+
let test_decode_wrong_scheme () =
1249
+
let auth_header = "Bearer sometoken" in
1250
+
check
1251
+
(option (pair string string))
1252
+
"wrong scheme" None
1253
+
(decode_credentials auth_header)
1254
+
1255
+
let test_missing_auth_header () =
1256
+
let auth = create ~realm:"test" ~validate:(fun _ _ -> true) in
1257
+
let req = make_request () in
1258
+
let resp = auth echo_handler req in
1259
+
check bool "401 status" true (resp.status = `Unauthorized);
1260
+
let www_auth =
1261
+
List.find_opt
1262
+
(fun (n, _) -> String.lowercase_ascii n = "www-authenticate")
1263
+
resp.Hcs.Server.headers
1264
+
in
1265
+
check bool "has www-authenticate" true (Option.is_some www_auth)
1266
+
1267
+
let test_valid_credentials_pass () =
1268
+
let auth =
1269
+
create ~realm:"test" ~validate:(fun u p -> u = "admin" && p = "secret")
1270
+
in
1271
+
let req =
1272
+
make_request ~headers:[ ("Authorization", "Basic YWRtaW46c2VjcmV0") ] ()
1273
+
in
1274
+
let resp = auth echo_handler req in
1275
+
check bool "200 status" true (resp.status = `OK)
1276
+
1277
+
let test_invalid_credentials_fail () =
1278
+
let auth =
1279
+
create ~realm:"test" ~validate:(fun u p -> u = "admin" && p = "secret")
1280
+
in
1281
+
let req =
1282
+
make_request ~headers:[ ("Authorization", "Basic YWRtaW46d3Jvbmc=") ] ()
1283
+
in
1284
+
let resp = auth echo_handler req in
1285
+
check bool "401 status" true (resp.status = `Unauthorized)
1286
+
1287
+
let test_create_static () =
1288
+
let auth = create_static ~realm:"test" ~username:"user" ~password:"pass" in
1289
+
let req =
1290
+
make_request ~headers:[ ("Authorization", "Basic dXNlcjpwYXNz") ] ()
1291
+
in
1292
+
let resp = auth echo_handler req in
1293
+
check bool "200 status" true (resp.status = `OK)
1294
+
1295
+
let test_create_with_map () =
1296
+
let credentials = Hashtbl.create 2 in
1297
+
Hashtbl.add credentials "alice" "wonderland";
1298
+
Hashtbl.add credentials "bob" "builder";
1299
+
let auth = create_with_map ~realm:"test" ~credentials in
1300
+
let req_alice =
1301
+
make_request
1302
+
~headers:[ ("Authorization", "Basic YWxpY2U6d29uZGVybGFuZA==") ]
1303
+
()
1304
+
in
1305
+
let resp_alice = auth echo_handler req_alice in
1306
+
check bool "alice ok" true (resp_alice.status = `OK);
1307
+
let req_bob =
1308
+
make_request ~headers:[ ("Authorization", "Basic Ym9iOmJ1aWxkZXI=") ] ()
1309
+
in
1310
+
let resp_bob = auth echo_handler req_bob in
1311
+
check bool "bob ok" true (resp_bob.status = `OK)
1312
+
1313
+
let tests =
1314
+
[
1315
+
test_case "decode valid credentials" `Quick test_decode_valid_credentials;
1316
+
test_case "decode invalid base64" `Quick test_decode_invalid_base64;
1317
+
test_case "decode missing colon" `Quick test_decode_missing_colon;
1318
+
test_case "decode wrong scheme" `Quick test_decode_wrong_scheme;
1319
+
test_case "missing auth header" `Quick test_missing_auth_header;
1320
+
test_case "valid credentials pass" `Quick test_valid_credentials_pass;
1321
+
test_case "invalid credentials fail" `Quick test_invalid_credentials_fail;
1322
+
test_case "create static" `Quick test_create_static;
1323
+
test_case "create with map" `Quick test_create_with_map;
1324
+
]
1325
+
end
1326
+
1327
+
module Test_retry = struct
1328
+
open Hcs.Plug.Retry
1329
+
1330
+
let test_backoff_constant () =
1331
+
let backoff = Backoff.constant 1.0 in
1332
+
check (float 0.001) "attempt 0" 1.0 (backoff 0);
1333
+
check (float 0.001) "attempt 1" 1.0 (backoff 1);
1334
+
check (float 0.001) "attempt 5" 1.0 (backoff 5)
1335
+
1336
+
let test_backoff_exponential () =
1337
+
let backoff = Backoff.exponential ~base:1.0 in
1338
+
check (float 0.001) "attempt 0" 1.0 (backoff 0);
1339
+
check (float 0.001) "attempt 1" 2.0 (backoff 1);
1340
+
check (float 0.001) "attempt 2" 4.0 (backoff 2);
1341
+
check (float 0.001) "attempt 3" 8.0 (backoff 3)
1342
+
1343
+
let test_backoff_linear () =
1344
+
let backoff = Backoff.linear ~base:1.0 in
1345
+
check (float 0.001) "attempt 0" 1.0 (backoff 0);
1346
+
check (float 0.001) "attempt 1" 2.0 (backoff 1);
1347
+
check (float 0.001) "attempt 2" 3.0 (backoff 2);
1348
+
check (float 0.001) "attempt 3" 4.0 (backoff 3)
1349
+
1350
+
let test_backoff_capped () =
1351
+
let backoff =
1352
+
Backoff.capped ~max_delay:5.0 (Backoff.exponential ~base:1.0)
1353
+
in
1354
+
check (float 0.001) "attempt 0" 1.0 (backoff 0);
1355
+
check (float 0.001) "attempt 1" 2.0 (backoff 1);
1356
+
check (float 0.001) "attempt 2" 4.0 (backoff 2);
1357
+
check (float 0.001) "attempt 3 capped" 5.0 (backoff 3);
1358
+
check (float 0.001) "attempt 10 capped" 5.0 (backoff 10)
1359
+
1360
+
let tests env =
1361
+
let make_request ?(meth = `GET) () : Hcs.Server.request =
1362
+
{
1363
+
meth;
1364
+
target = "/";
1365
+
headers = [];
1366
+
body = "";
1367
+
version = Hcs.Server.HTTP_1_1;
1368
+
}
1369
+
in
1370
+
let clock = Eio.Stdenv.clock env in
1371
+
[
1372
+
test_case "backoff constant" `Quick test_backoff_constant;
1373
+
test_case "backoff exponential" `Quick test_backoff_exponential;
1374
+
test_case "backoff linear" `Quick test_backoff_linear;
1375
+
test_case "backoff capped" `Quick test_backoff_capped;
1376
+
test_case "retries on 5xx" `Quick (fun () ->
1377
+
let attempts = ref 0 in
1378
+
let handler _req =
1379
+
incr attempts;
1380
+
if !attempts < 3 then
1381
+
{
1382
+
Hcs.Server.status = `Internal_server_error;
1383
+
headers = [];
1384
+
body = Hcs.Server.Body_empty;
1385
+
}
1386
+
else Hcs.Server.respond "ok"
1387
+
in
1388
+
let config =
1389
+
{
1390
+
max_attempts = 5;
1391
+
backoff = Backoff.constant 0.001;
1392
+
should_retry = (fun _ -> true);
1393
+
}
1394
+
in
1395
+
let retry = create ~clock ~config () in
1396
+
let resp = retry handler (make_request ()) in
1397
+
check bool "success" true (resp.status = `OK);
1398
+
check int "3 attempts" 3 !attempts);
1399
+
test_case "stops at max attempts" `Quick (fun () ->
1400
+
let attempts = ref 0 in
1401
+
let handler _req =
1402
+
incr attempts;
1403
+
{
1404
+
Hcs.Server.status = `Internal_server_error;
1405
+
headers = [];
1406
+
body = Hcs.Server.Body_empty;
1407
+
}
1408
+
in
1409
+
let config =
1410
+
{
1411
+
max_attempts = 3;
1412
+
backoff = Backoff.constant 0.001;
1413
+
should_retry = (fun _ -> true);
1414
+
}
1415
+
in
1416
+
let retry = create ~clock ~config () in
1417
+
let resp = retry handler (make_request ()) in
1418
+
check bool "still 500" true (H1.Status.to_code resp.status >= 500);
1419
+
check int "4 attempts" 4 !attempts);
1420
+
test_case "no retry on success" `Quick (fun () ->
1421
+
let attempts = ref 0 in
1422
+
let handler _req =
1423
+
incr attempts;
1424
+
Hcs.Server.respond "ok"
1425
+
in
1426
+
let retry = create ~clock () in
1427
+
let _ = retry handler (make_request ()) in
1428
+
check int "1 attempt" 1 !attempts);
1429
+
test_case "no retry for POST" `Quick (fun () ->
1430
+
let attempts = ref 0 in
1431
+
let handler _req =
1432
+
incr attempts;
1433
+
{
1434
+
Hcs.Server.status = `Internal_server_error;
1435
+
headers = [];
1436
+
body = Hcs.Server.Body_empty;
1437
+
}
1438
+
in
1439
+
let retry = create ~clock () in
1440
+
let _ = retry handler (make_request ~meth:`POST ()) in
1441
+
check int "1 attempt for POST" 1 !attempts);
1442
+
]
1443
+
end
1444
+
1445
+
module Test_static = struct
1446
+
open Hcs.Plug.Static
1447
+
1448
+
let test_normalize_path_simple () =
1449
+
match normalize_path "/foo/bar" with
1450
+
| Some p -> check string "simple path" "foo/bar" p
1451
+
| None -> fail "expected valid path"
1452
+
1453
+
let test_normalize_path_removes_dots () =
1454
+
match normalize_path "/foo/./bar" with
1455
+
| Some p -> check string "removes dot" "foo/bar" p
1456
+
| None -> fail "expected valid path"
1457
+
1458
+
let test_normalize_path_blocks_traversal () =
1459
+
match normalize_path "/foo/../bar" with
1460
+
| Some _ -> fail "should block traversal"
1461
+
| None -> ()
1462
+
1463
+
let test_normalize_path_strips_query () =
1464
+
match normalize_path "/foo?query=1" with
1465
+
| Some p -> check string "strips query" "foo" p
1466
+
| None -> fail "expected valid path"
1467
+
1468
+
let test_normalize_path_strips_fragment () =
1469
+
match normalize_path "/foo#section" with
1470
+
| Some p -> check string "strips fragment" "foo" p
1471
+
| None -> fail "expected valid path"
1472
+
1473
+
let test_normalize_path_blocks_null () =
1474
+
match normalize_path "/foo\x00bar" with
1475
+
| Some _ -> fail "should block null"
1476
+
| None -> ()
1477
+
1478
+
let test_mime_type_html () =
1479
+
check string "html" "text/html; charset=utf-8"
1480
+
(mime_type_of_extension ".html")
1481
+
1482
+
let test_mime_type_css () =
1483
+
check string "css" "text/css; charset=utf-8" (mime_type_of_extension ".css")
1484
+
1485
+
let test_mime_type_js () =
1486
+
check string "js" "application/javascript; charset=utf-8"
1487
+
(mime_type_of_extension ".js")
1488
+
1489
+
let test_mime_type_json () =
1490
+
check string "json" "application/json" (mime_type_of_extension ".json")
1491
+
1492
+
let test_mime_type_png () =
1493
+
check string "png" "image/png" (mime_type_of_extension ".png")
1494
+
1495
+
let test_mime_type_unknown () =
1496
+
check string "unknown" "application/octet-stream"
1497
+
(mime_type_of_extension ".xyz")
1498
+
1499
+
let test_html_escape () =
1500
+
check string "escapes" "<script>&""
1501
+
(html_escape "<script>&\"")
1502
+
1503
+
let test_generate_etag () =
1504
+
let etag = generate_etag "hello world" in
1505
+
check bool "starts with quote" true
1506
+
(String.length etag > 0 && etag.[0] = '"');
1507
+
check bool "ends with quote" true (etag.[String.length etag - 1] = '"');
1508
+
let etag2 = generate_etag "hello world" in
1509
+
check string "deterministic" etag etag2;
1510
+
let etag3 = generate_etag "hello world!" in
1511
+
check bool "different content" true (etag <> etag3)
1512
+
1513
+
let tests =
1514
+
[
1515
+
test_case "normalize path simple" `Quick test_normalize_path_simple;
1516
+
test_case "normalize path removes dots" `Quick
1517
+
test_normalize_path_removes_dots;
1518
+
test_case "normalize path blocks traversal" `Quick
1519
+
test_normalize_path_blocks_traversal;
1520
+
test_case "normalize path strips query" `Quick
1521
+
test_normalize_path_strips_query;
1522
+
test_case "normalize path strips fragment" `Quick
1523
+
test_normalize_path_strips_fragment;
1524
+
test_case "normalize path blocks null" `Quick
1525
+
test_normalize_path_blocks_null;
1526
+
test_case "mime type html" `Quick test_mime_type_html;
1527
+
test_case "mime type css" `Quick test_mime_type_css;
1528
+
test_case "mime type js" `Quick test_mime_type_js;
1529
+
test_case "mime type json" `Quick test_mime_type_json;
1530
+
test_case "mime type png" `Quick test_mime_type_png;
1531
+
test_case "mime type unknown" `Quick test_mime_type_unknown;
1532
+
test_case "html escape" `Quick test_html_escape;
1533
+
test_case "generate etag" `Quick test_generate_etag;
1534
+
]
1535
+
end
1536
+
871
1537
let () =
872
1538
Mirage_crypto_rng_unix.use_default ();
873
1539
Eio_main.run @@ fun env ->
···
880
1546
("Rate_limit", Test_rate_limit.tests env);
881
1547
("Circuit_breaker", Test_circuit_breaker.tests env);
882
1548
("Session", Test_session.tests);
1549
+
("Compress", Test_compress.tests);
1550
+
("Cors", Test_cors.tests);
1551
+
("Csrf", Test_csrf.tests);
1552
+
("Basic_auth", Test_basic_auth.tests);
1553
+
("Retry", Test_retry.tests env);
1554
+
("Static", Test_static.tests);
883
1555
]