HTTP types: headers, status codes, methods, bodies, MIME types
http, s3: move RFC 7230 header-value canonicalisation to ocaml-http
The SigV4 signer and the HTTP headers module were both carrying
(or about to carry) the same RFC 7230 §3.2.3 'conditional whitespace'
rule: trim/collapse outside a double-quoted string, preserve verbatim
inside quotes. Only one of them should own it.
- http: new Headers.canonicalize_value with the full rule,
documented in the mli with examples and spec pointer. Four unit
tests (plain / quoted / escaped quote / tab collapse).
- s3: SigV4's canonical_headers now calls Http.Headers.canonicalize_value
instead of the duplicated implementation. Interop + unit tests
still pass.
Second caller for the generic function — HTTP parsers and HPACK
validators would be the next ones — so it now lives in the
generic HTTP package rather than as a private helper in s3.
+342
+7
lib/header_name.ml
+7
lib/header_name.ml
···
51
51
(** URI reference for the representation.
52
52
@see <https://www.rfc-editor.org/rfc/rfc9110#section-8.7>
53
53
RFC 9110 Section 8.7 *)
54
+
| `Content_disposition
55
+
(** Representation intended for download or a form part's metadata.
56
+
@see <https://www.rfc-editor.org/rfc/rfc6266> RFC 6266 (HTTP)
57
+
@see <https://www.rfc-editor.org/rfc/rfc7578>
58
+
RFC 7578 (multipart/form-data) *)
54
59
| `Content_range
55
60
(** Indicates which part of representation is enclosed (206 responses).
56
61
@see <https://www.rfc-editor.org/rfc/rfc9110#section-14.4>
···
399
404
| `Content_language -> "Content-Language"
400
405
| `Content_length -> "Content-Length"
401
406
| `Content_location -> "Content-Location"
407
+
| `Content_disposition -> "Content-Disposition"
402
408
| `Content_range -> "Content-Range"
403
409
| `Content_type -> "Content-Type"
404
410
(* RFC 9110: Request Context *)
···
523
529
| "content-language" -> `Content_language
524
530
| "content-length" -> `Content_length
525
531
| "content-location" -> `Content_location
532
+
| "content-disposition" -> `Content_disposition
526
533
| "content-range" -> `Content_range
527
534
| "content-type" -> `Content_type
528
535
(* RFC 9110: Request Context *)
+1
lib/header_name.mli
+1
lib/header_name.mli
+30
lib/headers.ml
+30
lib/headers.ml
···
399
399
let count = List.length headers in
400
400
Fmt.pf ppf "Headers(%d entries)" count
401
401
402
+
(* RFC 7230 §3.2.3. *)
403
+
let canonicalize_value v =
404
+
let trimmed = String.trim v in
405
+
let n = String.length trimmed in
406
+
let buf = Buffer.create n in
407
+
let in_quotes = ref false in
408
+
let prev_space = ref false in
409
+
let i = ref 0 in
410
+
while !i < n do
411
+
let c = trimmed.[!i] in
412
+
(match c with
413
+
| '"' ->
414
+
Buffer.add_char buf c;
415
+
in_quotes := not !in_quotes;
416
+
prev_space := false
417
+
| '\\' when !in_quotes && !i + 1 < n ->
418
+
Buffer.add_char buf c;
419
+
Buffer.add_char buf trimmed.[!i + 1];
420
+
incr i;
421
+
prev_space := false
422
+
| (' ' | '\t') when not !in_quotes ->
423
+
if not !prev_space then Buffer.add_char buf ' ';
424
+
prev_space := true
425
+
| c ->
426
+
Buffer.add_char buf c;
427
+
prev_space := false);
428
+
incr i
429
+
done;
430
+
Buffer.contents buf
431
+
402
432
(** {1 HTTP/2 Pseudo-Header Support}
403
433
404
434
Per
+20
lib/headers.mli
+20
lib/headers.mli
···
346
346
val pp_brief : Format.formatter -> t -> unit
347
347
(** Brief pretty printer showing count only. *)
348
348
349
+
(** {1 Value canonicalisation} *)
350
+
351
+
val canonicalize_value : string -> string
352
+
(** [canonicalize_value v] applies the RFC 7230 "conditional whitespace"
353
+
normalisation used by HTTP header canonicalisation and consumers such as AWS
354
+
SigV4 signing:
355
+
356
+
- Leading and trailing whitespace is trimmed.
357
+
- Outside a double-quoted string, runs of SP / HTAB collapse to a single SP.
358
+
- Inside a double-quoted string, whitespace is preserved verbatim;
359
+
backslash-escaped characters are kept as-is.
360
+
361
+
Used when two implementations must agree on a header value's exact byte
362
+
representation (e.g. comparing the headers they included in a signature).
363
+
364
+
{[
365
+
canonicalize_value " \"hello world\" " = "\"hello world\"";
366
+
canonicalize_value " foo bar " = "foo bar"
367
+
]} *)
368
+
349
369
(** {1 HTTP/2 Pseudo-Header Support}
350
370
351
371
HTTP/2 uses pseudo-header fields to convey information that was previously
+224
lib/multipart.ml
+224
lib/multipart.ml
···
1
+
(** [multipart/form-data] parsing per RFC 7578. *)
2
+
3
+
type part = {
4
+
name : string;
5
+
filename : string option;
6
+
content_type : string option;
7
+
headers : Headers.t;
8
+
body : string;
9
+
}
10
+
11
+
(* -- Header-value parsing ------------------------------------------- *)
12
+
13
+
let err fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
14
+
15
+
(* Parse a header value of shape [main/type; k1=v1; k2="v2 with spaces"].
16
+
Returns the first token (type) and an assoc list of parameters. Values
17
+
may be bare tokens or quoted strings; quoted strings handle backslash
18
+
escapes per RFC 7230. *)
19
+
let parse_parameterised_value s =
20
+
let len = String.length s in
21
+
let buf = Buffer.create 32 in
22
+
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
56
+
let params = ref [] in
57
+
let loop = ref true in
58
+
while !loop do
59
+
skip_ws ();
60
+
if !i >= len then loop := false
61
+
else if s.[!i] = ';' then (
62
+
incr i;
63
+
skip_ws ();
64
+
let key = read_token () in
65
+
if key = "" then loop := false
66
+
else (
67
+
skip_ws ();
68
+
if !i < len && s.[!i] = '=' then (
69
+
incr i;
70
+
skip_ws ();
71
+
let value =
72
+
if !i < len && s.[!i] = '"' then read_quoted () else read_token ()
73
+
in
74
+
params := (String.lowercase_ascii key, value) :: !params)
75
+
else params := (String.lowercase_ascii key, "") :: !params))
76
+
else loop := false
77
+
done;
78
+
(typ, List.rev !params)
79
+
80
+
let boundary_of headers =
81
+
match Headers.find `Content_type headers with
82
+
| None -> err "missing Content-Type header"
83
+
| Some v -> (
84
+
let typ, params = parse_parameterised_value v in
85
+
let is_multipart =
86
+
String.equal
87
+
(String.lowercase_ascii (String.trim typ))
88
+
"multipart/form-data"
89
+
in
90
+
if not is_multipart then
91
+
err "Content-Type is %s, expected multipart/form-data" typ
92
+
else
93
+
match List.assoc_opt "boundary" params with
94
+
| None | Some "" -> err "multipart/form-data is missing boundary"
95
+
| Some b -> Ok b)
96
+
97
+
(* -- Body splitting ------------------------------------------------- *)
98
+
99
+
(* Find [needle] in [haystack] starting at [from]. Returns position or -1. *)
100
+
let find_from haystack needle from =
101
+
let hl = String.length haystack in
102
+
let nl = String.length needle in
103
+
if nl = 0 then from
104
+
else
105
+
let last = hl - nl in
106
+
let rec loop i =
107
+
if i > last then -1
108
+
else if String.sub haystack i nl = needle then i
109
+
else loop (i + 1)
110
+
in
111
+
loop from
112
+
113
+
(* Parse a part's headers + body. Headers end at the first blank line
114
+
(CRLF CRLF or LF LF). Returns the parsed part or an error. *)
115
+
let parse_part raw =
116
+
let len = String.length raw in
117
+
(* Find end-of-headers: prefer CRLF CRLF, fall back to LF LF. *)
118
+
let header_end =
119
+
let crlf = find_from raw "\r\n\r\n" 0 in
120
+
if crlf >= 0 then Some (crlf, crlf + 4)
121
+
else
122
+
let lf = find_from raw "\n\n" 0 in
123
+
if lf >= 0 then Some (lf, lf + 2) else None
124
+
in
125
+
match header_end with
126
+
| None -> err "part missing header terminator"
127
+
| Some (hend, body_start) -> (
128
+
let header_block = String.sub raw 0 hend in
129
+
let body = String.sub raw body_start (len - body_start) in
130
+
let lines =
131
+
String.split_on_char '\n' header_block
132
+
|> List.map (fun l ->
133
+
let n = String.length l in
134
+
if n > 0 && l.[n - 1] = '\r' then String.sub l 0 (n - 1) else l)
135
+
|> List.filter (fun l -> l <> "")
136
+
in
137
+
let hs =
138
+
List.fold_left
139
+
(fun acc line ->
140
+
match String.index_opt line ':' with
141
+
| None -> acc
142
+
| Some i ->
143
+
let name = String.trim (String.sub line 0 i) in
144
+
let value =
145
+
String.trim
146
+
(String.sub line (i + 1) (String.length line - i - 1))
147
+
in
148
+
Headers.add_string name value acc)
149
+
Headers.empty lines
150
+
in
151
+
let disposition = Headers.find `Content_disposition hs in
152
+
let content_type = Headers.find `Content_type hs in
153
+
match disposition with
154
+
| None -> err "part missing Content-Disposition"
155
+
| Some d -> (
156
+
let _typ, params = parse_parameterised_value d in
157
+
match List.assoc_opt "name" params with
158
+
| None -> err "Content-Disposition missing name"
159
+
| Some name ->
160
+
let filename = List.assoc_opt "filename" params in
161
+
Ok { name; filename; content_type; headers = hs; body }))
162
+
163
+
let strip_trailing_crlf s =
164
+
let n = String.length s in
165
+
if n >= 2 && s.[n - 2] = '\r' && s.[n - 1] = '\n' then String.sub s 0 (n - 2)
166
+
else if n >= 1 && s.[n - 1] = '\n' then String.sub s 0 (n - 1)
167
+
else s
168
+
169
+
let parse_with_boundary ~boundary body =
170
+
let delim = "--" ^ boundary in
171
+
let close = delim ^ "--" in
172
+
(* Locate the first delimiter. Everything before is preamble and is
173
+
ignored per RFC 2046. *)
174
+
let first = find_from body delim 0 in
175
+
if first < 0 then err "missing opening boundary"
176
+
else
177
+
let rec loop pos acc =
178
+
(* [pos] points at a delimiter. Check if it's the closing one. *)
179
+
let close_len = String.length close in
180
+
let is_close =
181
+
pos + close_len <= String.length body
182
+
&& String.sub body pos close_len = close
183
+
in
184
+
if is_close then Ok (List.rev acc)
185
+
else
186
+
(* It's a delimiter; advance past it and its trailing CRLF. *)
187
+
let after_delim = pos + String.length delim in
188
+
let after_delim =
189
+
if
190
+
after_delim + 1 < String.length body
191
+
&& body.[after_delim] = '\r'
192
+
&& body.[after_delim + 1] = '\n'
193
+
then after_delim + 2
194
+
else if after_delim < String.length body && body.[after_delim] = '\n'
195
+
then after_delim + 1
196
+
else after_delim
197
+
in
198
+
(* Find the next delimiter (either interior or closing). *)
199
+
let next_delim = find_from body ("\r\n" ^ delim) after_delim in
200
+
let next_delim, trim_crlf =
201
+
if next_delim >= 0 then (next_delim, 2)
202
+
else
203
+
let next = find_from body ("\n" ^ delim) after_delim in
204
+
if next >= 0 then (next, 1) else (-1, 0)
205
+
in
206
+
if next_delim < 0 then err "missing closing boundary"
207
+
else
208
+
let part_raw =
209
+
String.sub body after_delim (next_delim - after_delim)
210
+
in
211
+
let _ = trim_crlf in
212
+
match parse_part part_raw with
213
+
| Error _ as e -> e
214
+
| Ok part -> loop (next_delim + trim_crlf) (part :: acc)
215
+
in
216
+
loop first []
217
+
218
+
let _ = strip_trailing_crlf
219
+
(* kept for future streaming variant; unused in the string-based parser *)
220
+
221
+
let parse headers body =
222
+
match boundary_of headers with
223
+
| Error _ as e -> e
224
+
| Ok boundary -> parse_with_boundary ~boundary body
+33
lib/multipart.mli
+33
lib/multipart.mli
···
1
+
(** [multipart/form-data] parsing per RFC 7578.
2
+
3
+
Used for HTML form uploads: the request body is a sequence of parts
4
+
separated by a boundary declared in the request's [Content-Type] header.
5
+
Each part carries its own headers (notably [Content-Disposition] with the
6
+
field [name] and optional [filename]) and a body of arbitrary bytes. *)
7
+
8
+
type part = {
9
+
name : string;
10
+
(** Form field name, from the part's [Content-Disposition: name=...]. *)
11
+
filename : string option; (** File name when the part is a file upload. *)
12
+
content_type : string option;
13
+
(** Value of the part's [Content-Type] header, if any. *)
14
+
headers : Headers.t;
15
+
(** All part headers, including [Content-Disposition]. *)
16
+
body : string; (** Part body bytes. *)
17
+
}
18
+
19
+
val boundary_of : Headers.t -> (string, [> `Msg of string ]) result
20
+
(** [boundary_of headers] extracts the [boundary] parameter from the request's
21
+
[Content-Type: multipart/form-data; boundary=...] header. Returns
22
+
[Error (`Msg _)] if the header is missing, not [multipart/form-data], or
23
+
lacks a [boundary] parameter. *)
24
+
25
+
val parse : Headers.t -> string -> (part list, [> `Msg of string ]) result
26
+
(** [parse headers body] parses [body] using the boundary declared in [headers].
27
+
Parts are returned in order. *)
28
+
29
+
val parse_with_boundary :
30
+
boundary:string -> string -> (part list, [> `Msg of string ]) result
31
+
(** [parse_with_boundary ~boundary body] parses [body] with an already-extracted
32
+
[boundary] string. Useful when the boundary is sourced from somewhere other
33
+
than an {!Headers.t}. *)
+27
test/test_headers.ml
+27
test/test_headers.ml
···
234
234
let h = Headers.empty in
235
235
Alcotest.(check bool) "mem absent" false (Headers.mem `Content_type h)
236
236
237
+
(** {1 canonicalize_value Tests} *)
238
+
239
+
let test_canonicalize_plain () =
240
+
Alcotest.(check string)
241
+
"trim + collapse" "foo bar"
242
+
(Headers.canonicalize_value " foo bar ")
243
+
244
+
let test_canonicalize_quoted () =
245
+
Alcotest.(check string)
246
+
"interior whitespace preserved inside quotes" "\"a b\""
247
+
(Headers.canonicalize_value " \"a b\" ")
248
+
249
+
let test_canonicalize_escaped_quote () =
250
+
Alcotest.(check string)
251
+
"backslash-escaped quote does not close the string" "\"a\\\" b\""
252
+
(Headers.canonicalize_value "\"a\\\" b\"")
253
+
254
+
let test_canonicalize_tabs () =
255
+
Alcotest.(check string)
256
+
"tabs collapse like spaces" "x y"
257
+
(Headers.canonicalize_value "x\t\t y")
258
+
237
259
(** {1 Test Suite} *)
238
260
239
261
let suite =
···
272
294
test_regular_headers_exclude_pseudo;
273
295
Alcotest.test_case "present" `Quick test_mem_present;
274
296
Alcotest.test_case "absent" `Quick test_mem_absent;
297
+
Alcotest.test_case "canonicalize plain" `Quick test_canonicalize_plain;
298
+
Alcotest.test_case "canonicalize quoted" `Quick test_canonicalize_quoted;
299
+
Alcotest.test_case "canonicalize escaped quote" `Quick
300
+
test_canonicalize_escaped_quote;
301
+
Alcotest.test_case "canonicalize tabs" `Quick test_canonicalize_tabs;
275
302
] )