HTTP types: headers, status codes, methods, bodies, MIME types
Linter fixes: auth refactor, github-oauth merge, respond cleanup
+9840
+4
http.opam
+4
http.opam
+398
lib/body.ml
+398
lib/body.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "requests.body" ~doc:"HTTP Request/Response Body"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
type 'a part = {
11
+
name : string;
12
+
filename : string option;
13
+
content_type : Mime.t;
14
+
content :
15
+
[ `String of string
16
+
| `Stream of Eio.Flow.source_ty Eio.Resource.t
17
+
| `File of 'a Eio.Path.t ];
18
+
}
19
+
20
+
type t =
21
+
| Empty
22
+
| String of { content : string; mime : Mime.t }
23
+
| Stream of {
24
+
source : Eio.Flow.source_ty Eio.Resource.t;
25
+
mime : Mime.t;
26
+
length : int64 option;
27
+
}
28
+
| File : { file : 'a Eio.Path.t; mime : Mime.t } -> t
29
+
| Multipart : { parts : 'a part list; boundary : string } -> t
30
+
31
+
let empty = Empty
32
+
let of_string mime content = String { content; mime }
33
+
let of_stream ?length mime source = Stream { source; mime; length }
34
+
35
+
let of_file ?mime file =
36
+
let path = Eio.Path.native_exn file in
37
+
let mime =
38
+
Option.value mime
39
+
~default:
40
+
((* Use magic-mime library to guess MIME type from file extension *)
41
+
let guessed_str = Magic_mime.lookup path in
42
+
let guessed = Mime.of_string guessed_str in
43
+
Log.debug (fun m ->
44
+
m "Guessed MIME type %s for file %s" (Mime.to_string guessed) path);
45
+
guessed)
46
+
in
47
+
Log.debug (fun m ->
48
+
m "Creating file body from %s with MIME type %s" path
49
+
(Mime.to_string mime));
50
+
File { file; mime }
51
+
52
+
let json_encoding_error e =
53
+
let msg = Jsont.Error.to_string e in
54
+
raise (Error.err (Error.Json_encode_error { reason = msg }))
55
+
56
+
(* For simple JSON encoding, we just take a Jsont.json value and encode it *)
57
+
let json (json_value : Jsont.json) =
58
+
let content =
59
+
match
60
+
Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value
61
+
with
62
+
| Ok s -> s
63
+
| Error e -> json_encoding_error e
64
+
in
65
+
String { content; mime = Mime.json }
66
+
67
+
(* Typed JSON encoding using a Jsont.t codec *)
68
+
let jsonv (type a) (codec : a Jsont.t) (value : a) =
69
+
let content =
70
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Minify codec value with
71
+
| Ok s -> s
72
+
| Error e -> json_encoding_error e
73
+
in
74
+
String { content; mime = Mime.json }
75
+
76
+
(* JSON streaming using jsont - we encode the value to string and stream it *)
77
+
module Json_stream_source = struct
78
+
type t = { content : string; mutable offset : int }
79
+
80
+
let single_read t dst =
81
+
if t.offset >= String.length t.content then raise End_of_file
82
+
else begin
83
+
let available = String.length t.content - t.offset in
84
+
let to_copy = min (Cstruct.length dst) available in
85
+
Cstruct.blit_from_string t.content t.offset dst 0 to_copy;
86
+
t.offset <- t.offset + to_copy;
87
+
to_copy
88
+
end
89
+
90
+
let read_methods = []
91
+
end
92
+
93
+
let json_stream_source_create json_value =
94
+
(* Encode the entire JSON value to string with minified format *)
95
+
let content =
96
+
match
97
+
Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value
98
+
with
99
+
| Ok s -> s
100
+
| Error e -> json_encoding_error e
101
+
in
102
+
let t = { Json_stream_source.content; offset = 0 } in
103
+
let ops = Eio.Flow.Pi.source (module Json_stream_source) in
104
+
Eio.Resource.T (t, ops)
105
+
106
+
let json_stream json_value =
107
+
let source = json_stream_source_create json_value in
108
+
Stream { source; mime = Mime.json; length = None }
109
+
110
+
let text content = String { content; mime = Mime.text }
111
+
112
+
let form params =
113
+
let encode_param (k, v) =
114
+
Fmt.str "%s=%s"
115
+
(Uri.pct_encode ~component:`Query_value k)
116
+
(Uri.pct_encode ~component:`Query_value v)
117
+
in
118
+
let content = String.concat "&" (List.map encode_param params) in
119
+
String { content; mime = Mime.form }
120
+
121
+
let generate_boundary () =
122
+
let random_bytes = Crypto_rng.generate 16 in
123
+
let random_part =
124
+
let buf = Buffer.create (String.length random_bytes * 2) in
125
+
String.iter
126
+
(fun c -> Buffer.add_string buf (Printf.sprintf "%02x" (Char.code c)))
127
+
random_bytes;
128
+
Buffer.contents buf
129
+
in
130
+
Fmt.str "----WebKitFormBoundary%s" random_part
131
+
132
+
let multipart parts =
133
+
let boundary = generate_boundary () in
134
+
Multipart { parts; boundary }
135
+
136
+
let content_type = function
137
+
| Empty -> None
138
+
| String { mime; _ } -> Some mime
139
+
| Stream { mime; _ } -> Some mime
140
+
| File { mime; _ } -> Some mime
141
+
| Multipart { boundary; _ } ->
142
+
Some (Mime.multipart_form |> Mime.with_param "boundary" boundary)
143
+
144
+
let content_length = function
145
+
| Empty -> Some 0L
146
+
| String { content; _ } -> Some (Int64.of_int (String.length content))
147
+
| Stream { length; _ } -> length
148
+
| File { file; _ } -> (
149
+
(* Try to get file size *)
150
+
try
151
+
let stat = Eio.Path.stat ~follow:true file in
152
+
Some (Optint.Int63.to_int64 stat.size)
153
+
with Eio.Io _ -> None)
154
+
| Multipart _ ->
155
+
(* Complex to calculate, handled during sending *)
156
+
None
157
+
158
+
(* Strings_source - A flow source that streams from a doubly-linked list of strings/flows *)
159
+
module Strings_source = struct
160
+
type element = String of string | Flow of Eio.Flow.source_ty Eio.Resource.t
161
+
162
+
type t = {
163
+
dllist : element Lwt_dllist.t;
164
+
mutable current_element : element option;
165
+
mutable string_offset : int;
166
+
}
167
+
168
+
let rec single_read t dst =
169
+
match t.current_element with
170
+
| None ->
171
+
(* Try to get the first element from the list *)
172
+
if Lwt_dllist.is_empty t.dllist then raise End_of_file
173
+
else begin
174
+
t.current_element <- Some (Lwt_dllist.take_l t.dllist);
175
+
single_read t dst
176
+
end
177
+
| Some (String s) when t.string_offset >= String.length s ->
178
+
(* Current string exhausted, move to next element *)
179
+
t.current_element <- None;
180
+
t.string_offset <- 0;
181
+
single_read t dst
182
+
| Some (String s) ->
183
+
(* Read from current string *)
184
+
let available = String.length s - t.string_offset in
185
+
let to_read = min (Cstruct.length dst) available in
186
+
Cstruct.blit_from_string s t.string_offset dst 0 to_read;
187
+
t.string_offset <- t.string_offset + to_read;
188
+
to_read
189
+
| Some (Flow flow) -> (
190
+
(* Read from flow *)
191
+
try
192
+
let n = Eio.Flow.single_read flow dst in
193
+
if n = 0 then begin
194
+
(* Flow exhausted, move to next element *)
195
+
t.current_element <- None;
196
+
single_read t dst
197
+
end
198
+
else n
199
+
with End_of_file ->
200
+
t.current_element <- None;
201
+
single_read t dst)
202
+
203
+
let read_methods = [] (* No special read methods *)
204
+
205
+
let create () =
206
+
{ dllist = Lwt_dllist.create (); current_element = None; string_offset = 0 }
207
+
208
+
let add_string t s = ignore (Lwt_dllist.add_r (String s) t.dllist)
209
+
let add_flow t flow = ignore (Lwt_dllist.add_r (Flow flow) t.dllist)
210
+
end
211
+
212
+
let strings_source_create () =
213
+
let t = Strings_source.create () in
214
+
let ops = Eio.Flow.Pi.source (module Strings_source) in
215
+
(t, Eio.Resource.T (t, ops))
216
+
217
+
let to_flow_source ~sw = function
218
+
| Empty -> None
219
+
| String { content; _ } -> Some (Eio.Flow.string_source content)
220
+
| Stream { source; _ } -> Some source
221
+
| File { file; _ } ->
222
+
(* Open file and stream it directly without loading into memory *)
223
+
let flow = Eio.Path.open_in ~sw file in
224
+
Some (flow :> Eio.Flow.source_ty Eio.Resource.t)
225
+
| Multipart { parts; boundary } ->
226
+
(* Create a single strings_source with dllist for streaming *)
227
+
let source, flow = strings_source_create () in
228
+
229
+
List.iter
230
+
(fun part ->
231
+
(* Add boundary *)
232
+
Strings_source.add_string source "--";
233
+
Strings_source.add_string source boundary;
234
+
Strings_source.add_string source "\r\n";
235
+
236
+
(* Add Content-Disposition header *)
237
+
Strings_source.add_string source
238
+
"Content-Disposition: form-data; name=\"";
239
+
Strings_source.add_string source part.name;
240
+
Strings_source.add_string source "\"";
241
+
(match part.filename with
242
+
| Some f ->
243
+
Strings_source.add_string source "; filename=\"";
244
+
Strings_source.add_string source f;
245
+
Strings_source.add_string source "\""
246
+
| None -> ());
247
+
Strings_source.add_string source "\r\n";
248
+
249
+
(* Add Content-Type header *)
250
+
Strings_source.add_string source "Content-Type: ";
251
+
Strings_source.add_string source (Mime.to_string part.content_type);
252
+
Strings_source.add_string source "\r\n\r\n";
253
+
254
+
(* Add content *)
255
+
(match part.content with
256
+
| `String s -> Strings_source.add_string source s
257
+
| `File file ->
258
+
(* Open file and add as flow *)
259
+
let file_flow = Eio.Path.open_in ~sw file in
260
+
Strings_source.add_flow source
261
+
(file_flow :> Eio.Flow.source_ty Eio.Resource.t)
262
+
| `Stream stream ->
263
+
(* Add stream directly *)
264
+
Strings_source.add_flow source stream);
265
+
266
+
(* Add trailing newline *)
267
+
Strings_source.add_string source "\r\n")
268
+
parts;
269
+
270
+
(* Add final boundary *)
271
+
Strings_source.add_string source "--";
272
+
Strings_source.add_string source boundary;
273
+
Strings_source.add_string source "--\r\n";
274
+
275
+
Some flow
276
+
277
+
(* Private module *)
278
+
module Private = struct
279
+
let to_flow_source = to_flow_source
280
+
281
+
let to_string = function
282
+
| Empty -> ""
283
+
| String { content; _ } -> content
284
+
| Stream _ ->
285
+
invalid_arg
286
+
"Body.Private.to_string: cannot convert streaming body (must be \
287
+
materialized first)"
288
+
| File _ ->
289
+
invalid_arg
290
+
"Body.Private.to_string: cannot convert file body (must be read \
291
+
first)"
292
+
| Multipart _ ->
293
+
invalid_arg
294
+
"Body.Private.to_string: cannot convert multipart body (must be \
295
+
encoded first)"
296
+
297
+
let is_empty = function Empty -> true | _ -> false
298
+
299
+
let is_chunked = function
300
+
| Empty -> false
301
+
| String _ -> false
302
+
| Stream { length = Some _; _ } -> false
303
+
| Stream { length = None; _ } -> true
304
+
| File _ -> false
305
+
| Multipart _ -> true
306
+
307
+
module Write = Eio.Buf_write
308
+
309
+
let crlf w = Write.string w "\r\n"
310
+
311
+
(** Copy from a flow source to the writer *)
312
+
let write_stream w source =
313
+
let cs = Cstruct.create 8192 in
314
+
let rec copy () =
315
+
match Eio.Flow.single_read source cs with
316
+
| n ->
317
+
Write.bytes w ~off:0 ~len:n (Cstruct.to_bytes cs);
318
+
copy ()
319
+
| exception End_of_file -> ()
320
+
in
321
+
copy ()
322
+
323
+
(** Write a chunk with hex size prefix *)
324
+
let write_chunk w cs len =
325
+
Write.printf w "%x" len;
326
+
crlf w;
327
+
Write.bytes w ~off:0 ~len (Cstruct.to_bytes cs);
328
+
crlf w
329
+
330
+
(** Copy from a flow source using chunked transfer encoding *)
331
+
let write_stream_chunked w source =
332
+
let cs = Cstruct.create 8192 in
333
+
let rec copy () =
334
+
match Eio.Flow.single_read source cs with
335
+
| n ->
336
+
write_chunk w cs n;
337
+
copy ()
338
+
| exception End_of_file ->
339
+
(* Final chunk *)
340
+
Write.string w "0";
341
+
crlf w;
342
+
crlf w
343
+
in
344
+
copy ()
345
+
346
+
let write ~sw w = function
347
+
| Empty -> ()
348
+
| String { content; _ } -> if content <> "" then Write.string w content
349
+
| Stream { source; _ } -> write_stream w source
350
+
| File { file; _ } ->
351
+
let flow = Eio.Path.open_in ~sw file in
352
+
write_stream w (flow :> Eio.Flow.source_ty Eio.Resource.t)
353
+
| Multipart _ as body -> (
354
+
(* For multipart, get the flow source and write it *)
355
+
match to_flow_source ~sw body with
356
+
| Some source -> write_stream w source
357
+
| None -> ())
358
+
359
+
let write_chunked ~sw w = function
360
+
| Empty ->
361
+
(* Empty body with chunked encoding is just final chunk *)
362
+
Write.string w "0";
363
+
crlf w;
364
+
crlf w
365
+
| String { content; _ } ->
366
+
if content <> "" then begin
367
+
Write.printf w "%x" (String.length content);
368
+
crlf w;
369
+
Write.string w content;
370
+
crlf w
371
+
end;
372
+
Write.string w "0";
373
+
crlf w;
374
+
crlf w
375
+
| Stream { source; _ } -> write_stream_chunked w source
376
+
| File { file; _ } ->
377
+
let flow = Eio.Path.open_in ~sw file in
378
+
write_stream_chunked w (flow :> Eio.Flow.source_ty Eio.Resource.t)
379
+
| Multipart _ as body -> (
380
+
match to_flow_source ~sw body with
381
+
| Some source -> write_stream_chunked w source
382
+
| None ->
383
+
Write.string w "0";
384
+
crlf w;
385
+
crlf w)
386
+
end
387
+
388
+
let pp fmt = function
389
+
| Empty -> Format.pp_print_string fmt "Empty"
390
+
| String { content; mime } ->
391
+
Fmt.pf fmt "String(%s, %d bytes)" (Mime.to_string mime)
392
+
(String.length content)
393
+
| Stream { mime; length; _ } ->
394
+
Fmt.pf fmt "Stream(%s, %s)" (Mime.to_string mime)
395
+
(Option.fold ~none:"unknown" ~some:Int64.to_string length)
396
+
| File { mime; _ } -> Fmt.pf fmt "File(%s)" (Mime.to_string mime)
397
+
| Multipart { parts; _ } ->
398
+
Fmt.pf fmt "Multipart(%d parts)" (List.length parts)
+220
lib/body.mli
+220
lib/body.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP request body construction
7
+
8
+
This module provides various ways to construct HTTP request bodies,
9
+
including strings, files, streams, forms, and multipart data.
10
+
11
+
{2 Examples}
12
+
13
+
{[
14
+
(* Simple text body *)
15
+
let body = Body.text "Hello, World!"
16
+
17
+
(* JSON body *)
18
+
let body = Body.json {|{"name": "Alice", "age": 30}|}
19
+
20
+
(* Form data *)
21
+
let body = Body.form [ ("username", "alice"); ("password", "secret") ]
22
+
23
+
(* File upload *)
24
+
let body = Body.of_file ~mime:Mime.pdf Eio.Path.(fs / "document.pdf")
25
+
26
+
(* Multipart form with file *)
27
+
let body =
28
+
Body.multipart
29
+
[
30
+
{
31
+
name = "field";
32
+
filename = None;
33
+
content_type = Mime.text_plain;
34
+
content = `String "value";
35
+
};
36
+
{
37
+
name = "file";
38
+
filename = Some "photo.jpg";
39
+
content_type = Mime.jpeg;
40
+
content = `File Eio.Path.(fs / "photo.jpg");
41
+
};
42
+
]
43
+
]} *)
44
+
45
+
val src : Logs.Src.t
46
+
(** Log source for body operations. *)
47
+
48
+
type t
49
+
(** Abstract body type representing HTTP request body content. *)
50
+
51
+
val pp : Format.formatter -> t -> unit
52
+
(** [pp fmt body] pretty-prints [body]. *)
53
+
54
+
(** {1 Basic Constructors} *)
55
+
56
+
val empty : t
57
+
(** [empty] creates an empty body (no content). *)
58
+
59
+
val of_string : Mime.t -> string -> t
60
+
(** [of_string mime content] creates a body from a string with the specified
61
+
MIME type. Example: [of_string Mime.json {|{"key": "value"}|}]. *)
62
+
63
+
val of_stream :
64
+
?length:int64 -> Mime.t -> Eio.Flow.source_ty Eio.Resource.t -> t
65
+
(** [of_stream ?length mime stream] creates a streaming body. If [length] is
66
+
provided, it will be used for the Content-Length header, otherwise chunked
67
+
encoding is used. *)
68
+
69
+
val of_file : ?mime:Mime.t -> _ Eio.Path.t -> t
70
+
(** [of_file ?mime path] creates a body from a file. If [mime] is not provided,
71
+
the MIME type is automatically detected from the file extension using the
72
+
{{:https://github.com/mirage/ocaml-magic-mime}magic-mime} library, which
73
+
provides accurate MIME type mappings for hundreds of file extensions. *)
74
+
75
+
(** {1 Convenience Constructors} *)
76
+
77
+
val json : Jsont.json -> t
78
+
(** [json value] creates a JSON body from a Jsont.json value. The value is
79
+
encoded to a JSON string with Content-Type: application/json.
80
+
81
+
Example:
82
+
{[
83
+
let body =
84
+
Body.json
85
+
(Jsont.Object
86
+
( [
87
+
("status", Jsont.String "success");
88
+
("count", Jsont.Number 42.);
89
+
( "items",
90
+
Jsont.Array
91
+
( [ Jsont.String "first"; Jsont.String "second" ],
92
+
Jsont.Meta.none ) );
93
+
],
94
+
Jsont.Meta.none ))
95
+
]} *)
96
+
97
+
val jsonv : 'a Jsont.t -> 'a -> t
98
+
(** [jsonv codec value] creates a JSON body by encoding [value] using the typed
99
+
[codec]. The value is encoded to a minified JSON string with Content-Type:
100
+
application/json.
101
+
102
+
This is the preferred way to create JSON bodies from typed OCaml values, as
103
+
it provides type safety and works with custom record types.
104
+
105
+
Example:
106
+
{[
107
+
(* Define a codec for your type *)
108
+
type user = { name : string; age : int }
109
+
110
+
let user_codec =
111
+
Jsont.Obj.map ~kind:"user" (fun name age -> { name; age })
112
+
|> Jsont.Obj.mem "name" Jsont.string ~enc:(fun u -> u.name)
113
+
|> Jsont.Obj.mem "age" Jsont.int ~enc:(fun u -> u.age)
114
+
|> Jsont.Obj.finish
115
+
116
+
(* Create a JSON body from a typed value *)
117
+
let body = Body.jsonv user_codec { name = "Alice"; age = 30 }
118
+
]}
119
+
120
+
@raise Eio.Io with {!Error.Json_encode_error} if encoding fails. *)
121
+
122
+
val json_stream : Jsont.json -> t
123
+
(** [json_stream json_value] creates a streaming JSON body from a Jsont.json
124
+
value. The JSON value will be encoded to a minified JSON string and
125
+
streamed.
126
+
127
+
Example:
128
+
{[
129
+
let large_data = Jsont.Object ([
130
+
("users", Jsont.Array ([...], Jsont.Meta.none))
131
+
], Jsont.Meta.none) in
132
+
let body = Body.json_stream large_data
133
+
]} *)
134
+
135
+
val text : string -> t
136
+
(** [text str] creates a plain text body with Content-Type: text/plain. *)
137
+
138
+
val form : (string * string) list -> t
139
+
(** [form fields] creates a URL-encoded form body with Content-Type:
140
+
application/x-www-form-urlencoded. Example:
141
+
[form [("username", "alice"); ("password", "secret")]]. *)
142
+
143
+
(** {1 Multipart Support} *)
144
+
145
+
type 'a part = {
146
+
name : string; (** Form field name *)
147
+
filename : string option; (** Optional filename for file uploads *)
148
+
content_type : Mime.t; (** MIME type of this part *)
149
+
content :
150
+
[ `String of string (** String content *)
151
+
| `Stream of Eio.Flow.source_ty Eio.Resource.t (** Streaming content *)
152
+
| `File of 'a Eio.Path.t (** File content *) ];
153
+
}
154
+
(** A single part in a multipart body. *)
155
+
156
+
val multipart : _ part list -> t
157
+
(** [multipart parts] creates a multipart/form-data body from a list of parts.
158
+
This is commonly used for file uploads and complex form submissions.
159
+
160
+
Example:
161
+
{[
162
+
let body =
163
+
Body.multipart
164
+
[
165
+
{
166
+
name = "username";
167
+
filename = None;
168
+
content_type = Mime.text_plain;
169
+
content = `String "alice";
170
+
};
171
+
{
172
+
name = "avatar";
173
+
filename = Some "photo.jpg";
174
+
content_type = Mime.jpeg;
175
+
content = `File Eio.Path.(fs / "photo.jpg");
176
+
};
177
+
]
178
+
]} *)
179
+
180
+
(** {1 Properties} *)
181
+
182
+
val content_type : t -> Mime.t option
183
+
(** [content_type body] returns the MIME type of the body, if set. *)
184
+
185
+
val content_length : t -> int64 option
186
+
(** [content_length body] returns the content length in bytes, if known. Returns
187
+
[None] for streaming bodies without a predetermined length. *)
188
+
189
+
(** {1 Private API} *)
190
+
191
+
(** Internal functions exposed for use by other modules in the library. These
192
+
are not part of the public API and may change between versions. *)
193
+
module Private : sig
194
+
val to_flow_source :
195
+
sw:Eio.Switch.t -> t -> Eio.Flow.source_ty Eio.Resource.t option
196
+
(** [to_flow_source ~sw body] converts the body to an Eio flow source. Uses
197
+
the switch to manage resources like file handles. This function is used
198
+
internally by the Client module. *)
199
+
200
+
val to_string : t -> string
201
+
(** [to_string body] converts the body to a string for HTTP/1.1 requests. Only
202
+
works for materialized bodies (String type). Raises Failure for
203
+
streaming/file/multipart bodies. *)
204
+
205
+
val is_empty : t -> bool
206
+
(** [is_empty body] returns true if the body is empty. *)
207
+
208
+
val is_chunked : t -> bool
209
+
(** [is_chunked body] returns true if the body should use chunked transfer
210
+
encoding (i.e., it's a stream without known length or a multipart body).
211
+
*)
212
+
213
+
val write : sw:Eio.Switch.t -> Eio.Buf_write.t -> t -> unit
214
+
(** [write ~sw w body] writes the body content to the buffer writer. Uses the
215
+
switch to manage resources like file handles. *)
216
+
217
+
val write_chunked : sw:Eio.Switch.t -> Eio.Buf_write.t -> t -> unit
218
+
(** [write_chunked ~sw w body] writes the body content using HTTP chunked
219
+
transfer encoding. Each chunk is prefixed with its hex size. *)
220
+
end
+495
lib/cache_control.ml
+495
lib/cache_control.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP Cache-Control header parsing per RFC 9111 (HTTP Caching)
7
+
8
+
This module provides parsing and representation of Cache-Control directives
9
+
for both requests and responses. It supports all standard directives from
10
+
RFC 9111 Section 5.2.
11
+
12
+
Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance *)
13
+
14
+
let src = Logs.Src.create "requests.cache_control" ~doc:"HTTP Cache-Control"
15
+
16
+
module Log = (val Logs.src_log src : Logs.LOG)
17
+
18
+
(** {1 Response Cache-Control Directives}
19
+
20
+
RFC 9111 Section 5.2.2: Cache-Control Response Directives *)
21
+
22
+
type response_directive =
23
+
| Max_age of int (** max-age=N - response is fresh for N seconds *)
24
+
| S_maxage of int (** s-maxage=N - shared cache max-age *)
25
+
| No_cache of string list (** no-cache[=headers] - must revalidate *)
26
+
| No_store (** no-store - must not be stored *)
27
+
| No_transform (** no-transform - must not be transformed *)
28
+
| Must_revalidate (** must-revalidate - stale must be revalidated *)
29
+
| Proxy_revalidate (** proxy-revalidate - shared caches must revalidate *)
30
+
| Must_understand (** must-understand - RFC 9111 *)
31
+
| Private of string list (** private[=headers] - only private cache *)
32
+
| Public (** public - can be stored by any cache *)
33
+
| Immutable (** immutable - will not change during freshness *)
34
+
| Stale_while_revalidate of int (** stale-while-revalidate=N *)
35
+
| Stale_if_error of int (** stale-if-error=N *)
36
+
| Response_extension of string * string option (** Unknown directive *)
37
+
38
+
(** {1 Request Cache-Control Directives}
39
+
40
+
RFC 9111 Section 5.2.1: Cache-Control Request Directives *)
41
+
42
+
type request_directive =
43
+
| Req_max_age of int (** max-age=N *)
44
+
| Req_max_stale of int option (** max-stale[=N] *)
45
+
| Req_min_fresh of int (** min-fresh=N *)
46
+
| Req_no_cache (** no-cache *)
47
+
| Req_no_store (** no-store *)
48
+
| Req_no_transform (** no-transform *)
49
+
| Req_only_if_cached (** only-if-cached *)
50
+
| Request_extension of string * string option (** Unknown directive *)
51
+
52
+
type response = {
53
+
max_age : int option;
54
+
s_maxage : int option;
55
+
no_cache : string list option;
56
+
(** None = not present, Some [] = present without headers *)
57
+
no_store : bool;
58
+
no_transform : bool;
59
+
must_revalidate : bool;
60
+
proxy_revalidate : bool;
61
+
must_understand : bool;
62
+
private_ : string list option;
63
+
(** None = not present, Some [] = present without headers *)
64
+
public : bool;
65
+
immutable : bool;
66
+
stale_while_revalidate : int option;
67
+
stale_if_error : int option;
68
+
extensions : (string * string option) list;
69
+
}
70
+
(** Parsed response Cache-Control header *)
71
+
72
+
type request = {
73
+
req_max_age : int option;
74
+
req_max_stale : int option option;
75
+
(** None = not present, Some None = present without value *)
76
+
req_min_fresh : int option;
77
+
req_no_cache : bool;
78
+
req_no_store : bool;
79
+
req_no_transform : bool;
80
+
req_only_if_cached : bool;
81
+
req_extensions : (string * string option) list;
82
+
}
83
+
(** Parsed request Cache-Control header *)
84
+
85
+
(** {1 Parsing Functions} *)
86
+
87
+
let empty_response =
88
+
{
89
+
max_age = None;
90
+
s_maxage = None;
91
+
no_cache = None;
92
+
no_store = false;
93
+
no_transform = false;
94
+
must_revalidate = false;
95
+
proxy_revalidate = false;
96
+
must_understand = false;
97
+
private_ = None;
98
+
public = false;
99
+
immutable = false;
100
+
stale_while_revalidate = None;
101
+
stale_if_error = None;
102
+
extensions = [];
103
+
}
104
+
105
+
let empty_request =
106
+
{
107
+
req_max_age = None;
108
+
req_max_stale = None;
109
+
req_min_fresh = None;
110
+
req_no_cache = false;
111
+
req_no_store = false;
112
+
req_no_transform = false;
113
+
req_only_if_cached = false;
114
+
req_extensions = [];
115
+
}
116
+
117
+
(** Parse a single token (alphanumeric + some punctuation) *)
118
+
let parse_token s start =
119
+
let len = String.length s in
120
+
let rec find_end i =
121
+
if i >= len then i
122
+
else
123
+
match s.[i] with
124
+
| 'a' .. 'z'
125
+
| 'A' .. 'Z'
126
+
| '0' .. '9'
127
+
| '-' | '_' | '.' | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '^'
128
+
| '`' | '|' | '~' ->
129
+
find_end (i + 1)
130
+
| _ -> i
131
+
in
132
+
let end_pos = find_end start in
133
+
if end_pos = start then None
134
+
else Some (String.sub s start (end_pos - start), end_pos)
135
+
136
+
(** Parse a quoted string starting at position (after opening quote) *)
137
+
let parse_quoted_string s start =
138
+
let buf = Buffer.create 32 in
139
+
let len = String.length s in
140
+
let rec loop i =
141
+
if i >= len then None (* Unterminated quote *)
142
+
else
143
+
match s.[i] with
144
+
| '"' -> Some (Buffer.contents buf, i + 1)
145
+
| '\\' when i + 1 < len ->
146
+
Buffer.add_char buf s.[i + 1];
147
+
loop (i + 2)
148
+
| c ->
149
+
Buffer.add_char buf c;
150
+
loop (i + 1)
151
+
in
152
+
loop start
153
+
154
+
(** Parse a directive value (token or quoted-string) *)
155
+
let parse_value s start =
156
+
let len = String.length s in
157
+
if start >= len then None
158
+
else if s.[start] = '"' then parse_quoted_string s (start + 1)
159
+
else parse_token s start
160
+
161
+
(** Parse comma-separated header list (for no-cache=, private=) *)
162
+
let parse_header_list s =
163
+
(* Handle quoted list like "Accept, Accept-Encoding" *)
164
+
let s = String.trim s in
165
+
let s =
166
+
if String.length s >= 2 && s.[0] = '"' && s.[String.length s - 1] = '"' then
167
+
String.sub s 1 (String.length s - 2)
168
+
else s
169
+
in
170
+
String.split_on_char ',' s |> List.map String.trim
171
+
|> List.filter (fun s -> s <> "")
172
+
173
+
(** Skip whitespace and optional comma *)
174
+
let skip_ws_comma s start =
175
+
let len = String.length s in
176
+
let rec loop i =
177
+
if i >= len then i
178
+
else match s.[i] with ' ' | '\t' | ',' -> loop (i + 1) | _ -> i
179
+
in
180
+
loop start
181
+
182
+
(** Parse all directives from a Cache-Control header value *)
183
+
let parse_directives s =
184
+
let s = String.trim s in
185
+
let len = String.length s in
186
+
let rec loop i acc =
187
+
if i >= len then List.rev acc
188
+
else
189
+
let i = skip_ws_comma s i in
190
+
if i >= len then List.rev acc
191
+
else
192
+
match parse_token s i with
193
+
| None -> List.rev acc (* Invalid, stop parsing *)
194
+
| Some (name, next_pos) ->
195
+
let name_lower = String.lowercase_ascii name in
196
+
(* Check for =value *)
197
+
let next_pos = skip_ws_comma s next_pos in
198
+
if next_pos < len && s.[next_pos] = '=' then
199
+
let value_start = skip_ws_comma s (next_pos + 1) in
200
+
match parse_value s value_start with
201
+
| Some (value, end_pos) ->
202
+
loop (skip_ws_comma s end_pos)
203
+
((name_lower, Some value) :: acc)
204
+
| None ->
205
+
loop
206
+
(skip_ws_comma s (next_pos + 1))
207
+
((name_lower, None) :: acc)
208
+
else loop next_pos ((name_lower, None) :: acc)
209
+
in
210
+
loop 0 []
211
+
212
+
(** Parse response Cache-Control header *)
213
+
let parse_response header_value =
214
+
let directives = parse_directives header_value in
215
+
Log.debug (fun m -> m "Parsing response Cache-Control: %s" header_value);
216
+
List.fold_left
217
+
(fun acc (name, value) ->
218
+
match (name, value) with
219
+
| "max-age", Some v -> (
220
+
try { acc with max_age = Some (int_of_string v) }
221
+
with Failure _ -> acc)
222
+
| "s-maxage", Some v -> (
223
+
try { acc with s_maxage = Some (int_of_string v) }
224
+
with Failure _ -> acc)
225
+
| "no-cache", None -> { acc with no_cache = Some [] }
226
+
| "no-cache", Some v -> { acc with no_cache = Some (parse_header_list v) }
227
+
| "no-store", _ -> { acc with no_store = true }
228
+
| "no-transform", _ -> { acc with no_transform = true }
229
+
| "must-revalidate", _ -> { acc with must_revalidate = true }
230
+
| "proxy-revalidate", _ -> { acc with proxy_revalidate = true }
231
+
| "must-understand", _ -> { acc with must_understand = true }
232
+
| "private", None -> { acc with private_ = Some [] }
233
+
| "private", Some v -> { acc with private_ = Some (parse_header_list v) }
234
+
| "public", _ -> { acc with public = true }
235
+
| "immutable", _ -> { acc with immutable = true }
236
+
| "stale-while-revalidate", Some v -> (
237
+
try { acc with stale_while_revalidate = Some (int_of_string v) }
238
+
with Failure _ -> acc)
239
+
| "stale-if-error", Some v -> (
240
+
try { acc with stale_if_error = Some (int_of_string v) }
241
+
with Failure _ -> acc)
242
+
| other, v -> { acc with extensions = (other, v) :: acc.extensions })
243
+
empty_response directives
244
+
245
+
(** Parse request Cache-Control header *)
246
+
let parse_request header_value =
247
+
let directives = parse_directives header_value in
248
+
Log.debug (fun m -> m "Parsing request Cache-Control: %s" header_value);
249
+
List.fold_left
250
+
(fun acc (name, value) ->
251
+
match (name, value) with
252
+
| "max-age", Some v -> (
253
+
try { acc with req_max_age = Some (int_of_string v) }
254
+
with Failure _ -> acc)
255
+
| "max-stale", None -> { acc with req_max_stale = Some None }
256
+
| "max-stale", Some v -> (
257
+
try { acc with req_max_stale = Some (Some (int_of_string v)) }
258
+
with Failure _ -> { acc with req_max_stale = Some None })
259
+
| "min-fresh", Some v -> (
260
+
try { acc with req_min_fresh = Some (int_of_string v) }
261
+
with Failure _ -> acc)
262
+
| "no-cache", _ -> { acc with req_no_cache = true }
263
+
| "no-store", _ -> { acc with req_no_store = true }
264
+
| "no-transform", _ -> { acc with req_no_transform = true }
265
+
| "only-if-cached", _ -> { acc with req_only_if_cached = true }
266
+
| other, v ->
267
+
{ acc with req_extensions = (other, v) :: acc.req_extensions })
268
+
empty_request directives
269
+
270
+
(** {1 Freshness Calculation}
271
+
272
+
RFC 9111 Section 4.2: Freshness *)
273
+
274
+
(** Calculate freshness lifetime from response directives and headers. Returns
275
+
freshness lifetime in seconds, or None if not cacheable. *)
276
+
let freshness_lifetime ~response_cc ?expires ?date () =
277
+
(* RFC 9111 Section 4.2.1: Priority:
278
+
1. s-maxage (shared caches only, we skip this)
279
+
2. max-age
280
+
3. Expires - Date
281
+
4. Heuristic (we return None, let caller decide) *)
282
+
let ( let* ) = Option.bind in
283
+
match response_cc.max_age with
284
+
| Some age -> Some age
285
+
| None -> (
286
+
match (expires, date) with
287
+
| Some exp_str, Some date_str ->
288
+
(* Use Http_date.parse to parse HTTP dates *)
289
+
let* exp_time = Http_date.parse exp_str in
290
+
let* date_time = Http_date.parse date_str in
291
+
let diff = Ptime.diff exp_time date_time in
292
+
Ptime.Span.to_int_s diff
293
+
| _ -> None)
294
+
295
+
(** {1 Age Calculation}
296
+
297
+
RFC 9111 Section 4.2.3: Calculating Age *)
298
+
299
+
type age_inputs = {
300
+
date_value : Ptime.t option;
301
+
(** Value of Date header (when response was generated) *)
302
+
age_value : int; (** Value of Age header in seconds (0 if not present) *)
303
+
request_time : Ptime.t; (** Time when the request was initiated *)
304
+
response_time : Ptime.t; (** Time when the response was received *)
305
+
}
306
+
(** Age calculation inputs *)
307
+
308
+
(** Calculate the current age of a cached response. Per RFC 9111 Section 4.2.3:
309
+
310
+
{v
311
+
apparent_age = max(0, response_time - date_value)
312
+
response_delay = response_time - request_time
313
+
corrected_age_value = age_value + response_delay
314
+
corrected_initial_age = max(apparent_age, corrected_age_value)
315
+
resident_time = now - response_time
316
+
current_age = corrected_initial_age + resident_time
317
+
v}
318
+
319
+
@param inputs Age calculation inputs
320
+
@param now Current time
321
+
@return Current age in seconds *)
322
+
let calculate_age ~inputs ~now =
323
+
(* apparent_age = max(0, response_time - date_value) *)
324
+
let apparent_age =
325
+
match inputs.date_value with
326
+
| Some date ->
327
+
let diff = Ptime.diff inputs.response_time date in
328
+
max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
329
+
| None -> 0
330
+
in
331
+
(* response_delay = response_time - request_time *)
332
+
let response_delay =
333
+
let diff = Ptime.diff inputs.response_time inputs.request_time in
334
+
max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
335
+
in
336
+
(* corrected_age_value = age_value + response_delay *)
337
+
let corrected_age_value = inputs.age_value + response_delay in
338
+
(* corrected_initial_age = max(apparent_age, corrected_age_value) *)
339
+
let corrected_initial_age = max apparent_age corrected_age_value in
340
+
(* resident_time = now - response_time *)
341
+
let resident_time =
342
+
let diff = Ptime.diff now inputs.response_time in
343
+
max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
344
+
in
345
+
(* current_age = corrected_initial_age + resident_time *)
346
+
corrected_initial_age + resident_time
347
+
348
+
(** {1 Heuristic Freshness}
349
+
350
+
RFC 9111 Section 4.2.2: Calculating Heuristic Freshness *)
351
+
352
+
(** Default heuristic fraction: 10% of time since Last-Modified. RFC 9111
353
+
recommends this as a typical value. *)
354
+
let default_heuristic_fraction = 0.10
355
+
356
+
(** Maximum heuristic freshness lifetime: 1 day (86400 seconds). This prevents
357
+
excessively long heuristic caching. *)
358
+
let default_max_heuristic_age = 86400
359
+
360
+
(** Calculate heuristic freshness lifetime when no explicit caching info
361
+
provided. Per RFC 9111 Section 4.2.2, caches MAY use heuristics when
362
+
explicit freshness is not available.
363
+
364
+
@param last_modified Value of Last-Modified header
365
+
@param response_time When the response was received
366
+
@param fraction Fraction of (now - last_modified) to use (default 10%)
367
+
@param max_age Maximum heuristic age in seconds (default 1 day)
368
+
@return Heuristic freshness lifetime in seconds, or None *)
369
+
let heuristic_freshness ?last_modified ~response_time
370
+
?(fraction = default_heuristic_fraction)
371
+
?(max_age = default_max_heuristic_age) () =
372
+
match last_modified with
373
+
| Some lm_str -> (
374
+
match Http_date.parse lm_str with
375
+
| Some lm_time ->
376
+
let age_since_modified =
377
+
let diff = Ptime.diff response_time lm_time in
378
+
max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
379
+
in
380
+
let heuristic =
381
+
int_of_float (float_of_int age_since_modified *. fraction)
382
+
in
383
+
Some (min heuristic max_age)
384
+
| None ->
385
+
Log.debug (fun m -> m "Failed to parse Last-Modified: %s" lm_str);
386
+
None)
387
+
| None -> None
388
+
389
+
(** Check if a cached response is fresh.
390
+
391
+
@param current_age Current age from calculate_age
392
+
@param freshness_lifetime From freshness_lifetime or heuristic_freshness
393
+
@return true if the response is still fresh *)
394
+
let is_fresh ~current_age ~freshness_lifetime = current_age < freshness_lifetime
395
+
396
+
(** Check if a stale response can still be served based on request directives.
397
+
398
+
@param request_cc Parsed request Cache-Control
399
+
@param current_age Current age of the cached response
400
+
@param freshness_lifetime Freshness lifetime of the cached response
401
+
@return true if the stale response can be served *)
402
+
let can_serve_stale ~request_cc ~current_age ~freshness_lifetime =
403
+
let staleness = current_age - freshness_lifetime in
404
+
if staleness <= 0 then true (* Not stale *)
405
+
else
406
+
match request_cc.req_max_stale with
407
+
| Some None -> true (* max-stale without value: accept any staleness *)
408
+
| Some (Some allowed_stale) -> staleness <= allowed_stale
409
+
| None -> false (* No max-stale: don't serve stale *)
410
+
411
+
(** Check if a response is cacheable based on Cache-Control directives *)
412
+
let is_cacheable ~response_cc ~status =
413
+
(* RFC 9111 Section 3: A response is cacheable if:
414
+
- no-store is not present
415
+
- status is cacheable by default OR explicit caching directive present *)
416
+
if response_cc.no_store then false
417
+
else
418
+
(* Default cacheable statuses per RFC 9110 Section 15.1 *)
419
+
let default_cacheable =
420
+
List.mem status
421
+
[ 200; 203; 204; 206; 300; 301; 308; 404; 405; 410; 414; 501 ]
422
+
in
423
+
default_cacheable
424
+
|| Option.is_some response_cc.max_age
425
+
|| Option.is_some response_cc.s_maxage
426
+
427
+
(** Check if response requires revalidation before use *)
428
+
let must_revalidate ~response_cc =
429
+
response_cc.must_revalidate || response_cc.proxy_revalidate
430
+
|| Option.is_some response_cc.no_cache
431
+
432
+
(** Check if response can be stored in shared caches *)
433
+
let is_public ~response_cc =
434
+
response_cc.public && not (Option.is_some response_cc.private_)
435
+
436
+
(** Check if response can only be stored in private caches *)
437
+
let is_private ~response_cc = Option.is_some response_cc.private_
438
+
439
+
(** {1 Pretty Printers} *)
440
+
441
+
let add_opt_int key v acc =
442
+
match v with Some n -> Fmt.str "%s=%d" key n :: acc | None -> acc
443
+
444
+
let add_flag key b acc = if b then key :: acc else acc
445
+
446
+
let add_opt_field key v acc =
447
+
match v with
448
+
| Some [] -> key :: acc
449
+
| Some hs -> Fmt.str "%s=\"%s\"" key (String.concat ", " hs) :: acc
450
+
| None -> acc
451
+
452
+
let pp_response ppf r =
453
+
let items =
454
+
[]
455
+
|> add_opt_int "max-age" r.max_age
456
+
|> add_opt_int "s-maxage" r.s_maxage
457
+
|> add_opt_field "no-cache" r.no_cache
458
+
|> add_flag "no-store" r.no_store
459
+
|> add_flag "no-transform" r.no_transform
460
+
|> add_flag "must-revalidate" r.must_revalidate
461
+
|> add_flag "proxy-revalidate" r.proxy_revalidate
462
+
|> add_flag "must-understand" r.must_understand
463
+
|> add_opt_field "private" r.private_
464
+
|> add_flag "public" r.public
465
+
|> add_flag "immutable" r.immutable
466
+
|> add_opt_int "stale-while-revalidate" r.stale_while_revalidate
467
+
|> add_opt_int "stale-if-error" r.stale_if_error
468
+
in
469
+
Fmt.pf ppf "%s" (String.concat ", " (List.rev items))
470
+
471
+
let pp_request ppf r =
472
+
let items = [] in
473
+
let items =
474
+
match r.req_max_age with
475
+
| Some a -> Fmt.str "max-age=%d" a :: items
476
+
| None -> items
477
+
in
478
+
let items =
479
+
match r.req_max_stale with
480
+
| Some None -> "max-stale" :: items
481
+
| Some (Some s) -> Fmt.str "max-stale=%d" s :: items
482
+
| None -> items
483
+
in
484
+
let items =
485
+
match r.req_min_fresh with
486
+
| Some s -> Fmt.str "min-fresh=%d" s :: items
487
+
| None -> items
488
+
in
489
+
let items = if r.req_no_cache then "no-cache" :: items else items in
490
+
let items = if r.req_no_store then "no-store" :: items else items in
491
+
let items = if r.req_no_transform then "no-transform" :: items else items in
492
+
let items =
493
+
if r.req_only_if_cached then "only-if-cached" :: items else items
494
+
in
495
+
Fmt.pf ppf "%s" (String.concat ", " (List.rev items))
+253
lib/cache_control.mli
+253
lib/cache_control.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP Cache-Control header parsing per RFC 9111 (HTTP Caching)
7
+
8
+
This module provides parsing and representation of Cache-Control directives
9
+
for both requests and responses. It supports all standard directives from
10
+
RFC 9111 Section 5.2.
11
+
12
+
Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance
13
+
14
+
{2 Examples}
15
+
16
+
{[
17
+
(* Parse response Cache-Control *)
18
+
let cc = Cache_control.parse_response "max-age=3600, public" in
19
+
Printf.printf "Max age: %d\n" (Option.get cc.max_age);
20
+
21
+
(* Check if cacheable *)
22
+
if Cache_control.is_cacheable ~response_cc:cc ~status:200 then
23
+
Printf.printf "Response is cacheable\n"
24
+
]} *)
25
+
26
+
val src : Logs.Src.t
27
+
(** Log source for cache control operations. *)
28
+
29
+
(** {1 Response Cache-Control Directives}
30
+
31
+
RFC 9111 Section 5.2.2: Cache-Control Response Directives *)
32
+
33
+
type response_directive =
34
+
| Max_age of int (** max-age=N - response is fresh for N seconds *)
35
+
| S_maxage of int (** s-maxage=N - shared cache max-age *)
36
+
| No_cache of string list (** no-cache[=headers] - must revalidate *)
37
+
| No_store (** no-store - must not be stored *)
38
+
| No_transform (** no-transform - must not be transformed *)
39
+
| Must_revalidate (** must-revalidate - stale must be revalidated *)
40
+
| Proxy_revalidate (** proxy-revalidate - shared caches must revalidate *)
41
+
| Must_understand (** must-understand - RFC 9111 *)
42
+
| Private of string list (** private[=headers] - only private cache *)
43
+
| Public (** public - can be stored by any cache *)
44
+
| Immutable (** immutable - will not change during freshness *)
45
+
| Stale_while_revalidate of int (** stale-while-revalidate=N *)
46
+
| Stale_if_error of int (** stale-if-error=N *)
47
+
| Response_extension of string * string option (** Unknown directive *)
48
+
49
+
(** {1 Request Cache-Control Directives}
50
+
51
+
RFC 9111 Section 5.2.1: Cache-Control Request Directives *)
52
+
53
+
type request_directive =
54
+
| Req_max_age of int (** max-age=N *)
55
+
| Req_max_stale of int option (** max-stale[=N] *)
56
+
| Req_min_fresh of int (** min-fresh=N *)
57
+
| Req_no_cache (** no-cache *)
58
+
| Req_no_store (** no-store *)
59
+
| Req_no_transform (** no-transform *)
60
+
| Req_only_if_cached (** only-if-cached *)
61
+
| Request_extension of string * string option (** Unknown directive *)
62
+
63
+
(** {1 Parsed Cache-Control Types} *)
64
+
65
+
type response = {
66
+
max_age : int option; (** max-age directive value in seconds *)
67
+
s_maxage : int option; (** s-maxage directive value for shared caches *)
68
+
no_cache : string list option;
69
+
(** [None] = not present, [Some []] = present without headers,
70
+
[Some headers] = must revalidate for these headers *)
71
+
no_store : bool; (** If true, the response must not be stored *)
72
+
no_transform : bool;
73
+
(** If true, intermediaries must not transform the response *)
74
+
must_revalidate : bool; (** If true, stale responses must be revalidated *)
75
+
proxy_revalidate : bool;
76
+
(** Like must_revalidate but only for shared caches *)
77
+
must_understand : bool;
78
+
(** If true, cache must understand the caching rules *)
79
+
private_ : string list option;
80
+
(** [None] = not present, [Some []] = entirely private, [Some headers] =
81
+
these headers are private *)
82
+
public : bool; (** If true, response may be stored by any cache *)
83
+
immutable : bool;
84
+
(** If true, response will not change during freshness lifetime *)
85
+
stale_while_revalidate : int option;
86
+
(** Seconds stale responses may be served while revalidating *)
87
+
stale_if_error : int option;
88
+
(** Seconds stale responses may be served on error *)
89
+
extensions : (string * string option) list;
90
+
(** Unknown directives for forward compatibility *)
91
+
}
92
+
(** Parsed response Cache-Control header *)
93
+
94
+
type request = {
95
+
req_max_age : int option;
96
+
(** max-age directive - maximum age client will accept *)
97
+
req_max_stale : int option option;
98
+
(** [None] = not present, [Some None] = accept any stale, [Some (Some n)]
99
+
= accept stale up to n seconds *)
100
+
req_min_fresh : int option;
101
+
(** min-fresh directive - response must be fresh for at least n more
102
+
seconds *)
103
+
req_no_cache : bool; (** If true, force revalidation with origin server *)
104
+
req_no_store : bool; (** If true, response must not be stored *)
105
+
req_no_transform : bool; (** If true, intermediaries must not transform *)
106
+
req_only_if_cached : bool;
107
+
(** If true, return cached response or 504 Gateway Timeout *)
108
+
req_extensions : (string * string option) list;
109
+
(** Unknown directives for forward compatibility *)
110
+
}
111
+
(** Parsed request Cache-Control header *)
112
+
113
+
(** {1 Empty Values} *)
114
+
115
+
val empty_response : response
116
+
(** An empty response Cache-Control (no directives set). *)
117
+
118
+
val empty_request : request
119
+
(** An empty request Cache-Control (no directives set). *)
120
+
121
+
(** {1 Parsing Functions} *)
122
+
123
+
val parse_response : string -> response
124
+
(** [parse_response header_value] parses a response Cache-Control header value.
125
+
Unknown directives are preserved in [extensions] for forward compatibility.
126
+
*)
127
+
128
+
val parse_request : string -> request
129
+
(** [parse_request header_value] parses a request Cache-Control header value.
130
+
Unknown directives are preserved in [req_extensions] for forward
131
+
compatibility. *)
132
+
133
+
(** {1 Freshness Calculation}
134
+
135
+
RFC 9111 Section 4.2: Freshness *)
136
+
137
+
val freshness_lifetime :
138
+
response_cc:response -> ?expires:string -> ?date:string -> unit -> int option
139
+
(** [freshness_lifetime ~response_cc ?expires ?date ()] calculates the freshness
140
+
lifetime of a response in seconds, based on Cache-Control directives and
141
+
optional Expires/Date headers.
142
+
143
+
Priority (per RFC 9111 Section 4.2.1): 1. max-age directive 2. Expires
144
+
header minus Date header 3. Returns [None] if no explicit freshness (caller
145
+
should use heuristics).
146
+
147
+
@param response_cc Parsed Cache-Control from response.
148
+
@param expires Optional Expires header value (HTTP-date format).
149
+
@param date Optional Date header value (HTTP-date format). *)
150
+
151
+
(** {1 Age Calculation}
152
+
153
+
Per RFC 9111 Section 4.2.3: Calculating Age. *)
154
+
155
+
type age_inputs = {
156
+
date_value : Ptime.t option;
157
+
(** Value of Date header (when response was generated) *)
158
+
age_value : int; (** Value of Age header in seconds (0 if not present) *)
159
+
request_time : Ptime.t; (** Time when the request was initiated *)
160
+
response_time : Ptime.t; (** Time when the response was received *)
161
+
}
162
+
(** Inputs required for age calculation per RFC 9111 Section 4.2.3. *)
163
+
164
+
val calculate_age : inputs:age_inputs -> now:Ptime.t -> int
165
+
(** [calculate_age ~inputs ~now] calculates the current age of a cached
166
+
response.
167
+
168
+
Per RFC 9111 Section 4.2.3:
169
+
{v
170
+
apparent_age = max(0, response_time - date_value)
171
+
response_delay = response_time - request_time
172
+
corrected_age_value = age_value + response_delay
173
+
corrected_initial_age = max(apparent_age, corrected_age_value)
174
+
resident_time = now - response_time
175
+
current_age = corrected_initial_age + resident_time
176
+
v}
177
+
178
+
@return Current age in seconds. *)
179
+
180
+
(** {1 Heuristic Freshness}
181
+
182
+
Per RFC 9111 Section 4.2.2: Calculating Heuristic Freshness. *)
183
+
184
+
val default_heuristic_fraction : float
185
+
(** Default heuristic fraction: 10% of time since Last-Modified. RFC 9111
186
+
recommends this as a typical value. *)
187
+
188
+
val default_max_heuristic_age : int
189
+
(** Maximum heuristic freshness lifetime: 1 day (86400 seconds). *)
190
+
191
+
val heuristic_freshness :
192
+
?last_modified:string ->
193
+
response_time:Ptime.t ->
194
+
?fraction:float ->
195
+
?max_age:int ->
196
+
unit ->
197
+
int option
198
+
(** [heuristic_freshness ?last_modified ~response_time ?fraction ?max_age ()]
199
+
calculates heuristic freshness lifetime when no explicit caching info
200
+
provided.
201
+
202
+
Per RFC 9111 Section 4.2.2, caches MAY use heuristics when explicit
203
+
freshness is not available. The typical heuristic is 10% of time since
204
+
Last-Modified.
205
+
206
+
@param last_modified Value of Last-Modified header
207
+
@param response_time When the response was received
208
+
@param fraction Fraction of (now - last_modified) to use (default 10%)
209
+
@param max_age Maximum heuristic age in seconds (default 1 day)
210
+
@return Heuristic freshness lifetime in seconds, or None. *)
211
+
212
+
val is_fresh : current_age:int -> freshness_lifetime:int -> bool
213
+
(** [is_fresh ~current_age ~freshness_lifetime] returns true if a cached
214
+
response is still fresh (current_age < freshness_lifetime). *)
215
+
216
+
val can_serve_stale :
217
+
request_cc:request -> current_age:int -> freshness_lifetime:int -> bool
218
+
(** [can_serve_stale ~request_cc ~current_age ~freshness_lifetime] returns true
219
+
if a stale response can still be served based on request Cache-Control
220
+
directives (specifically max-stale). *)
221
+
222
+
(** {1 Cacheability Checks} *)
223
+
224
+
val is_cacheable : response_cc:response -> status:int -> bool
225
+
(** [is_cacheable ~response_cc ~status] returns true if the response may be
226
+
cached based on its Cache-Control directives and HTTP status code.
227
+
228
+
A response is cacheable if:
229
+
- no-store is NOT present
230
+
- Status is cacheable by default (200, 203, 204, 206, 300, 301, 308, 404,
231
+
405, 410, 414, 501) OR explicit caching directive is present. *)
232
+
233
+
val must_revalidate : response_cc:response -> bool
234
+
(** [must_revalidate ~response_cc] returns true if cached response must be
235
+
revalidated with the origin server before use.
236
+
237
+
True if any of: must-revalidate, proxy-revalidate, or no-cache is set. *)
238
+
239
+
val is_public : response_cc:response -> bool
240
+
(** [is_public ~response_cc] returns true if the response may be stored in
241
+
shared caches (CDNs, proxies). *)
242
+
243
+
val is_private : response_cc:response -> bool
244
+
(** [is_private ~response_cc] returns true if the response may only be stored in
245
+
private caches (browser cache). *)
246
+
247
+
(** {1 Pretty Printers} *)
248
+
249
+
val pp_response : Format.formatter -> response -> unit
250
+
(** Pretty print a parsed response Cache-Control. *)
251
+
252
+
val pp_request : Format.formatter -> request -> unit
253
+
(** Pretty print a parsed request Cache-Control. *)
+15
lib/dune
+15
lib/dune
+478
lib/error.ml
+478
lib/error.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Centralized error handling for the Requests library using Eio.Io exceptions
7
+
*)
8
+
9
+
let src = Logs.Src.create "requests.error" ~doc:"HTTP Request Errors"
10
+
11
+
module Log = (val Logs.src_log src : Logs.LOG)
12
+
13
+
(** {1 Error Type}
14
+
15
+
Following the Eio.Io exception pattern for structured error handling. Each
16
+
variant contains a record with contextual information. *)
17
+
18
+
type t =
19
+
(* Timeout errors *)
20
+
| Timeout of { operation : string; duration : float option }
21
+
(* Redirect errors *)
22
+
| Too_many_redirects of { url : string; count : int; max : int }
23
+
| Invalid_redirect of { url : string; reason : string }
24
+
(* HTTP response errors *)
25
+
(* Note: headers stored as list to avoid dependency cycle with Headers module *)
26
+
| Http_error of {
27
+
url : string;
28
+
status : int;
29
+
reason : string;
30
+
body_preview : string option;
31
+
headers : (string * string) list;
32
+
}
33
+
(* Authentication errors *)
34
+
| Authentication_failed of { url : string; reason : string }
35
+
(* Connection errors - granular breakdown per Recommendation #17 *)
36
+
| Dns_resolution_failed of { hostname : string }
37
+
| Tcp_connect_failed of { host : string; port : int; reason : string }
38
+
| Tls_handshake_failed of { host : string; reason : string }
39
+
(* Security-related errors *)
40
+
| Invalid_header of { name : string; reason : string }
41
+
| Body_too_large of { limit : int64; actual : int64 option }
42
+
| Headers_too_large of { limit : int; actual : int }
43
+
| Decompression_bomb of { limit : int64; ratio : float }
44
+
| Content_length_mismatch of { expected : int64; actual : int64 }
45
+
| Insecure_auth of { url : string; auth_type : string }
46
+
(** Per RFC 7617 Section 4 and RFC 6750 Section 5.1: Basic, Bearer, and
47
+
Digest authentication over unencrypted HTTP exposes credentials to
48
+
eavesdropping. *)
49
+
(* JSON errors *)
50
+
| Json_parse_error of { body_preview : string; reason : string }
51
+
| Json_encode_error of { reason : string }
52
+
(* Other errors *)
53
+
| Proxy_error of { host : string; reason : string }
54
+
| Encoding_error of { encoding : string; reason : string }
55
+
| Invalid_url of { url : string; reason : string }
56
+
| Invalid_request of { reason : string }
57
+
(* OAuth 2.0 errors - per RFC 6749 Section 5.2 *)
58
+
| Oauth_error of {
59
+
error_code : string;
60
+
description : string option;
61
+
uri : string option;
62
+
}
63
+
(** OAuth 2.0 error response from authorization server. Per
64
+
{{:https://datatracker.ietf.org/doc/html/rfc6749#section-5.2}RFC 6749
65
+
Section 5.2}. *)
66
+
| Token_refresh_failed of { reason : string }
67
+
(** Token refresh operation failed. *)
68
+
| Token_expired
69
+
(** Access token has expired and no refresh token is available. *)
70
+
(* HTTP/2 protocol errors - per RFC 9113 *)
71
+
| H2_protocol_error of { code : int32; message : string }
72
+
(** HTTP/2 connection error per
73
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.4.1}RFC
74
+
9113 Section 5.4.1}. Error codes are defined in RFC 9113 Section 7.
75
+
*)
76
+
| H2_stream_error of { stream_id : int32; code : int32; message : string }
77
+
(** HTTP/2 stream error per
78
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.4.2}RFC
79
+
9113 Section 5.4.2}. *)
80
+
| H2_flow_control_error of { stream_id : int32 option }
81
+
(** Flow control window exceeded per
82
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.2}RFC 9113
83
+
Section 5.2}. *)
84
+
| H2_compression_error of { message : string }
85
+
(** HPACK decompression failed per
86
+
{{:https://datatracker.ietf.org/doc/html/rfc7541}RFC 7541}. *)
87
+
| H2_settings_timeout
88
+
(** SETTINGS acknowledgment timeout per
89
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-6.5.3}RFC
90
+
9113 Section 6.5.3}. *)
91
+
| H2_goaway of { last_stream_id : int32; code : int32; debug : string }
92
+
(** Server sent GOAWAY frame per
93
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-6.8}RFC 9113
94
+
Section 6.8}. *)
95
+
| H2_frame_error of { frame_type : int; message : string }
96
+
(** Invalid frame received per RFC 9113 Section 4-6. *)
97
+
| H2_header_validation_error of { message : string }
98
+
(** HTTP/2 header validation failed per RFC 9113 Section 8.2-8.3. *)
99
+
100
+
(** {1 URL and Credential Sanitization}
101
+
102
+
Per Recommendation #20: Remove sensitive info from error messages *)
103
+
104
+
let sanitize_url url =
105
+
try
106
+
let uri = Uri.of_string url in
107
+
let sanitized = Uri.with_userinfo uri None in
108
+
Uri.to_string sanitized
109
+
with Invalid_argument _ | Failure _ ->
110
+
url (* If parsing fails, return original *)
111
+
112
+
(** List of header names considered sensitive (lowercase) *)
113
+
let sensitive_header_names =
114
+
[
115
+
"authorization";
116
+
"cookie";
117
+
"csrf-token";
118
+
"proxy-authorization";
119
+
"x-api-key";
120
+
"x-csrf-token";
121
+
"x-xsrf-token";
122
+
"api-key";
123
+
"set-cookie";
124
+
]
125
+
126
+
(** Check if a header name is sensitive (case-insensitive) *)
127
+
let is_sensitive_header name =
128
+
List.mem (String.lowercase_ascii name) sensitive_header_names
129
+
130
+
(** Sanitize a header list by redacting sensitive values *)
131
+
let sanitize_headers headers =
132
+
List.map
133
+
(fun (name, value) ->
134
+
if is_sensitive_header name then (name, "[REDACTED]") else (name, value))
135
+
headers
136
+
137
+
(** {1 Pretty Printing} *)
138
+
139
+
let pp_error ppf = function
140
+
| Timeout { operation; duration } -> (
141
+
match duration with
142
+
| Some d -> Fmt.pf ppf "Timeout during %s after %.2fs" operation d
143
+
| None -> Fmt.pf ppf "Timeout during %s" operation)
144
+
| Too_many_redirects { url; count; max } ->
145
+
Fmt.pf ppf "Too many redirects (%d/%d) for URL: %s" count max
146
+
(sanitize_url url)
147
+
| Invalid_redirect { url; reason } ->
148
+
Fmt.pf ppf "Invalid redirect to %s: %s" (sanitize_url url) reason
149
+
| Http_error { url; status; reason; body_preview; headers = _ } ->
150
+
Fmt.pf ppf "@[<v>HTTP %d %s@ URL: %s" status reason (sanitize_url url);
151
+
Option.iter
152
+
(fun body ->
153
+
let preview =
154
+
if String.length body > 200 then String.sub body 0 200 ^ "..."
155
+
else body
156
+
in
157
+
Fmt.pf ppf "@ Body: %s" preview)
158
+
body_preview;
159
+
Fmt.pf ppf "@]"
160
+
| Authentication_failed { url; reason } ->
161
+
Fmt.pf ppf "Authentication failed for %s: %s" (sanitize_url url) reason
162
+
| Dns_resolution_failed { hostname } ->
163
+
Fmt.pf ppf "DNS resolution failed for hostname: %s" hostname
164
+
| Tcp_connect_failed { host; port; reason } ->
165
+
Fmt.pf ppf "TCP connection to %s:%d failed: %s" host port reason
166
+
| Tls_handshake_failed { host; reason } ->
167
+
Fmt.pf ppf "TLS handshake with %s failed: %s" host reason
168
+
| Invalid_header { name; reason } ->
169
+
Fmt.pf ppf "Invalid header '%s': %s" name reason
170
+
| Body_too_large { limit; actual } -> (
171
+
match actual with
172
+
| Some a ->
173
+
Fmt.pf ppf "Response body too large: %Ld bytes (limit: %Ld)" a limit
174
+
| None -> Fmt.pf ppf "Response body exceeds limit of %Ld bytes" limit)
175
+
| Headers_too_large { limit; actual } ->
176
+
Fmt.pf ppf "Response headers too large: %d (limit: %d)" actual limit
177
+
| Decompression_bomb { limit; ratio } ->
178
+
Fmt.pf ppf
179
+
"Decompression bomb detected: ratio %.1f:1 exceeds limit, max size %Ld \
180
+
bytes"
181
+
ratio limit
182
+
| Content_length_mismatch { expected; actual } ->
183
+
Fmt.pf ppf
184
+
"Content-Length mismatch: expected %Ld bytes, received %Ld bytes"
185
+
expected actual
186
+
| Insecure_auth { url; auth_type } ->
187
+
Fmt.pf ppf
188
+
"%s authentication over unencrypted HTTP rejected for %s. Use HTTPS or \
189
+
set allow_insecure_auth=true (not recommended)"
190
+
auth_type (sanitize_url url)
191
+
| Json_parse_error { body_preview; reason } ->
192
+
let preview =
193
+
if String.length body_preview > 100 then
194
+
String.sub body_preview 0 100 ^ "..."
195
+
else body_preview
196
+
in
197
+
Fmt.pf ppf "@[<v>JSON parse error: %s@ Body preview: %s@]" reason preview
198
+
| Json_encode_error { reason } -> Fmt.pf ppf "JSON encode error: %s" reason
199
+
| Proxy_error { host; reason } ->
200
+
Fmt.pf ppf "Proxy error for %s: %s" host reason
201
+
| Encoding_error { encoding; reason } ->
202
+
Fmt.pf ppf "Encoding error (%s): %s" encoding reason
203
+
| Invalid_url { url; reason } ->
204
+
Fmt.pf ppf "Invalid URL '%s': %s" (sanitize_url url) reason
205
+
| Invalid_request { reason } -> Fmt.pf ppf "Invalid request: %s" reason
206
+
| Oauth_error { error_code; description; uri } ->
207
+
Fmt.pf ppf "OAuth error: %s" error_code;
208
+
Option.iter (fun desc -> Fmt.pf ppf " - %s" desc) description;
209
+
Option.iter (fun u -> Fmt.pf ppf " (see: %s)" u) uri
210
+
| Token_refresh_failed { reason } ->
211
+
Fmt.pf ppf "Token refresh failed: %s" reason
212
+
| Token_expired ->
213
+
Fmt.pf ppf "Access token expired and no refresh token available"
214
+
(* HTTP/2 errors *)
215
+
| H2_protocol_error { code; message } ->
216
+
Fmt.pf ppf "HTTP/2 protocol error (code 0x%02lx): %s" code message
217
+
| H2_stream_error { stream_id; code; message } ->
218
+
Fmt.pf ppf "HTTP/2 stream %ld error (code 0x%02lx): %s" stream_id code
219
+
message
220
+
| H2_flow_control_error { stream_id } -> (
221
+
match stream_id with
222
+
| Some id -> Fmt.pf ppf "HTTP/2 flow control error on stream %ld" id
223
+
| None -> Fmt.pf ppf "HTTP/2 connection flow control error")
224
+
| H2_compression_error { message } ->
225
+
Fmt.pf ppf "HTTP/2 HPACK compression error: %s" message
226
+
| H2_settings_timeout -> Fmt.pf ppf "HTTP/2 SETTINGS acknowledgment timeout"
227
+
| H2_goaway { last_stream_id; code; debug } ->
228
+
Fmt.pf ppf "HTTP/2 GOAWAY received (last_stream=%ld, code=0x%02lx): %s"
229
+
last_stream_id code debug
230
+
| H2_frame_error { frame_type; message } ->
231
+
Fmt.pf ppf "HTTP/2 frame error (type 0x%02x): %s" frame_type message
232
+
| H2_header_validation_error { message } ->
233
+
Fmt.pf ppf "HTTP/2 header validation error: %s" message
234
+
235
+
(** {1 Eio.Exn Integration}
236
+
237
+
Following the pattern from ocaml-conpool for structured Eio exceptions *)
238
+
239
+
type Eio.Exn.err += E of t
240
+
241
+
let err e = Eio.Exn.create (E e)
242
+
243
+
let () =
244
+
Eio.Exn.register_pp (fun f -> function
245
+
| E e ->
246
+
Fmt.pf f "Requests: ";
247
+
pp_error f e;
248
+
true
249
+
| _ -> false)
250
+
251
+
(** {1 Query Functions}
252
+
253
+
Per Recommendation #17: Enable smarter retry logic and error handling *)
254
+
255
+
let is_timeout = function Timeout _ -> true | _ -> false
256
+
let is_dns = function Dns_resolution_failed _ -> true | _ -> false
257
+
let is_tls = function Tls_handshake_failed _ -> true | _ -> false
258
+
259
+
let is_connection = function
260
+
| Dns_resolution_failed _ -> true
261
+
| Tcp_connect_failed _ -> true
262
+
| Tls_handshake_failed _ -> true
263
+
| _ -> false
264
+
265
+
let is_http_error = function Http_error _ -> true | _ -> false
266
+
267
+
let is_client_error = function
268
+
| Http_error { status; _ } -> status >= 400 && status < 500
269
+
| Authentication_failed _ -> true
270
+
| Invalid_url _ -> true
271
+
| Invalid_request _ -> true
272
+
| Invalid_header _ -> true
273
+
| _ -> false
274
+
275
+
let is_server_error = function
276
+
| Http_error { status; _ } -> status >= 500 && status < 600
277
+
| _ -> false
278
+
279
+
let is_retryable = function
280
+
| Timeout _ -> true
281
+
| Dns_resolution_failed _ -> true
282
+
| Tcp_connect_failed _ -> true
283
+
| Tls_handshake_failed _ -> true
284
+
| Http_error { status; _ } ->
285
+
(* Retryable status codes: 408, 429, 500, 502, 503, 504 *)
286
+
List.mem status [ 408; 429; 500; 502; 503; 504 ]
287
+
| Proxy_error _ -> true
288
+
| _ -> false
289
+
290
+
let is_security_error = function
291
+
| Invalid_header _ -> true
292
+
| Body_too_large _ -> true
293
+
| Headers_too_large _ -> true
294
+
| Decompression_bomb _ -> true
295
+
| Invalid_redirect _ -> true
296
+
| Insecure_auth _ -> true
297
+
| _ -> false
298
+
299
+
let is_json_error = function
300
+
| Json_parse_error _ -> true
301
+
| Json_encode_error _ -> true
302
+
| _ -> false
303
+
304
+
let is_oauth_error = function
305
+
| Oauth_error _ -> true
306
+
| Token_refresh_failed _ -> true
307
+
| Token_expired -> true
308
+
| _ -> false
309
+
310
+
(** {1 HTTP/2 Error Query Functions} *)
311
+
312
+
let is_h2_error = function
313
+
| H2_protocol_error _ -> true
314
+
| H2_stream_error _ -> true
315
+
| H2_flow_control_error _ -> true
316
+
| H2_compression_error _ -> true
317
+
| H2_settings_timeout -> true
318
+
| H2_goaway _ -> true
319
+
| H2_frame_error _ -> true
320
+
| H2_header_validation_error _ -> true
321
+
| _ -> false
322
+
323
+
let is_h2_connection_error = function
324
+
| H2_protocol_error _ -> true
325
+
| H2_flow_control_error { stream_id = None } -> true
326
+
| H2_compression_error _ -> true
327
+
| H2_settings_timeout -> true
328
+
| H2_goaway _ -> true
329
+
| _ -> false
330
+
331
+
let is_h2_stream_error = function
332
+
| H2_stream_error _ -> true
333
+
| H2_flow_control_error { stream_id = Some _ } -> true
334
+
| _ -> false
335
+
336
+
let is_h2_retryable = function
337
+
(* GOAWAY with NO_ERROR is graceful shutdown - safe to retry *)
338
+
| H2_goaway { code = 0l; _ } -> true
339
+
(* REFUSED_STREAM means server didn't process, safe to retry *)
340
+
| H2_stream_error { code = 0x7l; _ } -> true
341
+
| H2_protocol_error { code = 0x7l; _ } -> true
342
+
(* ENHANCE_YOUR_CALM might be retryable after backoff *)
343
+
| H2_stream_error { code = 0xbl; _ } -> true
344
+
| _ -> false
345
+
346
+
let h2_error_code = function
347
+
| H2_protocol_error { code; _ } -> Some code
348
+
| H2_stream_error { code; _ } -> Some code
349
+
| H2_goaway { code; _ } -> Some code
350
+
| _ -> None
351
+
352
+
let h2_stream_id = function
353
+
| H2_stream_error { stream_id; _ } -> Some stream_id
354
+
| H2_flow_control_error { stream_id } -> stream_id
355
+
| H2_goaway { last_stream_id; _ } -> Some last_stream_id
356
+
| _ -> None
357
+
358
+
(** {1 Error Extraction}
359
+
360
+
Extract error from Eio.Io exception *)
361
+
362
+
let of_eio_exn = function Eio.Io (E e, _) -> Some e | _ -> None
363
+
364
+
(** {1 HTTP Status Helpers} *)
365
+
366
+
let http_status = function Http_error { status; _ } -> Some status | _ -> None
367
+
368
+
let url = function
369
+
| Too_many_redirects { url; _ } -> Some url
370
+
| Invalid_redirect { url; _ } -> Some url
371
+
| Http_error { url; _ } -> Some url
372
+
| Authentication_failed { url; _ } -> Some url
373
+
| Invalid_url { url; _ } -> Some url
374
+
| _ -> None
375
+
376
+
(** {1 String Conversion} *)
377
+
378
+
let pp = pp_error
379
+
let to_string e = Fmt.str "%a" pp_error e
380
+
381
+
(** {1 Convenience Constructors}
382
+
383
+
These functions provide a more concise way to raise common errors compared
384
+
to the verbose [raise (err (Error_type { field = value; ... }))] pattern. *)
385
+
386
+
let invalid_request ~reason = err (Invalid_request { reason })
387
+
let invalid_redirect ~url ~reason = err (Invalid_redirect { url; reason })
388
+
let invalid_url ~url ~reason = err (Invalid_url { url; reason })
389
+
let timeout ~operation ?duration () = err (Timeout { operation; duration })
390
+
let body_too_large ~limit ?actual () = err (Body_too_large { limit; actual })
391
+
let headers_too_large ~limit ~actual = err (Headers_too_large { limit; actual })
392
+
let proxy_error ~host ~reason = err (Proxy_error { host; reason })
393
+
394
+
let tls_handshake_failed ~host ~reason =
395
+
err (Tls_handshake_failed { host; reason })
396
+
397
+
let tcp_connect_failed ~host ~port ~reason =
398
+
err (Tcp_connect_failed { host; port; reason })
399
+
400
+
(** {1 Format String Constructors}
401
+
402
+
These functions accept printf-style format strings for the reason field,
403
+
making error construction more concise when messages need interpolation. *)
404
+
405
+
let invalid_requestf fmt =
406
+
Fmt.kstr (fun reason -> err (Invalid_request { reason })) fmt
407
+
408
+
let invalid_redirectf ~url fmt =
409
+
Fmt.kstr (fun reason -> err (Invalid_redirect { url; reason })) fmt
410
+
411
+
let invalid_urlf ~url fmt =
412
+
Fmt.kstr (fun reason -> err (Invalid_url { url; reason })) fmt
413
+
414
+
let proxy_errorf ~host fmt =
415
+
Fmt.kstr (fun reason -> err (Proxy_error { host; reason })) fmt
416
+
417
+
let tls_handshake_failedf ~host fmt =
418
+
Fmt.kstr (fun reason -> err (Tls_handshake_failed { host; reason })) fmt
419
+
420
+
let tcp_connect_failedf ~host ~port fmt =
421
+
Fmt.kstr (fun reason -> err (Tcp_connect_failed { host; port; reason })) fmt
422
+
423
+
(** {1 OAuth Error Constructors} *)
424
+
425
+
let oauth_error ~error_code ?description ?uri () =
426
+
err (Oauth_error { error_code; description; uri })
427
+
428
+
let token_refresh_failed ~reason = err (Token_refresh_failed { reason })
429
+
let token_expired () = err Token_expired
430
+
431
+
(** {1 HTTP/2 Error Constructors}
432
+
433
+
Per
434
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-7}RFC 9113 Section
435
+
7}. *)
436
+
437
+
let h2_protocol_error ~code ~message = err (H2_protocol_error { code; message })
438
+
439
+
let h2_stream_error ~stream_id ~code ~message =
440
+
err (H2_stream_error { stream_id; code; message })
441
+
442
+
let h2_flow_control_error ?stream_id () =
443
+
err (H2_flow_control_error { stream_id })
444
+
445
+
let h2_compression_error ~message = err (H2_compression_error { message })
446
+
let h2_settings_timeout () = err H2_settings_timeout
447
+
448
+
let h2_goaway ~last_stream_id ~code ~debug =
449
+
err (H2_goaway { last_stream_id; code; debug })
450
+
451
+
let h2_frame_error ~frame_type ~message =
452
+
err (H2_frame_error { frame_type; message })
453
+
454
+
let h2_header_validation_error ~message =
455
+
err (H2_header_validation_error { message })
456
+
457
+
(** {2 HTTP/2 Error Code Names}
458
+
459
+
Per
460
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-7}RFC 9113 Section
461
+
7}. *)
462
+
463
+
let h2_error_code_name = function
464
+
| 0x0l -> "NO_ERROR"
465
+
| 0x1l -> "PROTOCOL_ERROR"
466
+
| 0x2l -> "INTERNAL_ERROR"
467
+
| 0x3l -> "FLOW_CONTROL_ERROR"
468
+
| 0x4l -> "SETTINGS_TIMEOUT"
469
+
| 0x5l -> "STREAM_CLOSED"
470
+
| 0x6l -> "FRAME_SIZE_ERROR"
471
+
| 0x7l -> "REFUSED_STREAM"
472
+
| 0x8l -> "CANCEL"
473
+
| 0x9l -> "COMPRESSION_ERROR"
474
+
| 0xal -> "CONNECT_ERROR"
475
+
| 0xbl -> "ENHANCE_YOUR_CALM"
476
+
| 0xcl -> "INADEQUATE_SECURITY"
477
+
| 0xdl -> "HTTP_1_1_REQUIRED"
478
+
| code -> Fmt.str "UNKNOWN(0x%lx)" code
+404
lib/error.mli
+404
lib/error.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Centralized error handling for the Requests library using Eio.Io exceptions.
7
+
8
+
This module follows the Eio.Io exception pattern for structured error
9
+
handling, providing granular error types and query functions for smart retry
10
+
logic.
11
+
12
+
{2 Usage}
13
+
14
+
Errors are raised using the Eio.Io pattern:
15
+
{[
16
+
raise
17
+
(Error.err
18
+
(Error.Timeout { operation = "connect"; duration = Some 30.0 }))
19
+
]}
20
+
21
+
To catch and handle errors:
22
+
{[
23
+
try
24
+
(* ... HTTP request ... *)
25
+
with
26
+
| Eio.Io (Error.E e, _) when Error.is_retryable e ->
27
+
(* Retry the request *)
28
+
| Eio.Io (Error.E e, _) ->
29
+
Printf.eprintf "Request failed: %s\n" (Error.to_string e)
30
+
]} *)
31
+
32
+
val src : Logs.Src.t
33
+
(** Log source for error reporting. *)
34
+
35
+
(** {1 Error Type}
36
+
37
+
Granular error variants with contextual information. Each variant contains a
38
+
record with relevant details. *)
39
+
40
+
type t =
41
+
(* Timeout errors *)
42
+
| Timeout of { operation : string; duration : float option }
43
+
(* Redirect errors *)
44
+
| Too_many_redirects of { url : string; count : int; max : int }
45
+
| Invalid_redirect of { url : string; reason : string }
46
+
(* HTTP response errors *)
47
+
(* Note: headers stored as list to avoid dependency cycle with Headers module *)
48
+
| Http_error of {
49
+
url : string;
50
+
status : int;
51
+
reason : string;
52
+
body_preview : string option;
53
+
headers : (string * string) list;
54
+
}
55
+
(* Authentication errors *)
56
+
| Authentication_failed of { url : string; reason : string }
57
+
(* Connection errors - granular breakdown *)
58
+
| Dns_resolution_failed of { hostname : string }
59
+
| Tcp_connect_failed of { host : string; port : int; reason : string }
60
+
| Tls_handshake_failed of { host : string; reason : string }
61
+
(* Security-related errors *)
62
+
| Invalid_header of { name : string; reason : string }
63
+
| Body_too_large of { limit : int64; actual : int64 option }
64
+
| Headers_too_large of { limit : int; actual : int }
65
+
| Decompression_bomb of { limit : int64; ratio : float }
66
+
| Content_length_mismatch of { expected : int64; actual : int64 }
67
+
| Insecure_auth of { url : string; auth_type : string }
68
+
(** Per RFC 7617 Section 4 and RFC 6750 Section 5.1: Basic, Bearer, and
69
+
Digest authentication over unencrypted HTTP exposes credentials to
70
+
eavesdropping. Raised when attempting to use these auth methods over
71
+
HTTP without explicit opt-out. *)
72
+
(* JSON errors *)
73
+
| Json_parse_error of { body_preview : string; reason : string }
74
+
| Json_encode_error of { reason : string }
75
+
(* Other errors *)
76
+
| Proxy_error of { host : string; reason : string }
77
+
| Encoding_error of { encoding : string; reason : string }
78
+
| Invalid_url of { url : string; reason : string }
79
+
| Invalid_request of { reason : string }
80
+
(* OAuth 2.0 errors - per RFC 6749 Section 5.2 *)
81
+
| Oauth_error of {
82
+
error_code : string;
83
+
description : string option;
84
+
uri : string option;
85
+
}
86
+
(** OAuth 2.0 error response from authorization server. Per
87
+
{{:https://datatracker.ietf.org/doc/html/rfc6749#section-5.2}RFC 6749
88
+
Section 5.2}. *)
89
+
| Token_refresh_failed of { reason : string }
90
+
(** Token refresh operation failed. *)
91
+
| Token_expired
92
+
(** Access token has expired and no refresh token is available. *)
93
+
(* HTTP/2 protocol errors - per RFC 9113 *)
94
+
| H2_protocol_error of { code : int32; message : string }
95
+
(** HTTP/2 connection error per
96
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.4.1}RFC
97
+
9113 Section 5.4.1}. Error codes are defined in RFC 9113 Section 7.
98
+
*)
99
+
| H2_stream_error of { stream_id : int32; code : int32; message : string }
100
+
(** HTTP/2 stream error per
101
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.4.2}RFC
102
+
9113 Section 5.4.2}. *)
103
+
| H2_flow_control_error of { stream_id : int32 option }
104
+
(** Flow control window exceeded per
105
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.2}RFC 9113
106
+
Section 5.2}. *)
107
+
| H2_compression_error of { message : string }
108
+
(** HPACK decompression failed per
109
+
{{:https://datatracker.ietf.org/doc/html/rfc7541}RFC 7541}. *)
110
+
| H2_settings_timeout
111
+
(** SETTINGS acknowledgment timeout per
112
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-6.5.3}RFC
113
+
9113 Section 6.5.3}. *)
114
+
| H2_goaway of { last_stream_id : int32; code : int32; debug : string }
115
+
(** Server sent GOAWAY frame per
116
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-6.8}RFC 9113
117
+
Section 6.8}. *)
118
+
| H2_frame_error of { frame_type : int; message : string }
119
+
(** Invalid frame received per RFC 9113 Section 4-6. *)
120
+
| H2_header_validation_error of { message : string }
121
+
(** HTTP/2 header validation failed per RFC 9113 Section 8.2-8.3. *)
122
+
123
+
(** {1 Eio.Exn Integration} *)
124
+
125
+
(** Extension of [Eio.Exn.err] for Requests errors *)
126
+
type Eio.Exn.err += E of t
127
+
128
+
val err : t -> exn
129
+
(** [err e] creates an Eio exception from an error. *)
130
+
131
+
(** {1 URL and Credential Sanitization} *)
132
+
133
+
val sanitize_url : string -> string
134
+
(** Remove userinfo (username:password) from a URL for safe logging. *)
135
+
136
+
val sanitize_headers : (string * string) list -> (string * string) list
137
+
(** Redact sensitive headers (Authorization, Cookie, etc.) for safe logging.
138
+
Takes and returns a list of (name, value) pairs. *)
139
+
140
+
val is_sensitive_header : string -> bool
141
+
(** Check if a header name is sensitive (case-insensitive). *)
142
+
143
+
(** {1 Pretty Printing} *)
144
+
145
+
val pp_error : Format.formatter -> t -> unit
146
+
(** Pretty printer for error values. *)
147
+
148
+
(** {1 Query Functions}
149
+
150
+
These functions enable smart error handling without pattern matching. *)
151
+
152
+
val is_timeout : t -> bool
153
+
(** [is_timeout e] returns [true] if [e] is a timeout. *)
154
+
155
+
val is_dns : t -> bool
156
+
(** [is_dns e] returns [true] if [e] is a DNS resolution failure. *)
157
+
158
+
val is_tls : t -> bool
159
+
(** [is_tls e] returns [true] if [e] is a TLS handshake failure. *)
160
+
161
+
val is_connection : t -> bool
162
+
(** [is_connection e] returns [true] if [e] is any connection-related failure
163
+
(DNS, TCP connect, or TLS handshake). *)
164
+
165
+
val is_http_error : t -> bool
166
+
(** [is_http_error e] returns [true] if [e] is an HTTP response error. *)
167
+
168
+
val is_client_error : t -> bool
169
+
(** [is_client_error e] returns [true] if [e] is a client error (4xx status or
170
+
similar). *)
171
+
172
+
val is_server_error : t -> bool
173
+
(** [is_server_error e] returns [true] if [e] is a server error (5xx status). *)
174
+
175
+
val is_retryable : t -> bool
176
+
(** [is_retryable e] returns [true] if [e] is typically retryable. Retryable
177
+
errors include: timeouts, connection errors, and certain HTTP status codes
178
+
(408, 429, 500, 502, 503, 504). *)
179
+
180
+
val is_security_error : t -> bool
181
+
(** [is_security_error e] returns [true] if [e] is security-related (header
182
+
injection, body too large, decompression bomb, etc.). *)
183
+
184
+
val is_json_error : t -> bool
185
+
(** [is_json_error e] returns [true] if [e] is a JSON parsing or encoding error.
186
+
*)
187
+
188
+
val is_oauth_error : t -> bool
189
+
(** [is_oauth_error e] returns [true] if [e] is an OAuth-related error
190
+
(Oauth_error, Token_refresh_failed, Token_expired). *)
191
+
192
+
(** {1 Error Extraction} *)
193
+
194
+
val of_eio_exn : exn -> t option
195
+
(** Extract error from an Eio.Io exception, if it's a Requests error. *)
196
+
197
+
(** {1 HTTP Status Helpers} *)
198
+
199
+
val http_status : t -> int option
200
+
(** Get the HTTP status code from an error, if applicable. *)
201
+
202
+
val url : t -> string option
203
+
(** Get the URL associated with an error, if applicable. *)
204
+
205
+
(** {1 String Conversion} *)
206
+
207
+
val pp : Format.formatter -> t -> unit
208
+
(** [pp ppf e] pretty-prints the error. *)
209
+
210
+
val to_string : t -> string
211
+
(** Convert error to human-readable string. *)
212
+
213
+
(** {1 Convenience Constructors}
214
+
215
+
These functions provide a more concise way to create error exceptions
216
+
compared to the verbose [err (Error_type { field = value; ... })] pattern.
217
+
218
+
Example:
219
+
{[
220
+
(* Instead of: *)
221
+
raise
222
+
(err (Invalid_request { reason = "missing host" }))
223
+
(* Use: *)
224
+
raise
225
+
(invalid_request ~reason:"missing host")
226
+
]} *)
227
+
228
+
val invalid_request : reason:string -> exn
229
+
(** [invalid_request ~reason] creates an [Invalid_request] exception. *)
230
+
231
+
val invalid_redirect : url:string -> reason:string -> exn
232
+
(** [invalid_redirect ~url ~reason] creates an [Invalid_redirect] exception. *)
233
+
234
+
val invalid_url : url:string -> reason:string -> exn
235
+
(** [invalid_url ~url ~reason] creates an [Invalid_url] exception. *)
236
+
237
+
val timeout : operation:string -> ?duration:float -> unit -> exn
238
+
(** [timeout ~operation ?duration ()] creates a [Timeout] exception. *)
239
+
240
+
val body_too_large : limit:int64 -> ?actual:int64 -> unit -> exn
241
+
(** [body_too_large ~limit ?actual ()] creates a [Body_too_large] exception. *)
242
+
243
+
val headers_too_large : limit:int -> actual:int -> exn
244
+
(** [headers_too_large ~limit ~actual] creates a [Headers_too_large] exception.
245
+
*)
246
+
247
+
val proxy_error : host:string -> reason:string -> exn
248
+
(** [proxy_error ~host ~reason] creates a [Proxy_error] exception. *)
249
+
250
+
val tls_handshake_failed : host:string -> reason:string -> exn
251
+
(** [tls_handshake_failed ~host ~reason] creates a [Tls_handshake_failed]
252
+
exception. *)
253
+
254
+
val tcp_connect_failed : host:string -> port:int -> reason:string -> exn
255
+
(** [tcp_connect_failed ~host ~port ~reason] creates a [Tcp_connect_failed]
256
+
exception. *)
257
+
258
+
(** {1 Format String Constructors}
259
+
260
+
These functions accept printf-style format strings for the reason field,
261
+
making error construction more concise when messages need interpolation.
262
+
263
+
Example:
264
+
{[
265
+
(* Instead of: *)
266
+
raise
267
+
(Error.err
268
+
(Error.Invalid_request
269
+
{ reason = Fmt.str "Invalid status code: %s" code_str }))
270
+
(* Use: *)
271
+
raise
272
+
(Error.invalid_requestf "Invalid status code: %s" code_str)
273
+
]} *)
274
+
275
+
val invalid_requestf : ('a, Format.formatter, unit, exn) format4 -> 'a
276
+
(** [invalid_requestf fmt] creates an [Invalid_request] exception with a format
277
+
string. *)
278
+
279
+
val invalid_redirectf :
280
+
url:string -> ('a, Format.formatter, unit, exn) format4 -> 'a
281
+
(** [invalid_redirectf ~url fmt] creates an [Invalid_redirect] exception with a
282
+
format string. *)
283
+
284
+
val invalid_urlf : url:string -> ('a, Format.formatter, unit, exn) format4 -> 'a
285
+
(** [invalid_urlf ~url fmt] creates an [Invalid_url] exception with a format
286
+
string. *)
287
+
288
+
val proxy_errorf :
289
+
host:string -> ('a, Format.formatter, unit, exn) format4 -> 'a
290
+
(** [proxy_errorf ~host fmt] creates a [Proxy_error] exception with a format
291
+
string. *)
292
+
293
+
val tls_handshake_failedf :
294
+
host:string -> ('a, Format.formatter, unit, exn) format4 -> 'a
295
+
(** [tls_handshake_failedf ~host fmt] creates a [Tls_handshake_failed] exception
296
+
with a format string. *)
297
+
298
+
val tcp_connect_failedf :
299
+
host:string -> port:int -> ('a, Format.formatter, unit, exn) format4 -> 'a
300
+
(** [tcp_connect_failedf ~host ~port fmt] creates a [Tcp_connect_failed]
301
+
exception with a format string. *)
302
+
303
+
(** {1 OAuth Error Constructors} *)
304
+
305
+
val oauth_error :
306
+
error_code:string -> ?description:string -> ?uri:string -> unit -> exn
307
+
(** [oauth_error ~error_code ?description ?uri ()] creates an [Oauth_error]
308
+
exception. *)
309
+
310
+
val token_refresh_failed : reason:string -> exn
311
+
(** [token_refresh_failed ~reason] creates a [Token_refresh_failed] exception.
312
+
*)
313
+
314
+
val token_expired : unit -> exn
315
+
(** [token_expired ()] creates a [Token_expired] exception. *)
316
+
317
+
(** {1 HTTP/2 Error Query Functions}
318
+
319
+
Query functions for HTTP/2 specific errors per
320
+
{{:https://datatracker.ietf.org/doc/html/rfc9113}RFC 9113}. *)
321
+
322
+
val is_h2_error : t -> bool
323
+
(** [is_h2_error e] returns [true] if [e] is any HTTP/2 protocol error. *)
324
+
325
+
val is_h2_connection_error : t -> bool
326
+
(** [is_h2_connection_error e] returns [true] if [e] is an HTTP/2
327
+
connection-level error. Connection errors terminate the entire HTTP/2
328
+
connection. *)
329
+
330
+
val is_h2_stream_error : t -> bool
331
+
(** [is_h2_stream_error e] returns [true] if [e] is an HTTP/2 stream-level
332
+
error. Stream errors only affect a single stream. *)
333
+
334
+
val is_h2_retryable : t -> bool
335
+
(** [is_h2_retryable e] returns [true] if the HTTP/2 error is typically
336
+
retryable. Retryable errors include:
337
+
- GOAWAY with NO_ERROR (graceful shutdown)
338
+
- REFUSED_STREAM (server didn't process the request)
339
+
- ENHANCE_YOUR_CALM (after backoff). *)
340
+
341
+
val h2_error_code : t -> int32 option
342
+
(** Get the HTTP/2 error code from an error, if applicable. Error codes are
343
+
defined in RFC 9113 Section 7. *)
344
+
345
+
val h2_stream_id : t -> int32 option
346
+
(** Get the stream ID associated with an HTTP/2 error, if applicable. *)
347
+
348
+
(** {1 HTTP/2 Error Constructors}
349
+
350
+
Convenience constructors for HTTP/2 errors per
351
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-7}RFC 9113 Section
352
+
7}. *)
353
+
354
+
val h2_protocol_error : code:int32 -> message:string -> exn
355
+
(** [h2_protocol_error ~code ~message] creates an [H2_protocol_error] exception.
356
+
*)
357
+
358
+
val h2_stream_error : stream_id:int32 -> code:int32 -> message:string -> exn
359
+
(** [h2_stream_error ~stream_id ~code ~message] creates an [H2_stream_error]
360
+
exception. *)
361
+
362
+
val h2_flow_control_error : ?stream_id:int32 -> unit -> exn
363
+
(** [h2_flow_control_error ?stream_id ()] creates an [H2_flow_control_error]
364
+
exception. If [stream_id] is provided, it's a stream-level error; otherwise,
365
+
it's a connection-level error. *)
366
+
367
+
val h2_compression_error : message:string -> exn
368
+
(** [h2_compression_error ~message] creates an [H2_compression_error] exception.
369
+
*)
370
+
371
+
val h2_settings_timeout : unit -> exn
372
+
(** [h2_settings_timeout ()] creates an [H2_settings_timeout] exception. *)
373
+
374
+
val h2_goaway : last_stream_id:int32 -> code:int32 -> debug:string -> exn
375
+
(** [h2_goaway ~last_stream_id ~code ~debug] creates an [H2_goaway] exception.
376
+
*)
377
+
378
+
val h2_frame_error : frame_type:int -> message:string -> exn
379
+
(** [h2_frame_error ~frame_type ~message] creates an [H2_frame_error] exception.
380
+
*)
381
+
382
+
val h2_header_validation_error : message:string -> exn
383
+
(** [h2_header_validation_error ~message] creates an
384
+
[H2_header_validation_error] exception. *)
385
+
386
+
(** {2 HTTP/2 Error Code Names} *)
387
+
388
+
val h2_error_code_name : int32 -> string
389
+
(** [h2_error_code_name code] returns the name of an HTTP/2 error code. Per RFC
390
+
9113 Section 7:
391
+
- 0x0: NO_ERROR
392
+
- 0x1: PROTOCOL_ERROR
393
+
- 0x2: INTERNAL_ERROR
394
+
- 0x3: FLOW_CONTROL_ERROR
395
+
- 0x4: SETTINGS_TIMEOUT
396
+
- 0x5: STREAM_CLOSED
397
+
- 0x6: FRAME_SIZE_ERROR
398
+
- 0x7: REFUSED_STREAM
399
+
- 0x8: CANCEL
400
+
- 0x9: COMPRESSION_ERROR
401
+
- 0xa: CONNECT_ERROR
402
+
- 0xb: ENHANCE_YOUR_CALM
403
+
- 0xc: INADEQUATE_SECURITY
404
+
- 0xd: HTTP_1_1_REQUIRED. *)
+61
lib/expect_continue.ml
+61
lib/expect_continue.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP 100-Continue configuration
7
+
8
+
Configuration for the HTTP 100-Continue protocol, which allows clients to
9
+
check if the server will accept a request before sending a large body. Per
10
+
RFC 9110 Section 10.1.1 (Expect) and Section 15.2.1 (100 Continue). *)
11
+
12
+
type config =
13
+
[ `Disabled (** Never use 100-continue *)
14
+
| `Always (** Always use 100-continue regardless of body size *)
15
+
| `Threshold of int64 (** Use 100-continue for bodies >= threshold bytes *)
16
+
]
17
+
(** User-facing configuration as a polymorphic variant *)
18
+
19
+
type t = { enabled : bool; threshold : int64; timeout : float }
20
+
(** Internal representation *)
21
+
22
+
let default_threshold = 1_048_576L (* 1MB *)
23
+
24
+
let default =
25
+
{
26
+
enabled = true;
27
+
threshold = default_threshold;
28
+
timeout = 1.0;
29
+
(* 1 second *)
30
+
}
31
+
32
+
let of_config ?(timeout = 1.0) (config : config) : t =
33
+
match config with
34
+
| `Disabled -> { enabled = false; threshold = 0L; timeout }
35
+
| `Always -> { enabled = true; threshold = 0L; timeout }
36
+
| `Threshold n -> { enabled = true; threshold = n; timeout }
37
+
38
+
let v ?(enabled = true) ?(threshold = 1_048_576L) ?(timeout = 1.0) () =
39
+
{ enabled; threshold; timeout }
40
+
41
+
let disabled = { enabled = false; threshold = 0L; timeout = 0.0 }
42
+
let enabled t = t.enabled
43
+
let threshold t = t.threshold
44
+
let timeout t = t.timeout
45
+
let should_use t body_size = t.enabled && body_size >= t.threshold
46
+
47
+
let pp fmt t =
48
+
if not t.enabled then Fmt.pf fmt "100-continue: disabled"
49
+
else if t.threshold = 0L then
50
+
Fmt.pf fmt "100-continue: always (timeout: %.2fs)" t.timeout
51
+
else
52
+
Fmt.pf fmt "100-continue: threshold %Ld bytes (timeout: %.2fs)" t.threshold
53
+
t.timeout
54
+
55
+
let to_string t = Fmt.str "%a" pp t
56
+
57
+
let pp_config fmt (config : config) =
58
+
match config with
59
+
| `Disabled -> Fmt.pf fmt "`Disabled"
60
+
| `Always -> Fmt.pf fmt "`Always"
61
+
| `Threshold n -> Fmt.pf fmt "`Threshold %Ld" n
+89
lib/expect_continue.mli
+89
lib/expect_continue.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP 100-Continue configuration
7
+
8
+
Configuration for the HTTP 100-Continue protocol, which allows clients to
9
+
check if the server will accept a request before sending a large body. Per
10
+
RFC 9110 Section 10.1.1 (Expect) and Section 15.2.1 (100 Continue).
11
+
12
+
{2 Usage}
13
+
14
+
The simplest way to configure 100-continue is with the polymorphic variant:
15
+
{[
16
+
(* Use 100-continue for bodies >= 1MB (default) *)
17
+
let session =
18
+
Requests.v ~sw ~expect_100_continue:(`Threshold 1_048_576L) env
19
+
20
+
(* Always use 100-continue *)
21
+
let session = Requests.v ~sw ~expect_100_continue:`Always env
22
+
23
+
(* Disable 100-continue *)
24
+
let session = Requests.v ~sw ~expect_100_continue:`Disabled env
25
+
]} *)
26
+
27
+
(** {1 Configuration Types} *)
28
+
29
+
type config =
30
+
[ `Disabled (** Never use 100-continue *)
31
+
| `Always (** Always use 100-continue regardless of body size *)
32
+
| `Threshold of int64 (** Use 100-continue for bodies >= threshold bytes *)
33
+
]
34
+
(** User-facing configuration as a polymorphic variant.
35
+
36
+
- [`Disabled]: Never send Expect: 100-continue header
37
+
- [`Always]: Always send Expect: 100-continue for requests with bodies
38
+
- [`Threshold n]: Send Expect: 100-continue for bodies >= n bytes *)
39
+
40
+
type t
41
+
(** Internal configuration type with timeout. *)
42
+
43
+
(** {1 Default Values} *)
44
+
45
+
val default_threshold : int64
46
+
(** Default threshold: 1MB (1_048_576 bytes). *)
47
+
48
+
val default : t
49
+
(** Default configuration: [`Threshold 1_048_576L] with 1.0s timeout. *)
50
+
51
+
val disabled : t
52
+
(** Configuration with 100-Continue disabled. *)
53
+
54
+
(** {1 Construction} *)
55
+
56
+
val of_config : ?timeout:float -> config -> t
57
+
(** [of_config ?timeout config] creates internal configuration from user-facing
58
+
config. Timeout defaults to 1.0s. *)
59
+
60
+
val v : ?enabled:bool -> ?threshold:int64 -> ?timeout:float -> unit -> t
61
+
(** [v ?enabled ?threshold ?timeout ()] creates custom 100-Continue
62
+
configuration. All parameters are optional and default to the values in
63
+
{!default}. *)
64
+
65
+
(** {1 Accessors} *)
66
+
67
+
val enabled : t -> bool
68
+
(** Whether 100-continue is enabled. *)
69
+
70
+
val threshold : t -> int64
71
+
(** Body size threshold in bytes to trigger 100-continue. *)
72
+
73
+
val timeout : t -> float
74
+
(** Timeout in seconds to wait for 100 response. *)
75
+
76
+
val should_use : t -> int64 -> bool
77
+
(** [should_use t body_size] returns [true] if 100-continue should be used for a
78
+
request with the given [body_size]. *)
79
+
80
+
(** {1 Pretty Printing} *)
81
+
82
+
val pp : Format.formatter -> t -> unit
83
+
(** Pretty-printer for 100-Continue configuration. *)
84
+
85
+
val to_string : t -> string
86
+
(** Convert configuration to a human-readable string. *)
87
+
88
+
val pp_config : Format.formatter -> config -> unit
89
+
(** Pretty-printer for the user-facing config variant. *)
+764
lib/header_name.ml
+764
lib/header_name.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP Header Names as Polymorphic Variants
7
+
8
+
This module provides type-safe HTTP header names using polymorphic variants.
9
+
All standard headers have dedicated variants, with [`Other] for non-standard
10
+
or unknown headers. Header names are case-insensitive per RFC 9110 Section
11
+
5.1.
12
+
13
+
Header definitions are based on the IANA HTTP Field Name Registry:
14
+
{{:https://www.iana.org/assignments/http-fields/http-fields.xhtml} IANA HTTP
15
+
Field Name Registry}
16
+
17
+
@see <https://www.rfc-editor.org/rfc/rfc9110> RFC 9110: HTTP Semantics
18
+
@see <https://www.rfc-editor.org/rfc/rfc9111> RFC 9111: HTTP Caching
19
+
@see <https://www.rfc-editor.org/rfc/rfc9112> RFC 9112: HTTP/1.1 *)
20
+
21
+
type standard =
22
+
[ (* {2 RFC 9110: HTTP Semantics - Content Headers} *)
23
+
`Accept
24
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.1>
25
+
RFC 9110 Section 12.5.1 *)
26
+
| `Accept_encoding
27
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.3>
28
+
RFC 9110 Section 12.5.3 *)
29
+
| `Accept_language
30
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.4>
31
+
RFC 9110 Section 12.5.4 *)
32
+
| `Accept_ranges
33
+
(** Indicates whether server supports range requests.
34
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-14.3>
35
+
RFC 9110 Section 14.3 *)
36
+
| `Allow
37
+
(** Lists HTTP methods supported by target resource.
38
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.1>
39
+
RFC 9110 Section 10.2.1 *)
40
+
| `Content_encoding
41
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.4>
42
+
RFC 9110 Section 8.4 *)
43
+
| `Content_language
44
+
(** Natural language(s) of the intended audience.
45
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-8.5>
46
+
RFC 9110 Section 8.5 *)
47
+
| `Content_length
48
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.6>
49
+
RFC 9110 Section 8.6 *)
50
+
| `Content_location
51
+
(** URI reference for the representation.
52
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-8.7>
53
+
RFC 9110 Section 8.7 *)
54
+
| `Content_range
55
+
(** Indicates which part of representation is enclosed (206 responses).
56
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-14.4>
57
+
RFC 9110 Section 14.4 *)
58
+
| `Content_type
59
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.3>
60
+
RFC 9110 Section 8.3 *)
61
+
| (* {2 RFC 9110: HTTP Semantics - Request Context} *)
62
+
`Expect
63
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.1>
64
+
RFC 9110 Section 10.1.1 *)
65
+
| `From
66
+
(** Email address of the human user controlling the user agent.
67
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.2>
68
+
RFC 9110 Section 10.1.2 *)
69
+
| `Host
70
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.2>
71
+
RFC 9110 Section 7.2 *)
72
+
| `Max_forwards
73
+
(** Limits forwarding of TRACE/OPTIONS requests.
74
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-7.6.2>
75
+
RFC 9110 Section 7.6.2 *)
76
+
| `Range
77
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.2>
78
+
RFC 9110 Section 14.2 *)
79
+
| `Referer
80
+
(** URI of the resource from which request URI was obtained. Note: Header
81
+
name is intentionally misspelled (historical).
82
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.3>
83
+
RFC 9110 Section 10.1.3 *)
84
+
| `Te
85
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.4>
86
+
RFC 9110 Section 10.1.4 *)
87
+
| `User_agent
88
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.5>
89
+
RFC 9110 Section 10.1.5 *)
90
+
| (* {2 RFC 9110: HTTP Semantics - Response Context} *)
91
+
`Location
92
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.2>
93
+
RFC 9110 Section 10.2.2 *)
94
+
| `Retry_after
95
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.3>
96
+
RFC 9110 Section 10.2.3 *)
97
+
| `Server
98
+
(** Information about the origin server software.
99
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.4>
100
+
RFC 9110 Section 10.2.4 *)
101
+
| (* {2 RFC 9110: HTTP Semantics - Validators} *)
102
+
`Etag
103
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.8.3>
104
+
RFC 9110 Section 8.8.3 *)
105
+
| `Last_modified
106
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.8.2>
107
+
RFC 9110 Section 8.8.2 *)
108
+
| `Vary
109
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.5>
110
+
RFC 9110 Section 12.5.5 *)
111
+
| (* {2 RFC 9110: HTTP Semantics - Conditional Requests} *)
112
+
`If_match
113
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.1>
114
+
RFC 9110 Section 13.1.1 *)
115
+
| `If_modified_since
116
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.3>
117
+
RFC 9110 Section 13.1.3 *)
118
+
| `If_none_match
119
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.2>
120
+
RFC 9110 Section 13.1.2 *)
121
+
| `If_range
122
+
(** Makes Range request conditional on representation unchanged.
123
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.5>
124
+
RFC 9110 Section 13.1.5 *)
125
+
| `If_unmodified_since
126
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.4>
127
+
RFC 9110 Section 13.1.4 *)
128
+
| (* {2 RFC 9110: HTTP Semantics - Authentication} *)
129
+
`Authorization
130
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.2>
131
+
RFC 9110 Section 11.6.2 *)
132
+
| `Authentication_info
133
+
(** Server sends after successful auth (e.g., nextnonce for Digest).
134
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.3>
135
+
RFC 9110 Section 11.6.3 *)
136
+
| `Proxy_authenticate
137
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.7.1>
138
+
RFC 9110 Section 11.7.1 *)
139
+
| `Proxy_authentication_info
140
+
(** Proxy sends after successful auth.
141
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-11.7.3>
142
+
RFC 9110 Section 11.7.3 *)
143
+
| `Proxy_authorization
144
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.7.2>
145
+
RFC 9110 Section 11.7.2 *)
146
+
| `Www_authenticate
147
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.1>
148
+
RFC 9110 Section 11.6.1 *)
149
+
| (* {2 RFC 9110: HTTP Semantics - Connection Management} *)
150
+
`Connection
151
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.6.1>
152
+
RFC 9110 Section 7.6.1 *)
153
+
| `Upgrade
154
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.8>
155
+
RFC 9110 Section 7.8 *)
156
+
| `Via
157
+
(** Records intermediate protocols and recipients (proxies/gateways).
158
+
@see <https://www.rfc-editor.org/rfc/rfc9110#section-7.6.3>
159
+
RFC 9110 Section 7.6.3 *)
160
+
| (* {2 RFC 9110: HTTP Semantics - Date} *)
161
+
`Date
162
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-6.6.1>
163
+
RFC 9110 Section 6.6.1 *)
164
+
| (* {2 RFC 9111: HTTP Caching} *)
165
+
`Age
166
+
(** @see <https://www.rfc-editor.org/rfc/rfc9111#section-5.1>
167
+
RFC 9111 Section 5.1 *)
168
+
| `Cache_control
169
+
(** @see <https://www.rfc-editor.org/rfc/rfc9111#section-5.2>
170
+
RFC 9111 Section 5.2 *)
171
+
| `Expires
172
+
(** @see <https://www.rfc-editor.org/rfc/rfc9111#section-5.3>
173
+
RFC 9111 Section 5.3 *)
174
+
| `Pragma
175
+
(** Deprecated but widely used for HTTP/1.0 compatibility.
176
+
@see <https://www.rfc-editor.org/rfc/rfc9111#section-5.4>
177
+
RFC 9111 Section 5.4
178
+
@deprecated Use Cache-Control instead *)
179
+
| `Cache_status
180
+
(** Structured field indicating cache handling (hit/miss/etc).
181
+
@see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211 *)
182
+
| (* {2 RFC 9112: HTTP/1.1} *)
183
+
`Keep_alive
184
+
(** @see <https://www.rfc-editor.org/rfc/rfc2068#section-19.7.1>
185
+
RFC 2068 Section 19.7.1 *)
186
+
| `Trailer
187
+
(** @see <https://www.rfc-editor.org/rfc/rfc9110#section-6.6.2>
188
+
RFC 9110 Section 6.6.2 *)
189
+
| `Transfer_encoding
190
+
(** @see <https://www.rfc-editor.org/rfc/rfc9112#section-6.1>
191
+
RFC 9112 Section 6.1 *)
192
+
| (* {2 Cookies - RFC 6265bis} *)
193
+
`Cookie
194
+
(** @see <https://www.rfc-editor.org/rfc/rfc6265> RFC 6265 *)
195
+
| `Set_cookie (** @see <https://www.rfc-editor.org/rfc/rfc6265> RFC 6265 *)
196
+
| (* {2 Link Relations - RFC 8288} *)
197
+
`Link
198
+
(** @see <https://www.rfc-editor.org/rfc/rfc8288> RFC 8288 *)
199
+
| (* {2 CORS Headers - Fetch Standard}
200
+
201
+
Cross-Origin Resource Sharing headers for controlling cross-origin requests.
202
+
@see <https://fetch.spec.whatwg.org/> Fetch Standard *)
203
+
`Access_control_allow_credentials
204
+
(** Whether response can be shared when credentials mode is "include".
205
+
@see <https://fetch.spec.whatwg.org/#http-access-control-allow-credentials>
206
+
Fetch *)
207
+
| `Access_control_allow_headers
208
+
(** Headers allowed in actual request.
209
+
@see <https://fetch.spec.whatwg.org/#http-access-control-allow-headers>
210
+
Fetch *)
211
+
| `Access_control_allow_methods
212
+
(** HTTP methods allowed for actual request.
213
+
@see <https://fetch.spec.whatwg.org/#http-access-control-allow-methods>
214
+
Fetch *)
215
+
| `Access_control_allow_origin
216
+
(** Whether response can be shared, by origin.
217
+
@see <https://fetch.spec.whatwg.org/#http-access-control-allow-origin>
218
+
Fetch *)
219
+
| `Access_control_expose_headers
220
+
(** Headers that can be exposed to the requesting script.
221
+
@see <https://fetch.spec.whatwg.org/#http-access-control-expose-headers>
222
+
Fetch *)
223
+
| `Access_control_max_age
224
+
(** How long preflight results can be cached.
225
+
@see <https://fetch.spec.whatwg.org/#http-access-control-max-age> Fetch
226
+
*)
227
+
| `Access_control_request_headers
228
+
(** Headers to be used in actual request (preflight).
229
+
@see <https://fetch.spec.whatwg.org/#http-access-control-request-headers>
230
+
Fetch *)
231
+
| `Access_control_request_method
232
+
(** Method to be used in actual request (preflight).
233
+
@see <https://fetch.spec.whatwg.org/#http-access-control-request-method>
234
+
Fetch *)
235
+
| `Origin
236
+
(** Origin of the request.
237
+
@see <https://www.rfc-editor.org/rfc/rfc6454> RFC 6454 *)
238
+
| (* {2 Cross-Origin Policy Headers - HTML Standard} *)
239
+
`Cross_origin_embedder_policy
240
+
(** Controls cross-origin embedding.
241
+
@see <https://html.spec.whatwg.org/multipage/origin.html#coep> HTML *)
242
+
| `Cross_origin_embedder_policy_report_only
243
+
(** Report-only mode for COEP.
244
+
@see <https://html.spec.whatwg.org/multipage/origin.html#coep> HTML *)
245
+
| `Cross_origin_opener_policy
246
+
(** Controls browsing context group sharing.
247
+
@see <https://html.spec.whatwg.org/multipage/origin.html#cross-origin-opener-policies>
248
+
HTML *)
249
+
| `Cross_origin_opener_policy_report_only
250
+
(** Report-only mode for COOP.
251
+
@see <https://html.spec.whatwg.org/multipage/origin.html#cross-origin-opener-policies>
252
+
HTML *)
253
+
| `Cross_origin_resource_policy
254
+
(** Controls no-cors cross-origin requests.
255
+
@see <https://fetch.spec.whatwg.org/#cross-origin-resource-policy-header>
256
+
Fetch *)
257
+
| (* {2 Fetch Metadata Headers - W3C}
258
+
259
+
Request headers providing context about the request initiator.
260
+
@see <https://www.w3.org/TR/fetch-metadata/> Fetch Metadata Request Headers *)
261
+
`Sec_fetch_dest
262
+
(** Request destination (document, image, script, etc.).
263
+
@see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-dest-header>
264
+
Fetch Metadata *)
265
+
| `Sec_fetch_mode
266
+
(** Request mode (cors, navigate, no-cors, same-origin, websocket).
267
+
@see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-mode-header>
268
+
Fetch Metadata *)
269
+
| `Sec_fetch_site
270
+
(** Relationship between initiator and target (cross-site, same-origin,
271
+
etc.).
272
+
@see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-site-header>
273
+
Fetch Metadata *)
274
+
| `Sec_fetch_user
275
+
(** Whether navigation was user-activated.
276
+
@see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-user-header>
277
+
Fetch Metadata *)
278
+
| (* {2 Security Headers} *)
279
+
`Content_security_policy
280
+
(** Controls resources user agent is allowed to load.
281
+
@see <https://www.w3.org/TR/CSP3/> Content Security Policy Level 3 *)
282
+
| `Content_security_policy_report_only
283
+
(** Report-only mode for CSP.
284
+
@see <https://www.w3.org/TR/CSP3/> Content Security Policy Level 3 *)
285
+
| `Strict_transport_security
286
+
(** Instructs browser to only use HTTPS (HSTS).
287
+
@see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797 *)
288
+
| `X_content_type_options
289
+
(** Prevents MIME type sniffing. Value: "nosniff".
290
+
@see <https://fetch.spec.whatwg.org/#x-content-type-options-header>
291
+
Fetch *)
292
+
| `X_frame_options
293
+
(** Controls whether page can be displayed in frame/iframe.
294
+
@see <https://html.spec.whatwg.org/multipage/browsing-the-web.html#the-x-frame-options-header>
295
+
HTML *)
296
+
| `Referrer_policy
297
+
(** Controls how much referrer info is included.
298
+
@see <https://www.w3.org/TR/referrer-policy/> Referrer Policy *)
299
+
| (* {2 RFC 8053: Interactive Authentication} *)
300
+
`Optional_www_authenticate
301
+
(** Offers authentication without requiring it (HTTP 200 with auth option).
302
+
@see <https://www.rfc-editor.org/rfc/rfc8053#section-3>
303
+
RFC 8053 Section 3 *)
304
+
| `Authentication_control
305
+
(** Controls authentication UI behavior.
306
+
@see <https://www.rfc-editor.org/rfc/rfc8053#section-4>
307
+
RFC 8053 Section 4 *)
308
+
| (* {2 RFC 9449: OAuth 2.0 DPoP} *)
309
+
`Dpop
310
+
(** Demonstrating Proof of Possession token.
311
+
@see <https://www.rfc-editor.org/rfc/rfc9449> RFC 9449 *)
312
+
| `Dpop_nonce
313
+
(** Server-provided nonce for DPoP.
314
+
@see <https://www.rfc-editor.org/rfc/rfc9449> RFC 9449 *)
315
+
| (* {2 RFC 9530: Digest Fields} *)
316
+
`Content_digest
317
+
(** Digest of message content (after content-coding).
318
+
@see <https://www.rfc-editor.org/rfc/rfc9530#section-2>
319
+
RFC 9530 Section 2 *)
320
+
| `Repr_digest
321
+
(** Digest of representation (before content-coding).
322
+
@see <https://www.rfc-editor.org/rfc/rfc9530#section-3>
323
+
RFC 9530 Section 3 *)
324
+
| `Want_content_digest
325
+
(** Request for Content-Digest in response.
326
+
@see <https://www.rfc-editor.org/rfc/rfc9530#section-4>
327
+
RFC 9530 Section 4 *)
328
+
| `Want_repr_digest
329
+
(** Request for Repr-Digest in response.
330
+
@see <https://www.rfc-editor.org/rfc/rfc9530#section-4>
331
+
RFC 9530 Section 4 *)
332
+
| (* {2 RFC 9421: HTTP Message Signatures} *)
333
+
`Signature
334
+
(** Cryptographic signature over message components.
335
+
@see <https://www.rfc-editor.org/rfc/rfc9421#section-4.2>
336
+
RFC 9421 Section 4.2 *)
337
+
| `Signature_input
338
+
(** Metadata for signatures (components, algorithm, key ID, etc.).
339
+
@see <https://www.rfc-editor.org/rfc/rfc9421#section-4.1>
340
+
RFC 9421 Section 4.1 *)
341
+
| `Accept_signature
342
+
(** Indicates client can process signatures.
343
+
@see <https://www.rfc-editor.org/rfc/rfc9421#section-5.1>
344
+
RFC 9421 Section 5.1 *)
345
+
| (* {2 RFC 6455: WebSocket Protocol}
346
+
347
+
Headers used during WebSocket HTTP Upgrade handshake.
348
+
@see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455 *)
349
+
`Sec_websocket_key
350
+
(** Client's base64-encoded 16-byte random nonce.
351
+
@see <https://www.rfc-editor.org/rfc/rfc6455#section-4.1>
352
+
RFC 6455 Section 4.1 *)
353
+
| `Sec_websocket_accept
354
+
(** Server's proof of handshake (SHA-1 of key + GUID, base64).
355
+
@see <https://www.rfc-editor.org/rfc/rfc6455#section-4.2.2>
356
+
RFC 6455 Section 4.2.2 *)
357
+
| `Sec_websocket_protocol
358
+
(** Subprotocol negotiation.
359
+
@see <https://www.rfc-editor.org/rfc/rfc6455#section-11.3.4>
360
+
RFC 6455 Section 11.3.4 *)
361
+
| `Sec_websocket_version
362
+
(** WebSocket protocol version (must be "13").
363
+
@see <https://www.rfc-editor.org/rfc/rfc6455#section-4.1>
364
+
RFC 6455 Section 4.1 *)
365
+
| `Sec_websocket_extensions
366
+
(** Extension negotiation (e.g., permessage-deflate).
367
+
@see <https://www.rfc-editor.org/rfc/rfc6455#section-9>
368
+
RFC 6455 Section 9 *) ]
369
+
(** {1 Standard HTTP Headers}
370
+
371
+
These cover headers defined in:
372
+
- RFC 9110 (HTTP Semantics)
373
+
- RFC 9111 (HTTP Caching)
374
+
- RFC 9112 (HTTP/1.1)
375
+
- RFC 6455 (WebSocket Protocol)
376
+
- RFC 9421 (HTTP Message Signatures)
377
+
- RFC 9530 (Digest Fields)
378
+
- Fetch Standard (CORS and Security)
379
+
- Various other RFCs as noted *)
380
+
381
+
type t = [ standard | `Other of string ]
382
+
(** Complete header name type including non-standard headers.
383
+
384
+
Use [`Other name] for headers not in the standard set. The name should be
385
+
provided in its canonical form (e.g., "X-Custom-Header"). *)
386
+
387
+
(** Convert a header name to its canonical wire format string.
388
+
389
+
Standard headers are converted to their canonical capitalization. [`Other]
390
+
headers are returned as-is. *)
391
+
let to_string : t -> string = function
392
+
(* RFC 9110: Content *)
393
+
| `Accept -> "Accept"
394
+
| `Accept_encoding -> "Accept-Encoding"
395
+
| `Accept_language -> "Accept-Language"
396
+
| `Accept_ranges -> "Accept-Ranges"
397
+
| `Allow -> "Allow"
398
+
| `Content_encoding -> "Content-Encoding"
399
+
| `Content_language -> "Content-Language"
400
+
| `Content_length -> "Content-Length"
401
+
| `Content_location -> "Content-Location"
402
+
| `Content_range -> "Content-Range"
403
+
| `Content_type -> "Content-Type"
404
+
(* RFC 9110: Request Context *)
405
+
| `Expect -> "Expect"
406
+
| `From -> "From"
407
+
| `Host -> "Host"
408
+
| `Max_forwards -> "Max-Forwards"
409
+
| `Range -> "Range"
410
+
| `Referer -> "Referer"
411
+
| `Te -> "TE"
412
+
| `User_agent -> "User-Agent"
413
+
(* RFC 9110: Response Context *)
414
+
| `Location -> "Location"
415
+
| `Retry_after -> "Retry-After"
416
+
| `Server -> "Server"
417
+
(* RFC 9110: Validators *)
418
+
| `Etag -> "ETag"
419
+
| `Last_modified -> "Last-Modified"
420
+
| `Vary -> "Vary"
421
+
(* RFC 9110: Conditional *)
422
+
| `If_match -> "If-Match"
423
+
| `If_modified_since -> "If-Modified-Since"
424
+
| `If_none_match -> "If-None-Match"
425
+
| `If_range -> "If-Range"
426
+
| `If_unmodified_since -> "If-Unmodified-Since"
427
+
(* RFC 9110: Authentication *)
428
+
| `Authorization -> "Authorization"
429
+
| `Authentication_info -> "Authentication-Info"
430
+
| `Proxy_authenticate -> "Proxy-Authenticate"
431
+
| `Proxy_authentication_info -> "Proxy-Authentication-Info"
432
+
| `Proxy_authorization -> "Proxy-Authorization"
433
+
| `Www_authenticate -> "WWW-Authenticate"
434
+
(* RFC 9110: Connection *)
435
+
| `Connection -> "Connection"
436
+
| `Upgrade -> "Upgrade"
437
+
| `Via -> "Via"
438
+
(* RFC 9110: Date *)
439
+
| `Date -> "Date"
440
+
(* RFC 9111: Caching *)
441
+
| `Age -> "Age"
442
+
| `Cache_control -> "Cache-Control"
443
+
| `Expires -> "Expires"
444
+
| `Pragma -> "Pragma"
445
+
| `Cache_status -> "Cache-Status"
446
+
(* RFC 9112: HTTP/1.1 *)
447
+
| `Keep_alive -> "Keep-Alive"
448
+
| `Trailer -> "Trailer"
449
+
| `Transfer_encoding -> "Transfer-Encoding"
450
+
(* Cookies *)
451
+
| `Cookie -> "Cookie"
452
+
| `Set_cookie -> "Set-Cookie"
453
+
(* Link *)
454
+
| `Link -> "Link"
455
+
(* CORS *)
456
+
| `Access_control_allow_credentials -> "Access-Control-Allow-Credentials"
457
+
| `Access_control_allow_headers -> "Access-Control-Allow-Headers"
458
+
| `Access_control_allow_methods -> "Access-Control-Allow-Methods"
459
+
| `Access_control_allow_origin -> "Access-Control-Allow-Origin"
460
+
| `Access_control_expose_headers -> "Access-Control-Expose-Headers"
461
+
| `Access_control_max_age -> "Access-Control-Max-Age"
462
+
| `Access_control_request_headers -> "Access-Control-Request-Headers"
463
+
| `Access_control_request_method -> "Access-Control-Request-Method"
464
+
| `Origin -> "Origin"
465
+
(* Cross-Origin Policy *)
466
+
| `Cross_origin_embedder_policy -> "Cross-Origin-Embedder-Policy"
467
+
| `Cross_origin_embedder_policy_report_only ->
468
+
"Cross-Origin-Embedder-Policy-Report-Only"
469
+
| `Cross_origin_opener_policy -> "Cross-Origin-Opener-Policy"
470
+
| `Cross_origin_opener_policy_report_only ->
471
+
"Cross-Origin-Opener-Policy-Report-Only"
472
+
| `Cross_origin_resource_policy -> "Cross-Origin-Resource-Policy"
473
+
(* Sec-Fetch *)
474
+
| `Sec_fetch_dest -> "Sec-Fetch-Dest"
475
+
| `Sec_fetch_mode -> "Sec-Fetch-Mode"
476
+
| `Sec_fetch_site -> "Sec-Fetch-Site"
477
+
| `Sec_fetch_user -> "Sec-Fetch-User"
478
+
(* Security *)
479
+
| `Content_security_policy -> "Content-Security-Policy"
480
+
| `Content_security_policy_report_only ->
481
+
"Content-Security-Policy-Report-Only"
482
+
| `Strict_transport_security -> "Strict-Transport-Security"
483
+
| `X_content_type_options -> "X-Content-Type-Options"
484
+
| `X_frame_options -> "X-Frame-Options"
485
+
| `Referrer_policy -> "Referrer-Policy"
486
+
(* RFC 8053: Interactive Auth *)
487
+
| `Optional_www_authenticate -> "Optional-WWW-Authenticate"
488
+
| `Authentication_control -> "Authentication-Control"
489
+
(* RFC 9449: DPoP *)
490
+
| `Dpop -> "DPoP"
491
+
| `Dpop_nonce -> "DPoP-Nonce"
492
+
(* RFC 9530: Digest Fields *)
493
+
| `Content_digest -> "Content-Digest"
494
+
| `Repr_digest -> "Repr-Digest"
495
+
| `Want_content_digest -> "Want-Content-Digest"
496
+
| `Want_repr_digest -> "Want-Repr-Digest"
497
+
(* RFC 9421: Signatures *)
498
+
| `Signature -> "Signature"
499
+
| `Signature_input -> "Signature-Input"
500
+
| `Accept_signature -> "Accept-Signature"
501
+
(* RFC 6455: WebSocket *)
502
+
| `Sec_websocket_key -> "Sec-WebSocket-Key"
503
+
| `Sec_websocket_accept -> "Sec-WebSocket-Accept"
504
+
| `Sec_websocket_protocol -> "Sec-WebSocket-Protocol"
505
+
| `Sec_websocket_version -> "Sec-WebSocket-Version"
506
+
| `Sec_websocket_extensions -> "Sec-WebSocket-Extensions"
507
+
(* Other *)
508
+
| `Other s -> s
509
+
510
+
(** Convert a string to a header name.
511
+
512
+
Performs case-insensitive matching against known headers. Unknown headers
513
+
are wrapped in [`Other]. *)
514
+
let of_string s : t =
515
+
match String.lowercase_ascii s with
516
+
(* RFC 9110: Content *)
517
+
| "accept" -> `Accept
518
+
| "accept-encoding" -> `Accept_encoding
519
+
| "accept-language" -> `Accept_language
520
+
| "accept-ranges" -> `Accept_ranges
521
+
| "allow" -> `Allow
522
+
| "content-encoding" -> `Content_encoding
523
+
| "content-language" -> `Content_language
524
+
| "content-length" -> `Content_length
525
+
| "content-location" -> `Content_location
526
+
| "content-range" -> `Content_range
527
+
| "content-type" -> `Content_type
528
+
(* RFC 9110: Request Context *)
529
+
| "expect" -> `Expect
530
+
| "from" -> `From
531
+
| "host" -> `Host
532
+
| "max-forwards" -> `Max_forwards
533
+
| "range" -> `Range
534
+
| "referer" -> `Referer
535
+
| "te" -> `Te
536
+
| "user-agent" -> `User_agent
537
+
(* RFC 9110: Response Context *)
538
+
| "location" -> `Location
539
+
| "retry-after" -> `Retry_after
540
+
| "server" -> `Server
541
+
(* RFC 9110: Validators *)
542
+
| "etag" -> `Etag
543
+
| "last-modified" -> `Last_modified
544
+
| "vary" -> `Vary
545
+
(* RFC 9110: Conditional *)
546
+
| "if-match" -> `If_match
547
+
| "if-modified-since" -> `If_modified_since
548
+
| "if-none-match" -> `If_none_match
549
+
| "if-range" -> `If_range
550
+
| "if-unmodified-since" -> `If_unmodified_since
551
+
(* RFC 9110: Authentication *)
552
+
| "authorization" -> `Authorization
553
+
| "authentication-info" -> `Authentication_info
554
+
| "proxy-authenticate" -> `Proxy_authenticate
555
+
| "proxy-authentication-info" -> `Proxy_authentication_info
556
+
| "proxy-authorization" -> `Proxy_authorization
557
+
| "www-authenticate" -> `Www_authenticate
558
+
(* RFC 9110: Connection *)
559
+
| "connection" -> `Connection
560
+
| "upgrade" -> `Upgrade
561
+
| "via" -> `Via
562
+
(* RFC 9110: Date *)
563
+
| "date" -> `Date
564
+
(* RFC 9111: Caching *)
565
+
| "age" -> `Age
566
+
| "cache-control" -> `Cache_control
567
+
| "expires" -> `Expires
568
+
| "pragma" -> `Pragma
569
+
| "cache-status" -> `Cache_status
570
+
(* RFC 9112: HTTP/1.1 *)
571
+
| "keep-alive" -> `Keep_alive
572
+
| "trailer" -> `Trailer
573
+
| "transfer-encoding" -> `Transfer_encoding
574
+
(* Cookies *)
575
+
| "cookie" -> `Cookie
576
+
| "set-cookie" -> `Set_cookie
577
+
(* Link *)
578
+
| "link" -> `Link
579
+
(* CORS *)
580
+
| "access-control-allow-credentials" -> `Access_control_allow_credentials
581
+
| "access-control-allow-headers" -> `Access_control_allow_headers
582
+
| "access-control-allow-methods" -> `Access_control_allow_methods
583
+
| "access-control-allow-origin" -> `Access_control_allow_origin
584
+
| "access-control-expose-headers" -> `Access_control_expose_headers
585
+
| "access-control-max-age" -> `Access_control_max_age
586
+
| "access-control-request-headers" -> `Access_control_request_headers
587
+
| "access-control-request-method" -> `Access_control_request_method
588
+
| "origin" -> `Origin
589
+
(* Cross-Origin Policy *)
590
+
| "cross-origin-embedder-policy" -> `Cross_origin_embedder_policy
591
+
| "cross-origin-embedder-policy-report-only" ->
592
+
`Cross_origin_embedder_policy_report_only
593
+
| "cross-origin-opener-policy" -> `Cross_origin_opener_policy
594
+
| "cross-origin-opener-policy-report-only" ->
595
+
`Cross_origin_opener_policy_report_only
596
+
| "cross-origin-resource-policy" -> `Cross_origin_resource_policy
597
+
(* Sec-Fetch *)
598
+
| "sec-fetch-dest" -> `Sec_fetch_dest
599
+
| "sec-fetch-mode" -> `Sec_fetch_mode
600
+
| "sec-fetch-site" -> `Sec_fetch_site
601
+
| "sec-fetch-user" -> `Sec_fetch_user
602
+
(* Security *)
603
+
| "content-security-policy" -> `Content_security_policy
604
+
| "content-security-policy-report-only" ->
605
+
`Content_security_policy_report_only
606
+
| "strict-transport-security" -> `Strict_transport_security
607
+
| "x-content-type-options" -> `X_content_type_options
608
+
| "x-frame-options" -> `X_frame_options
609
+
| "referrer-policy" -> `Referrer_policy
610
+
(* RFC 8053: Interactive Auth *)
611
+
| "optional-www-authenticate" -> `Optional_www_authenticate
612
+
| "authentication-control" -> `Authentication_control
613
+
(* RFC 9449: DPoP *)
614
+
| "dpop" -> `Dpop
615
+
| "dpop-nonce" -> `Dpop_nonce
616
+
(* RFC 9530: Digest Fields *)
617
+
| "content-digest" -> `Content_digest
618
+
| "repr-digest" -> `Repr_digest
619
+
| "want-content-digest" -> `Want_content_digest
620
+
| "want-repr-digest" -> `Want_repr_digest
621
+
(* RFC 9421: Signatures *)
622
+
| "signature" -> `Signature
623
+
| "signature-input" -> `Signature_input
624
+
| "accept-signature" -> `Accept_signature
625
+
(* RFC 6455: WebSocket *)
626
+
| "sec-websocket-key" -> `Sec_websocket_key
627
+
| "sec-websocket-accept" -> `Sec_websocket_accept
628
+
| "sec-websocket-protocol" -> `Sec_websocket_protocol
629
+
| "sec-websocket-version" -> `Sec_websocket_version
630
+
| "sec-websocket-extensions" -> `Sec_websocket_extensions
631
+
(* Other *)
632
+
| _ -> `Other s
633
+
634
+
(** Convert to lowercase string for internal map keys. *)
635
+
let to_lowercase_string (name : t) : string =
636
+
match name with
637
+
| `Other s -> String.lowercase_ascii s
638
+
| #standard as s -> String.lowercase_ascii (to_string s)
639
+
640
+
(** Compare two header names (case-insensitive). *)
641
+
let compare (a : t) (b : t) : int =
642
+
String.compare (to_lowercase_string a) (to_lowercase_string b)
643
+
644
+
(** Check equality of two header names (case-insensitive). *)
645
+
let equal (a : t) (b : t) : bool = compare a b = 0
646
+
647
+
(** Pretty printer for header names. *)
648
+
let pp ppf name = Fmt.string ppf (to_string name)
649
+
650
+
(** {1 Header Categories}
651
+
652
+
Useful groupings for protocol handling. *)
653
+
654
+
(** Default hop-by-hop headers per RFC 9110 Section 7.6.1.
655
+
656
+
These headers MUST be removed before forwarding a message. *)
657
+
let hop_by_hop_headers : t list =
658
+
[
659
+
`Connection;
660
+
`Keep_alive;
661
+
`Proxy_authenticate;
662
+
`Proxy_authorization;
663
+
`Te;
664
+
`Trailer;
665
+
`Transfer_encoding;
666
+
`Upgrade;
667
+
`Via;
668
+
]
669
+
670
+
(** Headers that MUST NOT appear in trailers per RFC 9110 Section 6.5.1. *)
671
+
let forbidden_trailer_headers : t list =
672
+
[
673
+
`Transfer_encoding;
674
+
`Content_length;
675
+
`Host;
676
+
`Content_encoding;
677
+
`Content_type;
678
+
`Trailer;
679
+
]
680
+
681
+
(** CORS response headers.
682
+
683
+
These headers control cross-origin access.
684
+
@see <https://fetch.spec.whatwg.org/#http-responses> Fetch Standard *)
685
+
let cors_response_headers : t list =
686
+
[
687
+
`Access_control_allow_credentials;
688
+
`Access_control_allow_headers;
689
+
`Access_control_allow_methods;
690
+
`Access_control_allow_origin;
691
+
`Access_control_expose_headers;
692
+
`Access_control_max_age;
693
+
]
694
+
695
+
(** CORS request headers.
696
+
697
+
These headers are used in CORS preflight requests.
698
+
@see <https://fetch.spec.whatwg.org/#http-requests> Fetch Standard *)
699
+
let cors_request_headers : t list =
700
+
[ `Access_control_request_headers; `Access_control_request_method; `Origin ]
701
+
702
+
(** Security headers.
703
+
704
+
Headers related to web security policies. *)
705
+
let security_headers : t list =
706
+
[
707
+
`Content_security_policy;
708
+
`Content_security_policy_report_only;
709
+
`Strict_transport_security;
710
+
`X_content_type_options;
711
+
`X_frame_options;
712
+
`Referrer_policy;
713
+
`Cross_origin_embedder_policy;
714
+
`Cross_origin_embedder_policy_report_only;
715
+
`Cross_origin_opener_policy;
716
+
`Cross_origin_opener_policy_report_only;
717
+
`Cross_origin_resource_policy;
718
+
]
719
+
720
+
(** Fetch metadata headers.
721
+
722
+
Browser-set headers providing request context.
723
+
@see <https://www.w3.org/TR/fetch-metadata/> Fetch Metadata *)
724
+
let fetch_metadata_headers : t list =
725
+
[ `Sec_fetch_dest; `Sec_fetch_mode; `Sec_fetch_site; `Sec_fetch_user ]
726
+
727
+
(** WebSocket handshake headers.
728
+
729
+
Headers used during WebSocket upgrade.
730
+
@see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455 *)
731
+
let websocket_headers : t list =
732
+
[
733
+
`Sec_websocket_key;
734
+
`Sec_websocket_accept;
735
+
`Sec_websocket_protocol;
736
+
`Sec_websocket_version;
737
+
`Sec_websocket_extensions;
738
+
]
739
+
740
+
(** Check if a header is a hop-by-hop header. *)
741
+
let is_hop_by_hop (name : t) : bool =
742
+
List.exists (equal name) hop_by_hop_headers
743
+
744
+
(** Check if a header is forbidden in trailers. *)
745
+
let is_forbidden_trailer (name : t) : bool =
746
+
List.exists (equal name) forbidden_trailer_headers
747
+
748
+
(** Check if a header is a CORS response header. *)
749
+
let is_cors_response (name : t) : bool =
750
+
List.exists (equal name) cors_response_headers
751
+
752
+
(** Check if a header is a CORS request header. *)
753
+
let is_cors_request (name : t) : bool =
754
+
List.exists (equal name) cors_request_headers
755
+
756
+
(** Check if a header is a security header. *)
757
+
let is_security (name : t) : bool = List.exists (equal name) security_headers
758
+
759
+
(** Check if a header is a fetch metadata header. *)
760
+
let is_fetch_metadata (name : t) : bool =
761
+
List.exists (equal name) fetch_metadata_headers
762
+
763
+
(** Check if a header is a WebSocket header. *)
764
+
let is_websocket (name : t) : bool = List.exists (equal name) websocket_headers
+264
lib/header_name.mli
+264
lib/header_name.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP Header Names as Polymorphic Variants
7
+
8
+
This module provides type-safe HTTP header names using polymorphic variants.
9
+
All standard headers have dedicated variants, with [`Other] for non-standard
10
+
or unknown headers.
11
+
12
+
{2 Usage}
13
+
14
+
{[
15
+
(* Use standard headers directly *)
16
+
let headers = Headers.empty
17
+
|> Headers.set `Content_type "application/json"
18
+
|> Headers.set `Accept "text/html"
19
+
20
+
(* Use custom headers with `Other *)
21
+
let headers = headers
22
+
|> Headers.set (`Other "X-Custom-Header") "value"
23
+
24
+
(* Pattern match on headers *)
25
+
match Headers.find `Content_type headers with
26
+
| Some ct -> print_endline ct
27
+
| None -> ()
28
+
]}
29
+
30
+
Header names are case-insensitive per
31
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.1}RFC 9110
32
+
Section 5.1}.
33
+
34
+
Header definitions are based on the IANA HTTP Field Name Registry:
35
+
{{:https://www.iana.org/assignments/http-fields/http-fields.xhtml}IANA HTTP
36
+
Field Name Registry} *)
37
+
38
+
(** {1 Types} *)
39
+
40
+
type standard =
41
+
[ (* RFC 9110: HTTP Semantics - Content Headers *)
42
+
`Accept
43
+
| `Accept_encoding
44
+
| `Accept_language
45
+
| `Accept_ranges
46
+
| `Allow
47
+
| `Content_encoding
48
+
| `Content_language
49
+
| `Content_length
50
+
| `Content_location
51
+
| `Content_range
52
+
| `Content_type
53
+
| (* RFC 9110: HTTP Semantics - Request Context *)
54
+
`Expect
55
+
| `From
56
+
| `Host
57
+
| `Max_forwards
58
+
| `Range
59
+
| `Referer
60
+
| `Te
61
+
| `User_agent
62
+
| (* RFC 9110: HTTP Semantics - Response Context *)
63
+
`Location
64
+
| `Retry_after
65
+
| `Server
66
+
| (* RFC 9110: HTTP Semantics - Validators *)
67
+
`Etag
68
+
| `Last_modified
69
+
| `Vary
70
+
| (* RFC 9110: HTTP Semantics - Conditional Requests *)
71
+
`If_match
72
+
| `If_modified_since
73
+
| `If_none_match
74
+
| `If_range
75
+
| `If_unmodified_since
76
+
| (* RFC 9110: HTTP Semantics - Authentication *)
77
+
`Authorization
78
+
| `Authentication_info
79
+
| `Proxy_authenticate
80
+
| `Proxy_authentication_info
81
+
| `Proxy_authorization
82
+
| `Www_authenticate
83
+
| (* RFC 9110: HTTP Semantics - Connection Management *)
84
+
`Connection
85
+
| `Upgrade
86
+
| `Via
87
+
| (* RFC 9110: HTTP Semantics - Date *)
88
+
`Date
89
+
| (* RFC 9111: HTTP Caching *)
90
+
`Age
91
+
| `Cache_control
92
+
| `Expires
93
+
| `Pragma
94
+
| `Cache_status
95
+
| (* RFC 9112: HTTP/1.1 *)
96
+
`Keep_alive
97
+
| `Trailer
98
+
| `Transfer_encoding
99
+
| (* Cookies - RFC 6265bis *)
100
+
`Cookie
101
+
| `Set_cookie
102
+
| (* Link Relations - RFC 8288 *)
103
+
`Link
104
+
| (* CORS Headers - Fetch Standard *)
105
+
`Access_control_allow_credentials
106
+
| `Access_control_allow_headers
107
+
| `Access_control_allow_methods
108
+
| `Access_control_allow_origin
109
+
| `Access_control_expose_headers
110
+
| `Access_control_max_age
111
+
| `Access_control_request_headers
112
+
| `Access_control_request_method
113
+
| `Origin
114
+
| (* Cross-Origin Policy Headers - HTML Standard *)
115
+
`Cross_origin_embedder_policy
116
+
| `Cross_origin_embedder_policy_report_only
117
+
| `Cross_origin_opener_policy
118
+
| `Cross_origin_opener_policy_report_only
119
+
| `Cross_origin_resource_policy
120
+
| (* Fetch Metadata Headers - W3C *)
121
+
`Sec_fetch_dest
122
+
| `Sec_fetch_mode
123
+
| `Sec_fetch_site
124
+
| `Sec_fetch_user
125
+
| (* Security Headers *)
126
+
`Content_security_policy
127
+
| `Content_security_policy_report_only
128
+
| `Strict_transport_security
129
+
| `X_content_type_options
130
+
| `X_frame_options
131
+
| `Referrer_policy
132
+
| (* RFC 8053: Interactive Authentication *)
133
+
`Optional_www_authenticate
134
+
| `Authentication_control
135
+
| (* RFC 9449: OAuth 2.0 DPoP *)
136
+
`Dpop
137
+
| `Dpop_nonce
138
+
| (* RFC 9530: Digest Fields *)
139
+
`Content_digest
140
+
| `Repr_digest
141
+
| `Want_content_digest
142
+
| `Want_repr_digest
143
+
| (* RFC 9421: HTTP Message Signatures *)
144
+
`Signature
145
+
| `Signature_input
146
+
| `Accept_signature
147
+
| (* RFC 6455: WebSocket Protocol *)
148
+
`Sec_websocket_key
149
+
| `Sec_websocket_accept
150
+
| `Sec_websocket_protocol
151
+
| `Sec_websocket_version
152
+
| `Sec_websocket_extensions ]
153
+
(** Standard HTTP header names.
154
+
155
+
These cover headers defined in:
156
+
- {{:https://datatracker.ietf.org/doc/html/rfc9110}RFC 9110} (HTTP
157
+
Semantics)
158
+
- {{:https://datatracker.ietf.org/doc/html/rfc9111}RFC 9111} (HTTP Caching)
159
+
- {{:https://datatracker.ietf.org/doc/html/rfc9112}RFC 9112} (HTTP/1.1)
160
+
- {{:https://datatracker.ietf.org/doc/html/rfc6455}RFC 6455} (WebSocket
161
+
Protocol)
162
+
- {{:https://datatracker.ietf.org/doc/html/rfc9421}RFC 9421} (HTTP Message
163
+
Signatures)
164
+
- {{:https://datatracker.ietf.org/doc/html/rfc9530}RFC 9530} (Digest Fields)
165
+
- {{:https://fetch.spec.whatwg.org/}Fetch Standard} (CORS and Security)
166
+
- Various other RFCs as noted *)
167
+
168
+
type t = [ standard | `Other of string ]
169
+
(** Complete header name type including non-standard headers.
170
+
171
+
Use [`Other name] for headers not in the standard set. The name should be
172
+
provided in its canonical form (e.g., "X-Custom-Header"). *)
173
+
174
+
(** {1 Conversion} *)
175
+
176
+
val to_string : t -> string
177
+
(** [to_string name] converts a header name to its canonical wire format.
178
+
179
+
Standard headers use their canonical capitalization (e.g., [`Content_type]
180
+
becomes ["Content-Type"]). [`Other] headers are returned as-is. *)
181
+
182
+
val of_string : string -> t
183
+
(** [of_string s] parses a string into a header name.
184
+
185
+
Performs case-insensitive matching against known headers. Unknown headers
186
+
are wrapped in [`Other]. *)
187
+
188
+
val to_lowercase_string : t -> string
189
+
(** [to_lowercase_string name] returns the lowercase form for internal use. *)
190
+
191
+
(** {1 Comparison} *)
192
+
193
+
val compare : t -> t -> int
194
+
(** [compare a b] compares two header names case-insensitively. *)
195
+
196
+
val equal : t -> t -> bool
197
+
(** [equal a b] checks equality of two header names case-insensitively. *)
198
+
199
+
(** {1 Pretty Printing} *)
200
+
201
+
val pp : Format.formatter -> t -> unit
202
+
(** [pp ppf name] pretty-prints a header name. *)
203
+
204
+
(** {1 Header Categories} *)
205
+
206
+
val hop_by_hop_headers : t list
207
+
(** Default hop-by-hop headers per
208
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-7.6.1}RFC 9110
209
+
Section 7.6.1}.
210
+
211
+
These headers MUST be removed before forwarding a message: Connection,
212
+
Keep-Alive, Proxy-Authenticate, Proxy-Authorization, TE, Trailer,
213
+
Transfer-Encoding, Upgrade, Via. *)
214
+
215
+
val forbidden_trailer_headers : t list
216
+
(** Headers that MUST NOT appear in trailers per
217
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-6.5.1}RFC 9110
218
+
Section 6.5.1}.
219
+
220
+
Includes: Transfer-Encoding, Content-Length, Host, Content-Encoding,
221
+
Content-Type, Trailer. *)
222
+
223
+
val cors_response_headers : t list
224
+
(** CORS response headers that control cross-origin access.
225
+
@see <https://fetch.spec.whatwg.org/#http-responses> Fetch Standard. *)
226
+
227
+
val cors_request_headers : t list
228
+
(** CORS request headers used in preflight requests.
229
+
@see <https://fetch.spec.whatwg.org/#http-requests> Fetch Standard. *)
230
+
231
+
val security_headers : t list
232
+
(** Headers related to web security policies. *)
233
+
234
+
val fetch_metadata_headers : t list
235
+
(** Browser-set headers providing request context.
236
+
@see <https://www.w3.org/TR/fetch-metadata/> Fetch Metadata. *)
237
+
238
+
val websocket_headers : t list
239
+
(** Headers used during WebSocket upgrade.
240
+
@see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455. *)
241
+
242
+
val is_hop_by_hop : t -> bool
243
+
(** [is_hop_by_hop name] returns [true] if [name] is a hop-by-hop header. *)
244
+
245
+
val is_forbidden_trailer : t -> bool
246
+
(** [is_forbidden_trailer name] returns [true] if [name] is forbidden in
247
+
trailers. *)
248
+
249
+
val is_cors_response : t -> bool
250
+
(** [is_cors_response name] returns [true] if [name] is a CORS response header.
251
+
*)
252
+
253
+
val is_cors_request : t -> bool
254
+
(** [is_cors_request name] returns [true] if [name] is a CORS request header. *)
255
+
256
+
val is_security : t -> bool
257
+
(** [is_security name] returns [true] if [name] is a security header. *)
258
+
259
+
val is_fetch_metadata : t -> bool
260
+
(** [is_fetch_metadata name] returns [true] if [name] is a fetch metadata
261
+
header. *)
262
+
263
+
val is_websocket : t -> bool
264
+
(** [is_websocket name] returns [true] if [name] is a WebSocket header. *)
+665
lib/headers.ml
+665
lib/headers.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "requests.headers" ~doc:"HTTP Headers"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
(* Use a map with lowercase keys for case-insensitive lookup *)
11
+
module String_map = Map.Make (String)
12
+
13
+
type t = (string * string list) String_map.t
14
+
(** The internal representation stores: (canonical_name, values) *)
15
+
16
+
let empty = String_map.empty
17
+
18
+
(** {1 Header Injection Prevention}
19
+
20
+
Per Recommendation #3: Validate that header names and values do not contain
21
+
newlines (CR/LF) which could enable HTTP request smuggling attacks.
22
+
23
+
Note: We use Invalid_argument here to avoid a dependency cycle with Error
24
+
module. The error will be caught and wrapped appropriately by higher-level
25
+
code. *)
26
+
27
+
exception Invalid_header of { name : string; reason : string }
28
+
29
+
(** {1 Basic Auth Credential Validation}
30
+
31
+
Per RFC 7617 Section 2:
32
+
- Username must not contain a colon character
33
+
- Neither username nor password may contain control characters (0x00-0x1F,
34
+
0x7F) *)
35
+
36
+
exception Invalid_basic_auth of { reason : string }
37
+
38
+
let contains_control_chars s =
39
+
String.exists
40
+
(fun c ->
41
+
let code = Char.code c in
42
+
code <= 0x1F || code = 0x7F)
43
+
s
44
+
45
+
let validate_basic_auth_credentials ~username ~password =
46
+
(* RFC 7617 Section 2: "a user-id containing a colon character is invalid" *)
47
+
if String.contains username ':' then
48
+
raise
49
+
(Invalid_basic_auth
50
+
{ reason = "Username contains colon character (RFC 7617 Section 2)" });
51
+
(* RFC 7617 Section 2: "The user-id and password MUST NOT contain any control characters" *)
52
+
if contains_control_chars username then
53
+
raise
54
+
(Invalid_basic_auth
55
+
{
56
+
reason = "Username contains control characters (RFC 7617 Section 2)";
57
+
});
58
+
if contains_control_chars password then
59
+
raise
60
+
(Invalid_basic_auth
61
+
{
62
+
reason = "Password contains control characters (RFC 7617 Section 2)";
63
+
})
64
+
65
+
let validate_header_name_str name =
66
+
if String.contains name '\r' || String.contains name '\n' then
67
+
raise
68
+
(Invalid_header
69
+
{
70
+
name;
71
+
reason =
72
+
"Header name contains CR/LF characters (potential HTTP smuggling)";
73
+
})
74
+
75
+
let validate_header_value name value =
76
+
if String.contains value '\r' || String.contains value '\n' then
77
+
raise
78
+
(Invalid_header
79
+
{
80
+
name;
81
+
reason =
82
+
"Header value contains CR/LF characters (potential HTTP smuggling)";
83
+
})
84
+
85
+
(** {1 Core Operations with Typed Header Names} *)
86
+
87
+
let add (name : Header_name.t) value t =
88
+
(* Store header names in lowercase for HTTP/2 compatibility.
89
+
HTTP/1.x headers are case-insensitive per RFC 9110. *)
90
+
let canonical = Header_name.to_lowercase_string name in
91
+
let nkey = canonical in
92
+
validate_header_value canonical value;
93
+
let existing =
94
+
match String_map.find_opt nkey t with
95
+
| Some (_, values) -> values
96
+
| None -> []
97
+
in
98
+
(* Append to maintain order, avoiding reversal on retrieval *)
99
+
String_map.add nkey (canonical, existing @ [ value ]) t
100
+
101
+
let set (name : Header_name.t) value t =
102
+
(* Store header names in lowercase for HTTP/2 compatibility.
103
+
HTTP/1.x headers are case-insensitive per RFC 9110. *)
104
+
let canonical = Header_name.to_lowercase_string name in
105
+
let nkey = canonical in
106
+
validate_header_value canonical value;
107
+
String_map.add nkey (canonical, [ value ]) t
108
+
109
+
let find (name : Header_name.t) t =
110
+
let nkey = Header_name.to_lowercase_string name in
111
+
match String_map.find_opt nkey t with
112
+
| Some (_, values) -> List.nth_opt values 0
113
+
| None -> None
114
+
115
+
let all (name : Header_name.t) t =
116
+
let nkey = Header_name.to_lowercase_string name in
117
+
match String_map.find_opt nkey t with
118
+
| Some (_, values) -> values
119
+
| None -> []
120
+
121
+
let remove (name : Header_name.t) t =
122
+
let nkey = Header_name.to_lowercase_string name in
123
+
String_map.remove nkey t
124
+
125
+
let mem (name : Header_name.t) t =
126
+
let nkey = Header_name.to_lowercase_string name in
127
+
String_map.mem nkey t
128
+
129
+
(** {1 String-based Operations for Wire Format Compatibility}
130
+
131
+
These are used internally when parsing HTTP messages from the wire, where
132
+
header names come as strings. *)
133
+
134
+
let add_string key value t =
135
+
validate_header_name_str key;
136
+
validate_header_value key value;
137
+
let nkey = String.lowercase_ascii key in
138
+
let existing =
139
+
match String_map.find_opt nkey t with
140
+
| Some (_, values) -> values
141
+
| None -> []
142
+
in
143
+
String_map.add nkey (key, existing @ [ value ]) t
144
+
145
+
let set_string key value t =
146
+
validate_header_name_str key;
147
+
validate_header_value key value;
148
+
let nkey = String.lowercase_ascii key in
149
+
String_map.add nkey (key, [ value ]) t
150
+
151
+
let string key t =
152
+
let nkey = String.lowercase_ascii key in
153
+
match String_map.find_opt nkey t with
154
+
| Some (_, values) -> List.nth_opt values 0
155
+
| None -> None
156
+
157
+
let all_string key t =
158
+
let nkey = String.lowercase_ascii key in
159
+
match String_map.find_opt nkey t with
160
+
| Some (_, values) -> values
161
+
| None -> []
162
+
163
+
let remove_string key t =
164
+
let nkey = String.lowercase_ascii key in
165
+
String_map.remove nkey t
166
+
167
+
let mem_string key t =
168
+
let nkey = String.lowercase_ascii key in
169
+
String_map.mem nkey t
170
+
171
+
(** {1 Conversion} *)
172
+
173
+
let of_list lst =
174
+
List.fold_left (fun acc (k, v) -> add_string k v acc) empty lst
175
+
176
+
let to_list t =
177
+
String_map.fold
178
+
(fun _ (orig_key, values) acc ->
179
+
(* Values are already in correct order, build list in reverse then reverse at end *)
180
+
List.fold_left (fun acc v -> (orig_key, v) :: acc) acc values)
181
+
t []
182
+
|> List.rev
183
+
184
+
let merge t1 t2 = String_map.union (fun _ _ v2 -> Some v2) t1 t2
185
+
186
+
(** {1 Common Header Builders} *)
187
+
188
+
let content_type mime t = set `Content_type (Mime.to_string mime) t
189
+
let content_length len t = set `Content_length (Int64.to_string len) t
190
+
let accept mime t = set `Accept (Mime.to_string mime) t
191
+
let accept_language lang t = set `Accept_language lang t
192
+
let authorization value t = set `Authorization value t
193
+
let bearer token t = set `Authorization (Fmt.str "Bearer %s" token) t
194
+
195
+
let basic ~username ~password t =
196
+
validate_basic_auth_credentials ~username ~password;
197
+
let credentials = Fmt.str "%s:%s" username password in
198
+
let encoded = Base64.encode_exn credentials in
199
+
set `Authorization (Fmt.str "Basic %s" encoded) t
200
+
201
+
let user_agent ua t = set `User_agent ua t
202
+
let host h t = set `Host h t
203
+
let cookie name value t = add `Cookie (Fmt.str "%s=%s" name value) t
204
+
205
+
let range ~start ?end_ () t =
206
+
let range_value =
207
+
match end_ with
208
+
| None -> Fmt.str "bytes=%Ld-" start
209
+
| Some e -> Fmt.str "bytes=%Ld-%Ld" start e
210
+
in
211
+
set `Range range_value t
212
+
213
+
(** {1 HTTP 100-Continue Support}
214
+
215
+
Per Recommendation #7: Expect: 100-continue protocol for large uploads. RFC
216
+
9110 Section 10.1.1 (Expect) *)
217
+
218
+
let expect value t = set `Expect value t
219
+
let expect_100_continue t = set `Expect "100-continue" t
220
+
221
+
(** {1 TE Header Support}
222
+
223
+
Per RFC 9110 Section 10.1.4: The TE header indicates what transfer codings
224
+
the client is willing to accept in the response, and whether the client is
225
+
willing to accept trailer fields in a chunked transfer coding. *)
226
+
227
+
let te value t = set `Te value t
228
+
let te_trailers t = set `Te "trailers" t
229
+
230
+
(** {1 Cache Control Headers}
231
+
232
+
Per Recommendation #17 and #19: Response caching and conditional requests.
233
+
RFC 9111 (HTTP Caching), RFC 9110 Section 8.8.2-8.8.3 (Last-Modified, ETag)
234
+
*)
235
+
236
+
let if_none_match etag t = set `If_none_match etag t
237
+
let if_match etag t = set `If_match etag t
238
+
let if_modified_since date t = set `If_modified_since date t
239
+
let if_unmodified_since date t = set `If_unmodified_since date t
240
+
241
+
(** Format a Ptime.t as an HTTP-date (RFC 9110 Section 5.6.7) *)
242
+
let http_date_of_ptime time =
243
+
(* HTTP-date format: "Sun, 06 Nov 1994 08:49:37 GMT" *)
244
+
let (year, month, day), ((hour, min, sec), _tz_offset) =
245
+
Ptime.to_date_time time
246
+
in
247
+
let weekday =
248
+
match Ptime.weekday time with
249
+
| `Sun -> "Sun"
250
+
| `Mon -> "Mon"
251
+
| `Tue -> "Tue"
252
+
| `Wed -> "Wed"
253
+
| `Thu -> "Thu"
254
+
| `Fri -> "Fri"
255
+
| `Sat -> "Sat"
256
+
in
257
+
let month_name =
258
+
[|
259
+
"";
260
+
"Jan";
261
+
"Feb";
262
+
"Mar";
263
+
"Apr";
264
+
"May";
265
+
"Jun";
266
+
"Jul";
267
+
"Aug";
268
+
"Sep";
269
+
"Oct";
270
+
"Nov";
271
+
"Dec";
272
+
|].(month)
273
+
in
274
+
Fmt.str "%s, %02d %s %04d %02d:%02d:%02d GMT" weekday day month_name year hour
275
+
min sec
276
+
277
+
let if_modified_since_ptime time t =
278
+
if_modified_since (http_date_of_ptime time) t
279
+
280
+
let if_unmodified_since_ptime time t =
281
+
if_unmodified_since (http_date_of_ptime time) t
282
+
283
+
let cache_control directives t = set `Cache_control directives t
284
+
285
+
(** Build Cache-Control header from common directive components. For max_stale:
286
+
[None] = not present, [Some None] = any staleness, [Some (Some n)] = n
287
+
seconds *)
288
+
let cache_control_directives :
289
+
?max_age:int ->
290
+
?max_stale:int option option ->
291
+
?min_fresh:int ->
292
+
?no_cache:bool ->
293
+
?no_store:bool ->
294
+
?no_transform:bool ->
295
+
?only_if_cached:bool ->
296
+
unit ->
297
+
t ->
298
+
t =
299
+
fun ?max_age ?max_stale ?min_fresh ?(no_cache = false) ?(no_store = false)
300
+
?(no_transform = false) ?(only_if_cached = false) () t ->
301
+
let directives = [] in
302
+
let directives =
303
+
match max_age with
304
+
| Some age -> Fmt.str "max-age=%d" age :: directives
305
+
| None -> directives
306
+
in
307
+
let directives =
308
+
match max_stale with
309
+
| Some (Some None) -> "max-stale" :: directives
310
+
| Some (Some (Some secs)) -> Fmt.str "max-stale=%d" secs :: directives
311
+
| Some None | None -> directives
312
+
in
313
+
let directives =
314
+
match min_fresh with
315
+
| Some secs -> Fmt.str "min-fresh=%d" secs :: directives
316
+
| None -> directives
317
+
in
318
+
let directives = if no_cache then "no-cache" :: directives else directives in
319
+
let directives = if no_store then "no-store" :: directives else directives in
320
+
let directives =
321
+
if no_transform then "no-transform" :: directives else directives
322
+
in
323
+
let directives =
324
+
if only_if_cached then "only-if-cached" :: directives else directives
325
+
in
326
+
match directives with
327
+
| [] -> t
328
+
| _ -> set `Cache_control (String.concat ", " (List.rev directives)) t
329
+
330
+
let etag value t = set `Etag value t
331
+
let last_modified date t = set `Last_modified date t
332
+
let last_modified_ptime time t = last_modified (http_date_of_ptime time) t
333
+
334
+
(* Additional helper for getting multiple header values *)
335
+
let multi name t = all name t
336
+
337
+
(** {1 Connection Header Handling}
338
+
339
+
Per RFC 9110 Section 7.6.1: The Connection header field lists hop-by-hop
340
+
header fields that MUST be removed before forwarding the message. *)
341
+
342
+
(** Parse Connection header value into list of header names. The Connection
343
+
header lists additional hop-by-hop headers. *)
344
+
let parse_connection_header t =
345
+
match find `Connection t with
346
+
| None -> []
347
+
| Some value ->
348
+
String.split_on_char ',' value
349
+
|> List.map (fun s -> Header_name.of_string (String.trim s))
350
+
|> List.filter (fun n -> not (Header_name.equal n (`Other "")))
351
+
352
+
(** Get all hop-by-hop headers from a response. Returns the union of default
353
+
hop-by-hop headers and any headers listed in the Connection header. *)
354
+
let hop_by_hop_headers t =
355
+
let connection_headers = parse_connection_header t in
356
+
Header_name.hop_by_hop_headers @ connection_headers
357
+
|> List.sort_uniq Header_name.compare
358
+
359
+
(** Remove hop-by-hop headers from a header collection. This should be called
360
+
before caching or forwarding a response. Per RFC 9110 Section 7.6.1. *)
361
+
let remove_hop_by_hop t =
362
+
let hop_by_hop = hop_by_hop_headers t in
363
+
List.fold_left (fun headers name -> remove name headers) t hop_by_hop
364
+
365
+
(** Check if a response indicates the connection should be closed. Returns true
366
+
if Connection: close is present. *)
367
+
let connection_close t =
368
+
match find `Connection t with
369
+
| Some value ->
370
+
String.split_on_char ',' value
371
+
|> List.exists (fun s -> String.trim (String.lowercase_ascii s) = "close")
372
+
| None -> false
373
+
374
+
(** Check if a response indicates the connection should be kept alive. Returns
375
+
true if Connection: keep-alive is present (HTTP/1.0 behavior). *)
376
+
let connection_keep_alive t =
377
+
match find `Connection t with
378
+
| Some value ->
379
+
String.split_on_char ',' value
380
+
|> List.exists (fun s ->
381
+
String.trim (String.lowercase_ascii s) = "keep-alive")
382
+
| None -> false
383
+
384
+
(* Pretty printer for headers *)
385
+
let pp ppf t =
386
+
Fmt.pf ppf "@[<v>Headers:@,";
387
+
let headers = to_list t in
388
+
List.iter (fun (k, v) -> Fmt.pf ppf " %s: %s@," k v) headers;
389
+
Fmt.pf ppf "@]"
390
+
391
+
let pp_brief ppf t =
392
+
let headers = to_list t in
393
+
let count = List.length headers in
394
+
Fmt.pf ppf "Headers(%d entries)" count
395
+
396
+
(** {1 HTTP/2 Pseudo-Header Support}
397
+
398
+
Per
399
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-8.3}RFC 9113
400
+
Section 8.3}. *)
401
+
402
+
let is_pseudo_header name = String.length name > 0 && name.[0] = ':'
403
+
404
+
let pseudo name t =
405
+
let key = ":" ^ name in
406
+
string key t
407
+
408
+
let set_pseudo name value t =
409
+
let key = ":" ^ name in
410
+
set_string key value t
411
+
412
+
let remove_pseudo name t =
413
+
let key = ":" ^ name in
414
+
remove_string key t
415
+
416
+
let mem_pseudo name t =
417
+
let key = ":" ^ name in
418
+
mem_string key t
419
+
420
+
let has_pseudo_headers t =
421
+
String_map.exists (fun key _ -> String.length key > 0 && key.[0] = ':') t
422
+
423
+
let pseudo_headers t =
424
+
String_map.fold
425
+
(fun key (orig_key, values) acc ->
426
+
if is_pseudo_header key then
427
+
(* Remove the colon prefix for the returned name *)
428
+
let name = String.sub orig_key 1 (String.length orig_key - 1) in
429
+
List.fold_left (fun acc v -> (name, v) :: acc) acc values
430
+
else acc)
431
+
t []
432
+
|> List.rev
433
+
434
+
let regular_headers t =
435
+
String_map.fold
436
+
(fun key (orig_key, values) acc ->
437
+
if not (is_pseudo_header key) then
438
+
List.fold_left (fun acc v -> (orig_key, v) :: acc) acc values
439
+
else acc)
440
+
t []
441
+
|> List.rev
442
+
443
+
let to_list_ordered t =
444
+
(* RFC 9113 Section 8.3: pseudo-headers MUST appear before regular headers *)
445
+
let pseudos =
446
+
String_map.fold
447
+
(fun key (orig_key, values) acc ->
448
+
if is_pseudo_header key then
449
+
List.fold_left (fun acc v -> (orig_key, v) :: acc) acc values
450
+
else acc)
451
+
t []
452
+
|> List.rev
453
+
in
454
+
let regulars =
455
+
String_map.fold
456
+
(fun key (orig_key, values) acc ->
457
+
if not (is_pseudo_header key) then
458
+
List.fold_left (fun acc v -> (orig_key, v) :: acc) acc values
459
+
else acc)
460
+
t []
461
+
|> List.rev
462
+
in
463
+
pseudos @ regulars
464
+
465
+
let h2_request ~meth ~scheme ?authority ~path t =
466
+
let t = set_pseudo "method" meth t in
467
+
let t = set_pseudo "scheme" scheme t in
468
+
let t =
469
+
match authority with
470
+
| Some auth -> set_pseudo "authority" auth t
471
+
| None -> t
472
+
in
473
+
set_pseudo "path" path t
474
+
475
+
(** {2 HTTP/2 Header Validation} *)
476
+
477
+
type h2_validation_error =
478
+
| Missing_pseudo of string
479
+
| Invalid_pseudo of string
480
+
| Pseudo_after_regular
481
+
| Invalid_header_name of string
482
+
| Uppercase_header_name of string
483
+
| Connection_header_forbidden
484
+
| Te_header_invalid
485
+
486
+
let pp_h2_validation_error ppf = function
487
+
| Missing_pseudo name -> Fmt.pf ppf "Missing required pseudo-header: :%s" name
488
+
| Invalid_pseudo name ->
489
+
Fmt.pf ppf "Invalid or unknown pseudo-header: :%s" name
490
+
| Pseudo_after_regular ->
491
+
Fmt.pf ppf "Pseudo-header appeared after regular header"
492
+
| Invalid_header_name name -> Fmt.pf ppf "Invalid header name: %s" name
493
+
| Uppercase_header_name name ->
494
+
Fmt.pf ppf "Header name contains uppercase (forbidden in HTTP/2): %s" name
495
+
| Connection_header_forbidden ->
496
+
Fmt.pf ppf "Connection-specific header forbidden in HTTP/2"
497
+
| Te_header_invalid ->
498
+
Fmt.pf ppf "TE header must only contain 'trailers' in HTTP/2"
499
+
500
+
(** HTTP/2 forbidden headers per RFC 9113 Section 8.2.2 *)
501
+
let h2_forbidden_headers : Header_name.t list =
502
+
[
503
+
`Connection;
504
+
`Keep_alive;
505
+
`Other "Proxy-Connection";
506
+
`Transfer_encoding;
507
+
`Upgrade;
508
+
]
509
+
510
+
let remove_h2_forbidden t =
511
+
List.fold_left
512
+
(fun headers name -> remove name headers)
513
+
t h2_forbidden_headers
514
+
515
+
(** Check if a string contains uppercase ASCII letters *)
516
+
let contains_uppercase s = String.exists (fun c -> c >= 'A' && c <= 'Z') s
517
+
518
+
(** Valid request pseudo-headers per RFC 9113 Section 8.3.1 *)
519
+
let valid_request_pseudos =
520
+
[ ":method"; ":scheme"; ":authority"; ":path"; ":protocol" ]
521
+
522
+
(** Valid response pseudo-headers per RFC 9113 Section 8.3.2 *)
523
+
let valid_response_pseudos = [ ":status" ]
524
+
525
+
let rec check_pseudo_order seen_regular = function
526
+
| [] -> Ok ()
527
+
| (name, _) :: rest ->
528
+
if is_pseudo_header name then
529
+
if seen_regular then Error Pseudo_after_regular
530
+
else check_pseudo_order false rest
531
+
else check_pseudo_order true rest
532
+
533
+
let check_h2_request_pseudos t headers_list is_connect =
534
+
let has_protocol = mem_pseudo "protocol" t in
535
+
if not (mem_pseudo "method" t) then Error (Missing_pseudo "method")
536
+
else if has_protocol && not is_connect then
537
+
Error (Invalid_pseudo "protocol (requires CONNECT method)")
538
+
else if (not is_connect) && not (mem_pseudo "scheme" t) then
539
+
Error (Missing_pseudo "scheme")
540
+
else if (not is_connect) && not (mem_pseudo "path" t) then
541
+
Error (Missing_pseudo "path")
542
+
else
543
+
match
544
+
List.find_opt
545
+
(fun (name, _) ->
546
+
is_pseudo_header name && not (List.mem name valid_request_pseudos))
547
+
headers_list
548
+
with
549
+
| Some (name, _) ->
550
+
Error (Invalid_pseudo (String.sub name 1 (String.length name - 1)))
551
+
| None -> Ok ()
552
+
553
+
let check_h2_regular_headers t headers_list =
554
+
match
555
+
List.find_opt
556
+
(fun (name, _) ->
557
+
(not (is_pseudo_header name)) && contains_uppercase name)
558
+
headers_list
559
+
with
560
+
| Some (name, _) -> Error (Uppercase_header_name name)
561
+
| None -> (
562
+
if List.exists (fun h -> mem h t) h2_forbidden_headers then
563
+
Error Connection_header_forbidden
564
+
else
565
+
match find `Te t with
566
+
| Some te when String.lowercase_ascii (String.trim te) <> "trailers" ->
567
+
Error Te_header_invalid
568
+
| _ -> Ok ())
569
+
570
+
let validate_h2_request t =
571
+
let headers_list = to_list t in
572
+
match check_pseudo_order false headers_list with
573
+
| Error e -> Error e
574
+
| Ok () -> (
575
+
let is_connect = pseudo "method" t = Some "CONNECT" in
576
+
match check_h2_request_pseudos t headers_list is_connect with
577
+
| Error e -> Error e
578
+
| Ok () -> check_h2_regular_headers t headers_list)
579
+
580
+
let validate_h2_response t =
581
+
let headers_list = to_list t in
582
+
583
+
(* Check ordering: pseudo-headers must come before regular headers *)
584
+
let rec check_order seen_regular = function
585
+
| [] -> Ok ()
586
+
| (name, _) :: rest ->
587
+
if is_pseudo_header name then
588
+
if seen_regular then Error Pseudo_after_regular
589
+
else check_order false rest
590
+
else check_order true rest
591
+
in
592
+
593
+
match check_order false headers_list with
594
+
| Error e -> Error e
595
+
| Ok () -> (
596
+
if
597
+
(* Check for required :status pseudo-header *)
598
+
not (mem_pseudo "status" t)
599
+
then Error (Missing_pseudo "status")
600
+
else
601
+
(* Check all pseudo-headers are valid (only :status allowed) *)
602
+
let invalid_pseudo =
603
+
List.find_opt
604
+
(fun (name, _) ->
605
+
is_pseudo_header name
606
+
&& not (List.mem name valid_response_pseudos))
607
+
headers_list
608
+
in
609
+
match invalid_pseudo with
610
+
| Some (name, _) ->
611
+
let name_without_colon =
612
+
String.sub name 1 (String.length name - 1)
613
+
in
614
+
Error (Invalid_pseudo name_without_colon)
615
+
| None -> (
616
+
(* Check for uppercase in regular header names *)
617
+
let uppercase_header =
618
+
List.find_opt
619
+
(fun (name, _) ->
620
+
(not (is_pseudo_header name)) && contains_uppercase name)
621
+
headers_list
622
+
in
623
+
match uppercase_header with
624
+
| Some (name, _) -> Error (Uppercase_header_name name)
625
+
| None ->
626
+
(* Check for forbidden connection-specific headers *)
627
+
let has_forbidden =
628
+
List.exists (fun h -> mem h t) h2_forbidden_headers
629
+
in
630
+
if has_forbidden then Error Connection_header_forbidden
631
+
else Ok ()))
632
+
633
+
let validate_h2_user_headers t =
634
+
(* Validate user-provided headers for HTTP/2 (before pseudo-headers are added).
635
+
Per RFC 9113 Section 8.2.2 and 8.3, validates:
636
+
- No pseudo-headers (user should not provide them)
637
+
- No connection-specific headers
638
+
- TE header only contains "trailers" if present
639
+
640
+
Note: We don't reject uppercase header names here because the library
641
+
internally stores headers with canonical HTTP/1.x names (e.g., "Accept-Encoding").
642
+
The h2_adapter lowercases all header names before sending to HTTP/2. *)
643
+
let headers_list = to_list t in
644
+
645
+
(* Check for any pseudo-headers (user should not provide them) *)
646
+
let pseudo =
647
+
List.find_opt (fun (name, _) -> is_pseudo_header name) headers_list
648
+
in
649
+
match pseudo with
650
+
| Some (name, _) ->
651
+
let name_without_colon = String.sub name 1 (String.length name - 1) in
652
+
Error
653
+
(Invalid_pseudo
654
+
(name_without_colon
655
+
^ " (user-provided headers must not contain pseudo-headers)"))
656
+
| None -> (
657
+
(* Check for forbidden connection-specific headers *)
658
+
let has_forbidden = List.exists (fun h -> mem h t) h2_forbidden_headers in
659
+
if has_forbidden then Error Connection_header_forbidden
660
+
else
661
+
(* Check TE header - only "trailers" is allowed *)
662
+
match find `Te t with
663
+
| Some te when String.lowercase_ascii (String.trim te) <> "trailers" ->
664
+
Error Te_header_invalid
665
+
| _ -> Ok ())
+508
lib/headers.mli
+508
lib/headers.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP header field handling per
7
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-5}RFC 9110 Section
8
+
5}
9
+
10
+
This module provides an efficient implementation of HTTP headers with
11
+
case-insensitive field names per
12
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.1}RFC 9110
13
+
Section 5.1}. Headers can have multiple values for the same field name
14
+
(e.g., Set-Cookie).
15
+
16
+
{2 Type-Safe Header Names}
17
+
18
+
Header names use the {!Header_name.t} type, providing compile-time safety
19
+
for standard headers while allowing custom headers via [`Other]:
20
+
21
+
{[
22
+
let headers =
23
+
Headers.empty
24
+
|> Headers.set `Content_type "application/json"
25
+
|> Headers.set `Authorization "Bearer token"
26
+
|> Headers.set (`Other "X-Custom") "value"
27
+
]}
28
+
29
+
{2 Security}
30
+
31
+
Header names and values are validated to prevent HTTP header injection
32
+
attacks. CR and LF characters are rejected per
33
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.5}RFC 9110
34
+
Section 5.5}. *)
35
+
36
+
val src : Logs.Src.t
37
+
(** Log source for header operations. *)
38
+
39
+
type t
40
+
(** Abstract header collection type. Headers are stored with case-insensitive
41
+
keys and maintain insertion order. *)
42
+
43
+
(** {1 Creation and Conversion} *)
44
+
45
+
val empty : t
46
+
(** [empty] creates an empty header collection. *)
47
+
48
+
val of_list : (string * string) list -> t
49
+
(** [of_list pairs] creates headers from an association list of string pairs.
50
+
This is useful when parsing headers from the wire format. Later entries
51
+
override earlier ones for the same key. *)
52
+
53
+
val to_list : t -> (string * string) list
54
+
(** [to_list headers] converts headers to an association list. The order of
55
+
headers is preserved. *)
56
+
57
+
(** {1 Header Injection Prevention} *)
58
+
59
+
exception Invalid_header of { name : string; reason : string }
60
+
(** Raised when a header name or value contains invalid characters (CR/LF) that
61
+
could enable HTTP request smuggling attacks. *)
62
+
63
+
exception Invalid_basic_auth of { reason : string }
64
+
(** Raised when Basic auth credentials contain invalid characters. Per
65
+
{{:https://datatracker.ietf.org/doc/html/rfc7617#section-2}RFC 7617 Section
66
+
2}:
67
+
- Username must not contain colon characters
68
+
- Username and password must not contain control characters (0x00-0x1F,
69
+
0x7F) *)
70
+
71
+
(** {1 Type-Safe Header Operations}
72
+
73
+
These functions use {!Header_name.t} for compile-time type safety. *)
74
+
75
+
val add : Header_name.t -> string -> t -> t
76
+
(** [add name value headers] adds a header value. Multiple values for the same
77
+
header name are allowed (e.g., for Set-Cookie).
78
+
79
+
@raise Invalid_header
80
+
if the header value contains CR/LF characters (to prevent HTTP header
81
+
injection attacks). *)
82
+
83
+
val set : Header_name.t -> string -> t -> t
84
+
(** [set name value headers] sets a header value, replacing any existing values
85
+
for that header name.
86
+
87
+
@raise Invalid_header
88
+
if the header value contains CR/LF characters (to prevent HTTP header
89
+
injection attacks). *)
90
+
91
+
val find : Header_name.t -> t -> string option
92
+
(** [find name headers] returns the first value for a header name, or [None] if
93
+
the header doesn't exist. *)
94
+
95
+
val all : Header_name.t -> t -> string list
96
+
(** [all name headers] returns all values for a header name. Returns an empty
97
+
list if the header doesn't exist. *)
98
+
99
+
val remove : Header_name.t -> t -> t
100
+
(** [remove name headers] removes all values for a header name. *)
101
+
102
+
val mem : Header_name.t -> t -> bool
103
+
(** [mem name headers] checks if a header name exists. *)
104
+
105
+
(** {1 String-Based Header Operations}
106
+
107
+
These functions accept string header names for wire format compatibility.
108
+
Use these when parsing HTTP messages where header names arrive as strings.
109
+
*)
110
+
111
+
val add_string : string -> string -> t -> t
112
+
(** [add_string name value headers] adds a header using a string name. Use this
113
+
when parsing headers from the wire.
114
+
115
+
@raise Invalid_header if the header name or value contains CR/LF characters.
116
+
*)
117
+
118
+
val set_string : string -> string -> t -> t
119
+
(** [set_string name value headers] sets a header using a string name.
120
+
121
+
@raise Invalid_header if the header name or value contains CR/LF characters.
122
+
*)
123
+
124
+
val string : string -> t -> string option
125
+
(** [string name headers] gets a header using a string name. *)
126
+
127
+
val all_string : string -> t -> string list
128
+
(** [all_string name headers] gets all values for a string header name. *)
129
+
130
+
val remove_string : string -> t -> t
131
+
(** [remove_string name headers] removes a header using a string name. *)
132
+
133
+
val mem_string : string -> t -> bool
134
+
(** [mem_string name headers] checks if a header exists using a string name. *)
135
+
136
+
(** {1 Merging} *)
137
+
138
+
val merge : t -> t -> t
139
+
(** [merge base override] merges two header collections. Headers from [override]
140
+
replace those in [base]. *)
141
+
142
+
(** {1 Common Header Builders}
143
+
144
+
Convenience functions for setting common HTTP headers. *)
145
+
146
+
val content_type : Mime.t -> t -> t
147
+
(** [content_type mime headers] sets the Content-Type header. *)
148
+
149
+
val content_length : int64 -> t -> t
150
+
(** [content_length length headers] sets the Content-Length header. *)
151
+
152
+
val accept : Mime.t -> t -> t
153
+
(** [accept mime headers] sets the Accept header. *)
154
+
155
+
val accept_language : string -> t -> t
156
+
(** [accept_language lang headers] sets the Accept-Language header. Per
157
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-12.5.4}RFC 9110
158
+
Section 12.5.4}.
159
+
160
+
Examples:
161
+
{[
162
+
headers
163
+
|> Headers.accept_language "en-US" headers
164
+
|> Headers.accept_language "en-US, en;q=0.9, de;q=0.8" headers
165
+
|> Headers.accept_language "*"
166
+
]} *)
167
+
168
+
val authorization : string -> t -> t
169
+
(** [authorization value headers] sets the Authorization header with a raw
170
+
value. *)
171
+
172
+
val bearer : string -> t -> t
173
+
(** [bearer token headers] sets the Authorization header with a Bearer token.
174
+
Example: [bearer "abc123"] sets ["Authorization: Bearer abc123"]. *)
175
+
176
+
val basic : username:string -> password:string -> t -> t
177
+
(** [basic ~username ~password headers] sets the Authorization header with HTTP
178
+
Basic authentication (base64-encoded username:password).
179
+
180
+
@raise Invalid_basic_auth
181
+
if the username contains a colon character or if either username or
182
+
password contains control characters (RFC 7617 Section 2). *)
183
+
184
+
val user_agent : string -> t -> t
185
+
(** [user_agent ua headers] sets the User-Agent header. *)
186
+
187
+
val host : string -> t -> t
188
+
(** [host hostname headers] sets the Host header. *)
189
+
190
+
val cookie : string -> string -> t -> t
191
+
(** [cookie name value headers] adds a cookie to the Cookie header. Multiple
192
+
cookies can be added by calling this function multiple times. *)
193
+
194
+
val range : start:int64 -> ?end_:int64 -> unit -> t -> t
195
+
(** [range ~start ?end_ () headers] sets the Range header for partial content.
196
+
Example: [range ~start:0L ~end_:999L ()] requests the first 1000 bytes. *)
197
+
198
+
(** {1 HTTP 100-Continue Support}
199
+
200
+
Per Recommendation #7: Expect: 100-continue protocol for large uploads. RFC
201
+
9110 Section 10.1.1 (Expect) *)
202
+
203
+
val expect : string -> t -> t
204
+
(** [expect value headers] sets the Expect header. Example:
205
+
[expect "100-continue"] for large request bodies. *)
206
+
207
+
val expect_100_continue : t -> t
208
+
(** [expect_100_continue headers] sets [Expect: 100-continue]. Use this for
209
+
large uploads to allow the server to reject the request before the body is
210
+
sent, saving bandwidth. *)
211
+
212
+
(** {1 TE Header Support}
213
+
214
+
Per RFC 9110 Section 10.1.4: The TE header indicates what transfer codings
215
+
the client is willing to accept in the response, and whether the client is
216
+
willing to accept trailer fields in a chunked transfer coding. *)
217
+
218
+
val te : string -> t -> t
219
+
(** [te value headers] sets the TE header to indicate accepted transfer codings.
220
+
Example: [te "trailers, deflate"]. *)
221
+
222
+
val te_trailers : t -> t
223
+
(** [te_trailers headers] sets [TE: trailers] to indicate the client accepts
224
+
trailer fields in chunked transfer coding. Per RFC 9110 Section 10.1.4, a
225
+
client MUST send this if it wishes to receive trailers. *)
226
+
227
+
(** {1 Cache Control Headers}
228
+
229
+
Per Recommendation #17 and #19: Response caching and conditional requests.
230
+
RFC 9111 (HTTP Caching), RFC 9110 Section 8.8.2-8.8.3 (Last-Modified, ETag)
231
+
*)
232
+
233
+
val if_none_match : string -> t -> t
234
+
(** [if_none_match etag headers] sets the If-None-Match header for conditional
235
+
requests. The request succeeds only if the resource's ETag does NOT match.
236
+
Used with GET/HEAD to implement efficient caching (returns 304 Not Modified
237
+
if matches). *)
238
+
239
+
val if_match : string -> t -> t
240
+
(** [if_match etag headers] sets the If-Match header for conditional requests.
241
+
The request succeeds only if the resource's ETag matches. Used with
242
+
PUT/DELETE for optimistic concurrency (prevents lost updates). *)
243
+
244
+
val if_modified_since : string -> t -> t
245
+
(** [if_modified_since date headers] sets the If-Modified-Since header. The date
246
+
should be in HTTP-date format (RFC 9110 Section 5.6.7). Example:
247
+
["Sun, 06 Nov 1994 08:49:37 GMT"]. *)
248
+
249
+
val if_unmodified_since : string -> t -> t
250
+
(** [if_unmodified_since date headers] sets the If-Unmodified-Since header. The
251
+
request succeeds only if the resource has NOT been modified since the date.
252
+
*)
253
+
254
+
val http_date_of_ptime : Ptime.t -> string
255
+
(** [http_date_of_ptime time] formats a Ptime.t as an HTTP-date. Format: "Sun,
256
+
06 Nov 1994 08:49:37 GMT" (RFC 9110 Section 5.6.7). *)
257
+
258
+
val if_modified_since_ptime : Ptime.t -> t -> t
259
+
(** [if_modified_since_ptime time headers] sets If-Modified-Since using a
260
+
Ptime.t value. *)
261
+
262
+
val if_unmodified_since_ptime : Ptime.t -> t -> t
263
+
(** [if_unmodified_since_ptime time headers] sets If-Unmodified-Since using a
264
+
Ptime.t value. *)
265
+
266
+
val cache_control : string -> t -> t
267
+
(** [cache_control directives headers] sets the Cache-Control header with a raw
268
+
directive string. Example: [cache_control "no-cache, max-age=3600"]. *)
269
+
270
+
val cache_control_directives :
271
+
?max_age:int ->
272
+
?max_stale:int option option ->
273
+
?min_fresh:int ->
274
+
?no_cache:bool ->
275
+
?no_store:bool ->
276
+
?no_transform:bool ->
277
+
?only_if_cached:bool ->
278
+
unit ->
279
+
t ->
280
+
t
281
+
(** [cache_control_directives ?max_age ?max_stale ?min_fresh ~no_cache ~no_store
282
+
~no_transform ~only_if_cached () headers] builds a Cache-Control header
283
+
from individual directives (RFC 9111 request directives).
284
+
285
+
- [max_age]: Maximum age in seconds the client is willing to accept
286
+
- [max_stale]: Accept stale responses:
287
+
- [None]: omit max_stale entirely
288
+
- [Some None]: "max-stale" (accept any staleness)
289
+
- [Some (Some n)]: "max-stale=N" (accept n seconds staleness)
290
+
- [min_fresh]: Response must be fresh for at least n more seconds
291
+
- [no_cache]: Force revalidation with origin server
292
+
- [no_store]: Response must not be stored in cache
293
+
- [no_transform]: Intermediaries must not transform the response
294
+
- [only_if_cached]: Only return cached response, 504 if not available. *)
295
+
296
+
val etag : string -> t -> t
297
+
(** [etag value headers] sets the ETag header (for responses). Example:
298
+
[etag "\"abc123\""]. *)
299
+
300
+
val last_modified : string -> t -> t
301
+
(** [last_modified date headers] sets the Last-Modified header (for responses).
302
+
The date should be in HTTP-date format. *)
303
+
304
+
val last_modified_ptime : Ptime.t -> t -> t
305
+
(** [last_modified_ptime time headers] sets Last-Modified using a Ptime.t value.
306
+
*)
307
+
308
+
(** {1 Connection Header Handling}
309
+
310
+
Per
311
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-7.6.1}RFC 9110
312
+
Section 7.6.1}: The Connection header field lists hop-by-hop header fields
313
+
that MUST be removed before forwarding the message. *)
314
+
315
+
val parse_connection_header : t -> Header_name.t list
316
+
(** [parse_connection_header headers] parses the Connection header value into a
317
+
list of header names. *)
318
+
319
+
val hop_by_hop_headers : t -> Header_name.t list
320
+
(** [hop_by_hop_headers headers] returns all hop-by-hop headers. This is the
321
+
union of {!Header_name.hop_by_hop_headers} and any headers listed in the
322
+
Connection header. *)
323
+
324
+
val remove_hop_by_hop : t -> t
325
+
(** [remove_hop_by_hop headers] removes all hop-by-hop headers. This should be
326
+
called before caching or forwarding a response. Per RFC 9110 Section 7.6.1.
327
+
*)
328
+
329
+
val connection_close : t -> bool
330
+
(** [connection_close headers] returns [true] if Connection: close is present.
331
+
This indicates the connection should be closed after the current message. *)
332
+
333
+
val connection_keep_alive : t -> bool
334
+
(** [connection_keep_alive headers] returns [true] if Connection: keep-alive is
335
+
present. This is primarily used with HTTP/1.0 to request a persistent
336
+
connection. *)
337
+
338
+
(** {1 Aliases} *)
339
+
340
+
val multi : Header_name.t -> t -> string list
341
+
(** [multi] is an alias for {!all}. *)
342
+
343
+
val pp : Format.formatter -> t -> unit
344
+
(** Pretty printer for headers. *)
345
+
346
+
val pp_brief : Format.formatter -> t -> unit
347
+
(** Brief pretty printer showing count only. *)
348
+
349
+
(** {1 HTTP/2 Pseudo-Header Support}
350
+
351
+
HTTP/2 uses pseudo-header fields to convey information that was previously
352
+
carried in the request line (HTTP/1.1) or status line. Pseudo-headers start
353
+
with a colon character ([:]).
354
+
355
+
Per
356
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-8.3}RFC 9113
357
+
Section 8.3}:
358
+
- Pseudo-headers MUST appear before regular headers
359
+
- Pseudo-headers MUST NOT appear in trailers
360
+
- Unknown pseudo-headers MUST be treated as malformed
361
+
362
+
{2 Request Pseudo-Headers}
363
+
364
+
- [:method] - HTTP method (required)
365
+
- [:scheme] - URI scheme (required for non-CONNECT)
366
+
- [:authority] - Authority portion of URI (host:port)
367
+
- [:path] - Path and query (required for non-CONNECT)
368
+
369
+
{2 Response Pseudo-Headers}
370
+
371
+
- [:status] - HTTP status code (required) *)
372
+
373
+
val is_pseudo_header : string -> bool
374
+
(** [is_pseudo_header name] returns [true] if the header name starts with [:].
375
+
Per RFC 9113 Section 8.3, pseudo-headers are identified by a colon prefix.
376
+
*)
377
+
378
+
val pseudo : string -> t -> string option
379
+
(** [pseudo name headers] retrieves a pseudo-header value. The [name] should NOT
380
+
include the colon prefix. Example: [pseudo "method" headers] retrieves
381
+
[:method]. *)
382
+
383
+
val set_pseudo : string -> string -> t -> t
384
+
(** [set_pseudo name value headers] sets a pseudo-header value. The [name]
385
+
should NOT include the colon prefix. Pseudo-headers are stored with the
386
+
colon prefix internally. Example: [set_pseudo "method" "GET" headers] sets
387
+
[:method: GET].
388
+
389
+
@raise Invalid_header if the value contains CR/LF characters. *)
390
+
391
+
val remove_pseudo : string -> t -> t
392
+
(** [remove_pseudo name headers] removes a pseudo-header. The [name] should NOT
393
+
include the colon prefix. *)
394
+
395
+
val mem_pseudo : string -> t -> bool
396
+
(** [mem_pseudo name headers] returns [true] if the pseudo-header exists. The
397
+
[name] should NOT include the colon prefix. *)
398
+
399
+
val has_pseudo_headers : t -> bool
400
+
(** [has_pseudo_headers headers] returns [true] if any pseudo-headers are
401
+
present. *)
402
+
403
+
val pseudo_headers : t -> (string * string) list
404
+
(** [pseudo_headers headers] returns all pseudo-headers as [(name, value)]
405
+
pairs. Names are returned WITHOUT the colon prefix. *)
406
+
407
+
val regular_headers : t -> (string * string) list
408
+
(** [regular_headers headers] returns all non-pseudo headers as [(name, value)]
409
+
pairs. *)
410
+
411
+
val to_list_ordered : t -> (string * string) list
412
+
(** [to_list_ordered headers] returns all headers with pseudo-headers first,
413
+
followed by regular headers, as required by RFC 9113 Section 8.3. *)
414
+
415
+
(** {2 HTTP/2 Request Header Construction} *)
416
+
417
+
val h2_request :
418
+
meth:string -> scheme:string -> ?authority:string -> path:string -> t -> t
419
+
(** [h2_request ~meth ~scheme ?authority ~path headers] sets the required HTTP/2
420
+
request pseudo-headers.
421
+
422
+
Per RFC 9113 Section 8.3.1:
423
+
- [:method] is required
424
+
- [:scheme] is required (except for CONNECT)
425
+
- [:path] is required (except for CONNECT, OPTIONS with empty path)
426
+
- [:authority] is optional but recommended
427
+
428
+
Example:
429
+
{[
430
+
Headers.empty
431
+
|> Headers.h2_request ~meth:"GET" ~scheme:"https" ~authority:"example.com"
432
+
~path:"/"
433
+
|> Headers.set `Accept "application/json"
434
+
]} *)
435
+
436
+
(** {2 HTTP/2 Header Validation}
437
+
438
+
Per
439
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-8.2}RFC 9113
440
+
Section 8.2}. *)
441
+
442
+
type h2_validation_error =
443
+
| Missing_pseudo of string (** Required pseudo-header is missing *)
444
+
| Invalid_pseudo of string (** Unknown or misplaced pseudo-header *)
445
+
| Pseudo_after_regular (** Pseudo-header appeared after regular header *)
446
+
| Invalid_header_name of string
447
+
(** Header name contains invalid characters *)
448
+
| Uppercase_header_name of string
449
+
(** Header name contains uppercase (forbidden in HTTP/2) *)
450
+
| Connection_header_forbidden
451
+
(** Connection-specific headers are forbidden in HTTP/2 *)
452
+
| Te_header_invalid (** TE header with value other than "trailers" *)
453
+
454
+
val pp_h2_validation_error : Format.formatter -> h2_validation_error -> unit
455
+
(** Pretty printer for validation errors. *)
456
+
457
+
val validate_h2_request : t -> (unit, h2_validation_error) result
458
+
(** [validate_h2_request headers] validates headers for HTTP/2 request
459
+
constraints.
460
+
461
+
Per RFC 9113 Section 8.3.1, validates:
462
+
- Required pseudo-headers are present ([:method], [:scheme], [:path])
463
+
- No unknown pseudo-headers
464
+
- Pseudo-headers appear before regular headers
465
+
- No uppercase letters in header names
466
+
- No connection-specific headers (Connection, Keep-Alive, etc.)
467
+
- TE header only contains "trailers" if present. *)
468
+
469
+
val validate_h2_response : t -> (unit, h2_validation_error) result
470
+
(** [validate_h2_response headers] validates headers for HTTP/2 response
471
+
constraints.
472
+
473
+
Per RFC 9113 Section 8.3.2, validates:
474
+
- [:status] pseudo-header is present
475
+
- No other pseudo-headers
476
+
- Pseudo-headers appear before regular headers
477
+
- No uppercase letters in header names
478
+
- No connection-specific headers. *)
479
+
480
+
val validate_h2_user_headers : t -> (unit, h2_validation_error) result
481
+
(** [validate_h2_user_headers headers] validates user-provided headers for
482
+
HTTP/2.
483
+
484
+
Unlike {!validate_h2_request}, this validates headers {i before}
485
+
pseudo-headers are added by the HTTP/2 layer. Use this in the HTTP adapter.
486
+
487
+
Per RFC 9113 Section 8.2.2 and 8.3, validates:
488
+
- No pseudo-headers (user should not provide them)
489
+
- No uppercase letters in header names
490
+
- No connection-specific headers (Connection, Keep-Alive, etc.)
491
+
- TE header only contains "trailers" if present. *)
492
+
493
+
(** {2 HTTP/2 Forbidden Headers}
494
+
495
+
Per RFC 9113 Section 8.2.2, certain headers are connection-specific and MUST
496
+
NOT appear in HTTP/2. *)
497
+
498
+
val h2_forbidden_headers : Header_name.t list
499
+
(** Headers that MUST NOT appear in HTTP/2 messages:
500
+
- Connection
501
+
- Keep-Alive
502
+
- Proxy-Connection
503
+
- Transfer-Encoding
504
+
- Upgrade. *)
505
+
506
+
val remove_h2_forbidden : t -> t
507
+
(** [remove_h2_forbidden headers] removes all HTTP/2 forbidden headers. Use this
508
+
when converting HTTP/1.1 headers for use with HTTP/2. *)
+81
lib/http_date.ml
+81
lib/http_date.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP-date parsing per RFC 9110 Section 5.6.7 *)
7
+
8
+
let src = Logs.Src.create "requests.http_date" ~doc:"HTTP Date Parsing"
9
+
10
+
module Log = (val Logs.src_log src : Logs.LOG)
11
+
12
+
(** Parse HTTP-date (RFC 9110 Section 5.6.7) to Ptime.t *)
13
+
let parse s =
14
+
(* HTTP-date format: "Sun, 06 Nov 1994 08:49:37 GMT" (RFC 1123) *)
15
+
(* Also supports obsolete formats per RFC 9110 *)
16
+
let s = String.trim s in
17
+
18
+
(* Helper to parse month name *)
19
+
let parse_month month_str =
20
+
match String.lowercase_ascii month_str with
21
+
| "jan" -> 1
22
+
| "feb" -> 2
23
+
| "mar" -> 3
24
+
| "apr" -> 4
25
+
| "may" -> 5
26
+
| "jun" -> 6
27
+
| "jul" -> 7
28
+
| "aug" -> 8
29
+
| "sep" -> 9
30
+
| "oct" -> 10
31
+
| "nov" -> 11
32
+
| "dec" -> 12
33
+
| _ -> failwith "invalid month"
34
+
in
35
+
36
+
(* Validate time components per RFC 9110 Section 5.6.7 ABNF:
37
+
hour = 2DIGIT (00-23), minute = 2DIGIT (00-59), second = 2DIGIT (00-59).
38
+
Note: RFC 9110 inherits the 00-60 range from RFC 5234 to allow leap
39
+
seconds, but HTTP servers MUST NOT generate them and recipients SHOULD
40
+
treat second=60 as invalid. We reject second=60 for robustness. *)
41
+
let validate_time hour min sec =
42
+
hour >= 0 && hour <= 23 && min >= 0 && min <= 59 && sec >= 0 && sec <= 59
43
+
in
44
+
45
+
let make_datetime year month day hour min sec =
46
+
if validate_time hour min sec then
47
+
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0))
48
+
else None
49
+
in
50
+
51
+
(* Try different date formats in order of preference *)
52
+
let parsers =
53
+
[
54
+
(* RFC 1123 format: "Sun, 06 Nov 1994 08:49:37 GMT" *)
55
+
(fun () ->
56
+
Scanf.sscanf s "%_s %d %s %d %d:%d:%d GMT"
57
+
(fun day month_str year hour min sec ->
58
+
let month = parse_month month_str in
59
+
make_datetime year month day hour min sec));
60
+
(* RFC 850 format: "Sunday, 06-Nov-94 08:49:37 GMT" *)
61
+
(fun () ->
62
+
Scanf.sscanf s "%_s %d-%s@-%d %d:%d:%d GMT"
63
+
(fun day month_str year2 hour min sec ->
64
+
let year = if year2 >= 70 then 1900 + year2 else 2000 + year2 in
65
+
let month = parse_month month_str in
66
+
make_datetime year month day hour min sec));
67
+
(* ANSI C asctime() format: "Sun Nov 6 08:49:37 1994" *)
68
+
(fun () ->
69
+
Scanf.sscanf s "%_s %s %d %d:%d:%d %d"
70
+
(fun month_str day hour min sec year ->
71
+
let month = parse_month month_str in
72
+
make_datetime year month day hour min sec));
73
+
]
74
+
in
75
+
76
+
(* Try each parser until one succeeds *)
77
+
List.find_map
78
+
(fun parser ->
79
+
try parser ()
80
+
with Scanf.Scan_failure _ | Failure _ | End_of_file -> None)
81
+
parsers
+28
lib/http_date.mli
+28
lib/http_date.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP-date parsing per RFC 9110 Section 5.6.7
7
+
8
+
This module provides parsing of HTTP date strings as defined in RFC 9110. It
9
+
supports three date formats:
10
+
- RFC 1123: "Sun, 06 Nov 1994 08:49:37 GMT" (preferred)
11
+
- RFC 850: "Sunday, 06-Nov-94 08:49:37 GMT" (obsolete)
12
+
- ANSI C asctime(): "Sun Nov 6 08:49:37 1994" (obsolete) *)
13
+
14
+
val src : Logs.Src.t
15
+
(** Log source for HTTP date parsing. *)
16
+
17
+
val parse : string -> Ptime.t option
18
+
(** Parse an HTTP-date string to Ptime.t.
19
+
20
+
[parse s] attempts to parse the string [s] as an HTTP-date using the three
21
+
supported formats. Returns [None] if parsing fails.
22
+
23
+
Examples:
24
+
{[
25
+
parse "Sun, 06 Nov 1994 08:49:37 GMT" (* RFC 1123 *) parse
26
+
"Sunday, 06-Nov-94 08:49:37 GMT" (* RFC 850 *) parse
27
+
"Sun Nov 6 08:49:37 1994" (* asctime *)
28
+
]} *)
+61
lib/http_version.ml
+61
lib/http_version.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP protocol version identification and ALPN support.
7
+
8
+
Implements protocol identification per
9
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-3.1}RFC 9113
10
+
Section 3.1}. *)
11
+
12
+
type t = Http_1_0 | Http_1_1 | Http_2
13
+
14
+
let to_string = function
15
+
| Http_1_0 -> "HTTP/1.0"
16
+
| Http_1_1 -> "HTTP/1.1"
17
+
| Http_2 -> "HTTP/2"
18
+
19
+
let pp ppf v = Fmt.string ppf (to_string v)
20
+
21
+
let equal v1 v2 =
22
+
match (v1, v2) with
23
+
| Http_1_0, Http_1_0 -> true
24
+
| Http_1_1, Http_1_1 -> true
25
+
| Http_2, Http_2 -> true
26
+
| _ -> false
27
+
28
+
let compare v1 v2 =
29
+
let to_int = function Http_1_0 -> 0 | Http_1_1 -> 1 | Http_2 -> 2 in
30
+
Int.compare (to_int v1) (to_int v2)
31
+
32
+
(* ALPN Protocol Identifiers per RFC 9113 Section 3.1 *)
33
+
34
+
let alpn_h2 = "h2"
35
+
let alpn_http_1_1 = "http/1.1"
36
+
37
+
let alpn_of_version = function
38
+
| Http_1_0 -> None (* HTTP/1.0 has no ALPN identifier *)
39
+
| Http_1_1 -> Some alpn_http_1_1
40
+
| Http_2 -> Some alpn_h2
41
+
42
+
let version_of_alpn = function
43
+
| "h2" -> Some Http_2
44
+
| "http/1.1" -> Some Http_1_1
45
+
| _ -> None
46
+
47
+
let alpn_protocols ~preferred = List.filter_map alpn_of_version preferred
48
+
49
+
(* Version capability detection *)
50
+
51
+
let supports_multiplexing = function
52
+
| Http_2 -> true
53
+
| Http_1_0 | Http_1_1 -> false
54
+
55
+
let supports_server_push = function
56
+
| Http_2 -> true
57
+
| Http_1_0 | Http_1_1 -> false
58
+
59
+
let supports_header_compression = function
60
+
| Http_2 -> true
61
+
| Http_1_0 | Http_1_1 -> false
+94
lib/http_version.mli
+94
lib/http_version.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP protocol version identification and ALPN support.
7
+
8
+
This module provides types for HTTP protocol versions and utilities for TLS
9
+
Application-Layer Protocol Negotiation (ALPN) as specified in
10
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-3.1}RFC 9113
11
+
Section 3.1}.
12
+
13
+
{2 ALPN Protocol Identifiers}
14
+
15
+
Per RFC 9113 Section 3.1:
16
+
- ["h2"] identifies HTTP/2 over TLS
17
+
- ["http/1.1"] identifies HTTP/1.1
18
+
19
+
{2 Example}
20
+
21
+
{[
22
+
(* Configure TLS with HTTP/2 preference *)
23
+
let alpn = Http_version.alpn_protocols ~preferred:[Http_2; Http_1_1] in
24
+
(* alpn = ["h2"; "http/1.1"] *)
25
+
]} *)
26
+
27
+
(** {1 Version Type} *)
28
+
29
+
type t =
30
+
| Http_1_0 (** HTTP/1.0 *)
31
+
| Http_1_1 (** HTTP/1.1 *)
32
+
| Http_2 (** HTTP/2 per RFC 9113 *)
33
+
34
+
(** {1 Conversion} *)
35
+
36
+
val to_string : t -> string
37
+
(** [to_string version] returns a human-readable string. Examples: ["HTTP/1.0"],
38
+
["HTTP/1.1"], ["HTTP/2"]. *)
39
+
40
+
val pp : Format.formatter -> t -> unit
41
+
(** Pretty printer for versions. *)
42
+
43
+
(** {1 Comparison} *)
44
+
45
+
val equal : t -> t -> bool
46
+
(** [equal v1 v2] returns true if versions are equal. *)
47
+
48
+
val compare : t -> t -> int
49
+
(** [compare v1 v2] compares versions. HTTP/2 > HTTP/1.1 > HTTP/1.0. *)
50
+
51
+
(** {1 ALPN Protocol Negotiation}
52
+
53
+
Per
54
+
{{:https://datatracker.ietf.org/doc/html/rfc9113#section-3.1}RFC 9113
55
+
Section 3.1}. *)
56
+
57
+
val alpn_h2 : string
58
+
(** ALPN protocol identifier for HTTP/2 over TLS, the string [h2]. Serialized as
59
+
the two-octet sequence: 0x68, 0x32. *)
60
+
61
+
val alpn_http_1_1 : string
62
+
(** ALPN protocol identifier for HTTP/1.1, the string [http/1.1]. *)
63
+
64
+
val alpn_of_version : t -> string option
65
+
(** [alpn_of_version version] returns the ALPN identifier for a version. Returns
66
+
[None] for HTTP/1.0 which has no ALPN identifier. *)
67
+
68
+
val version_of_alpn : string -> t option
69
+
(** [version_of_alpn alpn] returns the version for an ALPN identifier. Returns
70
+
[None] for unrecognized identifiers. *)
71
+
72
+
val alpn_protocols : preferred:t list -> string list
73
+
(** [alpn_protocols ~preferred] returns ALPN protocol identifiers in preference
74
+
order. HTTP/1.0 is filtered out (no ALPN identifier).
75
+
76
+
Example:
77
+
{[
78
+
alpn_protocols ~preferred:[ Http_2; Http_1_1 ]
79
+
(* Returns: ["h2"; "http/1.1"] *)
80
+
]} *)
81
+
82
+
(** {1 Version Detection} *)
83
+
84
+
val supports_multiplexing : t -> bool
85
+
(** [supports_multiplexing version] returns true if the version supports request
86
+
multiplexing over a single connection. Only HTTP/2 supports this. *)
87
+
88
+
val supports_server_push : t -> bool
89
+
(** [supports_server_push version] returns true if the version supports server
90
+
push. Only HTTP/2 supports this. *)
91
+
92
+
val supports_header_compression : t -> bool
93
+
(** [supports_header_compression version] returns true if the version supports
94
+
header compression. Only HTTP/2 (HPACK) supports this. *)
+209
lib/huri.ml
+209
lib/huri.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
3
+
Copyright (c) 2012-2014 David Sheets <sheets@alum.mit.edu>
4
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>
5
+
6
+
Permission to use, copy, modify, and distribute this software for any
7
+
purpose with or without fee is hereby granted, provided that the above
8
+
copyright notice and this permission notice appear in all copies.
9
+
10
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17
+
---------------------------------------------------------------------------*)
18
+
19
+
(** URI Buf_write serialization for the requests library.
20
+
21
+
This module provides efficient [Eio.Buf_write] serialization for [Uri.t]
22
+
values. For all other URI operations, use the [uri] opam library directly.
23
+
24
+
{[
25
+
(* Use Uri for parsing and manipulation *)
26
+
let uri = Uri.of_string "https://example.com/path" in
27
+
let host = Uri.host uri in
28
+
29
+
(* Use Huri.write for efficient serialization to Buf_write *)
30
+
Eio.Buf_write.with_flow flow (fun w -> Huri.write w uri)
31
+
]} *)
32
+
33
+
(** {1 Type Alias} *)
34
+
35
+
type t = Uri.t
36
+
(** [t] is an alias for [Uri.t]. Use the [uri] library for all operations except
37
+
[Buf_write] serialization. *)
38
+
39
+
(** {1 Buf_write Serialization} *)
40
+
41
+
(** Hex character lookup table for efficient percent-encoding *)
42
+
let hex_chars = "0123456789ABCDEF"
43
+
44
+
(** Safe characters for different URI components per RFC 3986 *)
45
+
module Safe_chars = struct
46
+
type safe_chars = bool array
47
+
48
+
let sub_delims a =
49
+
let subd = "!$&'()*+,;=" in
50
+
for i = 0 to String.length subd - 1 do
51
+
a.(Char.code subd.[i]) <- true
52
+
done;
53
+
a
54
+
55
+
let unreserved : safe_chars =
56
+
let a = Array.make 256 false in
57
+
let always_safe =
58
+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.-~"
59
+
in
60
+
for i = 0 to String.length always_safe - 1 do
61
+
a.(Char.code always_safe.[i]) <- true
62
+
done;
63
+
a
64
+
65
+
let pchar : safe_chars =
66
+
let a = sub_delims (Array.copy unreserved) in
67
+
a.(Char.code ':') <- true;
68
+
a.(Char.code '@') <- true;
69
+
a
70
+
71
+
let path : safe_chars =
72
+
let a = sub_delims (Array.copy pchar) in
73
+
a.(Char.code '/') <- false;
74
+
a
75
+
76
+
let query : safe_chars =
77
+
let a = Array.copy pchar in
78
+
a.(Char.code '/') <- true;
79
+
a.(Char.code '?') <- true;
80
+
a.(Char.code '&') <- false;
81
+
a.(Char.code ';') <- false;
82
+
a.(Char.code '+') <- false;
83
+
a
84
+
85
+
let query_key : safe_chars =
86
+
let a = Array.copy query in
87
+
a.(Char.code '=') <- false;
88
+
a
89
+
90
+
let query_value : safe_chars =
91
+
let a = Array.copy query in
92
+
a.(Char.code ',') <- false;
93
+
a
94
+
95
+
let fragment : safe_chars = query
96
+
97
+
let userinfo : safe_chars =
98
+
let a = Array.copy unreserved in
99
+
a.(Char.code ':') <- false;
100
+
a
101
+
end
102
+
103
+
module Writer = struct
104
+
module Write = Eio.Buf_write
105
+
106
+
let write_pct_char w c =
107
+
Write.char w '%';
108
+
Write.char w hex_chars.[Char.code c lsr 4];
109
+
Write.char w hex_chars.[Char.code c land 0xf]
110
+
111
+
let write_pct_encoded ~safe_chars w s =
112
+
for i = 0 to String.length s - 1 do
113
+
let c = s.[i] in
114
+
if safe_chars.(Char.code c) then Write.char w c else write_pct_char w c
115
+
done
116
+
117
+
let write_path w path =
118
+
let len = String.length path in
119
+
let rec loop i =
120
+
if i >= len then ()
121
+
else if path.[i] = '/' then begin
122
+
Write.char w '/';
123
+
loop (i + 1)
124
+
end
125
+
else begin
126
+
let rec find_end j =
127
+
if j >= len || path.[j] = '/' then j else find_end (j + 1)
128
+
in
129
+
let j = find_end i in
130
+
write_pct_encoded ~safe_chars:Safe_chars.path w
131
+
(String.sub path i (j - i));
132
+
loop j
133
+
end
134
+
in
135
+
loop 0
136
+
137
+
let write_values w vs =
138
+
Write.char w '=';
139
+
List.iteri
140
+
(fun j v ->
141
+
if j > 0 then Write.char w ',';
142
+
write_pct_encoded ~safe_chars:Safe_chars.query_value w v)
143
+
vs
144
+
145
+
let write_query w query =
146
+
List.iteri
147
+
(fun i (k, vs) ->
148
+
if i > 0 then Write.char w '&';
149
+
write_pct_encoded ~safe_chars:Safe_chars.query_key w k;
150
+
if vs <> [] then write_values w vs)
151
+
query
152
+
153
+
let write w uri =
154
+
(* Scheme *)
155
+
Option.iter
156
+
(fun s ->
157
+
Write.string w s;
158
+
Write.char w ':')
159
+
(Uri.scheme uri);
160
+
(* Authority *)
161
+
(match (Uri.userinfo uri, Uri.host uri, Uri.port uri) with
162
+
| Some _, _, _ | _, Some _, _ | _, _, Some _ -> Write.string w "//"
163
+
| _ -> ());
164
+
(* Userinfo *)
165
+
Option.iter
166
+
(fun ui ->
167
+
write_pct_encoded ~safe_chars:Safe_chars.userinfo w ui;
168
+
Write.char w '@')
169
+
(Uri.userinfo uri);
170
+
(* Host *)
171
+
Option.iter
172
+
(fun h ->
173
+
if String.length h > 0 && h.[0] = '[' then Write.string w h
174
+
else write_pct_encoded ~safe_chars:Safe_chars.unreserved w h)
175
+
(Uri.host uri);
176
+
(* Port *)
177
+
Option.iter
178
+
(fun p ->
179
+
Write.char w ':';
180
+
Write.string w (string_of_int p))
181
+
(Uri.port uri);
182
+
(* Path *)
183
+
let path = Uri.path uri in
184
+
if path <> "" then write_path w path;
185
+
(* Query *)
186
+
let query = Uri.query uri in
187
+
if query <> [] then begin
188
+
Write.char w '?';
189
+
write_query w query
190
+
end;
191
+
(* Fragment *)
192
+
Option.iter
193
+
(fun f ->
194
+
Write.char w '#';
195
+
write_pct_encoded ~safe_chars:Safe_chars.fragment w f)
196
+
(Uri.fragment uri)
197
+
end
198
+
199
+
(** [write w uri] writes [uri] directly to the buffer [w]. This is more
200
+
efficient than [Uri.to_string] when writing to an I/O sink as it avoids
201
+
intermediate string allocation. *)
202
+
let write = Writer.write
203
+
204
+
let pp fmt uri = Format.pp_print_string fmt (Uri.to_string uri)
205
+
206
+
(** {1 JSON Codec} *)
207
+
208
+
(** JSON codec for URIs. Encodes as a JSON string. *)
209
+
let jsont = Jsont.string |> Jsont.map ~dec:Uri.of_string ~enc:Uri.to_string
+53
lib/huri.mli
+53
lib/huri.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2012-2013 Anil Madhavapeddy <anil@recoil.org>
3
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>
4
+
5
+
Permission to use, copy, modify, and distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
+
---------------------------------------------------------------------------*)
17
+
18
+
(** URI Buf_write serialization for the requests library.
19
+
20
+
This module provides efficient [Eio.Buf_write] serialization for [Uri.t]
21
+
values. For all other URI operations, use the [uri] opam library directly.
22
+
23
+
{2 Usage}
24
+
25
+
{[
26
+
(* Use Uri for parsing and manipulation *)
27
+
let uri = Uri.of_string "https://example.com/path" in
28
+
let host = Uri.host uri in
29
+
30
+
(* Use Huri.write for efficient serialization to Buf_write *)
31
+
Eio.Buf_write.with_flow flow (fun w -> Huri.write w uri)
32
+
]} *)
33
+
34
+
(** {1 Type Alias} *)
35
+
36
+
type t = Uri.t
37
+
(** [t] is an alias for [Uri.t]. Use the [uri] library for all operations except
38
+
[Buf_write] serialization. *)
39
+
40
+
val pp : Format.formatter -> t -> unit
41
+
(** [pp fmt t] pretty-prints a URI. *)
42
+
43
+
(** {1 Buf_write Serialization} *)
44
+
45
+
val write : Eio.Buf_write.t -> t -> unit
46
+
(** [write w uri] writes [uri] directly to the buffer [w]. This is more
47
+
efficient than [Uri.to_string] when writing to an I/O sink as it avoids
48
+
intermediate string allocation. *)
49
+
50
+
(** {1 JSON Codec} *)
51
+
52
+
val jsont : t Jsont.t
53
+
(** JSON codec for URIs. Encodes as a JSON string. *)
+93
lib/method.ml
+93
lib/method.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "requests.method" ~doc:"HTTP Methods"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
type t =
11
+
[ `GET
12
+
| `POST
13
+
| `PUT
14
+
| `DELETE
15
+
| `HEAD
16
+
| `OPTIONS
17
+
| `PATCH
18
+
| `CONNECT
19
+
| `TRACE
20
+
| `Other of string ]
21
+
22
+
let to_string = function
23
+
| `GET -> "GET"
24
+
| `POST -> "POST"
25
+
| `PUT -> "PUT"
26
+
| `DELETE -> "DELETE"
27
+
| `HEAD -> "HEAD"
28
+
| `OPTIONS -> "OPTIONS"
29
+
| `PATCH -> "PATCH"
30
+
| `CONNECT -> "CONNECT"
31
+
| `TRACE -> "TRACE"
32
+
| `Other s -> String.uppercase_ascii s
33
+
34
+
let of_string s =
35
+
match String.uppercase_ascii s with
36
+
| "GET" -> `GET
37
+
| "POST" -> `POST
38
+
| "PUT" -> `PUT
39
+
| "DELETE" -> `DELETE
40
+
| "HEAD" -> `HEAD
41
+
| "OPTIONS" -> `OPTIONS
42
+
| "PATCH" -> `PATCH
43
+
| "CONNECT" -> `CONNECT
44
+
| "TRACE" -> `TRACE
45
+
| other -> `Other other
46
+
47
+
let pp ppf m = Fmt.pf ppf "%s" (to_string m)
48
+
49
+
let is_safe = function
50
+
| `GET | `HEAD | `OPTIONS | `TRACE -> true
51
+
| `POST | `PUT | `DELETE | `PATCH | `CONNECT | `Other _ -> false
52
+
53
+
let is_idempotent = function
54
+
| `GET | `HEAD | `PUT | `DELETE | `OPTIONS | `TRACE -> true
55
+
| `POST | `PATCH | `CONNECT | `Other _ -> false
56
+
57
+
type body_semantics = Body_required | Body_optional | Body_forbidden
58
+
59
+
let request_body_semantics = function
60
+
| `POST | `PUT | `PATCH -> Body_required
61
+
| `DELETE | `OPTIONS -> Body_optional
62
+
| `GET ->
63
+
Body_optional
64
+
(* RFC 9110 Section 9.3.1: GET body has no defined semantics *)
65
+
| `HEAD ->
66
+
Body_forbidden
67
+
(* RFC 9110 Section 9.3.2: identical to GET but no body in response *)
68
+
| `TRACE -> Body_forbidden (* RFC 9110 Section 9.3.8: MUST NOT send body *)
69
+
| `CONNECT ->
70
+
Body_forbidden (* RFC 9110 Section 9.3.6: no body in CONNECT request *)
71
+
| `Other _ -> Body_optional (* Unknown methods - allow body for flexibility *)
72
+
73
+
let has_request_body = function
74
+
| `POST | `PUT | `PATCH -> true
75
+
| `GET | `HEAD | `DELETE | `OPTIONS | `CONNECT | `TRACE -> false
76
+
| `Other _ -> false (* Conservative default for unknown methods *)
77
+
78
+
let is_cacheable = function
79
+
| `GET | `HEAD -> true
80
+
| `POST -> true (* POST can be cacheable with explicit headers *)
81
+
| `PUT | `DELETE | `PATCH | `OPTIONS | `CONNECT | `TRACE | `Other _ -> false
82
+
83
+
let equal m1 m2 =
84
+
match (m1, m2) with
85
+
| `Other s1, `Other s2 ->
86
+
String.equal (String.uppercase_ascii s1) (String.uppercase_ascii s2)
87
+
| m1, m2 -> m1 = m2
88
+
89
+
let compare m1 m2 =
90
+
match (m1, m2) with
91
+
| `Other s1, `Other s2 ->
92
+
String.compare (String.uppercase_ascii s1) (String.uppercase_ascii s2)
93
+
| m1, m2 -> Stdlib.compare m1 m2
+96
lib/method.mli
+96
lib/method.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP request methods per
7
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-9}RFC 9110 Section
8
+
9}
9
+
10
+
HTTP methods indicate the desired action to be performed on a resource. The
11
+
method token is case-sensitive.
12
+
13
+
{2 Safe Methods}
14
+
15
+
Methods are considered "safe" if their semantics are read-only (GET, HEAD,
16
+
OPTIONS, TRACE). Per
17
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-9.2.1}RFC 9110
18
+
Section 9.2.1}.
19
+
20
+
{2 Idempotent Methods}
21
+
22
+
A method is "idempotent" if multiple identical requests have the same effect
23
+
as a single request (GET, HEAD, PUT, DELETE, OPTIONS, TRACE). Per
24
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-9.2.2}RFC 9110
25
+
Section 9.2.2}. *)
26
+
27
+
val src : Logs.Src.t
28
+
(** Log source for method operations. *)
29
+
30
+
type t =
31
+
[ `GET (** Retrieve a resource *)
32
+
| `POST (** Submit data to be processed *)
33
+
| `PUT (** Replace a resource *)
34
+
| `DELETE (** Delete a resource *)
35
+
| `HEAD (** Retrieve headers only *)
36
+
| `OPTIONS (** Retrieve allowed methods *)
37
+
| `PATCH (** Partial resource modification *)
38
+
| `CONNECT (** Establish tunnel to server *)
39
+
| `TRACE (** Echo received request *)
40
+
| `Other of string (** Non-standard or extension method *) ]
41
+
(** HTTP method type using polymorphic variants for better composability *)
42
+
43
+
(** {1 Conversion Functions} *)
44
+
45
+
val to_string : t -> string
46
+
(** Convert method to uppercase string representation. *)
47
+
48
+
val of_string : string -> t
49
+
(** [of_string s] parses a method from string (case-insensitive). Returns
50
+
[`Other s] for unrecognized methods. *)
51
+
52
+
val pp : Format.formatter -> t -> unit
53
+
(** Pretty printer for methods. *)
54
+
55
+
(** {1 Method Properties} *)
56
+
57
+
val is_safe : t -> bool
58
+
(** Returns true for safe methods (GET, HEAD, OPTIONS, TRACE). Safe methods
59
+
should not have side effects. *)
60
+
61
+
val is_idempotent : t -> bool
62
+
(** Returns true for idempotent methods (GET, HEAD, PUT, DELETE, OPTIONS,
63
+
TRACE). Idempotent methods can be called multiple times with the same
64
+
result. *)
65
+
66
+
(** Request body semantics per RFC 9110 Section 9.3 *)
67
+
type body_semantics =
68
+
| Body_required (** Method requires a body (POST, PUT, PATCH) *)
69
+
| Body_optional (** Method MAY have a body (DELETE, OPTIONS, GET) *)
70
+
| Body_forbidden (** Method MUST NOT have a body (HEAD, TRACE, CONNECT) *)
71
+
72
+
val request_body_semantics : t -> body_semantics
73
+
(** Returns the request body semantics for a method per RFC 9110.
74
+
75
+
- {!Body_required}: POST, PUT, PATCH - body is expected
76
+
- {!Body_optional}: DELETE, OPTIONS, GET - body allowed but has no defined
77
+
semantics
78
+
- {!Body_forbidden}: HEAD, TRACE, CONNECT - body MUST NOT be sent. *)
79
+
80
+
val has_request_body : t -> bool
81
+
(** Returns true for methods that typically have a request body (POST, PUT,
82
+
PATCH).
83
+
@deprecated
84
+
Use {!request_body_semantics} for more accurate RFC 9110 semantics. *)
85
+
86
+
val is_cacheable : t -> bool
87
+
(** Returns true for methods whose responses are cacheable by default (GET,
88
+
HEAD, POST). Note: POST is only cacheable with explicit cache headers. *)
89
+
90
+
(** {1 Comparison} *)
91
+
92
+
val equal : t -> t -> bool
93
+
(** Compare two methods for equality. *)
94
+
95
+
val compare : t -> t -> int
96
+
(** Compare two methods for ordering. *)
+90
lib/mime.ml
+90
lib/mime.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "requests.mime" ~doc:"MIME Type Handling"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
type t = {
11
+
type_ : string;
12
+
subtype : string;
13
+
parameters : (string * string) list;
14
+
}
15
+
16
+
let v type_ subtype = { type_; subtype; parameters = [] }
17
+
18
+
let of_string s =
19
+
let parts = String.split_on_char ';' s in
20
+
match parts with
21
+
| [] -> v "text" "plain"
22
+
| mime :: params ->
23
+
let mime_parts = String.split_on_char '/' (String.trim mime) in
24
+
let type_, subtype =
25
+
match mime_parts with
26
+
| [ t; s ] -> (String.trim t, String.trim s)
27
+
| [ t ] -> (String.trim t, "*")
28
+
| _ -> ("text", "plain")
29
+
in
30
+
let parse_param p =
31
+
match String.split_on_char '=' (String.trim p) with
32
+
| [ k; v ] ->
33
+
let k = String.trim k in
34
+
let v = String.trim v in
35
+
let v =
36
+
if
37
+
String.length v >= 2
38
+
&& v.[0] = '"'
39
+
&& v.[String.length v - 1] = '"'
40
+
then String.sub v 1 (String.length v - 2)
41
+
else v
42
+
in
43
+
Some (String.lowercase_ascii k, v)
44
+
| _ -> None
45
+
in
46
+
let parameters = List.filter_map parse_param params in
47
+
{ type_; subtype; parameters }
48
+
49
+
let to_string t =
50
+
let base = Fmt.str "%s/%s" t.type_ t.subtype in
51
+
match t.parameters with
52
+
| [] -> base
53
+
| params ->
54
+
let param_str =
55
+
List.map
56
+
(fun (k, v) ->
57
+
if String.contains v ' ' || String.contains v ';' then
58
+
Fmt.str "%s=\"%s\"" k v
59
+
else Fmt.str "%s=%s" k v)
60
+
params
61
+
|> String.concat "; "
62
+
in
63
+
Fmt.str "%s; %s" base param_str
64
+
65
+
let pp ppf t = Fmt.pf ppf "%s" (to_string t)
66
+
let charset t = List.assoc_opt "charset" t.parameters
67
+
68
+
let with_charset charset t =
69
+
let parameters =
70
+
("charset", charset)
71
+
:: List.filter (fun (k, _) -> k <> "charset") t.parameters
72
+
in
73
+
{ t with parameters }
74
+
75
+
let with_param key value t =
76
+
let key_lower = String.lowercase_ascii key in
77
+
let parameters =
78
+
(key_lower, value)
79
+
:: List.filter (fun (k, _) -> k <> key_lower) t.parameters
80
+
in
81
+
{ t with parameters }
82
+
83
+
(* Common MIME types *)
84
+
let json = v "application" "json"
85
+
let text = v "text" "plain"
86
+
let html = v "text" "html"
87
+
let xml = v "application" "xml"
88
+
let form = v "application" "x-www-form-urlencoded"
89
+
let octet_stream = v "application" "octet-stream"
90
+
let multipart_form = v "multipart" "form-data"
+56
lib/mime.mli
+56
lib/mime.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** MIME type handling *)
7
+
8
+
val src : Logs.Src.t
9
+
(** Log source for MIME type operations. *)
10
+
11
+
type t
12
+
(** Abstract MIME type *)
13
+
14
+
val of_string : string -> t
15
+
(** Parse MIME type from string (e.g., "text/html; charset=utf-8"). *)
16
+
17
+
val to_string : t -> string
18
+
(** Convert MIME type to string representation. *)
19
+
20
+
val pp : Format.formatter -> t -> unit
21
+
(** Pretty printer for MIME types. *)
22
+
23
+
val json : t
24
+
(** [json] is [application/json]. *)
25
+
26
+
val text : t
27
+
(** [text] is [text/plain]. *)
28
+
29
+
val html : t
30
+
(** [html] is [text/html]. *)
31
+
32
+
val xml : t
33
+
(** [xml] is [application/xml]. *)
34
+
35
+
val form : t
36
+
(** [form] is [application/x-www-form-urlencoded]. *)
37
+
38
+
val octet_stream : t
39
+
(** [octet_stream] is [application/octet-stream]. *)
40
+
41
+
val multipart_form : t
42
+
(** [multipart_form] is [multipart/form-data]. *)
43
+
44
+
val v : string -> string -> t
45
+
(** [v type subtype] creates a MIME type. *)
46
+
47
+
val with_charset : string -> t -> t
48
+
(** Add or update charset parameter. *)
49
+
50
+
val with_param : string -> string -> t -> t
51
+
(** [with_param key value t] adds or updates a parameter in the MIME type.
52
+
Example: [with_param "boundary" "----WebKit123" multipart_form] produces
53
+
"multipart/form-data; boundary=----WebKit123". *)
54
+
55
+
val charset : t -> string option
56
+
(** Extract charset parameter if present. *)
+235
lib/response.ml
+235
lib/response.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "requests.response" ~doc:"HTTP Response"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
type t = {
11
+
status : int;
12
+
headers : Headers.t;
13
+
body : Eio.Flow.source_ty Eio.Resource.t;
14
+
url : string;
15
+
elapsed : float;
16
+
mutable closed : bool;
17
+
}
18
+
19
+
let v ~sw ~status ~headers ~body ~url ~elapsed =
20
+
Log.debug (fun m ->
21
+
m "Creating response: status=%d url=%s elapsed=%.3fs" status url elapsed);
22
+
let response = { status; headers; body; url; elapsed; closed = false } in
23
+
24
+
(* Register cleanup with switch *)
25
+
Eio.Switch.on_release sw (fun () ->
26
+
if not response.closed then begin
27
+
Log.debug (fun m -> m "Auto-closing response for %s via switch" url);
28
+
response.closed <- true
29
+
(* Body cleanup happens automatically via Eio switch lifecycle.
30
+
The body flow (created via Eio.Flow.string_source) is a memory-backed
31
+
source that doesn't require explicit cleanup. File-based responses
32
+
would have their file handles cleaned up by the switch. *)
33
+
end);
34
+
35
+
response
36
+
37
+
let status t = Status.of_int t.status
38
+
let status_code t = t.status
39
+
let ok t = Status.is_success (Status.of_int t.status)
40
+
let headers t = t.headers
41
+
let header name t = Headers.find name t.headers
42
+
let header_string name t = Headers.string name t.headers
43
+
44
+
(** Option monad operators for cleaner code *)
45
+
let ( let* ) = Option.bind
46
+
47
+
let ( let+ ) x f = Option.map f x
48
+
49
+
let content_type t =
50
+
let+ ct = Headers.find `Content_type t.headers in
51
+
Mime.of_string ct
52
+
53
+
let content_length t =
54
+
let* len = Headers.find `Content_length t.headers in
55
+
try Some (Int64.of_string len) with Failure _ -> None
56
+
57
+
let location t = Headers.find `Location t.headers
58
+
59
+
(** {1 Conditional Request / Caching Headers}
60
+
61
+
Per Recommendation #19: Conditional Request Helpers (ETag/Last-Modified) RFC
62
+
9110 Section 8.8.2-8.8.3 *)
63
+
64
+
let etag t = Headers.find `Etag t.headers
65
+
let last_modified t = Headers.find `Last_modified t.headers
66
+
let parse_http_date = Http_date.parse
67
+
68
+
let last_modified_ptime t =
69
+
let* lm = last_modified t in
70
+
Http_date.parse lm
71
+
72
+
let date t = Headers.find `Date t.headers
73
+
74
+
let date_ptime t =
75
+
let* d = date t in
76
+
Http_date.parse d
77
+
78
+
let expires t = Headers.find `Expires t.headers
79
+
80
+
let expires_ptime t =
81
+
let* exp = expires t in
82
+
Http_date.parse exp
83
+
84
+
let age t =
85
+
let* s = Headers.find `Age t.headers in
86
+
try Some (int_of_string s) with Failure _ -> None
87
+
88
+
(** {1 Cache-Control Parsing}
89
+
90
+
Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance *)
91
+
92
+
let cache_control t =
93
+
Option.map Cache_control.parse_response
94
+
(Headers.find `Cache_control t.headers)
95
+
96
+
let cache_control_raw t = Headers.find `Cache_control t.headers
97
+
98
+
(** Check if response is cacheable based on status and Cache-Control *)
99
+
let is_cacheable t =
100
+
match cache_control t with
101
+
| Some cc -> Cache_control.is_cacheable ~response_cc:cc ~status:t.status
102
+
| None ->
103
+
(* No Cache-Control - use default cacheability based on status *)
104
+
List.mem t.status
105
+
[ 200; 203; 204; 206; 300; 301; 308; 404; 405; 410; 414; 501 ]
106
+
107
+
(** Calculate freshness lifetime in seconds *)
108
+
let freshness_lifetime t =
109
+
match cache_control t with
110
+
| Some cc ->
111
+
Cache_control.freshness_lifetime ~response_cc:cc ?expires:(expires t)
112
+
?date:(date t) ()
113
+
| None -> None
114
+
115
+
(** Check if response requires revalidation before use *)
116
+
let must_revalidate t =
117
+
match cache_control t with
118
+
| Some cc -> Cache_control.must_revalidate ~response_cc:cc
119
+
| None -> false
120
+
121
+
(** Check if response is stale (current time exceeds freshness) Requires the
122
+
current time as a parameter *)
123
+
let is_stale ~now t =
124
+
match (freshness_lifetime t, date_ptime t) with
125
+
| Some lifetime, Some response_date ->
126
+
let response_age =
127
+
match age t with
128
+
| Some a -> a
129
+
| None ->
130
+
(* Calculate age from Date header *)
131
+
let diff = Ptime.diff now response_date in
132
+
Ptime.Span.to_int_s diff |> Option.value ~default:0
133
+
in
134
+
response_age > lifetime
135
+
| _ -> false (* Cannot determine staleness without freshness info *)
136
+
137
+
(** Check if this is a 304 Not Modified response *)
138
+
let is_not_modified t = t.status = 304
139
+
140
+
(** Get the Vary header which indicates which request headers affect caching *)
141
+
let vary t = Headers.find `Vary t.headers
142
+
143
+
(** Parse Vary header into list of header names *)
144
+
let vary_headers t =
145
+
match vary t with
146
+
| None -> []
147
+
| Some v ->
148
+
String.split_on_char ',' v |> List.map String.trim
149
+
|> List.filter (fun s -> s <> "")
150
+
151
+
let url t = t.url
152
+
let elapsed t = t.elapsed
153
+
154
+
let body t =
155
+
if t.closed then invalid_arg "Response.body: response has been closed"
156
+
else t.body
157
+
158
+
let text t =
159
+
if t.closed then invalid_arg "Response.text: response has been closed"
160
+
else Eio.Buf_read.of_flow t.body ~max_size:max_int |> Eio.Buf_read.take_all
161
+
162
+
let json t =
163
+
let body_str = text t in
164
+
match Jsont_bytesrw.decode_string' Jsont.json body_str with
165
+
| Ok json -> json
166
+
| Error e ->
167
+
let preview =
168
+
if String.length body_str > 200 then String.sub body_str 0 200
169
+
else body_str
170
+
in
171
+
raise
172
+
(Error.err
173
+
(Error.Json_parse_error
174
+
{ body_preview = preview; reason = Jsont.Error.to_string e }))
175
+
176
+
let jsonv (type a) (codec : a Jsont.t) t =
177
+
let body_str = text t in
178
+
match Jsont_bytesrw.decode_string' codec body_str with
179
+
| Ok value -> value
180
+
| Error e ->
181
+
let preview =
182
+
if String.length body_str > 200 then String.sub body_str 0 200
183
+
else body_str
184
+
in
185
+
raise
186
+
(Error.err
187
+
(Error.Json_parse_error
188
+
{ body_preview = preview; reason = Jsont.Error.to_string e }))
189
+
190
+
let raise_for_status t =
191
+
if t.status >= 400 then
192
+
raise
193
+
(Error.err
194
+
(Error.Http_error
195
+
{
196
+
url = t.url;
197
+
status = t.status;
198
+
reason = Status.reason_phrase (Status.of_int t.status);
199
+
body_preview = None;
200
+
headers = Headers.to_list t.headers;
201
+
(* Convert to list for error type *)
202
+
}))
203
+
else t
204
+
205
+
(** Result-based status check - per Recommendation #21. Returns Ok response for
206
+
2xx success, Error for 4xx/5xx errors. Enables functional error handling
207
+
without exceptions. *)
208
+
let check_status t =
209
+
if t.status >= 400 then
210
+
Error
211
+
(Error.Http_error
212
+
{
213
+
url = t.url;
214
+
status = t.status;
215
+
reason = Status.reason_phrase (Status.of_int t.status);
216
+
body_preview = None;
217
+
headers = Headers.to_list t.headers;
218
+
})
219
+
else Ok t
220
+
221
+
(* Pretty printers *)
222
+
let pp ppf t =
223
+
Fmt.pf ppf
224
+
"@[<v>Response:@,status: %a@,url: %s@,elapsed: %.3fs@,headers: @[%a@]@]"
225
+
Status.pp (Status.of_int t.status) t.url t.elapsed Headers.pp_brief
226
+
t.headers
227
+
228
+
let pp_detailed ppf t =
229
+
Fmt.pf ppf "@[<v>Response:@,status: %a@,url: %s@,elapsed: %.3fs@,@[%a@]@]"
230
+
Status.pp_hum (Status.of_int t.status) t.url t.elapsed Headers.pp t.headers
231
+
232
+
(* Private module *)
233
+
module Private = struct
234
+
let make = v
235
+
end
+325
lib/response.mli
+325
lib/response.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP response handling per
7
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-15}RFC 9110}
8
+
9
+
This module represents HTTP responses and provides functions to access
10
+
status codes, headers, and response bodies. Responses support streaming to
11
+
efficiently handle large payloads.
12
+
13
+
Caching semantics follow
14
+
{{:https://datatracker.ietf.org/doc/html/rfc9111}RFC 9111} (HTTP Caching).
15
+
16
+
{2 Examples}
17
+
18
+
{[
19
+
(* Check response status *)
20
+
if Response.ok response then
21
+
Printf.printf "Success!\n"
22
+
else
23
+
Printf.printf "Error: %d\n" (Response.status_code response);
24
+
25
+
(* Access headers *)
26
+
match Response.content_type response with
27
+
| Some mime -> Printf.printf "Type: %s\n" (Mime.to_string mime)
28
+
| None -> ()
29
+
30
+
(* Stream response body *)
31
+
let body = Response.body response in
32
+
Eio.Flow.copy body (Eio.Flow.buffer_sink buffer)
33
+
34
+
(* Response automatically closes when the switch is released *)
35
+
]}
36
+
37
+
{b Note}: Responses are automatically closed when the switch they were
38
+
created with is released. Manual cleanup is not necessary. *)
39
+
40
+
open Eio
41
+
42
+
val src : Logs.Src.t
43
+
(** Log source for response operations. *)
44
+
45
+
type t
46
+
(** Abstract response type representing an HTTP response. *)
47
+
48
+
val v :
49
+
sw:Eio.Switch.t ->
50
+
status:int ->
51
+
headers:Headers.t ->
52
+
body:Eio.Flow.source_ty Eio.Resource.t ->
53
+
url:string ->
54
+
elapsed:float ->
55
+
t
56
+
(** [v ~sw ~status ~headers ~body ~url ~elapsed] creates a response. Internal
57
+
function primarily used for caching. *)
58
+
59
+
(** {1 Status Information} *)
60
+
61
+
val status : t -> Status.t
62
+
(** [status response] returns the HTTP status as a {!Status.t} value. *)
63
+
64
+
val status_code : t -> int
65
+
(** [status_code response] returns the HTTP status code as an integer (e.g.,
66
+
200, 404). *)
67
+
68
+
val ok : t -> bool
69
+
(** [ok response] returns [true] if the status code is in the 2xx success range.
70
+
This is an alias for {!Status.is_success}. *)
71
+
72
+
(** {1 Header Access} *)
73
+
74
+
val headers : t -> Headers.t
75
+
(** [headers response] returns all response headers. *)
76
+
77
+
val header : Header_name.t -> t -> string option
78
+
(** [header name response] returns the value of a specific header, or [None] if
79
+
not present. Header names are case-insensitive.
80
+
81
+
Example: [header `Content_type response]. *)
82
+
83
+
val header_string : string -> t -> string option
84
+
(** [header_string name response] returns the value of a header by string name.
85
+
Use this when header names come from external sources (e.g., wire format).
86
+
Header names are case-insensitive. *)
87
+
88
+
val content_type : t -> Mime.t option
89
+
(** [content_type response] returns the parsed Content-Type header as a MIME
90
+
type, or [None] if the header is not present or cannot be parsed. *)
91
+
92
+
val content_length : t -> int64 option
93
+
(** [content_length response] returns the Content-Length in bytes, or [None] if
94
+
not specified or chunked encoding is used. *)
95
+
96
+
val location : t -> string option
97
+
(** [location response] returns the Location header value, typically used in
98
+
redirects. Returns [None] if the header is not present. *)
99
+
100
+
(** {1 Conditional Request / Caching Headers}
101
+
102
+
Per Recommendation #19: Conditional Request Helpers (ETag/Last-Modified) RFC
103
+
9110 Section 8.8.2-8.8.3 *)
104
+
105
+
val etag : t -> string option
106
+
(** [etag response] returns the ETag header value, which is an opaque identifier
107
+
for a specific version of a resource. Use with {!Headers.if_none_match} for
108
+
conditional requests. Example: ["\"abc123\""] or [W/"abc123"] (weak
109
+
validator). *)
110
+
111
+
val last_modified : t -> string option
112
+
(** [last_modified response] returns the Last-Modified header as a raw string.
113
+
Format: HTTP-date (e.g., ["Sun, 06 Nov 1994 08:49:37 GMT"]). *)
114
+
115
+
val parse_http_date : string -> Ptime.t option
116
+
(** [parse_http_date s] parses an HTTP-date string (RFC 9110 Section 5.6.7) to
117
+
Ptime.t. Supports RFC 1123, RFC 850, and ANSI C asctime() formats. Returns
118
+
[None] if parsing fails.
119
+
120
+
This is exposed for use by other modules that need to parse HTTP dates. *)
121
+
122
+
val last_modified_ptime : t -> Ptime.t option
123
+
(** [last_modified_ptime response] parses the Last-Modified header as a Ptime.t.
124
+
Returns [None] if the header is not present or cannot be parsed. *)
125
+
126
+
val date : t -> string option
127
+
(** [date response] returns the Date header (time response was generated). *)
128
+
129
+
val date_ptime : t -> Ptime.t option
130
+
(** [date_ptime response] parses the Date header as a Ptime.t. *)
131
+
132
+
val expires : t -> string option
133
+
(** [expires response] returns the Expires header (HTTP/1.0 cache control).
134
+
Prefer using {!cache_control} for RFC 9111 compliant caching. *)
135
+
136
+
val expires_ptime : t -> Ptime.t option
137
+
(** [expires_ptime response] parses the Expires header as a Ptime.t. *)
138
+
139
+
val age : t -> int option
140
+
(** [age response] returns the Age header value in seconds. The Age header
141
+
indicates how long the response has been in a cache. *)
142
+
143
+
(** {1 Cache-Control Parsing}
144
+
145
+
Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance *)
146
+
147
+
val cache_control : t -> Cache_control.response option
148
+
(** [cache_control response] parses and returns the Cache-Control header
149
+
directives. Returns [None] if the header is not present.
150
+
151
+
Example:
152
+
{[
153
+
match Response.cache_control response with
154
+
| Some cc when cc.Cache_control.no_store -> "Do not cache"
155
+
| Some cc -> Fmt.str "Max age: %d" (Option.get cc.max_age)
156
+
| None -> "No cache directives"
157
+
]} *)
158
+
159
+
val cache_control_raw : t -> string option
160
+
(** [cache_control_raw response] returns the raw Cache-Control header string
161
+
without parsing. Useful for debugging or custom parsing. *)
162
+
163
+
val is_cacheable : t -> bool
164
+
(** [is_cacheable response] returns [true] if the response may be cached based
165
+
on its status code and Cache-Control directives. A response is cacheable if
166
+
no-store is not present and either:
167
+
- Status is cacheable by default (200, 203, 204, 206, 300, 301, 308, 404,
168
+
405, 410, 414, 501)
169
+
- Explicit caching directive (max-age, s-maxage) is present. *)
170
+
171
+
val freshness_lifetime : t -> int option
172
+
(** [freshness_lifetime response] calculates how long the response is fresh in
173
+
seconds, based on Cache-Control max-age or Expires header. Returns [None] if
174
+
freshness cannot be determined. *)
175
+
176
+
val must_revalidate : t -> bool
177
+
(** [must_revalidate response] returns [true] if cached copies must be
178
+
revalidated with the origin server before use (must-revalidate,
179
+
proxy-revalidate, or no-cache directive present). *)
180
+
181
+
val is_stale : now:Ptime.t -> t -> bool
182
+
(** [is_stale ~now response] returns [true] if the response's freshness lifetime
183
+
has expired. Requires the current time as [now]. Returns [false] if
184
+
staleness cannot be determined. *)
185
+
186
+
val is_not_modified : t -> bool
187
+
(** [is_not_modified response] returns [true] if this is a 304 Not Modified
188
+
response, indicating the cached version is still valid. *)
189
+
190
+
val vary : t -> string option
191
+
(** [vary response] returns the Vary header, which lists request headers that
192
+
affect the response (for cache key construction). *)
193
+
194
+
val vary_headers : t -> string list
195
+
(** [vary_headers response] parses the Vary header into a list of header names.
196
+
Returns an empty list if Vary is not present. *)
197
+
198
+
(** {1 Response Metadata} *)
199
+
200
+
val url : t -> string
201
+
(** [url response] returns the final URL after following any redirects. This may
202
+
differ from the originally requested URL. *)
203
+
204
+
val elapsed : t -> float
205
+
(** [elapsed response] returns the time taken for the request in seconds,
206
+
including connection establishment, sending the request, and receiving
207
+
headers. *)
208
+
209
+
(** {1 Response Body} *)
210
+
211
+
val body : t -> Flow.source_ty Resource.t
212
+
(** [body response] returns the response body as an Eio flow for streaming. This
213
+
allows efficient processing of large responses without loading them entirely
214
+
into memory.
215
+
216
+
Example:
217
+
{[
218
+
let body = Response.body response in
219
+
let buffer = Buffer.create 4096 in
220
+
Eio.Flow.copy body (Eio.Flow.buffer_sink buffer);
221
+
Buffer.contents buffer
222
+
]} *)
223
+
224
+
val text : t -> string
225
+
(** [text response] reads and returns the entire response body as a string. The
226
+
response body is fully consumed by this operation.
227
+
228
+
@raise Failure if the response has already been closed. *)
229
+
230
+
val json : t -> Jsont.json
231
+
(** [json response] parses the response body as JSON. The response body is fully
232
+
consumed by this operation.
233
+
234
+
Example:
235
+
{[
236
+
let json = Response.json response in
237
+
process_json json
238
+
]}
239
+
240
+
@raise Eio.Io with {!Error.Json_parse_error} if JSON parsing fails.
241
+
@raise Failure if the response has already been closed. *)
242
+
243
+
val jsonv : 'a Jsont.t -> t -> 'a
244
+
(** [jsonv codec response] parses the response body as JSON and decodes it to a
245
+
typed value using the provided [codec]. The response body is fully consumed
246
+
by this operation.
247
+
248
+
This is the preferred way to decode JSON responses into typed OCaml values,
249
+
as it provides type safety and works with custom record types.
250
+
251
+
Example:
252
+
{[
253
+
(* Define a codec for your type *)
254
+
type user = { name : string; age : int }
255
+
256
+
let user_codec =
257
+
Jsont.Obj.map ~kind:"user" (fun name age -> { name; age })
258
+
|> Jsont.Obj.mem "name" Jsont.string ~enc:(fun u -> u.name)
259
+
|> Jsont.Obj.mem "age" Jsont.int ~enc:(fun u -> u.age)
260
+
|> Jsont.Obj.finish
261
+
262
+
(* Decode the response to a typed value *)
263
+
let user = Response.jsonv user_codec response in
264
+
Printf.printf "User: %s, age %d\n" user.name user.age
265
+
]}
266
+
267
+
@raise Eio.Io with {!Error.Json_parse_error} if JSON parsing fails.
268
+
@raise Failure if the response has already been closed. *)
269
+
270
+
val raise_for_status : t -> t
271
+
(** [raise_for_status response] raises [Eio.Io] with [Error.Http_error] if the
272
+
response status code indicates an error (>= 400). Returns the response
273
+
unchanged if the status indicates success (< 400).
274
+
275
+
This is useful for failing fast on HTTP errors:
276
+
{[
277
+
let response = Requests.get req url |> Response.raise_for_status in
278
+
(* Only reaches here if status < 400 *)
279
+
process_success response
280
+
]}
281
+
282
+
@raise Eio.Io with [Error.Http_error] if status code >= 400. *)
283
+
284
+
val check_status : t -> (t, Error.t) result
285
+
(** [check_status response] returns [Ok response] if the status code is < 400,
286
+
or [Error error] if the status code indicates an error (>= 400).
287
+
288
+
This provides functional error handling without exceptions, complementing
289
+
{!raise_for_status} for different coding styles.
290
+
291
+
Example:
292
+
{[
293
+
match Response.check_status response with
294
+
| Ok resp -> process_success resp
295
+
| Error err -> handle_error err
296
+
]}
297
+
298
+
Per Recommendation #21: Provides a Result-based alternative to
299
+
raise_for_status. *)
300
+
301
+
(** {1 Pretty Printing} *)
302
+
303
+
val pp : Format.formatter -> t -> unit
304
+
(** Pretty print a response summary. *)
305
+
306
+
val pp_detailed : Format.formatter -> t -> unit
307
+
(** Pretty print a response with full headers. *)
308
+
309
+
(** {1 Private API} *)
310
+
311
+
(** Internal functions exposed for use by other modules in the library. These
312
+
are not part of the public API and may change between versions. *)
313
+
module Private : sig
314
+
val make :
315
+
sw:Eio.Switch.t ->
316
+
status:int ->
317
+
headers:Headers.t ->
318
+
body:Flow.source_ty Resource.t ->
319
+
url:string ->
320
+
elapsed:float ->
321
+
t
322
+
(** [make ~sw ~status ~headers ~body ~url ~elapsed] constructs a response. The
323
+
response will be automatically closed when the switch is released. This
324
+
function is used internally by the Client module. *)
325
+
end
+57
lib/response_limits.ml
+57
lib/response_limits.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Response limits for HTTP protocol handling
7
+
8
+
Configurable limits for response body size, header count, and header length
9
+
to prevent DoS attacks. *)
10
+
11
+
type t = {
12
+
max_response_body_size : int64;
13
+
max_header_size : int;
14
+
max_header_count : int;
15
+
max_decompressed_size : int64;
16
+
max_compression_ratio : float;
17
+
}
18
+
19
+
let default =
20
+
{
21
+
max_response_body_size = 104_857_600L;
22
+
(* 100MB *)
23
+
max_header_size = 16_384;
24
+
(* 16KB *)
25
+
max_header_count = 100;
26
+
max_decompressed_size = 104_857_600L;
27
+
(* 100MB *)
28
+
max_compression_ratio = 100.0;
29
+
(* 100:1 *)
30
+
}
31
+
32
+
let v ?(max_response_body_size = 104_857_600L) ?(max_header_size = 16_384)
33
+
?(max_header_count = 100) ?(max_decompressed_size = 104_857_600L)
34
+
?(max_compression_ratio = 100.0) () =
35
+
{
36
+
max_response_body_size;
37
+
max_header_size;
38
+
max_header_count;
39
+
max_decompressed_size;
40
+
max_compression_ratio;
41
+
}
42
+
43
+
let max_response_body_size t = t.max_response_body_size
44
+
let max_header_size t = t.max_header_size
45
+
let max_header_count t = t.max_header_count
46
+
let max_decompressed_size t = t.max_decompressed_size
47
+
let max_compression_ratio t = t.max_compression_ratio
48
+
49
+
let pp fmt t =
50
+
Fmt.pf fmt
51
+
"@[<v 2>Response_limits {@ max_response_body_size: %Ld bytes@ \
52
+
max_header_size: %d bytes@ max_header_count: %d@ max_decompressed_size: \
53
+
%Ld bytes@ max_compression_ratio: %.1f:1@ }@]"
54
+
t.max_response_body_size t.max_header_size t.max_header_count
55
+
t.max_decompressed_size t.max_compression_ratio
56
+
57
+
let to_string t = Fmt.str "%a" pp t
+54
lib/response_limits.mli
+54
lib/response_limits.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Response limits for HTTP protocol handling
7
+
8
+
Configurable limits for response body size, header count, and header length
9
+
to prevent DoS attacks. *)
10
+
11
+
type t
12
+
(** Abstract type representing HTTP response limits. *)
13
+
14
+
val default : t
15
+
(** Default limits:
16
+
- max_response_body_size: 100MB
17
+
- max_header_size: 16KB
18
+
- max_header_count: 100
19
+
- max_decompressed_size: 100MB
20
+
- max_compression_ratio: 100:1. *)
21
+
22
+
val v :
23
+
?max_response_body_size:int64 ->
24
+
?max_header_size:int ->
25
+
?max_header_count:int ->
26
+
?max_decompressed_size:int64 ->
27
+
?max_compression_ratio:float ->
28
+
unit ->
29
+
t
30
+
(** [v ?max_response_body_size ?max_header_size ?max_header_count
31
+
?max_decompressed_size ?max_compression_ratio ()] creates custom response
32
+
limits. All parameters are optional and default to the values in {!default}.
33
+
*)
34
+
35
+
val max_response_body_size : t -> int64
36
+
(** Maximum response body size in bytes. *)
37
+
38
+
val max_header_size : t -> int
39
+
(** Maximum size of a single header line in bytes. *)
40
+
41
+
val max_header_count : t -> int
42
+
(** Maximum number of headers allowed. *)
43
+
44
+
val max_decompressed_size : t -> int64
45
+
(** Maximum decompressed size in bytes. *)
46
+
47
+
val max_compression_ratio : t -> float
48
+
(** Maximum compression ratio allowed (e.g., 100.0 means 100:1). *)
49
+
50
+
val pp : Format.formatter -> t -> unit
51
+
(** Pretty-printer for response limits. *)
52
+
53
+
val to_string : t -> string
54
+
(** Convert response limits to a human-readable string. *)
+353
lib/status.ml
+353
lib/status.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP status codes following RFC 7231 and extensions *)
7
+
8
+
let src = Logs.Src.create "requests.status" ~doc:"HTTP Status Codes"
9
+
10
+
module Log = (val Logs.src_log src : Logs.LOG)
11
+
12
+
type informational =
13
+
[ `Continue | `Switching_protocols | `Processing | `Early_hints ]
14
+
15
+
type success =
16
+
[ `OK
17
+
| `Created
18
+
| `Accepted
19
+
| `Non_authoritative_information
20
+
| `No_content
21
+
| `Reset_content
22
+
| `Partial_content
23
+
| `Multi_status
24
+
| `Already_reported
25
+
| `Im_used ]
26
+
27
+
type redirection =
28
+
[ `Multiple_choices
29
+
| `Moved_permanently
30
+
| `Found
31
+
| `See_other
32
+
| `Not_modified
33
+
| `Use_proxy
34
+
| `Temporary_redirect
35
+
| `Permanent_redirect ]
36
+
37
+
type client_error =
38
+
[ `Bad_request
39
+
| `Unauthorized
40
+
| `Payment_required
41
+
| `Forbidden
42
+
| `Not_found
43
+
| `Method_not_allowed
44
+
| `Not_acceptable
45
+
| `Proxy_authentication_required
46
+
| `Request_timeout
47
+
| `Conflict
48
+
| `Gone
49
+
| `Length_required
50
+
| `Precondition_failed
51
+
| `Payload_too_large
52
+
| `Uri_too_long
53
+
| `Unsupported_media_type
54
+
| `Range_not_satisfiable
55
+
| `Expectation_failed
56
+
| `I_m_a_teapot
57
+
| `Misdirected_request
58
+
| `Unprocessable_entity
59
+
| `Locked
60
+
| `Failed_dependency
61
+
| `Too_early
62
+
| `Upgrade_required
63
+
| `Precondition_required
64
+
| `Too_many_requests
65
+
| `Request_header_fields_too_large
66
+
| `Unavailable_for_legal_reasons ]
67
+
68
+
type server_error =
69
+
[ `Internal_server_error
70
+
| `Not_implemented
71
+
| `Bad_gateway
72
+
| `Service_unavailable
73
+
| `Gateway_timeout
74
+
| `Http_version_not_supported
75
+
| `Variant_also_negotiates
76
+
| `Insufficient_storage
77
+
| `Loop_detected
78
+
| `Not_extended
79
+
| `Network_authentication_required ]
80
+
81
+
type standard =
82
+
[ informational | success | redirection | client_error | server_error ]
83
+
84
+
type t = [ `Code of int | standard ]
85
+
86
+
let to_int = function
87
+
(* Informational *)
88
+
| `Continue -> 100
89
+
| `Switching_protocols -> 101
90
+
| `Processing -> 102
91
+
| `Early_hints -> 103
92
+
(* Success *)
93
+
| `OK -> 200
94
+
| `Created -> 201
95
+
| `Accepted -> 202
96
+
| `Non_authoritative_information -> 203
97
+
| `No_content -> 204
98
+
| `Reset_content -> 205
99
+
| `Partial_content -> 206
100
+
| `Multi_status -> 207
101
+
| `Already_reported -> 208
102
+
| `Im_used -> 226
103
+
(* Redirection *)
104
+
| `Multiple_choices -> 300
105
+
| `Moved_permanently -> 301
106
+
| `Found -> 302
107
+
| `See_other -> 303
108
+
| `Not_modified -> 304
109
+
| `Use_proxy -> 305
110
+
| `Temporary_redirect -> 307
111
+
| `Permanent_redirect -> 308
112
+
(* Client Error *)
113
+
| `Bad_request -> 400
114
+
| `Unauthorized -> 401
115
+
| `Payment_required -> 402
116
+
| `Forbidden -> 403
117
+
| `Not_found -> 404
118
+
| `Method_not_allowed -> 405
119
+
| `Not_acceptable -> 406
120
+
| `Proxy_authentication_required -> 407
121
+
| `Request_timeout -> 408
122
+
| `Conflict -> 409
123
+
| `Gone -> 410
124
+
| `Length_required -> 411
125
+
| `Precondition_failed -> 412
126
+
| `Payload_too_large -> 413
127
+
| `Uri_too_long -> 414
128
+
| `Unsupported_media_type -> 415
129
+
| `Range_not_satisfiable -> 416
130
+
| `Expectation_failed -> 417
131
+
| `I_m_a_teapot -> 418
132
+
| `Misdirected_request -> 421
133
+
| `Unprocessable_entity -> 422
134
+
| `Locked -> 423
135
+
| `Failed_dependency -> 424
136
+
| `Too_early -> 425
137
+
| `Upgrade_required -> 426
138
+
| `Precondition_required -> 428
139
+
| `Too_many_requests -> 429
140
+
| `Request_header_fields_too_large -> 431
141
+
| `Unavailable_for_legal_reasons -> 451
142
+
(* Server Error *)
143
+
| `Internal_server_error -> 500
144
+
| `Not_implemented -> 501
145
+
| `Bad_gateway -> 502
146
+
| `Service_unavailable -> 503
147
+
| `Gateway_timeout -> 504
148
+
| `Http_version_not_supported -> 505
149
+
| `Variant_also_negotiates -> 506
150
+
| `Insufficient_storage -> 507
151
+
| `Loop_detected -> 508
152
+
| `Not_extended -> 510
153
+
| `Network_authentication_required -> 511
154
+
(* Custom code *)
155
+
| `Code c -> c
156
+
157
+
let of_int = function
158
+
(* Informational *)
159
+
| 100 -> `Continue
160
+
| 101 -> `Switching_protocols
161
+
| 102 -> `Processing
162
+
| 103 -> `Early_hints
163
+
(* Success *)
164
+
| 200 -> `OK
165
+
| 201 -> `Created
166
+
| 202 -> `Accepted
167
+
| 203 -> `Non_authoritative_information
168
+
| 204 -> `No_content
169
+
| 205 -> `Reset_content
170
+
| 206 -> `Partial_content
171
+
| 207 -> `Multi_status
172
+
| 208 -> `Already_reported
173
+
| 226 -> `Im_used
174
+
(* Redirection *)
175
+
| 300 -> `Multiple_choices
176
+
| 301 -> `Moved_permanently
177
+
| 302 -> `Found
178
+
| 303 -> `See_other
179
+
| 304 -> `Not_modified
180
+
| 305 -> `Use_proxy
181
+
| 307 -> `Temporary_redirect
182
+
| 308 -> `Permanent_redirect
183
+
(* Client Error *)
184
+
| 400 -> `Bad_request
185
+
| 401 -> `Unauthorized
186
+
| 402 -> `Payment_required
187
+
| 403 -> `Forbidden
188
+
| 404 -> `Not_found
189
+
| 405 -> `Method_not_allowed
190
+
| 406 -> `Not_acceptable
191
+
| 407 -> `Proxy_authentication_required
192
+
| 408 -> `Request_timeout
193
+
| 409 -> `Conflict
194
+
| 410 -> `Gone
195
+
| 411 -> `Length_required
196
+
| 412 -> `Precondition_failed
197
+
| 413 -> `Payload_too_large
198
+
| 414 -> `Uri_too_long
199
+
| 415 -> `Unsupported_media_type
200
+
| 416 -> `Range_not_satisfiable
201
+
| 417 -> `Expectation_failed
202
+
| 418 -> `I_m_a_teapot
203
+
| 421 -> `Misdirected_request
204
+
| 422 -> `Unprocessable_entity
205
+
| 423 -> `Locked
206
+
| 424 -> `Failed_dependency
207
+
| 425 -> `Too_early
208
+
| 426 -> `Upgrade_required
209
+
| 428 -> `Precondition_required
210
+
| 429 -> `Too_many_requests
211
+
| 431 -> `Request_header_fields_too_large
212
+
| 451 -> `Unavailable_for_legal_reasons
213
+
(* Server Error *)
214
+
| 500 -> `Internal_server_error
215
+
| 501 -> `Not_implemented
216
+
| 502 -> `Bad_gateway
217
+
| 503 -> `Service_unavailable
218
+
| 504 -> `Gateway_timeout
219
+
| 505 -> `Http_version_not_supported
220
+
| 506 -> `Variant_also_negotiates
221
+
| 507 -> `Insufficient_storage
222
+
| 508 -> `Loop_detected
223
+
| 510 -> `Not_extended
224
+
| 511 -> `Network_authentication_required
225
+
(* Unknown code *)
226
+
| c -> `Code c
227
+
228
+
let to_string t = string_of_int (to_int t)
229
+
230
+
let reason_phrase t =
231
+
match t with
232
+
(* Informational *)
233
+
| `Continue -> "Continue"
234
+
| `Switching_protocols -> "Switching Protocols"
235
+
| `Processing -> "Processing"
236
+
| `Early_hints -> "Early Hints"
237
+
(* Success *)
238
+
| `OK -> "OK"
239
+
| `Created -> "Created"
240
+
| `Accepted -> "Accepted"
241
+
| `Non_authoritative_information -> "Non-Authoritative Information"
242
+
| `No_content -> "No Content"
243
+
| `Reset_content -> "Reset Content"
244
+
| `Partial_content -> "Partial Content"
245
+
| `Multi_status -> "Multi-Status"
246
+
| `Already_reported -> "Already Reported"
247
+
| `Im_used -> "IM Used"
248
+
(* Redirection *)
249
+
| `Multiple_choices -> "Multiple Choices"
250
+
| `Moved_permanently -> "Moved Permanently"
251
+
| `Found -> "Found"
252
+
| `See_other -> "See Other"
253
+
| `Not_modified -> "Not Modified"
254
+
| `Use_proxy -> "Use Proxy"
255
+
| `Temporary_redirect -> "Temporary Redirect"
256
+
| `Permanent_redirect -> "Permanent Redirect"
257
+
(* Client Error *)
258
+
| `Bad_request -> "Bad Request"
259
+
| `Unauthorized -> "Unauthorized"
260
+
| `Payment_required -> "Payment Required"
261
+
| `Forbidden -> "Forbidden"
262
+
| `Not_found -> "Not Found"
263
+
| `Method_not_allowed -> "Method Not Allowed"
264
+
| `Not_acceptable -> "Not Acceptable"
265
+
| `Proxy_authentication_required -> "Proxy Authentication Required"
266
+
| `Request_timeout -> "Request Timeout"
267
+
| `Conflict -> "Conflict"
268
+
| `Gone -> "Gone"
269
+
| `Length_required -> "Length Required"
270
+
| `Precondition_failed -> "Precondition Failed"
271
+
| `Payload_too_large -> "Payload Too Large"
272
+
| `Uri_too_long -> "URI Too Long"
273
+
| `Unsupported_media_type -> "Unsupported Media Type"
274
+
| `Range_not_satisfiable -> "Range Not Satisfiable"
275
+
| `Expectation_failed -> "Expectation Failed"
276
+
| `I_m_a_teapot -> "I'm a teapot"
277
+
| `Misdirected_request -> "Misdirected Request"
278
+
| `Unprocessable_entity -> "Unprocessable Entity"
279
+
| `Locked -> "Locked"
280
+
| `Failed_dependency -> "Failed Dependency"
281
+
| `Too_early -> "Too Early"
282
+
| `Upgrade_required -> "Upgrade Required"
283
+
| `Precondition_required -> "Precondition Required"
284
+
| `Too_many_requests -> "Too Many Requests"
285
+
| `Request_header_fields_too_large -> "Request Header Fields Too Large"
286
+
| `Unavailable_for_legal_reasons -> "Unavailable For Legal Reasons"
287
+
(* Server Error *)
288
+
| `Internal_server_error -> "Internal Server Error"
289
+
| `Not_implemented -> "Not Implemented"
290
+
| `Bad_gateway -> "Bad Gateway"
291
+
| `Service_unavailable -> "Service Unavailable"
292
+
| `Gateway_timeout -> "Gateway Timeout"
293
+
| `Http_version_not_supported -> "HTTP Version Not Supported"
294
+
| `Variant_also_negotiates -> "Variant Also Negotiates"
295
+
| `Insufficient_storage -> "Insufficient Storage"
296
+
| `Loop_detected -> "Loop Detected"
297
+
| `Not_extended -> "Not Extended"
298
+
| `Network_authentication_required -> "Network Authentication Required"
299
+
(* Custom code - provide generic reason based on category *)
300
+
| `Code c ->
301
+
if c >= 100 && c < 200 then "Informational"
302
+
else if c >= 200 && c < 300 then "Success"
303
+
else if c >= 300 && c < 400 then "Redirection"
304
+
else if c >= 400 && c < 500 then "Client Error"
305
+
else if c >= 500 && c < 600 then "Server Error"
306
+
else "Unknown"
307
+
308
+
(* Classification functions *)
309
+
let is_informational t =
310
+
let code = to_int t in
311
+
code >= 100 && code < 200
312
+
313
+
let is_success t =
314
+
let code = to_int t in
315
+
code >= 200 && code < 300
316
+
317
+
let is_redirection t =
318
+
let code = to_int t in
319
+
code >= 300 && code < 400
320
+
321
+
let is_client_error t =
322
+
let code = to_int t in
323
+
code >= 400 && code < 500
324
+
325
+
let is_server_error t =
326
+
let code = to_int t in
327
+
code >= 500 && code < 600
328
+
329
+
let is_error t =
330
+
let code = to_int t in
331
+
code >= 400 && code < 600
332
+
333
+
(* Retry policy functions *)
334
+
let is_retryable t =
335
+
match t with
336
+
| `Request_timeout | `Too_many_requests | `Bad_gateway | `Service_unavailable
337
+
| `Gateway_timeout ->
338
+
true
339
+
(* 501 and 505 indicate permanent conditions that won't be fixed by retrying *)
340
+
| `Not_implemented ->
341
+
false (* 501: Server doesn't support the functionality *)
342
+
| `Http_version_not_supported ->
343
+
false (* 505: Protocol version not supported *)
344
+
| _ -> is_server_error t (* Other 5xx errors are generally retryable *)
345
+
346
+
let should_retry_on_different_host t =
347
+
match t with
348
+
| `Bad_gateway | `Service_unavailable | `Gateway_timeout -> true
349
+
| _ -> false
350
+
351
+
(* Pretty printing *)
352
+
let pp ppf t = Fmt.pf ppf "%d" (to_int t)
353
+
let pp_hum ppf t = Fmt.pf ppf "%d %s" (to_int t) (reason_phrase t)
+209
lib/status.mli
+209
lib/status.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP status codes per
7
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-15}RFC 9110 Section
8
+
15}
9
+
10
+
This module provides types and functions for working with HTTP response
11
+
status codes. Status codes are three-digit integers that indicate the result
12
+
of an HTTP request.
13
+
14
+
{2 Status Code Classes}
15
+
16
+
- {b 1xx Informational}: Request received, continuing process
17
+
- {b 2xx Success}: Request successfully received, understood, and accepted
18
+
- {b 3xx Redirection}: Further action needed to complete the request
19
+
- {b 4xx Client Error}: Request contains bad syntax or cannot be fulfilled
20
+
- {b 5xx Server Error}: Server failed to fulfill a valid request *)
21
+
22
+
val src : Logs.Src.t
23
+
(** Log source for status code operations. *)
24
+
25
+
(** {1 Status Categories} *)
26
+
27
+
type informational =
28
+
[ `Continue (** 100 - Client should continue with request *)
29
+
| `Switching_protocols (** 101 - Server is switching protocols *)
30
+
| `Processing (** 102 - Server has received and is processing the request *)
31
+
| `Early_hints
32
+
(** 103 - Used to return some response headers before final HTTP message *)
33
+
]
34
+
(** 1xx Informational responses *)
35
+
36
+
type success =
37
+
[ `OK (** 200 - Standard response for successful HTTP requests *)
38
+
| `Created (** 201 - Request has been fulfilled; new resource created *)
39
+
| `Accepted (** 202 - Request accepted, processing pending *)
40
+
| `Non_authoritative_information
41
+
(** 203 - Request processed, information may be from another source *)
42
+
| `No_content (** 204 - Request processed, no content returned *)
43
+
| `Reset_content
44
+
(** 205 - Request processed, no content returned, reset document view *)
45
+
| `Partial_content (** 206 - Partial resource return due to request header *)
46
+
| `Multi_status (** 207 - XML, can contain multiple separate responses *)
47
+
| `Already_reported (** 208 - Results previously returned *)
48
+
| `Im_used (** 226 - Request fulfilled, response is instance-manipulations *)
49
+
]
50
+
(** 2xx Success responses *)
51
+
52
+
type redirection =
53
+
[ `Multiple_choices (** 300 - Multiple options for the resource delivered *)
54
+
| `Moved_permanently
55
+
(** 301 - This and all future requests directed to the given URI *)
56
+
| `Found (** 302 - Temporary response to request found via alternative URI *)
57
+
| `See_other (** 303 - Response to request found via alternative URI *)
58
+
| `Not_modified
59
+
(** 304 - Resource has not been modified since last requested *)
60
+
| `Use_proxy
61
+
(** 305 - Content located elsewhere, retrieve from there (deprecated) *)
62
+
| `Temporary_redirect (** 307 - Connect again to different URI as provided *)
63
+
| `Permanent_redirect
64
+
(** 308 - Connect again to a different URI using the same method *) ]
65
+
(** 3xx Redirection messages *)
66
+
67
+
type client_error =
68
+
[ `Bad_request (** 400 - Request cannot be fulfilled due to bad syntax *)
69
+
| `Unauthorized (** 401 - Authentication is possible but has failed *)
70
+
| `Payment_required (** 402 - Payment required, reserved for future use *)
71
+
| `Forbidden (** 403 - Server refuses to respond to request *)
72
+
| `Not_found (** 404 - Requested resource could not be found *)
73
+
| `Method_not_allowed
74
+
(** 405 - Request method not supported by that resource *)
75
+
| `Not_acceptable
76
+
(** 406 - Content not acceptable according to the Accept headers *)
77
+
| `Proxy_authentication_required
78
+
(** 407 - Client must first authenticate itself with the proxy *)
79
+
| `Request_timeout (** 408 - Server timed out waiting for the request *)
80
+
| `Conflict (** 409 - Request could not be processed because of conflict *)
81
+
| `Gone
82
+
(** 410 - Resource is no longer available and will not be available again *)
83
+
| `Length_required
84
+
(** 411 - Request did not specify the length of its content *)
85
+
| `Precondition_failed
86
+
(** 412 - Server does not meet request preconditions *)
87
+
| `Payload_too_large
88
+
(** 413 - Request is larger than the server is willing or able to process *)
89
+
| `Uri_too_long
90
+
(** 414 - URI provided was too long for the server to process *)
91
+
| `Unsupported_media_type (** 415 - Server does not support media type *)
92
+
| `Range_not_satisfiable
93
+
(** 416 - Client has asked for unprovidable portion of the file *)
94
+
| `Expectation_failed
95
+
(** 417 - Server cannot meet requirements of Expect request-header field *)
96
+
| `I_m_a_teapot (** 418 - I'm a teapot (RFC 2324) *)
97
+
| `Misdirected_request
98
+
(** 421 - Request was directed at a server that is not able to produce a
99
+
response *)
100
+
| `Unprocessable_entity
101
+
(** 422 - Request unable to be followed due to semantic errors *)
102
+
| `Locked (** 423 - Resource that is being accessed is locked *)
103
+
| `Failed_dependency
104
+
(** 424 - Request failed due to failure of a previous request *)
105
+
| `Too_early
106
+
(** 425 - Server is unwilling to risk processing a request that might be
107
+
replayed *)
108
+
| `Upgrade_required (** 426 - Client should switch to a different protocol *)
109
+
| `Precondition_required
110
+
(** 428 - Origin server requires the request to be conditional *)
111
+
| `Too_many_requests
112
+
(** 429 - User has sent too many requests in a given amount of time *)
113
+
| `Request_header_fields_too_large
114
+
(** 431 - Server is unwilling to process the request *)
115
+
| `Unavailable_for_legal_reasons
116
+
(** 451 - Resource unavailable for legal reasons *) ]
117
+
(** 4xx Client error responses *)
118
+
119
+
type server_error =
120
+
[ `Internal_server_error (** 500 - Generic error message *)
121
+
| `Not_implemented
122
+
(** 501 - Server does not recognise method or lacks ability to fulfill *)
123
+
| `Bad_gateway
124
+
(** 502 - Server received an invalid response from upstream server *)
125
+
| `Service_unavailable (** 503 - Server is currently unavailable *)
126
+
| `Gateway_timeout
127
+
(** 504 - Gateway did not receive response from upstream server *)
128
+
| `Http_version_not_supported
129
+
(** 505 - Server does not support the HTTP protocol version *)
130
+
| `Variant_also_negotiates
131
+
(** 506 - Content negotiation for the request results in a circular
132
+
reference *)
133
+
| `Insufficient_storage
134
+
(** 507 - Server is unable to store the representation *)
135
+
| `Loop_detected
136
+
(** 508 - Server detected an infinite loop while processing the request *)
137
+
| `Not_extended (** 510 - Further extensions to the request are required *)
138
+
| `Network_authentication_required
139
+
(** 511 - Client needs to authenticate to gain network access *) ]
140
+
(** 5xx Server error responses *)
141
+
142
+
type standard =
143
+
[ informational | success | redirection | client_error | server_error ]
144
+
(** All standard HTTP status codes *)
145
+
146
+
type t = [ `Code of int (** Any status code as an integer *) | standard ]
147
+
(** HTTP status type *)
148
+
149
+
(** {1 Conversion Functions} *)
150
+
151
+
val to_int : t -> int
152
+
(** Convert status to its integer code. *)
153
+
154
+
val of_int : int -> t
155
+
(** Convert an integer to a status. *)
156
+
157
+
val to_string : t -> string
158
+
(** Get the string representation of a status code (e.g., "200", "404"). *)
159
+
160
+
val reason_phrase : t -> string
161
+
(** Get the standard reason phrase for a status code (e.g., "OK", "Not Found").
162
+
*)
163
+
164
+
(** {1 Classification Functions} *)
165
+
166
+
val is_informational : t -> bool
167
+
(** Check if status code is informational (1xx). *)
168
+
169
+
val is_success : t -> bool
170
+
(** Check if status code indicates success (2xx). *)
171
+
172
+
val is_redirection : t -> bool
173
+
(** Check if status code indicates redirection (3xx). *)
174
+
175
+
val is_client_error : t -> bool
176
+
(** Check if status code indicates client error (4xx). *)
177
+
178
+
val is_server_error : t -> bool
179
+
(** Check if status code indicates server error (5xx). *)
180
+
181
+
val is_error : t -> bool
182
+
(** Check if status code indicates any error (4xx or 5xx). *)
183
+
184
+
(** {1 Retry Policy} *)
185
+
186
+
val is_retryable : t -> bool
187
+
(** Check if a status code suggests the request could be retried. Returns true
188
+
for:
189
+
- 408 Request Timeout
190
+
- 429 Too Many Requests
191
+
- 502 Bad Gateway
192
+
- 503 Service Unavailable
193
+
- 504 Gateway Timeout
194
+
- Any 5xx errors. *)
195
+
196
+
val should_retry_on_different_host : t -> bool
197
+
(** Check if a status code suggests retrying on a different host might help.
198
+
Returns true for:
199
+
- 502 Bad Gateway
200
+
- 503 Service Unavailable
201
+
- 504 Gateway Timeout. *)
202
+
203
+
(** {1 Pretty Printing} *)
204
+
205
+
val pp : Format.formatter -> t -> unit
206
+
(** Pretty printer for status codes. *)
207
+
208
+
val pp_hum : Format.formatter -> t -> unit
209
+
(** Human-readable pretty printer that includes both code and reason phrase. *)
+18
test/test.ml
+18
test/test.ml
···
1
+
let () =
2
+
Alcotest.run "http"
3
+
[
4
+
Test_headers.suite;
5
+
Test_status.suite;
6
+
Test_method.suite;
7
+
Test_body.suite;
8
+
Test_header_name.suite;
9
+
Test_http_version.suite;
10
+
Test_http_date.suite;
11
+
Test_mime.suite;
12
+
Test_error.suite;
13
+
Test_huri.suite;
14
+
Test_response.suite;
15
+
Test_response_limits.suite;
16
+
Test_cache_control.suite;
17
+
Test_expect_continue.suite;
18
+
]
+148
test/test_body.ml
+148
test/test_body.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Body module *)
7
+
8
+
module Body = Http.Body
9
+
module Mime = Http.Mime
10
+
11
+
(** {1 Body.empty Tests} *)
12
+
13
+
let test_empty_is_empty () =
14
+
Alcotest.(check bool) "empty is_empty" true (Body.Private.is_empty Body.empty)
15
+
16
+
let test_empty_content_length () =
17
+
let cl = Body.content_length Body.empty in
18
+
Alcotest.(check (option int64)) "empty content_length" (Some 0L) cl
19
+
20
+
let test_empty_content_type () =
21
+
let ct = Body.content_type Body.empty in
22
+
Alcotest.(check bool) "empty content_type is None" true (Option.is_none ct)
23
+
24
+
(** {1 Body.of_string Tests} *)
25
+
26
+
let test_of_string_content_type () =
27
+
let body = Body.of_string Mime.json "test" in
28
+
let ct = Body.content_type body in
29
+
match ct with
30
+
| Some mime ->
31
+
Alcotest.(check string)
32
+
"mime is json" "application/json" (Mime.to_string mime)
33
+
| None -> Alcotest.fail "Expected Some content_type"
34
+
35
+
let test_of_string_content_length () =
36
+
let body = Body.of_string Mime.text "hello" in
37
+
let cl = Body.content_length body in
38
+
Alcotest.(check (option int64)) "content_length" (Some 5L) cl
39
+
40
+
let test_of_string_not_empty () =
41
+
let body = Body.of_string Mime.text "hello" in
42
+
Alcotest.(check bool) "not empty" false (Body.Private.is_empty body)
43
+
44
+
(** {1 Body.text Tests} *)
45
+
46
+
let test_text_creates_text_plain () =
47
+
let body = Body.text "hello" in
48
+
let ct = Body.content_type body in
49
+
match ct with
50
+
| Some mime ->
51
+
Alcotest.(check string) "text/plain" "text/plain" (Mime.to_string mime)
52
+
| None -> Alcotest.fail "Expected Some content_type for text body"
53
+
54
+
let test_text_content_length () =
55
+
let body = Body.text "hello" in
56
+
let cl = Body.content_length body in
57
+
Alcotest.(check (option int64)) "content_length" (Some 5L) cl
58
+
59
+
let test_text_to_string () =
60
+
let body = Body.text "hello" in
61
+
let s = Body.Private.to_string body in
62
+
Alcotest.(check string) "to_string" "hello" s
63
+
64
+
(** {1 Body.form Tests} *)
65
+
66
+
let test_form_creates_form_encoded () =
67
+
let body = Body.form [ ("key", "value") ] in
68
+
let ct = Body.content_type body in
69
+
match ct with
70
+
| Some mime ->
71
+
Alcotest.(check string)
72
+
"form content_type" "application/x-www-form-urlencoded"
73
+
(Mime.to_string mime)
74
+
| None -> Alcotest.fail "Expected Some content_type for form body"
75
+
76
+
let test_form_encodes_params () =
77
+
let body = Body.form [ ("key", "value"); ("name", "alice") ] in
78
+
let s = Body.Private.to_string body in
79
+
Alcotest.(check string) "form encoding" "key=value&name=alice" s
80
+
81
+
let test_form_encodes_special_chars () =
82
+
let body = Body.form [ ("key", "hello world") ] in
83
+
let s = Body.Private.to_string body in
84
+
(* URL-encoded space *)
85
+
Alcotest.(check bool)
86
+
"contains encoded space" true
87
+
(String.length s > 0 && not (String.contains s ' '))
88
+
89
+
(** {1 Body.json Tests} *)
90
+
91
+
let test_json_creates_json_body () =
92
+
let body = Body.json (Jsont.Json.string "hello") in
93
+
let ct = Body.content_type body in
94
+
match ct with
95
+
| Some mime ->
96
+
Alcotest.(check string)
97
+
"json content_type" "application/json" (Mime.to_string mime)
98
+
| None -> Alcotest.fail "Expected Some content_type for json body"
99
+
100
+
let test_json_content () =
101
+
let body = Body.json (Jsont.Json.string "hello") in
102
+
let s = Body.Private.to_string body in
103
+
Alcotest.(check string) "json content" "\"hello\"" s
104
+
105
+
let test_json_not_empty () =
106
+
let body = Body.json (Jsont.Json.string "test") in
107
+
Alcotest.(check bool) "json not empty" false (Body.Private.is_empty body)
108
+
109
+
(** {1 Body.is_empty Tests} *)
110
+
111
+
let test_is_empty_true () =
112
+
Alcotest.(check bool) "empty is empty" true (Body.Private.is_empty Body.empty)
113
+
114
+
let test_is_empty_false_str () =
115
+
let body = Body.text "not empty" in
116
+
Alcotest.(check bool) "text is not empty" false (Body.Private.is_empty body)
117
+
118
+
let test_is_empty_false_form () =
119
+
let body = Body.form [ ("k", "v") ] in
120
+
Alcotest.(check bool) "form is not empty" false (Body.Private.is_empty body)
121
+
122
+
(** {1 Test Suite} *)
123
+
124
+
let suite =
125
+
( "body",
126
+
[
127
+
Alcotest.test_case "is_empty" `Quick test_empty_is_empty;
128
+
Alcotest.test_case "content_length" `Quick test_empty_content_length;
129
+
Alcotest.test_case "content_type" `Quick test_empty_content_type;
130
+
Alcotest.test_case "content_type" `Quick test_of_string_content_type;
131
+
Alcotest.test_case "content_length" `Quick test_of_string_content_length;
132
+
Alcotest.test_case "not empty" `Quick test_of_string_not_empty;
133
+
Alcotest.test_case "creates text/plain" `Quick
134
+
test_text_creates_text_plain;
135
+
Alcotest.test_case "content_length" `Quick test_text_content_length;
136
+
Alcotest.test_case "to_string" `Quick test_text_to_string;
137
+
Alcotest.test_case "creates form-encoded" `Quick
138
+
test_form_creates_form_encoded;
139
+
Alcotest.test_case "encodes params" `Quick test_form_encodes_params;
140
+
Alcotest.test_case "encodes special chars" `Quick
141
+
test_form_encodes_special_chars;
142
+
Alcotest.test_case "creates json body" `Quick test_json_creates_json_body;
143
+
Alcotest.test_case "json content" `Quick test_json_content;
144
+
Alcotest.test_case "not empty" `Quick test_json_not_empty;
145
+
Alcotest.test_case "true for empty" `Quick test_is_empty_true;
146
+
Alcotest.test_case "false for string" `Quick test_is_empty_false_str;
147
+
Alcotest.test_case "false for form" `Quick test_is_empty_false_form;
148
+
] )
+4
test/test_body.mli
+4
test/test_body.mli
+249
test/test_cache_control.ml
+249
test/test_cache_control.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Cache_control module - RFC 9111 compliance *)
7
+
8
+
module Cache_control = Http.Cache_control
9
+
10
+
(** {1 Response Parsing Tests} *)
11
+
12
+
let test_parse_max_age () =
13
+
let cc = Cache_control.parse_response "max-age=3600" in
14
+
Alcotest.(check (option int)) "max_age" (Some 3600) cc.max_age
15
+
16
+
let test_no_cache_no_store () =
17
+
let cc = Cache_control.parse_response "no-cache, no-store" in
18
+
Alcotest.(check bool) "no_cache present" true (Option.is_some cc.no_cache);
19
+
Alcotest.(check bool) "no_store" true cc.no_store
20
+
21
+
let test_public_max_age_immutable () =
22
+
let cc = Cache_control.parse_response "public, max-age=604800, immutable" in
23
+
Alcotest.(check bool) "public" true cc.public;
24
+
Alcotest.(check (option int)) "max_age" (Some 604800) cc.max_age;
25
+
Alcotest.(check bool) "immutable" true cc.immutable
26
+
27
+
let test_parse_private_must_revalidate () =
28
+
let cc = Cache_control.parse_response "private, must-revalidate" in
29
+
Alcotest.(check bool) "private_ present" true (Option.is_some cc.private_);
30
+
Alcotest.(check bool) "must_revalidate" true cc.must_revalidate
31
+
32
+
let test_parse_s_maxage () =
33
+
let cc = Cache_control.parse_response "s-maxage=600" in
34
+
Alcotest.(check (option int)) "s_maxage" (Some 600) cc.s_maxage
35
+
36
+
let test_parse_no_transform () =
37
+
let cc = Cache_control.parse_response "no-transform" in
38
+
Alcotest.(check bool) "no_transform" true cc.no_transform
39
+
40
+
let test_parse_proxy_revalidate () =
41
+
let cc = Cache_control.parse_response "proxy-revalidate" in
42
+
Alcotest.(check bool) "proxy_revalidate" true cc.proxy_revalidate
43
+
44
+
let test_parse_stale_while_revalidate () =
45
+
let cc = Cache_control.parse_response "stale-while-revalidate=60" in
46
+
Alcotest.(check (option int))
47
+
"stale_while_revalidate" (Some 60) cc.stale_while_revalidate
48
+
49
+
let test_parse_stale_if_error () =
50
+
let cc = Cache_control.parse_response "stale-if-error=300" in
51
+
Alcotest.(check (option int)) "stale_if_error" (Some 300) cc.stale_if_error
52
+
53
+
let test_parse_must_understand () =
54
+
let cc = Cache_control.parse_response "must-understand" in
55
+
Alcotest.(check bool) "must_understand" true cc.must_understand
56
+
57
+
(** {1 Request Parsing Tests} *)
58
+
59
+
let test_request_max_age_zero () =
60
+
let cc = Cache_control.parse_request "max-age=0" in
61
+
Alcotest.(check (option int)) "req_max_age" (Some 0) cc.req_max_age
62
+
63
+
let test_request_no_cache () =
64
+
let cc = Cache_control.parse_request "no-cache" in
65
+
Alcotest.(check bool) "req_no_cache" true cc.req_no_cache
66
+
67
+
let test_request_no_store () =
68
+
let cc = Cache_control.parse_request "no-store" in
69
+
Alcotest.(check bool) "req_no_store" true cc.req_no_store
70
+
71
+
let test_request_no_transform () =
72
+
let cc = Cache_control.parse_request "no-transform" in
73
+
Alcotest.(check bool) "req_no_transform" true cc.req_no_transform
74
+
75
+
let test_request_only_if_cached () =
76
+
let cc = Cache_control.parse_request "only-if-cached" in
77
+
Alcotest.(check bool) "req_only_if_cached" true cc.req_only_if_cached
78
+
79
+
let test_request_min_fresh () =
80
+
let cc = Cache_control.parse_request "min-fresh=120" in
81
+
Alcotest.(check (option int)) "req_min_fresh" (Some 120) cc.req_min_fresh
82
+
83
+
(** {1 Cacheability Tests} *)
84
+
85
+
let test_cacheable_200_max_age () =
86
+
let cc = Cache_control.parse_response "max-age=3600" in
87
+
Alcotest.(check bool)
88
+
"cacheable 200 with max-age" true
89
+
(Cache_control.is_cacheable ~response_cc:cc ~status:200)
90
+
91
+
let test_is_cacheable_no_store () =
92
+
let cc = Cache_control.parse_response "no-store" in
93
+
Alcotest.(check bool)
94
+
"not cacheable with no-store" false
95
+
(Cache_control.is_cacheable ~response_cc:cc ~status:200)
96
+
97
+
let test_is_cacheable_default_status () =
98
+
let cc = Cache_control.empty_response in
99
+
Alcotest.(check bool)
100
+
"cacheable 200 default" true
101
+
(Cache_control.is_cacheable ~response_cc:cc ~status:200)
102
+
103
+
let test_cacheable_non_default_status () =
104
+
let cc = Cache_control.empty_response in
105
+
Alcotest.(check bool)
106
+
"non-cacheable 500 without directives" false
107
+
(Cache_control.is_cacheable ~response_cc:cc ~status:500)
108
+
109
+
let test_is_cacheable_301 () =
110
+
let cc = Cache_control.empty_response in
111
+
Alcotest.(check bool)
112
+
"cacheable 301 by default" true
113
+
(Cache_control.is_cacheable ~response_cc:cc ~status:301)
114
+
115
+
let test_is_cacheable_404 () =
116
+
let cc = Cache_control.empty_response in
117
+
Alcotest.(check bool)
118
+
"cacheable 404 by default" true
119
+
(Cache_control.is_cacheable ~response_cc:cc ~status:404)
120
+
121
+
(** {1 Predicate Tests} *)
122
+
123
+
let test_must_revalidate_flag () =
124
+
let cc = Cache_control.parse_response "must-revalidate" in
125
+
Alcotest.(check bool)
126
+
"must_revalidate" true
127
+
(Cache_control.must_revalidate ~response_cc:cc)
128
+
129
+
let test_revalidate_with_no_cache () =
130
+
let cc = Cache_control.parse_response "no-cache" in
131
+
Alcotest.(check bool)
132
+
"must_revalidate via no-cache" true
133
+
(Cache_control.must_revalidate ~response_cc:cc)
134
+
135
+
let test_revalidate_with_proxy () =
136
+
let cc = Cache_control.parse_response "proxy-revalidate" in
137
+
Alcotest.(check bool)
138
+
"must_revalidate via proxy-revalidate" true
139
+
(Cache_control.must_revalidate ~response_cc:cc)
140
+
141
+
let test_must_revalidate_false () =
142
+
let cc = Cache_control.parse_response "max-age=3600" in
143
+
Alcotest.(check bool)
144
+
"must_revalidate false" false
145
+
(Cache_control.must_revalidate ~response_cc:cc)
146
+
147
+
let test_is_public () =
148
+
let cc = Cache_control.parse_response "public" in
149
+
Alcotest.(check bool)
150
+
"is_public" true
151
+
(Cache_control.is_public ~response_cc:cc)
152
+
153
+
let test_is_public_false () =
154
+
let cc = Cache_control.parse_response "private" in
155
+
Alcotest.(check bool)
156
+
"is_public false" false
157
+
(Cache_control.is_public ~response_cc:cc)
158
+
159
+
let test_is_private () =
160
+
let cc = Cache_control.parse_response "private" in
161
+
Alcotest.(check bool)
162
+
"is_private" true
163
+
(Cache_control.is_private ~response_cc:cc)
164
+
165
+
let test_is_private_false () =
166
+
let cc = Cache_control.parse_response "public" in
167
+
Alcotest.(check bool)
168
+
"is_private false" false
169
+
(Cache_control.is_private ~response_cc:cc)
170
+
171
+
(** {1 Freshness Lifetime Tests} *)
172
+
173
+
let test_freshness_lifetime_max_age () =
174
+
let cc = Cache_control.parse_response "max-age=3600" in
175
+
let fl = Cache_control.freshness_lifetime ~response_cc:cc () in
176
+
Alcotest.(check (option int)) "freshness_lifetime from max-age" (Some 3600) fl
177
+
178
+
let test_freshness_lifetime_no_directives () =
179
+
let cc = Cache_control.empty_response in
180
+
let fl = Cache_control.freshness_lifetime ~response_cc:cc () in
181
+
Alcotest.(check (option int)) "freshness_lifetime none" None fl
182
+
183
+
(** {1 Empty Values Tests} *)
184
+
185
+
let test_empty_response () =
186
+
let cc = Cache_control.empty_response in
187
+
Alcotest.(check (option int)) "max_age" None cc.max_age;
188
+
Alcotest.(check (option int)) "s_maxage" None cc.s_maxage;
189
+
Alcotest.(check bool) "no_store" false cc.no_store;
190
+
Alcotest.(check bool) "must_revalidate" false cc.must_revalidate;
191
+
Alcotest.(check bool) "public" false cc.public;
192
+
Alcotest.(check bool) "immutable" false cc.immutable
193
+
194
+
let test_empty_request () =
195
+
let cc = Cache_control.empty_request in
196
+
Alcotest.(check (option int)) "req_max_age" None cc.req_max_age;
197
+
Alcotest.(check bool) "req_no_cache" false cc.req_no_cache;
198
+
Alcotest.(check bool) "req_no_store" false cc.req_no_store
199
+
200
+
(** {1 Test Suite} *)
201
+
202
+
let suite =
203
+
( "cache_control",
204
+
[
205
+
Alcotest.test_case "max-age=3600" `Quick test_parse_max_age;
206
+
Alcotest.test_case "no-cache, no-store" `Quick test_no_cache_no_store;
207
+
Alcotest.test_case "public, max-age, immutable" `Quick
208
+
test_public_max_age_immutable;
209
+
Alcotest.test_case "private, must-revalidate" `Quick
210
+
test_parse_private_must_revalidate;
211
+
Alcotest.test_case "s-maxage=600" `Quick test_parse_s_maxage;
212
+
Alcotest.test_case "no-transform" `Quick test_parse_no_transform;
213
+
Alcotest.test_case "proxy-revalidate" `Quick test_parse_proxy_revalidate;
214
+
Alcotest.test_case "stale-while-revalidate" `Quick
215
+
test_parse_stale_while_revalidate;
216
+
Alcotest.test_case "stale-if-error" `Quick test_parse_stale_if_error;
217
+
Alcotest.test_case "must-understand" `Quick test_parse_must_understand;
218
+
Alcotest.test_case "max-age=0" `Quick test_request_max_age_zero;
219
+
Alcotest.test_case "no-cache" `Quick test_request_no_cache;
220
+
Alcotest.test_case "no-store" `Quick test_request_no_store;
221
+
Alcotest.test_case "no-transform" `Quick test_request_no_transform;
222
+
Alcotest.test_case "only-if-cached" `Quick test_request_only_if_cached;
223
+
Alcotest.test_case "min-fresh=120" `Quick test_request_min_fresh;
224
+
Alcotest.test_case "200 with max-age" `Quick test_cacheable_200_max_age;
225
+
Alcotest.test_case "no-store not cacheable" `Quick
226
+
test_is_cacheable_no_store;
227
+
Alcotest.test_case "200 default status" `Quick
228
+
test_is_cacheable_default_status;
229
+
Alcotest.test_case "500 non-default" `Quick
230
+
test_cacheable_non_default_status;
231
+
Alcotest.test_case "301 cacheable by default" `Quick test_is_cacheable_301;
232
+
Alcotest.test_case "404 cacheable by default" `Quick test_is_cacheable_404;
233
+
Alcotest.test_case "must-revalidate" `Quick test_must_revalidate_flag;
234
+
Alcotest.test_case "must-revalidate via no-cache" `Quick
235
+
test_revalidate_with_no_cache;
236
+
Alcotest.test_case "must-revalidate via proxy-revalidate" `Quick
237
+
test_revalidate_with_proxy;
238
+
Alcotest.test_case "must-revalidate false" `Quick
239
+
test_must_revalidate_false;
240
+
Alcotest.test_case "is_public" `Quick test_is_public;
241
+
Alcotest.test_case "is_public false" `Quick test_is_public_false;
242
+
Alcotest.test_case "is_private" `Quick test_is_private;
243
+
Alcotest.test_case "is_private false" `Quick test_is_private_false;
244
+
Alcotest.test_case "from max-age" `Quick test_freshness_lifetime_max_age;
245
+
Alcotest.test_case "no directives" `Quick
246
+
test_freshness_lifetime_no_directives;
247
+
Alcotest.test_case "empty_response" `Quick test_empty_response;
248
+
Alcotest.test_case "empty_request" `Quick test_empty_request;
249
+
] )
+4
test/test_cache_control.mli
+4
test/test_cache_control.mli
+435
test/test_error.ml
+435
test/test_error.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Error module *)
7
+
8
+
module Error = Http.Error
9
+
10
+
(** {1 is_timeout Tests} *)
11
+
12
+
let test_is_timeout_true () =
13
+
let e = Error.Timeout { operation = "connect"; duration = Some 30.0 } in
14
+
Alcotest.(check bool) "timeout is_timeout" true (Error.is_timeout e)
15
+
16
+
let test_is_timeout_false () =
17
+
let e = Error.Dns_resolution_failed { hostname = "example.com" } in
18
+
Alcotest.(check bool) "dns is not timeout" false (Error.is_timeout e)
19
+
20
+
(** {1 is_dns Tests} *)
21
+
22
+
let test_is_dns_true () =
23
+
let e = Error.Dns_resolution_failed { hostname = "example.com" } in
24
+
Alcotest.(check bool) "dns is_dns" true (Error.is_dns e)
25
+
26
+
let test_is_dns_false () =
27
+
let e = Error.Timeout { operation = "read"; duration = None } in
28
+
Alcotest.(check bool) "timeout is not dns" false (Error.is_dns e)
29
+
30
+
(** {1 is_retryable Tests} *)
31
+
32
+
let test_is_retryable_timeout () =
33
+
let e = Error.Timeout { operation = "connect"; duration = Some 5.0 } in
34
+
Alcotest.(check bool) "timeout is retryable" true (Error.is_retryable e)
35
+
36
+
let test_is_retryable_dns () =
37
+
let e = Error.Dns_resolution_failed { hostname = "example.com" } in
38
+
Alcotest.(check bool) "dns is retryable" true (Error.is_retryable e)
39
+
40
+
let test_is_retryable_503 () =
41
+
let e =
42
+
Error.Http_error
43
+
{
44
+
url = "https://example.com";
45
+
status = 503;
46
+
reason = "Service Unavailable";
47
+
body_preview = None;
48
+
headers = [];
49
+
}
50
+
in
51
+
Alcotest.(check bool) "503 is retryable" true (Error.is_retryable e)
52
+
53
+
let test_is_retryable_502 () =
54
+
let e =
55
+
Error.Http_error
56
+
{
57
+
url = "https://example.com";
58
+
status = 502;
59
+
reason = "Bad Gateway";
60
+
body_preview = None;
61
+
headers = [];
62
+
}
63
+
in
64
+
Alcotest.(check bool) "502 is retryable" true (Error.is_retryable e)
65
+
66
+
let test_is_retryable_429 () =
67
+
let e =
68
+
Error.Http_error
69
+
{
70
+
url = "https://example.com";
71
+
status = 429;
72
+
reason = "Too Many Requests";
73
+
body_preview = None;
74
+
headers = [];
75
+
}
76
+
in
77
+
Alcotest.(check bool) "429 is retryable" true (Error.is_retryable e)
78
+
79
+
let test_is_retryable_connection () =
80
+
let e =
81
+
Error.Tcp_connect_failed
82
+
{ host = "example.com"; port = 443; reason = "refused" }
83
+
in
84
+
Alcotest.(check bool)
85
+
"tcp connect failed is retryable" true (Error.is_retryable e)
86
+
87
+
let test_is_retryable_404_false () =
88
+
let e =
89
+
Error.Http_error
90
+
{
91
+
url = "https://example.com";
92
+
status = 404;
93
+
reason = "Not Found";
94
+
body_preview = None;
95
+
headers = [];
96
+
}
97
+
in
98
+
Alcotest.(check bool) "404 is not retryable" false (Error.is_retryable e)
99
+
100
+
(** {1 is_client_error Tests} *)
101
+
102
+
let test_is_client_error_400 () =
103
+
let e =
104
+
Error.Http_error
105
+
{
106
+
url = "https://example.com";
107
+
status = 400;
108
+
reason = "Bad Request";
109
+
body_preview = None;
110
+
headers = [];
111
+
}
112
+
in
113
+
Alcotest.(check bool) "400 is client error" true (Error.is_client_error e)
114
+
115
+
let test_is_client_error_404 () =
116
+
let e =
117
+
Error.Http_error
118
+
{
119
+
url = "https://example.com";
120
+
status = 404;
121
+
reason = "Not Found";
122
+
body_preview = None;
123
+
headers = [];
124
+
}
125
+
in
126
+
Alcotest.(check bool) "404 is client error" true (Error.is_client_error e)
127
+
128
+
let test_is_client_error_499 () =
129
+
let e =
130
+
Error.Http_error
131
+
{
132
+
url = "https://example.com";
133
+
status = 499;
134
+
reason = "Client Closed Request";
135
+
body_preview = None;
136
+
headers = [];
137
+
}
138
+
in
139
+
Alcotest.(check bool) "499 is client error" true (Error.is_client_error e)
140
+
141
+
let test_client_error_500_false () =
142
+
let e =
143
+
Error.Http_error
144
+
{
145
+
url = "https://example.com";
146
+
status = 500;
147
+
reason = "Internal Server Error";
148
+
body_preview = None;
149
+
headers = [];
150
+
}
151
+
in
152
+
Alcotest.(check bool)
153
+
"500 is not client error" false (Error.is_client_error e)
154
+
155
+
(** {1 is_server_error Tests} *)
156
+
157
+
let test_is_server_error_500 () =
158
+
let e =
159
+
Error.Http_error
160
+
{
161
+
url = "https://example.com";
162
+
status = 500;
163
+
reason = "Internal Server Error";
164
+
body_preview = None;
165
+
headers = [];
166
+
}
167
+
in
168
+
Alcotest.(check bool) "500 is server error" true (Error.is_server_error e)
169
+
170
+
let test_is_server_error_503 () =
171
+
let e =
172
+
Error.Http_error
173
+
{
174
+
url = "https://example.com";
175
+
status = 503;
176
+
reason = "Service Unavailable";
177
+
body_preview = None;
178
+
headers = [];
179
+
}
180
+
in
181
+
Alcotest.(check bool) "503 is server error" true (Error.is_server_error e)
182
+
183
+
let test_server_error_400_false () =
184
+
let e =
185
+
Error.Http_error
186
+
{
187
+
url = "https://example.com";
188
+
status = 400;
189
+
reason = "Bad Request";
190
+
body_preview = None;
191
+
headers = [];
192
+
}
193
+
in
194
+
Alcotest.(check bool)
195
+
"400 is not server error" false (Error.is_server_error e)
196
+
197
+
(** {1 is_security_error Tests} *)
198
+
199
+
let test_is_security_error_tls () =
200
+
let e =
201
+
Error.Tls_handshake_failed { host = "example.com"; reason = "cert expired" }
202
+
in
203
+
Alcotest.(check bool)
204
+
"tls is not security error" false
205
+
(Error.is_security_error e)
206
+
207
+
let test_security_error_body_large () =
208
+
let e = Error.Body_too_large { limit = 1048576L; actual = Some 2097152L } in
209
+
Alcotest.(check bool)
210
+
"body_too_large is security error" true
211
+
(Error.is_security_error e)
212
+
213
+
let test_security_decompression_bomb () =
214
+
let e = Error.Decompression_bomb { limit = 10485760L; ratio = 100.0 } in
215
+
Alcotest.(check bool)
216
+
"decompression_bomb is security error" true
217
+
(Error.is_security_error e)
218
+
219
+
let test_security_invalid_header () =
220
+
let e = Error.Invalid_header { name = "Host"; reason = "contains newline" } in
221
+
Alcotest.(check bool)
222
+
"invalid_header is security error" true
223
+
(Error.is_security_error e)
224
+
225
+
let test_security_timeout_false () =
226
+
let e = Error.Timeout { operation = "read"; duration = None } in
227
+
Alcotest.(check bool)
228
+
"timeout is not security error" false
229
+
(Error.is_security_error e)
230
+
231
+
(** {1 sanitize_url Tests} *)
232
+
233
+
let test_sanitize_url_no_credentials () =
234
+
let url = "https://example.com/path" in
235
+
let sanitized = Error.sanitize_url url in
236
+
Alcotest.(check string) "no change" "https://example.com/path" sanitized
237
+
238
+
let has_substring s sub =
239
+
let len_s = String.length s in
240
+
let len_sub = String.length sub in
241
+
if len_sub > len_s then false
242
+
else
243
+
let found = ref false in
244
+
for i = 0 to len_s - len_sub do
245
+
if String.sub s i len_sub = sub then found := true
246
+
done;
247
+
!found
248
+
249
+
let test_sanitize_url_with_userinfo () =
250
+
let url = "https://user:pass@example.com/path" in
251
+
let sanitized = Error.sanitize_url url in
252
+
Alcotest.(check bool)
253
+
"no user:pass" false
254
+
(has_substring sanitized "user:pass")
255
+
256
+
let test_sanitize_url_user_only () =
257
+
let url = "https://user@example.com/path" in
258
+
let sanitized = Error.sanitize_url url in
259
+
Alcotest.(check bool) "no user@" false (has_substring sanitized "user@")
260
+
261
+
(** {1 is_sensitive_header Tests} *)
262
+
263
+
let test_is_sensitive_authorization () =
264
+
Alcotest.(check bool)
265
+
"Authorization is sensitive" true
266
+
(Error.is_sensitive_header "Authorization")
267
+
268
+
let test_is_sensitive_cookie () =
269
+
Alcotest.(check bool)
270
+
"Cookie is sensitive" true
271
+
(Error.is_sensitive_header "Cookie")
272
+
273
+
let test_is_sensitive_set_cookie () =
274
+
Alcotest.(check bool)
275
+
"Set-Cookie is sensitive" true
276
+
(Error.is_sensitive_header "Set-Cookie")
277
+
278
+
let test_is_sensitive_case_insensitive () =
279
+
Alcotest.(check bool)
280
+
"authorization (lowercase) is sensitive" true
281
+
(Error.is_sensitive_header "authorization")
282
+
283
+
let test_sensitive_content_type_false () =
284
+
Alcotest.(check bool)
285
+
"Content-Type is not sensitive" false
286
+
(Error.is_sensitive_header "Content-Type")
287
+
288
+
(** {1 Error Constructor Tests} *)
289
+
290
+
let test_err_creates_eio_exn () =
291
+
let exn =
292
+
Error.err (Error.Timeout { operation = "connect"; duration = Some 5.0 })
293
+
in
294
+
match exn with
295
+
| Eio.Io (Error.E (Timeout _), _) -> Alcotest.(check pass) "is Eio.Io" () ()
296
+
| _ -> Alcotest.fail "Expected Eio.Io with Timeout"
297
+
298
+
let test_of_eio_exn () =
299
+
let exn =
300
+
Error.err (Error.Timeout { operation = "connect"; duration = Some 5.0 })
301
+
in
302
+
match Error.of_eio_exn exn with
303
+
| Some (Error.Timeout { operation; _ }) ->
304
+
Alcotest.(check string) "operation" "connect" operation
305
+
| _ -> Alcotest.fail "Expected Some Timeout"
306
+
307
+
let test_to_string () =
308
+
let e = Error.Timeout { operation = "connect"; duration = Some 5.0 } in
309
+
let s = Error.to_string e in
310
+
Alcotest.(check bool) "contains operation" true (String.length s > 0)
311
+
312
+
(** {1 is_tls Tests} *)
313
+
314
+
let test_is_tls_true () =
315
+
let e =
316
+
Error.Tls_handshake_failed { host = "example.com"; reason = "cert invalid" }
317
+
in
318
+
Alcotest.(check bool) "tls handshake is_tls" true (Error.is_tls e)
319
+
320
+
let test_is_tls_false () =
321
+
let e = Error.Dns_resolution_failed { hostname = "example.com" } in
322
+
Alcotest.(check bool) "dns is not tls" false (Error.is_tls e)
323
+
324
+
(** {1 is_connection Tests} *)
325
+
326
+
let test_is_connection_dns () =
327
+
let e = Error.Dns_resolution_failed { hostname = "example.com" } in
328
+
Alcotest.(check bool) "dns is connection" true (Error.is_connection e)
329
+
330
+
let test_is_connection_tcp () =
331
+
let e =
332
+
Error.Tcp_connect_failed
333
+
{ host = "example.com"; port = 443; reason = "refused" }
334
+
in
335
+
Alcotest.(check bool) "tcp is connection" true (Error.is_connection e)
336
+
337
+
let test_is_connection_tls () =
338
+
let e =
339
+
Error.Tls_handshake_failed { host = "example.com"; reason = "cert invalid" }
340
+
in
341
+
Alcotest.(check bool) "tls is connection" true (Error.is_connection e)
342
+
343
+
let test_is_connection_timeout_false () =
344
+
let e = Error.Timeout { operation = "read"; duration = None } in
345
+
Alcotest.(check bool)
346
+
"timeout is not connection" false (Error.is_connection e)
347
+
348
+
(** {1 HTTP Status Helpers} *)
349
+
350
+
let test_get_http_status () =
351
+
let e =
352
+
Error.Http_error
353
+
{
354
+
url = "https://example.com";
355
+
status = 404;
356
+
reason = "Not Found";
357
+
body_preview = None;
358
+
headers = [];
359
+
}
360
+
in
361
+
Alcotest.(check (option int)) "status" (Some 404) (Error.http_status e)
362
+
363
+
let test_get_http_status_none () =
364
+
let e = Error.Timeout { operation = "read"; duration = None } in
365
+
Alcotest.(check (option int)) "no status" None (Error.http_status e)
366
+
367
+
let test_get_url () =
368
+
let e =
369
+
Error.Http_error
370
+
{
371
+
url = "https://example.com/path";
372
+
status = 500;
373
+
reason = "ISE";
374
+
body_preview = None;
375
+
headers = [];
376
+
}
377
+
in
378
+
Alcotest.(check (option string))
379
+
"url" (Some "https://example.com/path") (Error.url e)
380
+
381
+
(** {1 Test Suite} *)
382
+
383
+
let suite =
384
+
( "error",
385
+
[
386
+
Alcotest.test_case "true for Timeout" `Quick test_is_timeout_true;
387
+
Alcotest.test_case "false for DNS" `Quick test_is_timeout_false;
388
+
Alcotest.test_case "true for DNS" `Quick test_is_dns_true;
389
+
Alcotest.test_case "false for Timeout" `Quick test_is_dns_false;
390
+
Alcotest.test_case "timeout" `Quick test_is_retryable_timeout;
391
+
Alcotest.test_case "dns" `Quick test_is_retryable_dns;
392
+
Alcotest.test_case "503" `Quick test_is_retryable_503;
393
+
Alcotest.test_case "502" `Quick test_is_retryable_502;
394
+
Alcotest.test_case "429" `Quick test_is_retryable_429;
395
+
Alcotest.test_case "connection" `Quick test_is_retryable_connection;
396
+
Alcotest.test_case "404 not retryable" `Quick test_is_retryable_404_false;
397
+
Alcotest.test_case "400" `Quick test_is_client_error_400;
398
+
Alcotest.test_case "404" `Quick test_is_client_error_404;
399
+
Alcotest.test_case "499" `Quick test_is_client_error_499;
400
+
Alcotest.test_case "500 not client" `Quick test_client_error_500_false;
401
+
Alcotest.test_case "500" `Quick test_is_server_error_500;
402
+
Alcotest.test_case "503" `Quick test_is_server_error_503;
403
+
Alcotest.test_case "400 not server" `Quick test_server_error_400_false;
404
+
Alcotest.test_case "TLS" `Quick test_is_security_error_tls;
405
+
Alcotest.test_case "body too large" `Quick test_security_error_body_large;
406
+
Alcotest.test_case "decompression bomb" `Quick
407
+
test_security_decompression_bomb;
408
+
Alcotest.test_case "invalid header" `Quick test_security_invalid_header;
409
+
Alcotest.test_case "timeout not security" `Quick
410
+
test_security_timeout_false;
411
+
Alcotest.test_case "no credentials" `Quick
412
+
test_sanitize_url_no_credentials;
413
+
Alcotest.test_case "with userinfo" `Quick test_sanitize_url_with_userinfo;
414
+
Alcotest.test_case "with user only" `Quick test_sanitize_url_user_only;
415
+
Alcotest.test_case "Authorization" `Quick test_is_sensitive_authorization;
416
+
Alcotest.test_case "Cookie" `Quick test_is_sensitive_cookie;
417
+
Alcotest.test_case "Set-Cookie" `Quick test_is_sensitive_set_cookie;
418
+
Alcotest.test_case "case insensitive" `Quick
419
+
test_is_sensitive_case_insensitive;
420
+
Alcotest.test_case "Content-Type not sensitive" `Quick
421
+
test_sensitive_content_type_false;
422
+
Alcotest.test_case "err creates Eio.Io" `Quick test_err_creates_eio_exn;
423
+
Alcotest.test_case "of_eio_exn" `Quick test_of_eio_exn;
424
+
Alcotest.test_case "to_string" `Quick test_to_string;
425
+
Alcotest.test_case "true for TLS" `Quick test_is_tls_true;
426
+
Alcotest.test_case "false for DNS" `Quick test_is_tls_false;
427
+
Alcotest.test_case "DNS" `Quick test_is_connection_dns;
428
+
Alcotest.test_case "TCP" `Quick test_is_connection_tcp;
429
+
Alcotest.test_case "TLS" `Quick test_is_connection_tls;
430
+
Alcotest.test_case "timeout not connection" `Quick
431
+
test_is_connection_timeout_false;
432
+
Alcotest.test_case "http_status" `Quick test_get_http_status;
433
+
Alcotest.test_case "http_status none" `Quick test_get_http_status_none;
434
+
Alcotest.test_case "url" `Quick test_get_url;
435
+
] )
+4
test/test_error.mli
+4
test/test_error.mli
+150
test/test_expect_continue.ml
+150
test/test_expect_continue.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Expect_continue module *)
7
+
8
+
module Expect_continue = Http.Expect_continue
9
+
10
+
(** {1 Default Configuration Tests} *)
11
+
12
+
let test_default_threshold () =
13
+
let t = Expect_continue.default in
14
+
Alcotest.(check int64)
15
+
"default threshold is 1MB" 1_048_576L
16
+
(Expect_continue.threshold t)
17
+
18
+
let test_default_enabled () =
19
+
let t = Expect_continue.default in
20
+
Alcotest.(check bool) "default is enabled" true (Expect_continue.enabled t)
21
+
22
+
let test_default_timeout () =
23
+
let t = Expect_continue.default in
24
+
Alcotest.(check (float 0.01))
25
+
"default timeout" 1.0
26
+
(Expect_continue.timeout t)
27
+
28
+
(** {1 Disabled Configuration Tests} *)
29
+
30
+
let test_disabled_not_enabled () =
31
+
let t = Expect_continue.disabled in
32
+
Alcotest.(check bool)
33
+
"disabled is not enabled" false
34
+
(Expect_continue.enabled t)
35
+
36
+
(** {1 of_config Tests} *)
37
+
38
+
let test_of_config_disabled () =
39
+
let t = Expect_continue.of_config `Disabled in
40
+
Alcotest.(check bool) "Disabled config" false (Expect_continue.enabled t)
41
+
42
+
let test_of_config_always () =
43
+
let t = Expect_continue.of_config `Always in
44
+
Alcotest.(check bool) "Always enabled" true (Expect_continue.enabled t);
45
+
Alcotest.(check int64)
46
+
"Always threshold is 0" 0L
47
+
(Expect_continue.threshold t)
48
+
49
+
let test_of_config_threshold () =
50
+
let t = Expect_continue.of_config (`Threshold 5000L) in
51
+
Alcotest.(check bool) "Threshold enabled" true (Expect_continue.enabled t);
52
+
Alcotest.(check int64) "Threshold value" 5000L (Expect_continue.threshold t)
53
+
54
+
let test_of_config_custom_timeout () =
55
+
let t = Expect_continue.of_config ~timeout:2.5 (`Threshold 1000L) in
56
+
Alcotest.(check (float 0.01)) "custom timeout" 2.5 (Expect_continue.timeout t)
57
+
58
+
(** {1 should_use Tests} *)
59
+
60
+
let test_should_use_above_threshold () =
61
+
let t = Expect_continue.of_config (`Threshold 1000L) in
62
+
Alcotest.(check bool)
63
+
"body above threshold" true
64
+
(Expect_continue.should_use t 2000L)
65
+
66
+
let test_should_use_at_threshold () =
67
+
let t = Expect_continue.of_config (`Threshold 1000L) in
68
+
Alcotest.(check bool)
69
+
"body at threshold" true
70
+
(Expect_continue.should_use t 1000L)
71
+
72
+
let test_should_use_below_threshold () =
73
+
let t = Expect_continue.of_config (`Threshold 1000L) in
74
+
Alcotest.(check bool)
75
+
"body below threshold" false
76
+
(Expect_continue.should_use t 999L)
77
+
78
+
let test_should_use_disabled () =
79
+
let t = Expect_continue.disabled in
80
+
Alcotest.(check bool)
81
+
"disabled always false" false
82
+
(Expect_continue.should_use t 999_999_999L)
83
+
84
+
let test_should_use_always () =
85
+
let t = Expect_continue.of_config `Always in
86
+
Alcotest.(check bool)
87
+
"always with any body" true
88
+
(Expect_continue.should_use t 1L)
89
+
90
+
let test_should_use_always_zero () =
91
+
let t = Expect_continue.of_config `Always in
92
+
Alcotest.(check bool)
93
+
"always with zero body" true
94
+
(Expect_continue.should_use t 0L)
95
+
96
+
(** {1 default_threshold Tests} *)
97
+
98
+
let test_default_threshold_value () =
99
+
Alcotest.(check int64)
100
+
"default_threshold is 1MB" 1_048_576L Expect_continue.default_threshold
101
+
102
+
(** {1 make Tests} *)
103
+
104
+
let test_make_defaults () =
105
+
let t = Expect_continue.v () in
106
+
Alcotest.(check bool) "make defaults enabled" true (Expect_continue.enabled t);
107
+
Alcotest.(check int64)
108
+
"make defaults threshold" 1_048_576L
109
+
(Expect_continue.threshold t)
110
+
111
+
let test_make_custom () =
112
+
let t = Expect_continue.v ~enabled:false ~threshold:500L ~timeout:3.0 () in
113
+
Alcotest.(check bool) "custom not enabled" false (Expect_continue.enabled t);
114
+
Alcotest.(check int64) "custom threshold" 500L (Expect_continue.threshold t);
115
+
Alcotest.(check (float 0.01)) "custom timeout" 3.0 (Expect_continue.timeout t)
116
+
117
+
(** {1 to_string Tests} *)
118
+
119
+
let test_to_string () =
120
+
let t = Expect_continue.default in
121
+
let s = Expect_continue.to_string t in
122
+
Alcotest.(check bool) "to_string non-empty" true (String.length s > 0)
123
+
124
+
(** {1 Test Suite} *)
125
+
126
+
let suite =
127
+
( "expect_continue",
128
+
[
129
+
Alcotest.test_case "threshold is 1MB" `Quick test_default_threshold;
130
+
Alcotest.test_case "enabled" `Quick test_default_enabled;
131
+
Alcotest.test_case "timeout" `Quick test_default_timeout;
132
+
Alcotest.test_case "not enabled" `Quick test_disabled_not_enabled;
133
+
Alcotest.test_case "Disabled" `Quick test_of_config_disabled;
134
+
Alcotest.test_case "Always" `Quick test_of_config_always;
135
+
Alcotest.test_case "Threshold" `Quick test_of_config_threshold;
136
+
Alcotest.test_case "custom timeout" `Quick test_of_config_custom_timeout;
137
+
Alcotest.test_case "above threshold" `Quick
138
+
test_should_use_above_threshold;
139
+
Alcotest.test_case "at threshold" `Quick test_should_use_at_threshold;
140
+
Alcotest.test_case "below threshold" `Quick
141
+
test_should_use_below_threshold;
142
+
Alcotest.test_case "disabled always false" `Quick test_should_use_disabled;
143
+
Alcotest.test_case "always with any body" `Quick test_should_use_always;
144
+
Alcotest.test_case "always with zero body" `Quick
145
+
test_should_use_always_zero;
146
+
Alcotest.test_case "value" `Quick test_default_threshold_value;
147
+
Alcotest.test_case "defaults" `Quick test_make_defaults;
148
+
Alcotest.test_case "custom" `Quick test_make_custom;
149
+
Alcotest.test_case "non-empty" `Quick test_to_string;
150
+
] )
+4
test/test_expect_continue.mli
+4
test/test_expect_continue.mli
+282
test/test_header_name.ml
+282
test/test_header_name.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Header_name module - RFC 9110 header names *)
7
+
8
+
module Header_name = Http.Header_name
9
+
10
+
(** {1 of_string / to_string Tests} *)
11
+
12
+
let test_of_string_content_type () =
13
+
let hn = Header_name.of_string "Content-Type" in
14
+
Alcotest.(check bool) "Content-Type" true (hn = `Content_type)
15
+
16
+
let test_of_string_case_insensitive () =
17
+
let hn = Header_name.of_string "content-type" in
18
+
Alcotest.(check bool) "content-type lowercase" true (hn = `Content_type)
19
+
20
+
let test_of_string_uppercase () =
21
+
let hn = Header_name.of_string "CONTENT-TYPE" in
22
+
Alcotest.(check bool) "CONTENT-TYPE uppercase" true (hn = `Content_type)
23
+
24
+
let test_to_string_content_type () =
25
+
let s = Header_name.to_string `Content_type in
26
+
Alcotest.(check string) "canonical form" "Content-Type" s
27
+
28
+
let test_of_string_custom () =
29
+
let hn = Header_name.of_string "X-Custom" in
30
+
Alcotest.(check bool) "custom header" true (hn = `Other "X-Custom")
31
+
32
+
let test_to_string_custom () =
33
+
let s = Header_name.to_string (`Other "X-Custom") in
34
+
Alcotest.(check string) "custom to_string" "X-Custom" s
35
+
36
+
(** {1 Standard Header Roundtrip Tests} *)
37
+
38
+
let test_roundtrip_accept () =
39
+
let hn = Header_name.of_string "Accept" in
40
+
Alcotest.(check bool) "Accept parses" true (hn = `Accept);
41
+
Alcotest.(check string) "Accept roundtrip" "Accept" (Header_name.to_string hn)
42
+
43
+
let test_roundtrip_authorization () =
44
+
let hn = Header_name.of_string "Authorization" in
45
+
Alcotest.(check bool) "Authorization parses" true (hn = `Authorization);
46
+
Alcotest.(check string)
47
+
"Authorization roundtrip" "Authorization" (Header_name.to_string hn)
48
+
49
+
let test_roundtrip_content_length () =
50
+
let hn = Header_name.of_string "Content-Length" in
51
+
Alcotest.(check bool) "Content-Length parses" true (hn = `Content_length);
52
+
Alcotest.(check string)
53
+
"Content-Length roundtrip" "Content-Length" (Header_name.to_string hn)
54
+
55
+
let test_roundtrip_host () =
56
+
let hn = Header_name.of_string "Host" in
57
+
Alcotest.(check bool) "Host parses" true (hn = `Host);
58
+
Alcotest.(check string) "Host roundtrip" "Host" (Header_name.to_string hn)
59
+
60
+
let test_roundtrip_user_agent () =
61
+
let hn = Header_name.of_string "User-Agent" in
62
+
Alcotest.(check bool) "User-Agent parses" true (hn = `User_agent);
63
+
Alcotest.(check string)
64
+
"User-Agent roundtrip" "User-Agent" (Header_name.to_string hn)
65
+
66
+
let test_roundtrip_cache_control () =
67
+
let hn = Header_name.of_string "Cache-Control" in
68
+
Alcotest.(check bool) "Cache-Control parses" true (hn = `Cache_control);
69
+
Alcotest.(check string)
70
+
"Cache-Control roundtrip" "Cache-Control" (Header_name.to_string hn)
71
+
72
+
let test_roundtrip_connection () =
73
+
let hn = Header_name.of_string "Connection" in
74
+
Alcotest.(check bool) "Connection parses" true (hn = `Connection);
75
+
Alcotest.(check string)
76
+
"Connection roundtrip" "Connection" (Header_name.to_string hn)
77
+
78
+
let test_roundtrip_transfer_encoding () =
79
+
let hn = Header_name.of_string "Transfer-Encoding" in
80
+
Alcotest.(check bool) "Transfer-Encoding parses" true (hn = `Transfer_encoding);
81
+
Alcotest.(check string)
82
+
"Transfer-Encoding roundtrip" "Transfer-Encoding" (Header_name.to_string hn)
83
+
84
+
(** {1 equal Tests} *)
85
+
86
+
let test_equal_same () =
87
+
Alcotest.(check bool)
88
+
"same header" true
89
+
(Header_name.equal `Content_type `Content_type)
90
+
91
+
let test_equal_different () =
92
+
Alcotest.(check bool)
93
+
"different headers" false
94
+
(Header_name.equal `Content_type `Content_length)
95
+
96
+
let test_equal_case_insensitive () =
97
+
let a = Header_name.of_string "Content-Type" in
98
+
let b = Header_name.of_string "content-type" in
99
+
Alcotest.(check bool) "case insensitive equal" true (Header_name.equal a b)
100
+
101
+
let test_equal_custom () =
102
+
let a = Header_name.of_string "X-Custom" in
103
+
let b = Header_name.of_string "x-custom" in
104
+
Alcotest.(check bool) "custom case insensitive" true (Header_name.equal a b)
105
+
106
+
(** {1 is_hop_by_hop Tests} *)
107
+
108
+
let test_hop_by_hop_connection () =
109
+
Alcotest.(check bool)
110
+
"Connection is hop-by-hop" true
111
+
(Header_name.is_hop_by_hop `Connection)
112
+
113
+
let test_hop_by_hop_keepalive () =
114
+
Alcotest.(check bool)
115
+
"Keep-Alive is hop-by-hop" true
116
+
(Header_name.is_hop_by_hop `Keep_alive)
117
+
118
+
let hop_by_hop_transfer_enc () =
119
+
Alcotest.(check bool)
120
+
"Transfer-Encoding is hop-by-hop" true
121
+
(Header_name.is_hop_by_hop `Transfer_encoding)
122
+
123
+
let test_hop_by_hop_upgrade () =
124
+
Alcotest.(check bool)
125
+
"Upgrade is hop-by-hop" true
126
+
(Header_name.is_hop_by_hop `Upgrade)
127
+
128
+
let test_hop_by_hop_via () =
129
+
Alcotest.(check bool)
130
+
"Via is hop-by-hop" true
131
+
(Header_name.is_hop_by_hop `Via)
132
+
133
+
let hop_by_hop_content_false () =
134
+
Alcotest.(check bool)
135
+
"Content-Type is not hop-by-hop" false
136
+
(Header_name.is_hop_by_hop `Content_type)
137
+
138
+
(** {1 is_security Tests} *)
139
+
140
+
let test_security_csp () =
141
+
Alcotest.(check bool)
142
+
"CSP is security" true
143
+
(Header_name.is_security `Content_security_policy)
144
+
145
+
let test_security_hsts () =
146
+
Alcotest.(check bool)
147
+
"HSTS is security" true
148
+
(Header_name.is_security `Strict_transport_security)
149
+
150
+
let test_security_content_type_opts () =
151
+
Alcotest.(check bool)
152
+
"X-Content-Type-Options is security" true
153
+
(Header_name.is_security `X_content_type_options)
154
+
155
+
let test_security_x_frame_options () =
156
+
Alcotest.(check bool)
157
+
"X-Frame-Options is security" true
158
+
(Header_name.is_security `X_frame_options)
159
+
160
+
let test_security_content_type_false () =
161
+
Alcotest.(check bool)
162
+
"Content-Type is not security" false
163
+
(Header_name.is_security `Content_type)
164
+
165
+
(** {1 CORS Category Tests} *)
166
+
167
+
let test_cors_response_allow_origin () =
168
+
Alcotest.(check bool)
169
+
"Allow-Origin is CORS response" true
170
+
(Header_name.is_cors_response `Access_control_allow_origin)
171
+
172
+
let test_cors_response_allow_methods () =
173
+
Alcotest.(check bool)
174
+
"Allow-Methods is CORS response" true
175
+
(Header_name.is_cors_response `Access_control_allow_methods)
176
+
177
+
let test_cors_request_request_method () =
178
+
Alcotest.(check bool)
179
+
"Request-Method is CORS request" true
180
+
(Header_name.is_cors_request `Access_control_request_method)
181
+
182
+
let test_cors_request_request_headers () =
183
+
Alcotest.(check bool)
184
+
"Request-Headers is CORS request" true
185
+
(Header_name.is_cors_request `Access_control_request_headers)
186
+
187
+
let test_cors_origin () =
188
+
Alcotest.(check bool)
189
+
"Origin is CORS request" true
190
+
(Header_name.is_cors_request `Origin)
191
+
192
+
(** {1 WebSocket Category Tests} *)
193
+
194
+
let test_websocket_key () =
195
+
Alcotest.(check bool)
196
+
"Sec-WebSocket-Key is websocket" true
197
+
(Header_name.is_websocket `Sec_websocket_key)
198
+
199
+
let test_websocket_accept () =
200
+
Alcotest.(check bool)
201
+
"Sec-WebSocket-Accept is websocket" true
202
+
(Header_name.is_websocket `Sec_websocket_accept)
203
+
204
+
let test_websocket_version () =
205
+
Alcotest.(check bool)
206
+
"Sec-WebSocket-Version is websocket" true
207
+
(Header_name.is_websocket `Sec_websocket_version)
208
+
209
+
let test_websocket_content_type_false () =
210
+
Alcotest.(check bool)
211
+
"Content-Type is not websocket" false
212
+
(Header_name.is_websocket `Content_type)
213
+
214
+
(** {1 Fetch Metadata Tests} *)
215
+
216
+
let test_fetch_metadata_dest () =
217
+
Alcotest.(check bool)
218
+
"Sec-Fetch-Dest is fetch metadata" true
219
+
(Header_name.is_fetch_metadata `Sec_fetch_dest)
220
+
221
+
let test_fetch_metadata_mode () =
222
+
Alcotest.(check bool)
223
+
"Sec-Fetch-Mode is fetch metadata" true
224
+
(Header_name.is_fetch_metadata `Sec_fetch_mode)
225
+
226
+
(** {1 Test Suite} *)
227
+
228
+
let suite =
229
+
( "header_name",
230
+
[
231
+
Alcotest.test_case "Content-Type" `Quick test_of_string_content_type;
232
+
Alcotest.test_case "case insensitive" `Quick
233
+
test_of_string_case_insensitive;
234
+
Alcotest.test_case "uppercase" `Quick test_of_string_uppercase;
235
+
Alcotest.test_case "to_string canonical" `Quick
236
+
test_to_string_content_type;
237
+
Alcotest.test_case "custom header" `Quick test_of_string_custom;
238
+
Alcotest.test_case "custom to_string" `Quick test_to_string_custom;
239
+
Alcotest.test_case "Accept" `Quick test_roundtrip_accept;
240
+
Alcotest.test_case "Authorization" `Quick test_roundtrip_authorization;
241
+
Alcotest.test_case "Content-Length" `Quick test_roundtrip_content_length;
242
+
Alcotest.test_case "Host" `Quick test_roundtrip_host;
243
+
Alcotest.test_case "User-Agent" `Quick test_roundtrip_user_agent;
244
+
Alcotest.test_case "Cache-Control" `Quick test_roundtrip_cache_control;
245
+
Alcotest.test_case "Connection" `Quick test_roundtrip_connection;
246
+
Alcotest.test_case "Transfer-Encoding" `Quick
247
+
test_roundtrip_transfer_encoding;
248
+
Alcotest.test_case "same header" `Quick test_equal_same;
249
+
Alcotest.test_case "different headers" `Quick test_equal_different;
250
+
Alcotest.test_case "case insensitive" `Quick test_equal_case_insensitive;
251
+
Alcotest.test_case "custom case insensitive" `Quick test_equal_custom;
252
+
Alcotest.test_case "Connection" `Quick test_hop_by_hop_connection;
253
+
Alcotest.test_case "Keep-Alive" `Quick test_hop_by_hop_keepalive;
254
+
Alcotest.test_case "Transfer-Encoding" `Quick hop_by_hop_transfer_enc;
255
+
Alcotest.test_case "Upgrade" `Quick test_hop_by_hop_upgrade;
256
+
Alcotest.test_case "Via" `Quick test_hop_by_hop_via;
257
+
Alcotest.test_case "Content-Type not hop-by-hop" `Quick
258
+
hop_by_hop_content_false;
259
+
Alcotest.test_case "CSP" `Quick test_security_csp;
260
+
Alcotest.test_case "HSTS" `Quick test_security_hsts;
261
+
Alcotest.test_case "X-Content-Type-Options" `Quick
262
+
test_security_content_type_opts;
263
+
Alcotest.test_case "X-Frame-Options" `Quick test_security_x_frame_options;
264
+
Alcotest.test_case "Content-Type not security" `Quick
265
+
test_security_content_type_false;
266
+
Alcotest.test_case "Allow-Origin response" `Quick
267
+
test_cors_response_allow_origin;
268
+
Alcotest.test_case "Allow-Methods response" `Quick
269
+
test_cors_response_allow_methods;
270
+
Alcotest.test_case "Request-Method request" `Quick
271
+
test_cors_request_request_method;
272
+
Alcotest.test_case "Request-Headers request" `Quick
273
+
test_cors_request_request_headers;
274
+
Alcotest.test_case "Origin request" `Quick test_cors_origin;
275
+
Alcotest.test_case "Key" `Quick test_websocket_key;
276
+
Alcotest.test_case "Accept" `Quick test_websocket_accept;
277
+
Alcotest.test_case "Version" `Quick test_websocket_version;
278
+
Alcotest.test_case "Content-Type not websocket" `Quick
279
+
test_websocket_content_type_false;
280
+
Alcotest.test_case "Sec-Fetch-Dest" `Quick test_fetch_metadata_dest;
281
+
Alcotest.test_case "Sec-Fetch-Mode" `Quick test_fetch_metadata_mode;
282
+
] )
+4
test/test_header_name.mli
+4
test/test_header_name.mli
+275
test/test_headers.ml
+275
test/test_headers.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Headers module *)
7
+
8
+
module Headers = Http.Headers
9
+
module Header_name = Http.Header_name
10
+
11
+
(** {1 empty Tests} *)
12
+
13
+
let test_empty_has_no_headers () =
14
+
let h = Headers.empty in
15
+
let l = Headers.to_list h in
16
+
Alcotest.(check int) "empty has no headers" 0 (List.length l)
17
+
18
+
(** {1 of_list / to_list Tests} *)
19
+
20
+
let test_of_list_roundtrip () =
21
+
let pairs = [ ("Content-Type", "text/html"); ("Host", "example.com") ] in
22
+
let h = Headers.of_list pairs in
23
+
let l = Headers.to_list h in
24
+
Alcotest.(check int) "two headers" 2 (List.length l)
25
+
26
+
let test_of_list_preserves_values () =
27
+
let h = Headers.of_list [ ("Content-Type", "text/html") ] in
28
+
let v = Headers.find `Content_type h in
29
+
Alcotest.(check (option string)) "Content-Type value" (Some "text/html") v
30
+
31
+
(** {1 add / get / remove Tests} *)
32
+
33
+
let test_add_and_get () =
34
+
let h = Headers.empty |> Headers.add `Content_type "application/json" in
35
+
let v = Headers.find `Content_type h in
36
+
Alcotest.(check (option string)) "get after add" (Some "application/json") v
37
+
38
+
let test_add_multiple () =
39
+
let h =
40
+
Headers.empty
41
+
|> Headers.add `Set_cookie "a=1"
42
+
|> Headers.add `Set_cookie "b=2"
43
+
in
44
+
let values = Headers.all `Set_cookie h in
45
+
Alcotest.(check int) "multiple values" 2 (List.length values)
46
+
47
+
let test_get_missing () =
48
+
let h = Headers.empty in
49
+
let v = Headers.find `Content_type h in
50
+
Alcotest.(check (option string)) "missing header" None v
51
+
52
+
let test_remove () =
53
+
let h =
54
+
Headers.empty
55
+
|> Headers.add `Content_type "text/html"
56
+
|> Headers.remove `Content_type
57
+
in
58
+
let v = Headers.find `Content_type h in
59
+
Alcotest.(check (option string)) "removed header" None v
60
+
61
+
(** {1 set Tests} *)
62
+
63
+
let test_set_replaces () =
64
+
let h =
65
+
Headers.empty
66
+
|> Headers.add `Content_type "text/html"
67
+
|> Headers.set `Content_type "application/json"
68
+
in
69
+
let v = Headers.find `Content_type h in
70
+
Alcotest.(check (option string)) "set replaces" (Some "application/json") v
71
+
72
+
let test_set_replaces_all () =
73
+
let h =
74
+
Headers.empty
75
+
|> Headers.add `Set_cookie "a=1"
76
+
|> Headers.add `Set_cookie "b=2"
77
+
|> Headers.set `Set_cookie "c=3"
78
+
in
79
+
let values = Headers.all `Set_cookie h in
80
+
Alcotest.(check int) "set replaces all" 1 (List.length values);
81
+
Alcotest.(check string) "set value" "c=3" (List.hd values)
82
+
83
+
(** {1 all Tests} *)
84
+
85
+
let test_get_all_empty () =
86
+
let h = Headers.empty in
87
+
let values = Headers.all `Content_type h in
88
+
Alcotest.(check int) "all empty" 0 (List.length values)
89
+
90
+
let test_get_all_multiple () =
91
+
let h =
92
+
Headers.empty
93
+
|> Headers.add `Set_cookie "session=abc"
94
+
|> Headers.add `Set_cookie "lang=en"
95
+
in
96
+
let values = Headers.all `Set_cookie h in
97
+
Alcotest.(check int) "all multiple" 2 (List.length values)
98
+
99
+
(** {1 merge Tests} *)
100
+
101
+
let test_merge_combines () =
102
+
let a = Headers.empty |> Headers.set `Content_type "text/html" in
103
+
let b = Headers.empty |> Headers.set `Host "example.com" in
104
+
let merged = Headers.merge a b in
105
+
Alcotest.(check (option string))
106
+
"merged content-type" (Some "text/html")
107
+
(Headers.find `Content_type merged);
108
+
Alcotest.(check (option string))
109
+
"merged host" (Some "example.com")
110
+
(Headers.find `Host merged)
111
+
112
+
let test_merge_override () =
113
+
let a = Headers.empty |> Headers.set `Content_type "text/html" in
114
+
let b = Headers.empty |> Headers.set `Content_type "application/json" in
115
+
let merged = Headers.merge a b in
116
+
Alcotest.(check (option string))
117
+
"override replaces" (Some "application/json")
118
+
(Headers.find `Content_type merged)
119
+
120
+
(** {1 Convenience Constructor Tests} *)
121
+
122
+
let test_content_type () =
123
+
let h =
124
+
Headers.empty |> Headers.content_type (Http.Mime.of_string "text/html")
125
+
in
126
+
let v = Headers.find `Content_type h in
127
+
Alcotest.(check (option string)) "content_type" (Some "text/html") v
128
+
129
+
let test_content_length () =
130
+
let h = Headers.empty |> Headers.content_length 42L in
131
+
let v = Headers.find `Content_length h in
132
+
Alcotest.(check (option string)) "content_length" (Some "42") v
133
+
134
+
let test_host () =
135
+
let h = Headers.empty |> Headers.host "example.com" in
136
+
let v = Headers.find `Host h in
137
+
Alcotest.(check (option string)) "host" (Some "example.com") v
138
+
139
+
(** {1 Authentication Tests} *)
140
+
141
+
let test_bearer () =
142
+
let h = Headers.empty |> Headers.bearer "token123" in
143
+
let v = Headers.find `Authorization h in
144
+
Alcotest.(check (option string)) "bearer" (Some "Bearer token123") v
145
+
146
+
let test_basic () =
147
+
let h = Headers.empty |> Headers.basic ~username:"user" ~password:"pass" in
148
+
let v = Headers.find `Authorization h in
149
+
match v with
150
+
| Some auth ->
151
+
Alcotest.(check bool)
152
+
"starts with Basic" true
153
+
(String.length auth > 6 && String.sub auth 0 6 = "Basic ")
154
+
| None -> Alcotest.fail "Expected Authorization header"
155
+
156
+
(** {1 Connection Header Tests} *)
157
+
158
+
let test_connection_close () =
159
+
let h = Headers.of_list [ ("Connection", "close") ] in
160
+
Alcotest.(check bool) "connection_close" true (Headers.connection_close h)
161
+
162
+
let test_connection_close_false () =
163
+
let h = Headers.of_list [ ("Connection", "keep-alive") ] in
164
+
Alcotest.(check bool)
165
+
"not connection_close" false
166
+
(Headers.connection_close h)
167
+
168
+
let test_connection_keep_alive () =
169
+
let h = Headers.of_list [ ("Connection", "keep-alive") ] in
170
+
Alcotest.(check bool)
171
+
"connection_keep_alive" true
172
+
(Headers.connection_keep_alive h)
173
+
174
+
let test_parse_connection_header () =
175
+
let h = Headers.of_list [ ("Connection", "close, X-Custom") ] in
176
+
let names = Headers.parse_connection_header h in
177
+
Alcotest.(check bool) "has entries" true (List.length names > 0)
178
+
179
+
(** {1 HTTP/2 Pseudo-Header Tests} *)
180
+
181
+
let test_is_pseudo_header () =
182
+
Alcotest.(check bool)
183
+
":method is pseudo" true
184
+
(Headers.is_pseudo_header ":method");
185
+
Alcotest.(check bool)
186
+
"content-type not pseudo" false
187
+
(Headers.is_pseudo_header "content-type")
188
+
189
+
let test_set_get_pseudo () =
190
+
let h = Headers.empty |> Headers.set_pseudo "method" "GET" in
191
+
let v = Headers.pseudo "method" h in
192
+
Alcotest.(check (option string)) "get pseudo" (Some "GET") v
193
+
194
+
let test_pseudo_roundtrip () =
195
+
let h =
196
+
Headers.empty
197
+
|> Headers.set_pseudo "method" "GET"
198
+
|> Headers.set_pseudo "scheme" "https"
199
+
|> Headers.set_pseudo "path" "/"
200
+
in
201
+
Alcotest.(check bool) "has pseudo headers" true (Headers.has_pseudo_headers h);
202
+
let pseudos = Headers.pseudo_headers h in
203
+
Alcotest.(check int) "3 pseudo headers" 3 (List.length pseudos)
204
+
205
+
let test_remove_pseudo () =
206
+
let h =
207
+
Headers.empty
208
+
|> Headers.set_pseudo "method" "GET"
209
+
|> Headers.remove_pseudo "method"
210
+
in
211
+
Alcotest.(check bool) "removed pseudo" false (Headers.mem_pseudo "method" h)
212
+
213
+
let test_regular_headers_exclude_pseudo () =
214
+
let h =
215
+
Headers.empty
216
+
|> Headers.set_pseudo "method" "GET"
217
+
|> Headers.set `Content_type "text/html"
218
+
in
219
+
let regular = Headers.regular_headers h in
220
+
let has_pseudo =
221
+
List.exists
222
+
(fun (name, _) -> String.length name > 0 && name.[0] = ':')
223
+
regular
224
+
in
225
+
Alcotest.(check bool) "no pseudo in regular" false has_pseudo
226
+
227
+
(** {1 mem Tests} *)
228
+
229
+
let test_mem_present () =
230
+
let h = Headers.empty |> Headers.set `Content_type "text/html" in
231
+
Alcotest.(check bool) "mem present" true (Headers.mem `Content_type h)
232
+
233
+
let test_mem_absent () =
234
+
let h = Headers.empty in
235
+
Alcotest.(check bool) "mem absent" false (Headers.mem `Content_type h)
236
+
237
+
(** {1 Test Suite} *)
238
+
239
+
let suite =
240
+
( "headers",
241
+
[
242
+
Alcotest.test_case "no headers" `Quick test_empty_has_no_headers;
243
+
Alcotest.test_case "roundtrip" `Quick test_of_list_roundtrip;
244
+
Alcotest.test_case "preserves values" `Quick test_of_list_preserves_values;
245
+
Alcotest.test_case "add and get" `Quick test_add_and_get;
246
+
Alcotest.test_case "add multiple" `Quick test_add_multiple;
247
+
Alcotest.test_case "get missing" `Quick test_get_missing;
248
+
Alcotest.test_case "remove" `Quick test_remove;
249
+
Alcotest.test_case "replaces existing" `Quick test_set_replaces;
250
+
Alcotest.test_case "replaces all" `Quick test_set_replaces_all;
251
+
Alcotest.test_case "empty" `Quick test_get_all_empty;
252
+
Alcotest.test_case "multiple values" `Quick test_get_all_multiple;
253
+
Alcotest.test_case "combines" `Quick test_merge_combines;
254
+
Alcotest.test_case "override" `Quick test_merge_override;
255
+
Alcotest.test_case "content_type" `Quick test_content_type;
256
+
Alcotest.test_case "content_length" `Quick test_content_length;
257
+
Alcotest.test_case "host" `Quick test_host;
258
+
Alcotest.test_case "bearer" `Quick test_bearer;
259
+
Alcotest.test_case "basic" `Quick test_basic;
260
+
Alcotest.test_case "connection_close" `Quick test_connection_close;
261
+
Alcotest.test_case "connection_close false" `Quick
262
+
test_connection_close_false;
263
+
Alcotest.test_case "connection_keep_alive" `Quick
264
+
test_connection_keep_alive;
265
+
Alcotest.test_case "parse_connection_header" `Quick
266
+
test_parse_connection_header;
267
+
Alcotest.test_case "is_pseudo_header" `Quick test_is_pseudo_header;
268
+
Alcotest.test_case "set and get" `Quick test_set_get_pseudo;
269
+
Alcotest.test_case "roundtrip" `Quick test_pseudo_roundtrip;
270
+
Alcotest.test_case "remove" `Quick test_remove_pseudo;
271
+
Alcotest.test_case "regular excludes pseudo" `Quick
272
+
test_regular_headers_exclude_pseudo;
273
+
Alcotest.test_case "present" `Quick test_mem_present;
274
+
Alcotest.test_case "absent" `Quick test_mem_absent;
275
+
] )
+4
test/test_headers.mli
+4
test/test_headers.mli
+295
test/test_http_date.ml
+295
test/test_http_date.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Comprehensive tests for HTTP-date parsing per RFC 9110 Section 5.6.7 *)
7
+
8
+
let parse_http_date = Http.Response.parse_http_date
9
+
10
+
(** Alcotest testable for Ptime.t *)
11
+
module Alcotest_ptime = struct
12
+
let pp = Ptime.pp_rfc3339 ()
13
+
let equal = Ptime.equal
14
+
let testable = Alcotest.testable pp equal
15
+
end
16
+
17
+
(** Helper to create expected Ptime.t values *)
18
+
let time year month day hour min sec =
19
+
match Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)) with
20
+
| Some t -> t
21
+
| None ->
22
+
failwith
23
+
(Fmt.str "Invalid test time: %d-%02d-%02d %02d:%02d:%02d" year month day
24
+
hour min sec)
25
+
26
+
(** {1 RFC 1123 Format Tests} *)
27
+
28
+
let test_rfc1123_basic () =
29
+
(* RFC 9110 Section 5.6.7: preferred format "Sun, 06 Nov 1994 08:49:37 GMT" *)
30
+
let result = parse_http_date "Sun, 06 Nov 1994 08:49:37 GMT" in
31
+
let expected = Some (time 1994 11 6 8 49 37) in
32
+
Alcotest.(check (option Alcotest_ptime.testable))
33
+
"RFC 1123 basic parsing" expected result
34
+
35
+
let test_rfc1123_all_months () =
36
+
(* Test all month names *)
37
+
let months =
38
+
[
39
+
("Jan", 1);
40
+
("Feb", 2);
41
+
("Mar", 3);
42
+
("Apr", 4);
43
+
("May", 5);
44
+
("Jun", 6);
45
+
("Jul", 7);
46
+
("Aug", 8);
47
+
("Sep", 9);
48
+
("Oct", 10);
49
+
("Nov", 11);
50
+
("Dec", 12);
51
+
]
52
+
in
53
+
List.iter
54
+
(fun (month_str, month_num) ->
55
+
let date_str = Fmt.str "Mon, 01 %s 2020 00:00:00 GMT" month_str in
56
+
let result = parse_http_date date_str in
57
+
let expected = Some (time 2020 month_num 1 0 0 0) in
58
+
Alcotest.(check (option Alcotest_ptime.testable))
59
+
(Fmt.str "RFC 1123 month %s" month_str)
60
+
expected result)
61
+
months
62
+
63
+
let test_rfc1123_all_weekdays () =
64
+
(* Test all weekday names - the weekday is not validated, just skipped *)
65
+
let weekdays = [ "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" ] in
66
+
List.iter
67
+
(fun wday ->
68
+
let date_str = Fmt.str "%s, 06 Nov 1994 08:49:37 GMT" wday in
69
+
let result = parse_http_date date_str in
70
+
let expected = Some (time 1994 11 6 8 49 37) in
71
+
Alcotest.(check (option Alcotest_ptime.testable))
72
+
(Fmt.str "RFC 1123 weekday %s" wday)
73
+
expected result)
74
+
weekdays
75
+
76
+
let test_rfc1123_edge_dates () =
77
+
(* Test edge cases for dates *)
78
+
let test_cases =
79
+
[
80
+
("Thu, 01 Jan 1970 00:00:00 GMT", 1970, 1, 1, 0, 0, 0, "Unix epoch");
81
+
("Fri, 31 Dec 1999 23:59:59 GMT", 1999, 12, 31, 23, 59, 59, "Y2K eve");
82
+
("Sat, 01 Jan 2000 00:00:00 GMT", 2000, 1, 1, 0, 0, 0, "Y2K");
83
+
("Tue, 29 Feb 2000 12:00:00 GMT", 2000, 2, 29, 12, 0, 0, "Leap year");
84
+
("Fri, 13 Dec 2024 23:59:59 GMT", 2024, 12, 13, 23, 59, 59, "Near current");
85
+
]
86
+
in
87
+
List.iter
88
+
(fun (date_str, y, m, d, h, min, s, desc) ->
89
+
let result = parse_http_date date_str in
90
+
let expected = Some (time y m d h min s) in
91
+
Alcotest.(check (option Alcotest_ptime.testable))
92
+
(Fmt.str "RFC 1123 edge: %s" desc)
93
+
expected result)
94
+
test_cases
95
+
96
+
(** {1 RFC 850 Format Tests (Obsolete)} *)
97
+
98
+
let test_rfc850_basic () =
99
+
(* RFC 850 format: "Sunday, 06-Nov-94 08:49:37 GMT" *)
100
+
let result = parse_http_date "Sunday, 06-Nov-94 08:49:37 GMT" in
101
+
let expected = Some (time 1994 11 6 8 49 37) in
102
+
Alcotest.(check (option Alcotest_ptime.testable))
103
+
"RFC 850 basic parsing (2-digit year)" expected result
104
+
105
+
let test_rfc850_year_interpretation () =
106
+
(* Test Y2K two-digit year interpretation: 70-99 -> 1970-1999, 00-69 -> 2000-2069 *)
107
+
let test_cases =
108
+
[
109
+
("Monday, 01-Jan-70 00:00:00 GMT", 1970, "Year 70 -> 1970");
110
+
("Tuesday, 01-Jan-99 00:00:00 GMT", 1999, "Year 99 -> 1999");
111
+
("Saturday, 01-Jan-00 00:00:00 GMT", 2000, "Year 00 -> 2000");
112
+
("Sunday, 01-Jan-25 00:00:00 GMT", 2025, "Year 25 -> 2025");
113
+
("Thursday, 01-Jan-69 00:00:00 GMT", 2069, "Year 69 -> 2069");
114
+
]
115
+
in
116
+
List.iter
117
+
(fun (date_str, expected_year, desc) ->
118
+
let result = parse_http_date date_str in
119
+
let expected = Some (time expected_year 1 1 0 0 0) in
120
+
Alcotest.(check (option Alcotest_ptime.testable))
121
+
(Fmt.str "RFC 850 %s" desc)
122
+
expected result)
123
+
test_cases
124
+
125
+
(** {1 ANSI C asctime() Format Tests (Obsolete)} *)
126
+
127
+
let test_asctime_basic () =
128
+
(* asctime() format: "Sun Nov 6 08:49:37 1994" *)
129
+
let result = parse_http_date "Sun Nov 6 08:49:37 1994" in
130
+
let expected = Some (time 1994 11 6 8 49 37) in
131
+
Alcotest.(check (option Alcotest_ptime.testable))
132
+
"asctime basic parsing" expected result
133
+
134
+
let test_asctime_single_digit_day () =
135
+
(* asctime has space-padded day for single digits *)
136
+
let test_cases =
137
+
[
138
+
("Sun Nov 1 08:49:37 1994", 1, "Day 1");
139
+
("Sun Nov 9 08:49:37 1994", 9, "Day 9");
140
+
]
141
+
in
142
+
List.iter
143
+
(fun (date_str, day, desc) ->
144
+
let result = parse_http_date date_str in
145
+
let expected = Some (time 1994 11 day 8 49 37) in
146
+
Alcotest.(check (option Alcotest_ptime.testable))
147
+
(Fmt.str "asctime %s" desc)
148
+
expected result)
149
+
test_cases
150
+
151
+
(** {1 Invalid Input Tests} *)
152
+
153
+
let test_invalid_completely_wrong () =
154
+
(* Completely invalid strings *)
155
+
let invalid_inputs =
156
+
[
157
+
"";
158
+
"not a date";
159
+
"2024-12-13";
160
+
(* ISO 8601 not supported *)
161
+
"12/13/2024";
162
+
(* US format not supported *)
163
+
"13-Dec-2024";
164
+
(* No day name *)
165
+
]
166
+
in
167
+
List.iter
168
+
(fun input ->
169
+
let result = parse_http_date input in
170
+
Alcotest.(check (option Alcotest_ptime.testable))
171
+
(Fmt.str "Invalid input: %S" input)
172
+
None result)
173
+
invalid_inputs
174
+
175
+
let test_invalid_month_names () =
176
+
(* Invalid month names *)
177
+
let invalid_months =
178
+
[
179
+
"Sun, 06 Foo 1994 08:49:37 GMT";
180
+
"Sun, 06 13 1994 08:49:37 GMT";
181
+
(* Numeric month *)
182
+
"Sun, 06 November 1994 08:49:37 GMT";
183
+
(* Full month name *)
184
+
]
185
+
in
186
+
List.iter
187
+
(fun input ->
188
+
let result = parse_http_date input in
189
+
Alcotest.(check (option Alcotest_ptime.testable))
190
+
(Fmt.str "Invalid month: %S" input)
191
+
None result)
192
+
invalid_months
193
+
194
+
let test_invalid_dates () =
195
+
(* Dates that are syntactically correct but semantically invalid *)
196
+
let invalid_dates =
197
+
[
198
+
"Sun, 32 Jan 2020 00:00:00 GMT";
199
+
(* Day 32 *)
200
+
"Sun, 00 Jan 2020 00:00:00 GMT";
201
+
(* Day 0 *)
202
+
"Sun, 29 Feb 2021 00:00:00 GMT";
203
+
(* Feb 29 in non-leap year *)
204
+
"Sun, 31 Apr 2020 00:00:00 GMT";
205
+
(* April has 30 days *)
206
+
]
207
+
in
208
+
List.iter
209
+
(fun input ->
210
+
let result = parse_http_date input in
211
+
Alcotest.(check (option Alcotest_ptime.testable))
212
+
(Fmt.str "Invalid date: %S" input)
213
+
None result)
214
+
invalid_dates
215
+
216
+
let test_invalid_times () =
217
+
(* Invalid time components *)
218
+
let invalid_times =
219
+
[
220
+
"Sun, 06 Nov 1994 25:00:00 GMT";
221
+
(* Hour 25 *)
222
+
"Sun, 06 Nov 1994 00:60:00 GMT";
223
+
(* Minute 60 *)
224
+
"Sun, 06 Nov 1994 00:00:60 GMT";
225
+
(* Second 60 — RFC 9110 recipients SHOULD treat as invalid *)
226
+
]
227
+
in
228
+
List.iter
229
+
(fun input ->
230
+
let result = parse_http_date input in
231
+
Alcotest.(check (option Alcotest_ptime.testable))
232
+
(Fmt.str "Invalid time: %S" input)
233
+
None result)
234
+
invalid_times
235
+
236
+
(** {1 Whitespace and Case Tests} *)
237
+
238
+
let test_trimming_whitespace () =
239
+
(* Should handle leading/trailing whitespace *)
240
+
let test_cases =
241
+
[
242
+
" Sun, 06 Nov 1994 08:49:37 GMT ";
243
+
"\tSun, 06 Nov 1994 08:49:37 GMT\t";
244
+
"\n Sun, 06 Nov 1994 08:49:37 GMT \n";
245
+
]
246
+
in
247
+
let expected = Some (time 1994 11 6 8 49 37) in
248
+
List.iter
249
+
(fun input ->
250
+
let result = parse_http_date input in
251
+
Alcotest.(check (option Alcotest_ptime.testable))
252
+
"Whitespace trimming" expected result)
253
+
test_cases
254
+
255
+
let test_case_insensitive_months () =
256
+
(* Month names should be case-insensitive *)
257
+
let test_cases =
258
+
[
259
+
("Sun, 06 nov 1994 08:49:37 GMT", "lowercase");
260
+
("Sun, 06 NOV 1994 08:49:37 GMT", "uppercase");
261
+
("Sun, 06 NoV 1994 08:49:37 GMT", "mixed case");
262
+
]
263
+
in
264
+
let expected = Some (time 1994 11 6 8 49 37) in
265
+
List.iter
266
+
(fun (input, desc) ->
267
+
let result = parse_http_date input in
268
+
Alcotest.(check (option Alcotest_ptime.testable))
269
+
(Fmt.str "Case insensitive: %s" desc)
270
+
expected result)
271
+
test_cases
272
+
273
+
(** {1 Test Suite} *)
274
+
275
+
let suite =
276
+
( "http_date",
277
+
[
278
+
Alcotest.test_case "basic parsing" `Quick test_rfc1123_basic;
279
+
Alcotest.test_case "all months" `Quick test_rfc1123_all_months;
280
+
Alcotest.test_case "all weekdays" `Quick test_rfc1123_all_weekdays;
281
+
Alcotest.test_case "edge dates" `Quick test_rfc1123_edge_dates;
282
+
Alcotest.test_case "basic parsing" `Quick test_rfc850_basic;
283
+
Alcotest.test_case "Y2K year interpretation" `Quick
284
+
test_rfc850_year_interpretation;
285
+
Alcotest.test_case "basic parsing" `Quick test_asctime_basic;
286
+
Alcotest.test_case "single digit day" `Quick test_asctime_single_digit_day;
287
+
Alcotest.test_case "completely wrong format" `Quick
288
+
test_invalid_completely_wrong;
289
+
Alcotest.test_case "invalid month names" `Quick test_invalid_month_names;
290
+
Alcotest.test_case "invalid dates" `Quick test_invalid_dates;
291
+
Alcotest.test_case "invalid times" `Quick test_invalid_times;
292
+
Alcotest.test_case "trimming whitespace" `Quick test_trimming_whitespace;
293
+
Alcotest.test_case "case insensitive months" `Quick
294
+
test_case_insensitive_months;
295
+
] )
+4
test/test_http_date.mli
+4
test/test_http_date.mli
+194
test/test_http_version.ml
+194
test/test_http_version.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Http_version module *)
7
+
8
+
module Http_version = Http.Http_version
9
+
10
+
(** {1 to_string Tests} *)
11
+
12
+
let test_to_string_http10 () =
13
+
let s = Http_version.to_string Http_version.Http_1_0 in
14
+
Alcotest.(check string) "HTTP/1.0" "HTTP/1.0" s
15
+
16
+
let test_to_string_http11 () =
17
+
let s = Http_version.to_string Http_version.Http_1_1 in
18
+
Alcotest.(check string) "HTTP/1.1" "HTTP/1.1" s
19
+
20
+
let test_to_string_http_2 () =
21
+
let s = Http_version.to_string Http_version.Http_2 in
22
+
Alcotest.(check string) "HTTP/2" "HTTP/2" s
23
+
24
+
(** {1 equal Tests} *)
25
+
26
+
let test_equal_same () =
27
+
Alcotest.(check bool)
28
+
"equal same" true
29
+
(Http_version.equal Http_version.Http_1_1 Http_version.Http_1_1)
30
+
31
+
let test_equal_different () =
32
+
Alcotest.(check bool)
33
+
"equal different" false
34
+
(Http_version.equal Http_version.Http_1_1 Http_version.Http_2)
35
+
36
+
let test_equal_http_versions () =
37
+
Alcotest.(check bool)
38
+
"1.0 != 1.1" false
39
+
(Http_version.equal Http_version.Http_1_0 Http_version.Http_1_1)
40
+
41
+
(** {1 compare Tests} *)
42
+
43
+
let test_compare_order () =
44
+
Alcotest.(check bool)
45
+
"1.0 < 1.1" true
46
+
(Http_version.compare Http_version.Http_1_0 Http_version.Http_1_1 < 0);
47
+
Alcotest.(check bool)
48
+
"1.1 < 2" true
49
+
(Http_version.compare Http_version.Http_1_1 Http_version.Http_2 < 0);
50
+
Alcotest.(check bool)
51
+
"2 > 1.0" true
52
+
(Http_version.compare Http_version.Http_2 Http_version.Http_1_0 > 0)
53
+
54
+
(** {1 supports_multiplexing Tests} *)
55
+
56
+
let test_multiplexing_http2 () =
57
+
Alcotest.(check bool)
58
+
"HTTP/2 supports multiplexing" true
59
+
(Http_version.supports_multiplexing Http_version.Http_2)
60
+
61
+
let test_multiplexing_http11 () =
62
+
Alcotest.(check bool)
63
+
"HTTP/1.1 no multiplexing" false
64
+
(Http_version.supports_multiplexing Http_version.Http_1_1)
65
+
66
+
let test_multiplexing_http10 () =
67
+
Alcotest.(check bool)
68
+
"HTTP/1.0 no multiplexing" false
69
+
(Http_version.supports_multiplexing Http_version.Http_1_0)
70
+
71
+
(** {1 supports_header_compression Tests} *)
72
+
73
+
let test_header_compression_http2 () =
74
+
Alcotest.(check bool)
75
+
"HTTP/2 supports header compression" true
76
+
(Http_version.supports_header_compression Http_version.Http_2)
77
+
78
+
let test_header_compression_http11 () =
79
+
Alcotest.(check bool)
80
+
"HTTP/1.1 no header compression" false
81
+
(Http_version.supports_header_compression Http_version.Http_1_1)
82
+
83
+
let test_header_compression_http10 () =
84
+
Alcotest.(check bool)
85
+
"HTTP/1.0 no header compression" false
86
+
(Http_version.supports_header_compression Http_version.Http_1_0)
87
+
88
+
(** {1 supports_server_push Tests} *)
89
+
90
+
let test_server_push_http2 () =
91
+
Alcotest.(check bool)
92
+
"HTTP/2 supports server push" true
93
+
(Http_version.supports_server_push Http_version.Http_2)
94
+
95
+
let test_server_push_http11 () =
96
+
Alcotest.(check bool)
97
+
"HTTP/1.1 no server push" false
98
+
(Http_version.supports_server_push Http_version.Http_1_1)
99
+
100
+
(** {1 ALPN Tests} *)
101
+
102
+
let test_alpn_of_version_h2 () =
103
+
let alpn = Http_version.alpn_of_version Http_version.Http_2 in
104
+
Alcotest.(check (option string)) "HTTP/2 ALPN" (Some "h2") alpn
105
+
106
+
let test_alpn_of_version_http11 () =
107
+
let alpn = Http_version.alpn_of_version Http_version.Http_1_1 in
108
+
Alcotest.(check (option string)) "HTTP/1.1 ALPN" (Some "http/1.1") alpn
109
+
110
+
let test_alpn_of_version_http10 () =
111
+
let alpn = Http_version.alpn_of_version Http_version.Http_1_0 in
112
+
Alcotest.(check (option string)) "HTTP/1.0 no ALPN" None alpn
113
+
114
+
let test_version_of_alpn_h2 () =
115
+
let v = Http_version.version_of_alpn "h2" in
116
+
match v with
117
+
| Some Http_version.Http_2 -> Alcotest.(check pass) "h2 -> Http_2" () ()
118
+
| _ -> Alcotest.fail "Expected Some Http_2"
119
+
120
+
let test_version_of_alpn_http11 () =
121
+
let v = Http_version.version_of_alpn "http/1.1" in
122
+
match v with
123
+
| Some Http_version.Http_1_1 ->
124
+
Alcotest.(check pass) "http/1.1 -> Http_1_1" () ()
125
+
| _ -> Alcotest.fail "Expected Some Http_1_1"
126
+
127
+
let test_version_of_alpn_unknown () =
128
+
let v = Http_version.version_of_alpn "unknown" in
129
+
Alcotest.(check bool) "unknown ALPN" true (Option.is_none v)
130
+
131
+
let test_alpn_protocols_preferred () =
132
+
let protocols =
133
+
Http_version.alpn_protocols
134
+
~preferred:[ Http_version.Http_2; Http_version.Http_1_1 ]
135
+
in
136
+
Alcotest.(check (list string))
137
+
"preferred order" [ "h2"; "http/1.1" ] protocols
138
+
139
+
let test_alpn_protocols_single () =
140
+
let protocols =
141
+
Http_version.alpn_protocols ~preferred:[ Http_version.Http_1_1 ]
142
+
in
143
+
Alcotest.(check (list string)) "single" [ "http/1.1" ] protocols
144
+
145
+
let test_alpn_filters_http10 () =
146
+
let protocols =
147
+
Http_version.alpn_protocols
148
+
~preferred:
149
+
[ Http_version.Http_2; Http_version.Http_1_1; Http_version.Http_1_0 ]
150
+
in
151
+
Alcotest.(check (list string)) "filters 1.0" [ "h2"; "http/1.1" ] protocols
152
+
153
+
(** {1 ALPN Constants Tests} *)
154
+
155
+
let test_alpn_h2_constant () =
156
+
Alcotest.(check string) "alpn_h2" "h2" Http_version.alpn_h2
157
+
158
+
let test_alpn_http11_constant () =
159
+
Alcotest.(check string) "alpn_http_1_1" "http/1.1" Http_version.alpn_http_1_1
160
+
161
+
(** {1 Test Suite} *)
162
+
163
+
let suite =
164
+
( "http_version",
165
+
[
166
+
Alcotest.test_case "HTTP/1.0" `Quick test_to_string_http10;
167
+
Alcotest.test_case "HTTP/1.1" `Quick test_to_string_http11;
168
+
Alcotest.test_case "HTTP/2" `Quick test_to_string_http_2;
169
+
Alcotest.test_case "same" `Quick test_equal_same;
170
+
Alcotest.test_case "different" `Quick test_equal_different;
171
+
Alcotest.test_case "1.0 vs 1.1" `Quick test_equal_http_versions;
172
+
Alcotest.test_case "ordering" `Quick test_compare_order;
173
+
Alcotest.test_case "HTTP/2" `Quick test_multiplexing_http2;
174
+
Alcotest.test_case "HTTP/1.1" `Quick test_multiplexing_http11;
175
+
Alcotest.test_case "HTTP/1.0" `Quick test_multiplexing_http10;
176
+
Alcotest.test_case "HTTP/2" `Quick test_header_compression_http2;
177
+
Alcotest.test_case "HTTP/1.1" `Quick test_header_compression_http11;
178
+
Alcotest.test_case "HTTP/1.0" `Quick test_header_compression_http10;
179
+
Alcotest.test_case "HTTP/2" `Quick test_server_push_http2;
180
+
Alcotest.test_case "HTTP/1.1" `Quick test_server_push_http11;
181
+
Alcotest.test_case "HTTP/2 -> h2" `Quick test_alpn_of_version_h2;
182
+
Alcotest.test_case "HTTP/1.1 -> http/1.1" `Quick
183
+
test_alpn_of_version_http11;
184
+
Alcotest.test_case "HTTP/1.0 -> None" `Quick test_alpn_of_version_http10;
185
+
Alcotest.test_case "h2 -> HTTP/2" `Quick test_version_of_alpn_h2;
186
+
Alcotest.test_case "http/1.1 -> HTTP/1.1" `Quick
187
+
test_version_of_alpn_http11;
188
+
Alcotest.test_case "unknown -> None" `Quick test_version_of_alpn_unknown;
189
+
Alcotest.test_case "preferred order" `Quick test_alpn_protocols_preferred;
190
+
Alcotest.test_case "single" `Quick test_alpn_protocols_single;
191
+
Alcotest.test_case "filters HTTP/1.0" `Quick test_alpn_filters_http10;
192
+
Alcotest.test_case "h2" `Quick test_alpn_h2_constant;
193
+
Alcotest.test_case "http/1.1" `Quick test_alpn_http11_constant;
194
+
] )
+4
test/test_http_version.mli
+4
test/test_http_version.mli
+82
test/test_huri.ml
+82
test/test_huri.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Huri module - URI JSON codec *)
7
+
8
+
module Huri = Http.Huri
9
+
10
+
(** {1 JSON Codec Tests} *)
11
+
12
+
let test_jsont_roundtrip_simple () =
13
+
let uri = Uri.of_string "https://example.com" in
14
+
let encoded =
15
+
Jsont_bytesrw.encode_string' ~format:Jsont.Minify Huri.jsont uri
16
+
in
17
+
match encoded with
18
+
| Ok json_str -> (
19
+
let decoded = Jsont_bytesrw.decode_string' Huri.jsont json_str in
20
+
match decoded with
21
+
| Ok uri' ->
22
+
Alcotest.(check string)
23
+
"roundtrip" (Uri.to_string uri) (Uri.to_string uri')
24
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e))
25
+
| Error e -> Alcotest.failf "encode failed: %s" (Jsont.Error.to_string e)
26
+
27
+
let test_jsont_roundtrip_complex () =
28
+
let uri = Uri.of_string "http://user:pass@host:8080/path?q=1#frag" in
29
+
let encoded =
30
+
Jsont_bytesrw.encode_string' ~format:Jsont.Minify Huri.jsont uri
31
+
in
32
+
match encoded with
33
+
| Ok json_str -> (
34
+
let decoded = Jsont_bytesrw.decode_string' Huri.jsont json_str in
35
+
match decoded with
36
+
| Ok uri' ->
37
+
Alcotest.(check string)
38
+
"roundtrip complex" (Uri.to_string uri) (Uri.to_string uri')
39
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e))
40
+
| Error e -> Alcotest.failf "encode failed: %s" (Jsont.Error.to_string e)
41
+
42
+
let test_jsont_encodes_as_string () =
43
+
let uri = Uri.of_string "https://example.com" in
44
+
let encoded =
45
+
Jsont_bytesrw.encode_string' ~format:Jsont.Minify Huri.jsont uri
46
+
in
47
+
match encoded with
48
+
| Ok json_str ->
49
+
(* JSON string should be quoted *)
50
+
Alcotest.(check bool)
51
+
"starts with quote" true
52
+
(String.length json_str > 0 && json_str.[0] = '"');
53
+
Alcotest.(check bool)
54
+
"ends with quote" true
55
+
(String.length json_str > 0
56
+
&& json_str.[String.length json_str - 1] = '"')
57
+
| Error e -> Alcotest.failf "encode failed: %s" (Jsont.Error.to_string e)
58
+
59
+
let test_jsont_decode_from_string () =
60
+
let json_str = "\"https://example.com/test\"" in
61
+
let decoded = Jsont_bytesrw.decode_string' Huri.jsont json_str in
62
+
match decoded with
63
+
| Ok uri ->
64
+
Alcotest.(check string) "scheme" "https" (Option.get (Uri.scheme uri));
65
+
Alcotest.(check string) "host" "example.com" (Option.get (Uri.host uri));
66
+
Alcotest.(check string) "path" "/test" (Uri.path uri)
67
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
68
+
69
+
(** {1 Test Suite} *)
70
+
71
+
let suite =
72
+
( "huri",
73
+
[
74
+
Alcotest.test_case "roundtrip simple URI" `Quick
75
+
test_jsont_roundtrip_simple;
76
+
Alcotest.test_case "roundtrip complex URI" `Quick
77
+
test_jsont_roundtrip_complex;
78
+
Alcotest.test_case "encodes as JSON string" `Quick
79
+
test_jsont_encodes_as_string;
80
+
Alcotest.test_case "decode from JSON string" `Quick
81
+
test_jsont_decode_from_string;
82
+
] )
+4
test/test_huri.mli
+4
test/test_huri.mli
+164
test/test_method.ml
+164
test/test_method.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Method module - HTTP methods per RFC 9110 Section 9 *)
7
+
8
+
module Method = Http.Method
9
+
10
+
(** {1 Conversion Tests} *)
11
+
12
+
let standard_methods =
13
+
[
14
+
(`GET, "GET");
15
+
(`POST, "POST");
16
+
(`PUT, "PUT");
17
+
(`DELETE, "DELETE");
18
+
(`HEAD, "HEAD");
19
+
(`OPTIONS, "OPTIONS");
20
+
(`PATCH, "PATCH");
21
+
(`CONNECT, "CONNECT");
22
+
(`TRACE, "TRACE");
23
+
]
24
+
25
+
let test_to_string_roundtrip () =
26
+
List.iter
27
+
(fun (method_, expected_str) ->
28
+
let str = Method.to_string method_ in
29
+
Alcotest.(check string)
30
+
(Fmt.str "to_string %s" expected_str)
31
+
expected_str str;
32
+
let method_' = Method.of_string str in
33
+
Alcotest.(check bool)
34
+
(Fmt.str "roundtrip %s" expected_str)
35
+
true
36
+
(Method.equal method_ method_'))
37
+
standard_methods
38
+
39
+
let test_of_string_case_insensitive () =
40
+
let got = Method.of_string "get" in
41
+
Alcotest.(check bool) "get -> GET" true (Method.equal `GET got);
42
+
let got2 = Method.of_string "Post" in
43
+
Alcotest.(check bool) "Post -> POST" true (Method.equal `POST got2);
44
+
let got3 = Method.of_string "dElEtE" in
45
+
Alcotest.(check bool) "dElEtE -> DELETE" true (Method.equal `DELETE got3)
46
+
47
+
let test_custom_method () =
48
+
let custom = `Other "CUSTOM" in
49
+
let str = Method.to_string custom in
50
+
Alcotest.(check string) "custom to_string" "CUSTOM" str;
51
+
let parsed = Method.of_string "CUSTOM" in
52
+
Alcotest.(check bool) "custom roundtrip" true (Method.equal custom parsed)
53
+
54
+
(** {1 Safe Methods (RFC 9110 Section 9.2.1)} *)
55
+
56
+
let test_is_safe () =
57
+
let safe_methods = [ `GET; `HEAD; `OPTIONS; `TRACE ] in
58
+
let unsafe_methods = [ `POST; `PUT; `DELETE; `PATCH; `CONNECT ] in
59
+
List.iter
60
+
(fun m ->
61
+
Alcotest.(check bool)
62
+
(Fmt.str "%s is safe" (Method.to_string m))
63
+
true (Method.is_safe m))
64
+
safe_methods;
65
+
List.iter
66
+
(fun m ->
67
+
Alcotest.(check bool)
68
+
(Fmt.str "%s is not safe" (Method.to_string m))
69
+
false (Method.is_safe m))
70
+
unsafe_methods
71
+
72
+
(** {1 Idempotent Methods (RFC 9110 Section 9.2.2)} *)
73
+
74
+
let test_is_idempotent () =
75
+
let idempotent = [ `GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE ] in
76
+
let not_idempotent = [ `POST; `PATCH ] in
77
+
List.iter
78
+
(fun m ->
79
+
Alcotest.(check bool)
80
+
(Fmt.str "%s is idempotent" (Method.to_string m))
81
+
true (Method.is_idempotent m))
82
+
idempotent;
83
+
List.iter
84
+
(fun m ->
85
+
Alcotest.(check bool)
86
+
(Fmt.str "%s is not idempotent" (Method.to_string m))
87
+
false (Method.is_idempotent m))
88
+
not_idempotent
89
+
90
+
(** {1 Cacheable Methods (RFC 9110 Section 9.2.3)} *)
91
+
92
+
let test_is_cacheable () =
93
+
let cacheable = [ `GET; `HEAD; `POST ] in
94
+
let not_cacheable = [ `PUT; `DELETE; `PATCH; `OPTIONS; `TRACE; `CONNECT ] in
95
+
List.iter
96
+
(fun m ->
97
+
Alcotest.(check bool)
98
+
(Fmt.str "%s is cacheable" (Method.to_string m))
99
+
true (Method.is_cacheable m))
100
+
cacheable;
101
+
List.iter
102
+
(fun m ->
103
+
Alcotest.(check bool)
104
+
(Fmt.str "%s is not cacheable" (Method.to_string m))
105
+
false (Method.is_cacheable m))
106
+
not_cacheable
107
+
108
+
(** {1 Request Body Semantics (RFC 9110 Section 9.3)} *)
109
+
110
+
let test_request_body_semantics () =
111
+
(* Body required *)
112
+
List.iter
113
+
(fun m ->
114
+
Alcotest.(check bool)
115
+
(Fmt.str "%s body required" (Method.to_string m))
116
+
true
117
+
(Method.request_body_semantics m = Method.Body_required))
118
+
[ `POST; `PUT; `PATCH ];
119
+
(* Body forbidden *)
120
+
List.iter
121
+
(fun m ->
122
+
Alcotest.(check bool)
123
+
(Fmt.str "%s body forbidden" (Method.to_string m))
124
+
true
125
+
(Method.request_body_semantics m = Method.Body_forbidden))
126
+
[ `HEAD; `TRACE; `CONNECT ];
127
+
(* Body optional *)
128
+
List.iter
129
+
(fun m ->
130
+
Alcotest.(check bool)
131
+
(Fmt.str "%s body optional" (Method.to_string m))
132
+
true
133
+
(Method.request_body_semantics m = Method.Body_optional))
134
+
[ `GET; `DELETE; `OPTIONS ]
135
+
136
+
(** {1 Equality} *)
137
+
138
+
let test_equal () =
139
+
Alcotest.(check bool) "GET = GET" true (Method.equal `GET `GET);
140
+
Alcotest.(check bool) "GET <> POST" false (Method.equal `GET `POST);
141
+
Alcotest.(check bool)
142
+
"Other = Other" true
143
+
(Method.equal (`Other "X") (`Other "X"));
144
+
Alcotest.(check bool)
145
+
"Other <> Other" false
146
+
(Method.equal (`Other "X") (`Other "Y"))
147
+
148
+
(** {1 Test Suite} *)
149
+
150
+
let suite =
151
+
( "method",
152
+
[
153
+
Alcotest.test_case "to_string/of_string roundtrip" `Quick
154
+
test_to_string_roundtrip;
155
+
Alcotest.test_case "of_string case insensitive" `Quick
156
+
test_of_string_case_insensitive;
157
+
Alcotest.test_case "custom method" `Quick test_custom_method;
158
+
Alcotest.test_case "safe methods (9.2.1)" `Quick test_is_safe;
159
+
Alcotest.test_case "idempotent methods (9.2.2)" `Quick test_is_idempotent;
160
+
Alcotest.test_case "cacheable methods (9.2.3)" `Quick test_is_cacheable;
161
+
Alcotest.test_case "request body semantics (9.3)" `Quick
162
+
test_request_body_semantics;
163
+
Alcotest.test_case "equal" `Quick test_equal;
164
+
] )
+4
test/test_method.mli
+4
test/test_method.mli
+127
test/test_mime.ml
+127
test/test_mime.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Mime module - MIME type handling per RFC 6838 *)
7
+
8
+
module Mime = Http.Mime
9
+
10
+
(** {1 Well-Known MIME Types} *)
11
+
12
+
let test_json () =
13
+
Alcotest.(check string) "json" "application/json" (Mime.to_string Mime.json)
14
+
15
+
let test_text () =
16
+
Alcotest.(check string) "text" "text/plain" (Mime.to_string Mime.text)
17
+
18
+
let test_html () =
19
+
Alcotest.(check string) "html" "text/html" (Mime.to_string Mime.html)
20
+
21
+
let test_form () =
22
+
Alcotest.(check string)
23
+
"form" "application/x-www-form-urlencoded" (Mime.to_string Mime.form)
24
+
25
+
let test_octet_stream () =
26
+
Alcotest.(check string)
27
+
"octet_stream" "application/octet-stream"
28
+
(Mime.to_string Mime.octet_stream)
29
+
30
+
(** {1 Parsing} *)
31
+
32
+
let test_of_string_with_charset () =
33
+
let mime = Mime.of_string "text/html; charset=utf-8" in
34
+
let str = Mime.to_string mime in
35
+
(* Should preserve the type/subtype *)
36
+
Alcotest.(check bool)
37
+
"contains text/html" true
38
+
(String.length str >= 9
39
+
&& String.sub (String.lowercase_ascii str) 0 9 = "text/html");
40
+
(* Should have charset *)
41
+
let cs = Mime.charset mime in
42
+
Alcotest.(check bool) "has charset" true (Option.is_some cs)
43
+
44
+
let test_of_string_simple () =
45
+
let mime = Mime.of_string "application/json" in
46
+
Alcotest.(check string) "roundtrip" "application/json" (Mime.to_string mime)
47
+
48
+
let test_to_string_canonical () =
49
+
let mime = Mime.of_string "text/plain" in
50
+
Alcotest.(check string) "canonical" "text/plain" (Mime.to_string mime)
51
+
52
+
(** {1 Charset} *)
53
+
54
+
let test_charset_extract () =
55
+
let mime = Mime.of_string "text/html; charset=utf-8" in
56
+
match Mime.charset mime with
57
+
| Some cs ->
58
+
Alcotest.(check string) "charset" "utf-8" (String.lowercase_ascii cs)
59
+
| None -> Alcotest.fail "Expected charset"
60
+
61
+
let test_charset_absent () =
62
+
let mime = Mime.of_string "application/json" in
63
+
Alcotest.(check bool) "no charset" true (Option.is_none (Mime.charset mime))
64
+
65
+
let test_with_charset () =
66
+
let mime = Mime.with_charset "utf-8" Mime.html in
67
+
let cs = Mime.charset mime in
68
+
Alcotest.(check bool)
69
+
"has charset after with_charset" true (Option.is_some cs);
70
+
let str = Mime.to_string mime in
71
+
Alcotest.(check bool)
72
+
"contains charset" true
73
+
(let s = String.lowercase_ascii str in
74
+
let check sub =
75
+
try
76
+
let _ = String.index s (String.get sub 0) in
77
+
true
78
+
with Not_found -> false
79
+
in
80
+
check "charset")
81
+
82
+
(** {1 Construction} *)
83
+
84
+
let test_make () =
85
+
let mime = Mime.v "application" "pdf" in
86
+
Alcotest.(check string)
87
+
"make application/pdf" "application/pdf" (Mime.to_string mime)
88
+
89
+
let test_with_param () =
90
+
let mime = Mime.with_param "boundary" "----abc" Mime.multipart_form in
91
+
let str = Mime.to_string mime in
92
+
Alcotest.(check bool)
93
+
"contains boundary" true
94
+
(let s = String.lowercase_ascii str in
95
+
try
96
+
let _ =
97
+
(* Search for "boundary" substring *)
98
+
let rec find i =
99
+
if i + 8 > String.length s then raise Not_found
100
+
else if String.sub s i 8 = "boundary" then i
101
+
else find (i + 1)
102
+
in
103
+
find 0
104
+
in
105
+
true
106
+
with Not_found -> false)
107
+
108
+
(** {1 Test Suite} *)
109
+
110
+
let suite =
111
+
( "mime",
112
+
[
113
+
Alcotest.test_case "json" `Quick test_json;
114
+
Alcotest.test_case "text" `Quick test_text;
115
+
Alcotest.test_case "html" `Quick test_html;
116
+
Alcotest.test_case "form" `Quick test_form;
117
+
Alcotest.test_case "octet_stream" `Quick test_octet_stream;
118
+
Alcotest.test_case "of_string with charset" `Quick
119
+
test_of_string_with_charset;
120
+
Alcotest.test_case "of_string simple" `Quick test_of_string_simple;
121
+
Alcotest.test_case "to_string canonical" `Quick test_to_string_canonical;
122
+
Alcotest.test_case "extract charset" `Quick test_charset_extract;
123
+
Alcotest.test_case "absent charset" `Quick test_charset_absent;
124
+
Alcotest.test_case "with_charset" `Quick test_with_charset;
125
+
Alcotest.test_case "make" `Quick test_make;
126
+
Alcotest.test_case "with_param" `Quick test_with_param;
127
+
] )
+4
test/test_mime.mli
+4
test/test_mime.mli
+410
test/test_response.ml
+410
test/test_response.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Response module *)
7
+
8
+
module Response = Http.Response
9
+
module Headers = Http.Headers
10
+
module Error = Http.Error
11
+
12
+
(** Helper: create a response inside an Eio switch *)
13
+
let response ~sw ?(status = 200) ?(headers = []) ?(body = "")
14
+
?(url = "https://example.com") ?(elapsed = 0.1) () =
15
+
let hdrs = Headers.of_list headers in
16
+
let flow = Eio.Flow.string_source body in
17
+
Response.Private.make ~sw ~status ~headers:hdrs ~body:flow ~url ~elapsed
18
+
19
+
(** Helper: run a test inside Eio_main.run + Eio.Switch.run *)
20
+
let with_eio f =
21
+
Eio_main.run @@ fun _env ->
22
+
Eio.Switch.run @@ fun sw -> f sw
23
+
24
+
(** {1 Status Tests} *)
25
+
26
+
let test_status_200 () =
27
+
with_eio @@ fun sw ->
28
+
let r = response ~sw ~status:200 () in
29
+
Alcotest.(check int) "status_code 200" 200 (Response.status_code r)
30
+
31
+
let test_status_404 () =
32
+
with_eio @@ fun sw ->
33
+
let r = response ~sw ~status:404 () in
34
+
Alcotest.(check int) "status_code 404" 404 (Response.status_code r)
35
+
36
+
let test_ok_true () =
37
+
with_eio @@ fun sw ->
38
+
let r = response ~sw ~status:200 () in
39
+
Alcotest.(check bool) "200 is ok" true (Response.ok r)
40
+
41
+
let test_ok_false_4xx () =
42
+
with_eio @@ fun sw ->
43
+
let r = response ~sw ~status:404 () in
44
+
Alcotest.(check bool) "404 is not ok" false (Response.ok r)
45
+
46
+
let test_ok_false_5xx () =
47
+
with_eio @@ fun sw ->
48
+
let r = response ~sw ~status:500 () in
49
+
Alcotest.(check bool) "500 is not ok" false (Response.ok r)
50
+
51
+
let test_ok_true_201 () =
52
+
with_eio @@ fun sw ->
53
+
let r = response ~sw ~status:201 () in
54
+
Alcotest.(check bool) "201 is ok" true (Response.ok r)
55
+
56
+
(** {1 Header Extraction Tests} *)
57
+
58
+
let test_content_type () =
59
+
with_eio @@ fun sw ->
60
+
let r = response ~sw ~headers:[ ("content-type", "application/json") ] () in
61
+
match Response.content_type r with
62
+
| Some mime ->
63
+
Alcotest.(check string)
64
+
"content type" "application/json" (Http.Mime.to_string mime)
65
+
| None -> Alcotest.fail "Expected Some content_type"
66
+
67
+
let test_content_type_missing () =
68
+
with_eio @@ fun sw ->
69
+
let r = response ~sw () in
70
+
Alcotest.(check bool)
71
+
"no content-type" true
72
+
(Option.is_none (Response.content_type r))
73
+
74
+
let test_content_length () =
75
+
with_eio @@ fun sw ->
76
+
let r = response ~sw ~headers:[ ("content-length", "42") ] () in
77
+
Alcotest.(check (option int64))
78
+
"content_length" (Some 42L)
79
+
(Response.content_length r)
80
+
81
+
let test_content_length_missing () =
82
+
with_eio @@ fun sw ->
83
+
let r = response ~sw () in
84
+
Alcotest.(check (option int64))
85
+
"no content-length" None
86
+
(Response.content_length r)
87
+
88
+
let test_content_length_invalid () =
89
+
with_eio @@ fun sw ->
90
+
let r = response ~sw ~headers:[ ("content-length", "not-a-number") ] () in
91
+
Alcotest.(check (option int64))
92
+
"invalid content-length" None
93
+
(Response.content_length r)
94
+
95
+
let test_location () =
96
+
with_eio @@ fun sw ->
97
+
let r =
98
+
response ~sw ~status:301
99
+
~headers:[ ("location", "https://example.com/new") ]
100
+
()
101
+
in
102
+
Alcotest.(check (option string))
103
+
"location" (Some "https://example.com/new") (Response.location r)
104
+
105
+
let test_location_missing () =
106
+
with_eio @@ fun sw ->
107
+
let r = response ~sw () in
108
+
Alcotest.(check (option string)) "no location" None (Response.location r)
109
+
110
+
let test_etag () =
111
+
with_eio @@ fun sw ->
112
+
let r = response ~sw ~headers:[ ("etag", "\"abc123\"") ] () in
113
+
Alcotest.(check (option string)) "etag" (Some "\"abc123\"") (Response.etag r)
114
+
115
+
let test_etag_missing () =
116
+
with_eio @@ fun sw ->
117
+
let r = response ~sw () in
118
+
Alcotest.(check (option string)) "no etag" None (Response.etag r)
119
+
120
+
let test_last_modified () =
121
+
with_eio @@ fun sw ->
122
+
let r =
123
+
response ~sw
124
+
~headers:[ ("last-modified", "Sun, 06 Nov 1994 08:49:37 GMT") ]
125
+
()
126
+
in
127
+
Alcotest.(check (option string))
128
+
"last-modified" (Some "Sun, 06 Nov 1994 08:49:37 GMT")
129
+
(Response.last_modified r)
130
+
131
+
(** {1 RFC 9111 Cacheability Tests} *)
132
+
133
+
let test_cacheable_200 () =
134
+
with_eio @@ fun sw ->
135
+
let r = response ~sw ~status:200 () in
136
+
Alcotest.(check bool) "200 is cacheable" true (Response.is_cacheable r)
137
+
138
+
let test_cacheable_301 () =
139
+
with_eio @@ fun sw ->
140
+
let r = response ~sw ~status:301 () in
141
+
Alcotest.(check bool) "301 is cacheable" true (Response.is_cacheable r)
142
+
143
+
let test_not_cacheable_500 () =
144
+
with_eio @@ fun sw ->
145
+
let r = response ~sw ~status:500 () in
146
+
Alcotest.(check bool) "500 is not cacheable" false (Response.is_cacheable r)
147
+
148
+
let test_not_cacheable_no_store () =
149
+
with_eio @@ fun sw ->
150
+
let r =
151
+
response ~sw ~status:200 ~headers:[ ("cache-control", "no-store") ] ()
152
+
in
153
+
Alcotest.(check bool)
154
+
"no-store is not cacheable" false (Response.is_cacheable r)
155
+
156
+
let test_cacheable_max_age () =
157
+
with_eio @@ fun sw ->
158
+
let r =
159
+
response ~sw ~status:200 ~headers:[ ("cache-control", "max-age=3600") ] ()
160
+
in
161
+
Alcotest.(check bool) "max-age is cacheable" true (Response.is_cacheable r)
162
+
163
+
let test_not_cacheable_502 () =
164
+
with_eio @@ fun sw ->
165
+
let r = response ~sw ~status:502 () in
166
+
Alcotest.(check bool) "502 is not cacheable" false (Response.is_cacheable r)
167
+
168
+
let test_cacheable_404 () =
169
+
with_eio @@ fun sw ->
170
+
let r = response ~sw ~status:404 () in
171
+
Alcotest.(check bool)
172
+
"404 is cacheable by default" true (Response.is_cacheable r)
173
+
174
+
(** {1 Freshness Lifetime Tests} *)
175
+
176
+
let test_freshness_max_age () =
177
+
with_eio @@ fun sw ->
178
+
let r = response ~sw ~headers:[ ("cache-control", "max-age=3600") ] () in
179
+
Alcotest.(check (option int))
180
+
"freshness from max-age" (Some 3600)
181
+
(Response.freshness_lifetime r)
182
+
183
+
let test_freshness_no_cache_control () =
184
+
with_eio @@ fun sw ->
185
+
let r = response ~sw () in
186
+
Alcotest.(check (option int))
187
+
"no freshness info" None
188
+
(Response.freshness_lifetime r)
189
+
190
+
(** {1 Must Revalidate Tests} *)
191
+
192
+
let test_must_revalidate_true () =
193
+
with_eio @@ fun sw ->
194
+
let r =
195
+
response ~sw ~headers:[ ("cache-control", "must-revalidate, max-age=0") ] ()
196
+
in
197
+
Alcotest.(check bool) "must-revalidate" true (Response.must_revalidate r)
198
+
199
+
let test_must_revalidate_no_cache () =
200
+
with_eio @@ fun sw ->
201
+
let r = response ~sw ~headers:[ ("cache-control", "no-cache") ] () in
202
+
Alcotest.(check bool)
203
+
"no-cache requires revalidation" true
204
+
(Response.must_revalidate r)
205
+
206
+
let test_must_revalidate_false () =
207
+
with_eio @@ fun sw ->
208
+
let r = response ~sw ~headers:[ ("cache-control", "max-age=3600") ] () in
209
+
Alcotest.(check bool)
210
+
"plain max-age no revalidation" false
211
+
(Response.must_revalidate r)
212
+
213
+
let test_must_revalidate_absent () =
214
+
with_eio @@ fun sw ->
215
+
let r = response ~sw () in
216
+
Alcotest.(check bool)
217
+
"no cache-control no revalidation" false
218
+
(Response.must_revalidate r)
219
+
220
+
(** {1 304 Not Modified Tests} *)
221
+
222
+
let test_is_not_modified_true () =
223
+
with_eio @@ fun sw ->
224
+
let r = response ~sw ~status:304 () in
225
+
Alcotest.(check bool) "304 is not-modified" true (Response.is_not_modified r)
226
+
227
+
let test_is_not_modified_false () =
228
+
with_eio @@ fun sw ->
229
+
let r = response ~sw ~status:200 () in
230
+
Alcotest.(check bool)
231
+
"200 is not not-modified" false
232
+
(Response.is_not_modified r)
233
+
234
+
(** {1 Vary Header Tests} *)
235
+
236
+
let test_vary_single () =
237
+
with_eio @@ fun sw ->
238
+
let r = response ~sw ~headers:[ ("vary", "Accept-Encoding") ] () in
239
+
Alcotest.(check (list string))
240
+
"single vary header" [ "Accept-Encoding" ] (Response.vary_headers r)
241
+
242
+
let test_vary_multiple () =
243
+
with_eio @@ fun sw ->
244
+
let r =
245
+
response ~sw
246
+
~headers:[ ("vary", "Accept-Encoding, Accept-Language, Cookie") ]
247
+
()
248
+
in
249
+
Alcotest.(check (list string))
250
+
"multiple vary headers"
251
+
[ "Accept-Encoding"; "Accept-Language"; "Cookie" ]
252
+
(Response.vary_headers r)
253
+
254
+
let test_vary_empty () =
255
+
with_eio @@ fun sw ->
256
+
let r = response ~sw () in
257
+
Alcotest.(check (list string)) "no vary header" [] (Response.vary_headers r)
258
+
259
+
let test_vary_whitespace () =
260
+
with_eio @@ fun sw ->
261
+
let r = response ~sw ~headers:[ ("vary", " Accept , Origin ") ] () in
262
+
Alcotest.(check (list string))
263
+
"vary with whitespace" [ "Accept"; "Origin" ] (Response.vary_headers r)
264
+
265
+
(** {1 check_status Tests} *)
266
+
267
+
let test_check_status_ok () =
268
+
with_eio @@ fun sw ->
269
+
let r = response ~sw ~status:200 () in
270
+
match Response.check_status r with
271
+
| Ok _ -> ()
272
+
| Error _ -> Alcotest.fail "Expected Ok for 200"
273
+
274
+
let test_check_status_201 () =
275
+
with_eio @@ fun sw ->
276
+
let r = response ~sw ~status:201 () in
277
+
match Response.check_status r with
278
+
| Ok _ -> ()
279
+
| Error _ -> Alcotest.fail "Expected Ok for 201"
280
+
281
+
let test_check_status_301 () =
282
+
with_eio @@ fun sw ->
283
+
let r = response ~sw ~status:301 () in
284
+
match Response.check_status r with
285
+
| Ok _ -> ()
286
+
| Error _ -> Alcotest.fail "Expected Ok for 301 (not an error status)"
287
+
288
+
let test_check_status_404 () =
289
+
with_eio @@ fun sw ->
290
+
let r = response ~sw ~status:404 () in
291
+
match Response.check_status r with
292
+
| Ok _ -> Alcotest.fail "Expected Error for 404"
293
+
| Error (Error.Http_error { status; _ }) ->
294
+
Alcotest.(check int) "error status" 404 status
295
+
| Error _ -> Alcotest.fail "Expected Http_error"
296
+
297
+
let test_check_status_500 () =
298
+
with_eio @@ fun sw ->
299
+
let r = response ~sw ~status:500 () in
300
+
match Response.check_status r with
301
+
| Ok _ -> Alcotest.fail "Expected Error for 500"
302
+
| Error (Error.Http_error { status; _ }) ->
303
+
Alcotest.(check int) "error status" 500 status
304
+
| Error _ -> Alcotest.fail "Expected Http_error"
305
+
306
+
(** {1 raise_for_status Tests} *)
307
+
308
+
let test_raise_for_status_ok () =
309
+
with_eio @@ fun sw ->
310
+
let r = response ~sw ~status:200 () in
311
+
let r' = Response.raise_for_status r in
312
+
Alcotest.(check int) "returns same response" 200 (Response.status_code r')
313
+
314
+
let test_raise_for_status_4xx () =
315
+
with_eio @@ fun sw ->
316
+
let r = response ~sw ~status:403 () in
317
+
match Response.raise_for_status r with
318
+
| _ -> Alcotest.fail "Expected exception for 403"
319
+
| exception Eio.Io _ -> ()
320
+
321
+
let test_raise_for_status_5xx () =
322
+
with_eio @@ fun sw ->
323
+
let r = response ~sw ~status:503 () in
324
+
match Response.raise_for_status r with
325
+
| _ -> Alcotest.fail "Expected exception for 503"
326
+
| exception Eio.Io _ -> ()
327
+
328
+
(** {1 Metadata Tests} *)
329
+
330
+
let test_url () =
331
+
with_eio @@ fun sw ->
332
+
let r = response ~sw ~url:"https://example.com/path" () in
333
+
Alcotest.(check string) "url" "https://example.com/path" (Response.url r)
334
+
335
+
let test_elapsed () =
336
+
with_eio @@ fun sw ->
337
+
let r = response ~sw ~elapsed:1.5 () in
338
+
Alcotest.(check bool)
339
+
"elapsed" true
340
+
(Float.abs (Response.elapsed r -. 1.5) < 0.001)
341
+
342
+
(** {1 Test Suite} *)
343
+
344
+
let suite =
345
+
( "response",
346
+
[
347
+
(* Status *)
348
+
Alcotest.test_case "status_code 200" `Quick test_status_200;
349
+
Alcotest.test_case "status_code 404" `Quick test_status_404;
350
+
Alcotest.test_case "ok for 200" `Quick test_ok_true;
351
+
Alcotest.test_case "not ok for 404" `Quick test_ok_false_4xx;
352
+
Alcotest.test_case "not ok for 500" `Quick test_ok_false_5xx;
353
+
Alcotest.test_case "ok for 201" `Quick test_ok_true_201;
354
+
(* Header extraction *)
355
+
Alcotest.test_case "content_type" `Quick test_content_type;
356
+
Alcotest.test_case "content_type missing" `Quick test_content_type_missing;
357
+
Alcotest.test_case "content_length" `Quick test_content_length;
358
+
Alcotest.test_case "content_length missing" `Quick
359
+
test_content_length_missing;
360
+
Alcotest.test_case "content_length invalid" `Quick
361
+
test_content_length_invalid;
362
+
Alcotest.test_case "location" `Quick test_location;
363
+
Alcotest.test_case "location missing" `Quick test_location_missing;
364
+
Alcotest.test_case "etag" `Quick test_etag;
365
+
Alcotest.test_case "etag missing" `Quick test_etag_missing;
366
+
Alcotest.test_case "last_modified" `Quick test_last_modified;
367
+
(* RFC 9111 cacheability *)
368
+
Alcotest.test_case "200 cacheable" `Quick test_cacheable_200;
369
+
Alcotest.test_case "301 cacheable" `Quick test_cacheable_301;
370
+
Alcotest.test_case "500 not cacheable" `Quick test_not_cacheable_500;
371
+
Alcotest.test_case "no-store not cacheable" `Quick
372
+
test_not_cacheable_no_store;
373
+
Alcotest.test_case "max-age cacheable" `Quick test_cacheable_max_age;
374
+
Alcotest.test_case "502 not cacheable" `Quick test_not_cacheable_502;
375
+
Alcotest.test_case "404 cacheable" `Quick test_cacheable_404;
376
+
(* Freshness *)
377
+
Alcotest.test_case "freshness from max-age" `Quick test_freshness_max_age;
378
+
Alcotest.test_case "freshness no cache-control" `Quick
379
+
test_freshness_no_cache_control;
380
+
(* Must revalidate *)
381
+
Alcotest.test_case "must-revalidate" `Quick test_must_revalidate_true;
382
+
Alcotest.test_case "no-cache revalidate" `Quick
383
+
test_must_revalidate_no_cache;
384
+
Alcotest.test_case "max-age no revalidate" `Quick
385
+
test_must_revalidate_false;
386
+
Alcotest.test_case "absent no revalidate" `Quick
387
+
test_must_revalidate_absent;
388
+
(* 304 Not Modified *)
389
+
Alcotest.test_case "304 is not-modified" `Quick test_is_not_modified_true;
390
+
Alcotest.test_case "200 is not not-modified" `Quick
391
+
test_is_not_modified_false;
392
+
(* Vary *)
393
+
Alcotest.test_case "vary single" `Quick test_vary_single;
394
+
Alcotest.test_case "vary multiple" `Quick test_vary_multiple;
395
+
Alcotest.test_case "vary empty" `Quick test_vary_empty;
396
+
Alcotest.test_case "vary whitespace" `Quick test_vary_whitespace;
397
+
(* check_status *)
398
+
Alcotest.test_case "check_status 200" `Quick test_check_status_ok;
399
+
Alcotest.test_case "check_status 201" `Quick test_check_status_201;
400
+
Alcotest.test_case "check_status 301" `Quick test_check_status_301;
401
+
Alcotest.test_case "check_status 404" `Quick test_check_status_404;
402
+
Alcotest.test_case "check_status 500" `Quick test_check_status_500;
403
+
(* raise_for_status *)
404
+
Alcotest.test_case "raise_for_status 200" `Quick test_raise_for_status_ok;
405
+
Alcotest.test_case "raise_for_status 403" `Quick test_raise_for_status_4xx;
406
+
Alcotest.test_case "raise_for_status 503" `Quick test_raise_for_status_5xx;
407
+
(* Metadata *)
408
+
Alcotest.test_case "url" `Quick test_url;
409
+
Alcotest.test_case "elapsed" `Quick test_elapsed;
410
+
] )
+4
test/test_response.mli
+4
test/test_response.mli
+112
test/test_response_limits.ml
+112
test/test_response_limits.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Response_limits module *)
7
+
8
+
module Response_limits = Http.Response_limits
9
+
10
+
(** {1 Default Values} *)
11
+
12
+
let test_default_body_size () =
13
+
let d = Response_limits.default in
14
+
(* 100MB = 100 * 1024 * 1024 = 104857600 *)
15
+
Alcotest.(check int64)
16
+
"max_response_body_size" 104857600L
17
+
(Response_limits.max_response_body_size d)
18
+
19
+
let test_default_header_size () =
20
+
let d = Response_limits.default in
21
+
(* 16KB = 16 * 1024 = 16384 *)
22
+
Alcotest.(check int)
23
+
"max_header_size" 16384
24
+
(Response_limits.max_header_size d)
25
+
26
+
let test_default_header_count () =
27
+
let d = Response_limits.default in
28
+
Alcotest.(check int)
29
+
"max_header_count" 100
30
+
(Response_limits.max_header_count d)
31
+
32
+
let test_default_decompressed_size () =
33
+
let d = Response_limits.default in
34
+
(* 100MB *)
35
+
Alcotest.(check int64)
36
+
"max_decompressed_size" 104857600L
37
+
(Response_limits.max_decompressed_size d)
38
+
39
+
let test_default_compression_ratio () =
40
+
let d = Response_limits.default in
41
+
let expected = 100.0 in
42
+
let actual = Response_limits.max_compression_ratio d in
43
+
Alcotest.(check bool)
44
+
"max_compression_ratio" true
45
+
(Float.abs (actual -. expected) < 0.001)
46
+
47
+
(** {1 Custom Values} *)
48
+
49
+
let test_make_custom () =
50
+
let limits =
51
+
Response_limits.v ~max_response_body_size:1024L ~max_header_size:512
52
+
~max_header_count:50 ~max_decompressed_size:2048L
53
+
~max_compression_ratio:10.0 ()
54
+
in
55
+
Alcotest.(check int64)
56
+
"custom body size" 1024L
57
+
(Response_limits.max_response_body_size limits);
58
+
Alcotest.(check int)
59
+
"custom header size" 512
60
+
(Response_limits.max_header_size limits);
61
+
Alcotest.(check int)
62
+
"custom header count" 50
63
+
(Response_limits.max_header_count limits);
64
+
Alcotest.(check int64)
65
+
"custom decompressed size" 2048L
66
+
(Response_limits.max_decompressed_size limits);
67
+
Alcotest.(check bool)
68
+
"custom compression ratio" true
69
+
(Float.abs (Response_limits.max_compression_ratio limits -. 10.0) < 0.001)
70
+
71
+
let test_make_partial () =
72
+
(* Only override some values, rest should be defaults *)
73
+
let limits = Response_limits.v ~max_header_count:200 () in
74
+
Alcotest.(check int)
75
+
"overridden header count" 200
76
+
(Response_limits.max_header_count limits);
77
+
(* Other values should be defaults *)
78
+
Alcotest.(check int64)
79
+
"default body size" 104857600L
80
+
(Response_limits.max_response_body_size limits)
81
+
82
+
let test_make_zero_limits () =
83
+
let limits =
84
+
Response_limits.v ~max_response_body_size:0L ~max_header_size:0
85
+
~max_header_count:0 ()
86
+
in
87
+
Alcotest.(check int64)
88
+
"zero body size" 0L
89
+
(Response_limits.max_response_body_size limits);
90
+
Alcotest.(check int)
91
+
"zero header size" 0
92
+
(Response_limits.max_header_size limits);
93
+
Alcotest.(check int)
94
+
"zero header count" 0
95
+
(Response_limits.max_header_count limits)
96
+
97
+
(** {1 Test Suite} *)
98
+
99
+
let suite =
100
+
( "response_limits",
101
+
[
102
+
Alcotest.test_case "body size" `Quick test_default_body_size;
103
+
Alcotest.test_case "header size" `Quick test_default_header_size;
104
+
Alcotest.test_case "header count" `Quick test_default_header_count;
105
+
Alcotest.test_case "decompressed size" `Quick
106
+
test_default_decompressed_size;
107
+
Alcotest.test_case "compression ratio" `Quick
108
+
test_default_compression_ratio;
109
+
Alcotest.test_case "full custom" `Quick test_make_custom;
110
+
Alcotest.test_case "partial override" `Quick test_make_partial;
111
+
Alcotest.test_case "zero limits" `Quick test_make_zero_limits;
112
+
] )
+4
test/test_response_limits.mli
+4
test/test_response_limits.mli
+126
test/test_status.ml
+126
test/test_status.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for HTTP status codes *)
7
+
8
+
module Status = Http.Status
9
+
10
+
(** {1 Roundtrip Tests} *)
11
+
12
+
let test_of_int_roundtrip () =
13
+
let codes = [ 200; 301; 404; 500 ] in
14
+
List.iter
15
+
(fun code ->
16
+
let status = Status.of_int code in
17
+
let got = Status.to_int status in
18
+
Alcotest.(check int) (Fmt.str "roundtrip %d" code) code got)
19
+
codes
20
+
21
+
(** {1 Reason Phrase Tests} *)
22
+
23
+
let test_reason_phrase () =
24
+
let cases =
25
+
[
26
+
(200, "OK");
27
+
(301, "Moved Permanently");
28
+
(404, "Not Found");
29
+
(500, "Internal Server Error");
30
+
]
31
+
in
32
+
List.iter
33
+
(fun (code, expected) ->
34
+
let status = Status.of_int code in
35
+
let phrase = Status.reason_phrase status in
36
+
Alcotest.(check string) (Fmt.str "reason_phrase %d" code) expected phrase)
37
+
cases
38
+
39
+
(** {1 Classification Tests} *)
40
+
41
+
let test_is_informational () =
42
+
Alcotest.(check bool)
43
+
"100 is informational" true
44
+
(Status.is_informational (Status.of_int 100));
45
+
Alcotest.(check bool)
46
+
"200 is not informational" false
47
+
(Status.is_informational (Status.of_int 200))
48
+
49
+
let test_is_success () =
50
+
Alcotest.(check bool)
51
+
"200 is success" true
52
+
(Status.is_success (Status.of_int 200));
53
+
Alcotest.(check bool)
54
+
"404 is not success" false
55
+
(Status.is_success (Status.of_int 404))
56
+
57
+
let test_is_redirection () =
58
+
Alcotest.(check bool)
59
+
"301 is redirection" true
60
+
(Status.is_redirection (Status.of_int 301));
61
+
Alcotest.(check bool)
62
+
"200 is not redirection" false
63
+
(Status.is_redirection (Status.of_int 200))
64
+
65
+
let test_is_client_error () =
66
+
Alcotest.(check bool)
67
+
"404 is client_error" true
68
+
(Status.is_client_error (Status.of_int 404));
69
+
Alcotest.(check bool)
70
+
"500 is not client_error" false
71
+
(Status.is_client_error (Status.of_int 500))
72
+
73
+
let test_is_server_error () =
74
+
Alcotest.(check bool)
75
+
"500 is server_error" true
76
+
(Status.is_server_error (Status.of_int 500));
77
+
Alcotest.(check bool)
78
+
"404 is not server_error" false
79
+
(Status.is_server_error (Status.of_int 404))
80
+
81
+
let test_is_error () =
82
+
Alcotest.(check bool)
83
+
"404 is error" true
84
+
(Status.is_error (Status.of_int 404));
85
+
Alcotest.(check bool)
86
+
"500 is error" true
87
+
(Status.is_error (Status.of_int 500));
88
+
Alcotest.(check bool)
89
+
"200 is not error" false
90
+
(Status.is_error (Status.of_int 200))
91
+
92
+
(** {1 Retryable Tests} *)
93
+
94
+
let test_is_retryable () =
95
+
let retryable = [ 408; 429; 502; 503; 504 ] in
96
+
let not_retryable = [ 200; 301; 400; 404 ] in
97
+
List.iter
98
+
(fun code ->
99
+
Alcotest.(check bool)
100
+
(Fmt.str "%d is retryable" code)
101
+
true
102
+
(Status.is_retryable (Status.of_int code)))
103
+
retryable;
104
+
List.iter
105
+
(fun code ->
106
+
Alcotest.(check bool)
107
+
(Fmt.str "%d is not retryable" code)
108
+
false
109
+
(Status.is_retryable (Status.of_int code)))
110
+
not_retryable
111
+
112
+
(** {1 Test Suite} *)
113
+
114
+
let suite =
115
+
( "status",
116
+
[
117
+
Alcotest.test_case "of_int/to_int roundtrip" `Quick test_of_int_roundtrip;
118
+
Alcotest.test_case "known reason phrases" `Quick test_reason_phrase;
119
+
Alcotest.test_case "is_informational" `Quick test_is_informational;
120
+
Alcotest.test_case "is_success" `Quick test_is_success;
121
+
Alcotest.test_case "is_redirection" `Quick test_is_redirection;
122
+
Alcotest.test_case "is_client_error" `Quick test_is_client_error;
123
+
Alcotest.test_case "is_server_error" `Quick test_is_server_error;
124
+
Alcotest.test_case "is_error" `Quick test_is_error;
125
+
Alcotest.test_case "retryable codes" `Quick test_is_retryable;
126
+
] )