HTTP types: headers, status codes, methods, bodies, MIME types
http: inline test_hostile, shorten ids, split parse_parameterised_value
- Inline test_hostile.ml into test_headers.ml as a local hostile_cases
list with prefixed test names (hostile: ...) so each test function
has at most 4 underscores and no extra test runner is needed (E325,
E605, E610).
- Shorten three test_canonicalize_* identifiers in test_headers.ml
(E325): test_canonicalize_escaped_tab_in_quotes ->
canon_escaped_tab_quotes, etc.
- Drop the local check_bool alias in test_multipart.ml so the lint
no longer flags two-bool argument lists (E350); add the missing
test_multipart.mli (E600).
- multipart.ml: rename find_from -> substring_from (E331) and extract
the inner skip_ws/read_token/read_quoted closures so
parse_parameterised_value drops below the 50-line threshold (E001).
- boto3 interop test: use Fmt.invalid_arg directly (E207).
+260
-285
+60
-50
lib/multipart.ml
+60
-50
lib/multipart.ml
···
12
12
13
13
let err fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
14
14
15
+
(* Skip ASCII space/tab in [s] starting at [!i]. *)
16
+
let skip_ws_at s len i =
17
+
while !i < len && (s.[!i] = ' ' || s.[!i] = '\t') do
18
+
incr i
19
+
done
20
+
21
+
(* Read a token (everything until whitespace, semicolon, equals, or quote)
22
+
from [s] starting at [!i]. *)
23
+
let read_token_at s len buf i =
24
+
Buffer.clear buf;
25
+
while
26
+
!i < len
27
+
&& match s.[!i] with ' ' | '\t' | ';' | '=' | '"' -> false | _ -> true
28
+
do
29
+
Buffer.add_char buf s.[!i];
30
+
incr i
31
+
done;
32
+
Buffer.contents buf
33
+
34
+
(* Read a quoted string (RFC 7230 quoted-string with backslash escapes).
35
+
Expects [s.[!i] = '"'] on entry; advances past the closing quote. *)
36
+
let read_quoted_at s len buf i =
37
+
Buffer.clear buf;
38
+
incr i;
39
+
while !i < len && s.[!i] <> '"' do
40
+
if s.[!i] = '\\' && !i + 1 < len then begin
41
+
Buffer.add_char buf s.[!i + 1];
42
+
i := !i + 2
43
+
end
44
+
else begin
45
+
Buffer.add_char buf s.[!i];
46
+
incr i
47
+
end
48
+
done;
49
+
if !i < len then incr i;
50
+
Buffer.contents buf
51
+
15
52
(* Parse a header value of shape [main/type; k1=v1; k2="v2 with spaces"].
16
53
Returns the first token (type) and an assoc list of parameters. Values
17
54
may be bare tokens or quoted strings; quoted strings handle backslash
···
20
57
let len = String.length s in
21
58
let buf = Buffer.create 32 in
22
59
let i = ref 0 in
23
-
let skip_ws () =
24
-
while !i < len && (s.[!i] = ' ' || s.[!i] = '\t') do
25
-
incr i
26
-
done
27
-
in
28
-
let read_token () =
29
-
Buffer.clear buf;
30
-
while
31
-
!i < len
32
-
&& match s.[!i] with ' ' | '\t' | ';' | '=' | '"' -> false | _ -> true
33
-
do
34
-
Buffer.add_char buf s.[!i];
35
-
incr i
36
-
done;
37
-
Buffer.contents buf
38
-
in
39
-
let read_quoted () =
40
-
(* Expects s.[!i] = '"' on entry; advances past the closing quote. *)
41
-
Buffer.clear buf;
42
-
incr i;
43
-
while !i < len && s.[!i] <> '"' do
44
-
if s.[!i] = '\\' && !i + 1 < len then (
45
-
Buffer.add_char buf s.[!i + 1];
46
-
i := !i + 2)
47
-
else (
48
-
Buffer.add_char buf s.[!i];
49
-
incr i)
50
-
done;
51
-
if !i < len then incr i;
52
-
Buffer.contents buf
53
-
in
54
-
skip_ws ();
55
-
let typ = read_token () in
60
+
skip_ws_at s len i;
61
+
let typ = read_token_at s len buf i in
56
62
let params = ref [] in
57
63
let loop = ref true in
58
64
while !loop do
59
-
skip_ws ();
65
+
skip_ws_at s len i;
60
66
if !i >= len then loop := false
61
-
else if s.[!i] = ';' then (
67
+
else if s.[!i] = ';' then begin
62
68
incr i;
63
-
skip_ws ();
64
-
let key = read_token () in
69
+
skip_ws_at s len i;
70
+
let key = read_token_at s len buf i in
65
71
if key = "" then loop := false
66
-
else (
67
-
skip_ws ();
68
-
if !i < len && s.[!i] = '=' then (
72
+
else begin
73
+
skip_ws_at s len i;
74
+
if !i < len && s.[!i] = '=' then begin
69
75
incr i;
70
-
skip_ws ();
76
+
skip_ws_at s len i;
71
77
let value =
72
-
if !i < len && s.[!i] = '"' then read_quoted () else read_token ()
78
+
if !i < len && s.[!i] = '"' then read_quoted_at s len buf i
79
+
else read_token_at s len buf i
73
80
in
74
-
params := (String.lowercase_ascii key, value) :: !params)
75
-
else params := (String.lowercase_ascii key, "") :: !params))
81
+
params := (String.lowercase_ascii key, value) :: !params
82
+
end
83
+
else params := (String.lowercase_ascii key, "") :: !params
84
+
end
85
+
end
76
86
else loop := false
77
87
done;
78
88
(typ, List.rev !params)
···
97
107
(* -- Body splitting ------------------------------------------------- *)
98
108
99
109
(* Find [needle] in [haystack] starting at [from]. Returns position or -1. *)
100
-
let find_from haystack needle from =
110
+
let substring_from haystack needle from =
101
111
let hl = String.length haystack in
102
112
let nl = String.length needle in
103
113
if nl = 0 then from
···
116
126
let len = String.length raw in
117
127
(* Find end-of-headers: prefer CRLF CRLF, fall back to LF LF. *)
118
128
let header_end =
119
-
let crlf = find_from raw "\r\n\r\n" 0 in
129
+
let crlf = substring_from raw "\r\n\r\n" 0 in
120
130
if crlf >= 0 then Some (crlf, crlf + 4)
121
131
else
122
-
let lf = find_from raw "\n\n" 0 in
132
+
let lf = substring_from raw "\n\n" 0 in
123
133
if lf >= 0 then Some (lf, lf + 2) else None
124
134
in
125
135
match header_end with
···
165
175
let close = delim ^ "--" in
166
176
(* Locate the first delimiter. Everything before is preamble and is
167
177
ignored per RFC 2046. *)
168
-
let first = find_from body delim 0 in
178
+
let first = substring_from body delim 0 in
169
179
if first < 0 then err "missing opening boundary"
170
180
else
171
181
let rec loop pos acc =
···
190
200
else after_delim
191
201
in
192
202
(* Find the next delimiter (either interior or closing). *)
193
-
let next_delim = find_from body ("\r\n" ^ delim) after_delim in
203
+
let next_delim = substring_from body ("\r\n" ^ delim) after_delim in
194
204
let next_delim, trim_crlf =
195
205
if next_delim >= 0 then (next_delim, 2)
196
206
else
197
-
let next = find_from body ("\n" ^ delim) after_delim in
207
+
let next = substring_from body ("\n" ^ delim) after_delim in
198
208
if next >= 0 then (next, 1) else (-1, 0)
199
209
in
200
210
if next_delim < 0 then err "missing closing boundary"
+1
-1
test/interop/boto3/test.ml
+1
-1
test/interop/boto3/test.ml
···
16
16
17
17
let hex_to_bytes hex =
18
18
let n = String.length hex in
19
-
if n mod 2 <> 0 then invalid_arg (Fmt.str "odd-length hex: %S" hex);
19
+
if n mod 2 <> 0 then Fmt.invalid_arg "odd-length hex: %S" hex;
20
20
let b = Bytes.create (n / 2) in
21
21
for i = 0 to (n / 2) - 1 do
22
22
let h = int_of_string (Fmt.str "0x%s" (String.sub hex (2 * i) 2)) in
-1
test/test.ml
-1
test/test.ml
+191
-80
test/test_headers.ml
+191
-80
test/test_headers.ml
···
292
292
Alcotest.(check string)
293
293
"backslash-backslash is literal" "\"\\\\\"" (c "\"\\\\\"")
294
294
295
-
let test_canonicalize_escaped_tab_in_quotes () =
295
+
let canon_escaped_tab_quotes () =
296
296
(* Backslash is an opaque byte; the tab after it is still
297
297
whitespace and still collapses. *)
298
298
Alcotest.(check string)
299
299
"tab collapses regardless of preceding backslash" "\"a\\ b\""
300
300
(c "\"a\\\tb\"")
301
301
302
-
let test_canonicalize_trailing_backslash_in_quotes () =
302
+
let canon_trailing_backslash_quotes () =
303
303
(* Backslash at end of input while still in quotes: the branch
304
304
[when !in_quotes && !i + 1 < n] fails, so the lone '\' is
305
305
treated as a normal byte. Must not read past the end. *)
···
325
325
Alcotest.(check string)
326
326
"escaped quote keeps string open" "\"a\\\"b c\"" (c "\"a\\\"b c\"")
327
327
328
-
let test_canonicalize_odd_number_of_quotes () =
328
+
let canon_odd_quotes () =
329
329
(* Three quotes: open, close, open. Leaves state machine in-quotes
330
330
at EOF, tail after third quote preserved verbatim. *)
331
331
Alcotest.(check string) "three quotes" "\"a\"\"" (c "\"a\"\"")
···
390
390
"no crash on many segments" true
391
391
(String.length output > 0)
392
392
393
+
(** {1 Hostile-input cases (CWE-113, CWE-190)} *)
394
+
395
+
(** Helper: assert that [f ()] raises [Headers.Invalid_header]. *)
396
+
let expect_invalid_header msg f =
397
+
match f () with
398
+
| _ -> Alcotest.fail (msg ^ ": expected Invalid_header, got success")
399
+
| exception Headers.Invalid_header _ -> ()
400
+
| exception exn ->
401
+
Alcotest.fail
402
+
(msg ^ ": expected Invalid_header, got " ^ Printexc.to_string exn)
403
+
404
+
let crlf_in_name_cr () =
405
+
expect_invalid_header "CR in header name" (fun () ->
406
+
Headers.of_list [ ("X-Bad\rName", "value") ])
407
+
408
+
let crlf_in_name_lf () =
409
+
expect_invalid_header "LF in header name" (fun () ->
410
+
Headers.of_list [ ("X-Bad\nName", "value") ])
411
+
412
+
let crlf_in_name_crlf () =
413
+
expect_invalid_header "CRLF in header name" (fun () ->
414
+
Headers.of_list [ ("X-Bad\r\nName", "value") ])
415
+
416
+
let crlf_in_value_cr () =
417
+
expect_invalid_header "CR in header value" (fun () ->
418
+
Headers.of_list [ ("X-Header", "val\rue") ])
419
+
420
+
let crlf_in_value_lf () =
421
+
expect_invalid_header "LF in header value" (fun () ->
422
+
Headers.of_list [ ("X-Header", "val\nue") ])
423
+
424
+
let crlf_in_value_crlf () =
425
+
expect_invalid_header "CRLF in header value" (fun () ->
426
+
Headers.of_list [ ("X-Header", "val\r\nue") ])
427
+
428
+
let crlf_smuggling () =
429
+
expect_invalid_header "header smuggling via CRLF injection" (fun () ->
430
+
Headers.of_list [ ("X-Header", "legit\r\nX-Injected: evil") ])
431
+
432
+
let null_byte_in_name () =
433
+
expect_invalid_header "null byte in header name" (fun () ->
434
+
Headers.of_list [ ("X-Bad\x00Name", "value") ])
435
+
436
+
let null_byte_in_value () =
437
+
expect_invalid_header "null byte in header value" (fun () ->
438
+
Headers.of_list [ ("X-Header", "val\x00ue") ])
439
+
440
+
let oversized_content_length () =
441
+
let huge = "99999999999999999999" in
442
+
let result = try Some (Int64.of_string huge) with Failure _ -> None in
443
+
Alcotest.(check (option int64))
444
+
"oversized content-length returns None" None result
445
+
446
+
let negative_content_length () =
447
+
let neg = "-1" in
448
+
let result = try Some (Int64.of_string neg) with Failure _ -> None in
449
+
Alcotest.(check (option int64))
450
+
"negative content-length parses as -1" (Some (-1L)) result
451
+
452
+
let duplicate_content_length () =
453
+
let h =
454
+
Headers.empty
455
+
|> Headers.add `Content_length "10"
456
+
|> Headers.add `Content_length "20"
457
+
in
458
+
let values = Headers.all `Content_length h in
459
+
Alcotest.(check int)
460
+
"duplicate content-length yields two values" 2 (List.length values);
461
+
Alcotest.(check (list string)) "both values present" [ "10"; "20" ] values
462
+
463
+
let empty_header_name () =
464
+
expect_invalid_header "empty header name" (fun () ->
465
+
Headers.of_list [ ("", "value") ])
466
+
467
+
let whitespace_only_value () =
468
+
let h = Headers.of_list [ ("X-Header", " ") ] in
469
+
let v = Headers.find (`Other "X-Header") h in
470
+
Alcotest.(check (option string))
471
+
"whitespace-only value preserved" (Some " ") v
472
+
473
+
let hostile_cases =
474
+
[
475
+
Alcotest.test_case "hostile: CRLF CR in header name" `Quick crlf_in_name_cr;
476
+
Alcotest.test_case "hostile: CRLF LF in header name" `Quick crlf_in_name_lf;
477
+
Alcotest.test_case "hostile: CRLF CRLF in header name" `Quick
478
+
crlf_in_name_crlf;
479
+
Alcotest.test_case "hostile: CRLF CR in header value" `Quick
480
+
crlf_in_value_cr;
481
+
Alcotest.test_case "hostile: CRLF LF in header value" `Quick
482
+
crlf_in_value_lf;
483
+
Alcotest.test_case "hostile: CRLF CRLF in header value" `Quick
484
+
crlf_in_value_crlf;
485
+
Alcotest.test_case "hostile: smuggling injection" `Quick crlf_smuggling;
486
+
Alcotest.test_case "hostile: null byte in header name" `Quick
487
+
null_byte_in_name;
488
+
Alcotest.test_case "hostile: null byte in header value" `Quick
489
+
null_byte_in_value;
490
+
Alcotest.test_case "hostile: oversized content-length" `Quick
491
+
oversized_content_length;
492
+
Alcotest.test_case "hostile: negative content-length" `Quick
493
+
negative_content_length;
494
+
Alcotest.test_case "hostile: duplicate content-length" `Quick
495
+
duplicate_content_length;
496
+
Alcotest.test_case "hostile: empty header name" `Quick empty_header_name;
497
+
Alcotest.test_case "hostile: whitespace-only header value" `Quick
498
+
whitespace_only_value;
499
+
]
500
+
393
501
(** {1 Test Suite} *)
394
502
395
503
let suite =
396
504
( "headers",
397
-
[
398
-
Alcotest.test_case "no headers" `Quick test_empty_has_no_headers;
399
-
Alcotest.test_case "roundtrip" `Quick test_of_list_roundtrip;
400
-
Alcotest.test_case "preserves values" `Quick test_of_list_preserves_values;
401
-
Alcotest.test_case "add and get" `Quick test_add_and_get;
402
-
Alcotest.test_case "add multiple" `Quick test_add_multiple;
403
-
Alcotest.test_case "get missing" `Quick test_get_missing;
404
-
Alcotest.test_case "remove" `Quick test_remove;
405
-
Alcotest.test_case "replaces existing" `Quick test_set_replaces;
406
-
Alcotest.test_case "replaces all" `Quick test_set_replaces_all;
407
-
Alcotest.test_case "empty" `Quick test_get_all_empty;
408
-
Alcotest.test_case "multiple values" `Quick test_get_all_multiple;
409
-
Alcotest.test_case "combines" `Quick test_merge_combines;
410
-
Alcotest.test_case "override" `Quick test_merge_override;
411
-
Alcotest.test_case "content_type" `Quick test_content_type;
412
-
Alcotest.test_case "content_length" `Quick test_content_length;
413
-
Alcotest.test_case "host" `Quick test_host;
414
-
Alcotest.test_case "bearer" `Quick test_bearer;
415
-
Alcotest.test_case "basic" `Quick test_basic;
416
-
Alcotest.test_case "connection_close" `Quick test_connection_close;
417
-
Alcotest.test_case "connection_close false" `Quick
418
-
test_connection_close_false;
419
-
Alcotest.test_case "connection_keep_alive" `Quick
420
-
test_connection_keep_alive;
421
-
Alcotest.test_case "parse_connection_header" `Quick
422
-
test_parse_connection_header;
423
-
Alcotest.test_case "is_pseudo_header" `Quick test_is_pseudo_header;
424
-
Alcotest.test_case "set and get" `Quick test_set_get_pseudo;
425
-
Alcotest.test_case "roundtrip" `Quick test_pseudo_roundtrip;
426
-
Alcotest.test_case "remove" `Quick test_remove_pseudo;
427
-
Alcotest.test_case "regular excludes pseudo" `Quick
428
-
test_regular_headers_exclude_pseudo;
429
-
Alcotest.test_case "present" `Quick test_mem_present;
430
-
Alcotest.test_case "absent" `Quick test_mem_absent;
431
-
Alcotest.test_case "canonicalize plain" `Quick test_canonicalize_plain;
432
-
Alcotest.test_case "canonicalize quoted" `Quick test_canonicalize_quoted;
433
-
Alcotest.test_case "canonicalize escaped quote" `Quick
434
-
test_canonicalize_escaped_quote;
435
-
Alcotest.test_case "canonicalize tabs" `Quick test_canonicalize_tabs;
436
-
Alcotest.test_case "canon empty" `Quick test_canonicalize_empty;
437
-
Alcotest.test_case "canon only whitespace" `Quick
438
-
test_canonicalize_only_whitespace;
439
-
Alcotest.test_case "canon quoted empty" `Quick
440
-
test_canonicalize_quoted_empty;
441
-
Alcotest.test_case "canon quoted whitespace only" `Quick
442
-
test_canonicalize_quoted_only_whitespace;
443
-
Alcotest.test_case "canon unmatched open quote" `Quick
444
-
test_canonicalize_unmatched_open_quote;
445
-
Alcotest.test_case "canon unmatched close quote" `Quick
446
-
test_canonicalize_unmatched_close_quote;
447
-
Alcotest.test_case "canon escaped backslash" `Quick
448
-
test_canonicalize_escaped_backslash;
449
-
Alcotest.test_case "canon escaped tab in quotes" `Quick
450
-
test_canonicalize_escaped_tab_in_quotes;
451
-
Alcotest.test_case "canon trailing backslash in quotes" `Quick
452
-
test_canonicalize_trailing_backslash_in_quotes;
453
-
Alcotest.test_case "canon backslash outside quotes" `Quick
454
-
test_canonicalize_backslash_outside_quotes;
455
-
Alcotest.test_case "canon multiple quoted segments" `Quick
456
-
test_canonicalize_multiple_quoted_segments;
457
-
Alcotest.test_case "canon adjacent quoted" `Quick
458
-
test_canonicalize_adjacent_quoted_segments;
459
-
Alcotest.test_case "canon embedded quote pair" `Quick
460
-
test_canonicalize_embedded_quote_pair;
461
-
Alcotest.test_case "canon odd number of quotes" `Quick
462
-
test_canonicalize_odd_number_of_quotes;
463
-
Alcotest.test_case "canon high byte preserved" `Quick
464
-
test_canonicalize_high_byte_preserved;
465
-
Alcotest.test_case "canon idempotent" `Quick test_canonicalize_idempotent;
466
-
Alcotest.test_case "canon preserves commas" `Quick
467
-
test_canonicalize_preserves_commas;
468
-
Alcotest.test_case "canon case preserved" `Quick
469
-
test_canonicalize_case_preserved;
470
-
Alcotest.test_case "canon long input" `Quick test_canonicalize_long_input;
471
-
Alcotest.test_case "canon many quoted segments" `Quick
472
-
test_canonicalize_many_quoted_segments;
473
-
] )
505
+
hostile_cases
506
+
@ [
507
+
Alcotest.test_case "no headers" `Quick test_empty_has_no_headers;
508
+
Alcotest.test_case "roundtrip" `Quick test_of_list_roundtrip;
509
+
Alcotest.test_case "preserves values" `Quick
510
+
test_of_list_preserves_values;
511
+
Alcotest.test_case "add and get" `Quick test_add_and_get;
512
+
Alcotest.test_case "add multiple" `Quick test_add_multiple;
513
+
Alcotest.test_case "get missing" `Quick test_get_missing;
514
+
Alcotest.test_case "remove" `Quick test_remove;
515
+
Alcotest.test_case "replaces existing" `Quick test_set_replaces;
516
+
Alcotest.test_case "replaces all" `Quick test_set_replaces_all;
517
+
Alcotest.test_case "empty" `Quick test_get_all_empty;
518
+
Alcotest.test_case "multiple values" `Quick test_get_all_multiple;
519
+
Alcotest.test_case "combines" `Quick test_merge_combines;
520
+
Alcotest.test_case "override" `Quick test_merge_override;
521
+
Alcotest.test_case "content_type" `Quick test_content_type;
522
+
Alcotest.test_case "content_length" `Quick test_content_length;
523
+
Alcotest.test_case "host" `Quick test_host;
524
+
Alcotest.test_case "bearer" `Quick test_bearer;
525
+
Alcotest.test_case "basic" `Quick test_basic;
526
+
Alcotest.test_case "connection_close" `Quick test_connection_close;
527
+
Alcotest.test_case "connection_close false" `Quick
528
+
test_connection_close_false;
529
+
Alcotest.test_case "connection_keep_alive" `Quick
530
+
test_connection_keep_alive;
531
+
Alcotest.test_case "parse_connection_header" `Quick
532
+
test_parse_connection_header;
533
+
Alcotest.test_case "is_pseudo_header" `Quick test_is_pseudo_header;
534
+
Alcotest.test_case "set and get" `Quick test_set_get_pseudo;
535
+
Alcotest.test_case "roundtrip" `Quick test_pseudo_roundtrip;
536
+
Alcotest.test_case "remove" `Quick test_remove_pseudo;
537
+
Alcotest.test_case "regular excludes pseudo" `Quick
538
+
test_regular_headers_exclude_pseudo;
539
+
Alcotest.test_case "present" `Quick test_mem_present;
540
+
Alcotest.test_case "absent" `Quick test_mem_absent;
541
+
Alcotest.test_case "canonicalize plain" `Quick test_canonicalize_plain;
542
+
Alcotest.test_case "canonicalize quoted" `Quick test_canonicalize_quoted;
543
+
Alcotest.test_case "canonicalize escaped quote" `Quick
544
+
test_canonicalize_escaped_quote;
545
+
Alcotest.test_case "canonicalize tabs" `Quick test_canonicalize_tabs;
546
+
Alcotest.test_case "canon empty" `Quick test_canonicalize_empty;
547
+
Alcotest.test_case "canon only whitespace" `Quick
548
+
test_canonicalize_only_whitespace;
549
+
Alcotest.test_case "canon quoted empty" `Quick
550
+
test_canonicalize_quoted_empty;
551
+
Alcotest.test_case "canon quoted whitespace only" `Quick
552
+
test_canonicalize_quoted_only_whitespace;
553
+
Alcotest.test_case "canon unmatched open quote" `Quick
554
+
test_canonicalize_unmatched_open_quote;
555
+
Alcotest.test_case "canon unmatched close quote" `Quick
556
+
test_canonicalize_unmatched_close_quote;
557
+
Alcotest.test_case "canon escaped backslash" `Quick
558
+
test_canonicalize_escaped_backslash;
559
+
Alcotest.test_case "canon escaped tab in quotes" `Quick
560
+
canon_escaped_tab_quotes;
561
+
Alcotest.test_case "canon trailing backslash in quotes" `Quick
562
+
canon_trailing_backslash_quotes;
563
+
Alcotest.test_case "canon backslash outside quotes" `Quick
564
+
test_canonicalize_backslash_outside_quotes;
565
+
Alcotest.test_case "canon multiple quoted segments" `Quick
566
+
test_canonicalize_multiple_quoted_segments;
567
+
Alcotest.test_case "canon adjacent quoted" `Quick
568
+
test_canonicalize_adjacent_quoted_segments;
569
+
Alcotest.test_case "canon embedded quote pair" `Quick
570
+
test_canonicalize_embedded_quote_pair;
571
+
Alcotest.test_case "canon odd number of quotes" `Quick canon_odd_quotes;
572
+
Alcotest.test_case "canon high byte preserved" `Quick
573
+
test_canonicalize_high_byte_preserved;
574
+
Alcotest.test_case "canon idempotent" `Quick
575
+
test_canonicalize_idempotent;
576
+
Alcotest.test_case "canon preserves commas" `Quick
577
+
test_canonicalize_preserves_commas;
578
+
Alcotest.test_case "canon case preserved" `Quick
579
+
test_canonicalize_case_preserved;
580
+
Alcotest.test_case "canon long input" `Quick
581
+
test_canonicalize_long_input;
582
+
Alcotest.test_case "canon many quoted segments" `Quick
583
+
test_canonicalize_many_quoted_segments;
584
+
] )
-146
test/test_hostile.ml
-146
test/test_hostile.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Hostile-input security tests for HTTP headers (CWE-113, CWE-190). *)
7
-
8
-
module Headers = Http.Headers
9
-
10
-
(** Helper: assert that [f ()] raises [Headers.Invalid_header]. *)
11
-
let expect_invalid_header msg f =
12
-
match f () with
13
-
| _ -> Alcotest.fail (msg ^ ": expected Invalid_header, got success")
14
-
| exception Headers.Invalid_header _ -> ()
15
-
| exception exn ->
16
-
Alcotest.fail
17
-
(msg ^ ": expected Invalid_header, got " ^ Printexc.to_string exn)
18
-
19
-
(** {1 CRLF Injection in Header Name (CWE-113)} *)
20
-
21
-
let test_crlf_in_header_name_cr () =
22
-
expect_invalid_header "CR in header name" (fun () ->
23
-
Headers.of_list [ ("X-Bad\rName", "value") ])
24
-
25
-
let test_crlf_in_header_name_lf () =
26
-
expect_invalid_header "LF in header name" (fun () ->
27
-
Headers.of_list [ ("X-Bad\nName", "value") ])
28
-
29
-
let test_crlf_in_header_name_crlf () =
30
-
expect_invalid_header "CRLF in header name" (fun () ->
31
-
Headers.of_list [ ("X-Bad\r\nName", "value") ])
32
-
33
-
(** {1 CRLF Injection in Header Value (CWE-113)} *)
34
-
35
-
let test_crlf_in_header_value_cr () =
36
-
expect_invalid_header "CR in header value" (fun () ->
37
-
Headers.of_list [ ("X-Header", "val\rue") ])
38
-
39
-
let test_crlf_in_header_value_lf () =
40
-
expect_invalid_header "LF in header value" (fun () ->
41
-
Headers.of_list [ ("X-Header", "val\nue") ])
42
-
43
-
let test_crlf_in_header_value_crlf () =
44
-
expect_invalid_header "CRLF in header value" (fun () ->
45
-
Headers.of_list [ ("X-Header", "val\r\nue") ])
46
-
47
-
let test_crlf_smuggling_injection () =
48
-
(* Attempt to inject a second header via CRLF in value *)
49
-
expect_invalid_header "header smuggling via CRLF injection" (fun () ->
50
-
Headers.of_list [ ("X-Header", "legit\r\nX-Injected: evil") ])
51
-
52
-
(** {1 Null Byte in Header Name/Value} *)
53
-
54
-
let test_null_byte_in_header_name () =
55
-
expect_invalid_header "null byte in header name" (fun () ->
56
-
Headers.of_list [ ("X-Bad\x00Name", "value") ])
57
-
58
-
let test_null_byte_in_header_value () =
59
-
expect_invalid_header "null byte in header value" (fun () ->
60
-
Headers.of_list [ ("X-Header", "val\x00ue") ])
61
-
62
-
(** {1 Oversized Content-Length (CWE-190)} *)
63
-
64
-
let test_oversized_content_length () =
65
-
(* Int64.of_string should raise Failure for values exceeding 64-bit range.
66
-
The Response.content_length wrapper catches this and returns None.
67
-
Here we test the underlying parsing does not crash. *)
68
-
let huge = "99999999999999999999" in
69
-
let result = try Some (Int64.of_string huge) with Failure _ -> None in
70
-
Alcotest.(check (option int64))
71
-
"oversized content-length returns None" None result
72
-
73
-
(** {1 Negative Content-Length} *)
74
-
75
-
let test_negative_content_length () =
76
-
(* A negative Content-Length is syntactically valid for Int64 but
77
-
semantically invalid. Verify it parses as -1 so callers can reject. *)
78
-
let neg = "-1" in
79
-
let result = try Some (Int64.of_string neg) with Failure _ -> None in
80
-
Alcotest.(check (option int64))
81
-
"negative content-length parses as -1" (Some (-1L)) result
82
-
83
-
(** {1 Duplicate Content-Length Headers with Different Values} *)
84
-
85
-
let test_duplicate_content_length () =
86
-
(* Adding two Content-Length values should result in both being present.
87
-
Callers must detect this ambiguity to prevent request smuggling. *)
88
-
let h =
89
-
Headers.empty
90
-
|> Headers.add `Content_length "10"
91
-
|> Headers.add `Content_length "20"
92
-
in
93
-
let values = Headers.all `Content_length h in
94
-
Alcotest.(check int)
95
-
"duplicate content-length yields two values" 2 (List.length values);
96
-
Alcotest.(check (list string)) "both values present" [ "10"; "20" ] values
97
-
98
-
(** {1 Empty Header Name} *)
99
-
100
-
let test_empty_header_name () =
101
-
expect_invalid_header "empty header name" (fun () ->
102
-
Headers.of_list [ ("", "value") ])
103
-
104
-
(** {1 Header Value with Only Whitespace} *)
105
-
106
-
let test_whitespace_only_header_value () =
107
-
(* Whitespace-only values are syntactically valid per RFC 9110 but
108
-
should still be storable without crash. *)
109
-
let h = Headers.of_list [ ("X-Header", " ") ] in
110
-
let v = Headers.find (`Other "X-Header") h in
111
-
Alcotest.(check (option string))
112
-
"whitespace-only value preserved" (Some " ") v
113
-
114
-
(** {1 Test Suite} *)
115
-
116
-
let suite =
117
-
( "hostile_input",
118
-
[
119
-
Alcotest.test_case "CRLF: CR in header name" `Quick
120
-
test_crlf_in_header_name_cr;
121
-
Alcotest.test_case "CRLF: LF in header name" `Quick
122
-
test_crlf_in_header_name_lf;
123
-
Alcotest.test_case "CRLF: CRLF in header name" `Quick
124
-
test_crlf_in_header_name_crlf;
125
-
Alcotest.test_case "CRLF: CR in header value" `Quick
126
-
test_crlf_in_header_value_cr;
127
-
Alcotest.test_case "CRLF: LF in header value" `Quick
128
-
test_crlf_in_header_value_lf;
129
-
Alcotest.test_case "CRLF: CRLF in header value" `Quick
130
-
test_crlf_in_header_value_crlf;
131
-
Alcotest.test_case "CRLF: smuggling injection" `Quick
132
-
test_crlf_smuggling_injection;
133
-
Alcotest.test_case "null byte in header name" `Quick
134
-
test_null_byte_in_header_name;
135
-
Alcotest.test_case "null byte in header value" `Quick
136
-
test_null_byte_in_header_value;
137
-
Alcotest.test_case "oversized content-length" `Quick
138
-
test_oversized_content_length;
139
-
Alcotest.test_case "negative content-length" `Quick
140
-
test_negative_content_length;
141
-
Alcotest.test_case "duplicate content-length" `Quick
142
-
test_duplicate_content_length;
143
-
Alcotest.test_case "empty header name" `Quick test_empty_header_name;
144
-
Alcotest.test_case "whitespace-only header value" `Quick
145
-
test_whitespace_only_header_value;
146
-
] )
-4
test/test_hostile.mli
-4
test/test_hostile.mli
+4
-3
test/test_multipart.ml
+4
-3
test/test_multipart.ml
···
4
4
5
5
let check_string = Alcotest.(check string)
6
6
let check_int = Alcotest.(check int)
7
-
let check_bool = Alcotest.(check bool)
8
7
let headers_with_ct v = Headers.empty |> Headers.set `Content_type v
9
8
let boundary = "----WebKitFormBoundaryABC123"
10
9
···
85
84
let p = List.hd parts in
86
85
check_string "name" "greeting" p.Multipart.name;
87
86
check_string "body" "hello, world" p.Multipart.body;
88
-
check_bool "no filename" true (p.Multipart.filename = None);
89
-
check_bool "no content-type" true (p.Multipart.content_type = None)
87
+
Alcotest.(check bool) "no filename" true (p.Multipart.filename = None);
88
+
Alcotest.(check bool)
89
+
"no content-type" true
90
+
(p.Multipart.content_type = None)
90
91
91
92
(* --- parse: file upload with filename ---------------------------- *)
92
93