anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
Fix HTTP specification compliance issues
Same-origin check (RFC 6454):
- Include port in origin comparison, not just scheme and host
- http://example.com:80 and http://example.com:8080 are now different origins
Digest authentication (RFC 7616):
- Reject unknown algorithms instead of silent MD5 fallback
- Implement -sess algorithm variants (MD5-sess, SHA-256-sess)
with proper session key derivation: HA1 = hash(hash(u:r:p):nonce:cnonce)
HTTP methods (RFC 9110):
- Add request_body_semantics function with Body_required/Optional/Forbidden
- DELETE, OPTIONS, GET now correctly have Body_optional semantics
- Deprecate has_request_body in favor of the more accurate new function
Status codes:
- 501 Not Implemented and 505 HTTP Version Not Supported are no longer
marked as retryable (they indicate permanent conditions)
HTTP/2 (RFC 9113):
- Add SETTINGS_NO_RFC7540_PRIORITIES (0x09) to disable deprecated priorities
- Validate :protocol pseudo-header requires CONNECT method (RFC 8441)
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+6
lib/core/headers.ml
+6
lib/core/headers.ml
···
530
(* CONNECT requests don't require :scheme and :path *)
531
let is_connect = get_pseudo "method" t = Some "CONNECT" in
532
533
if not has_method then
534
Error (Missing_pseudo "method")
535
else if not is_connect && not has_scheme then
536
Error (Missing_pseudo "scheme")
537
else if not is_connect && not has_path then
···
530
(* CONNECT requests don't require :scheme and :path *)
531
let is_connect = get_pseudo "method" t = Some "CONNECT" in
532
533
+
(* :protocol is only valid with CONNECT (RFC 8441 extended CONNECT) *)
534
+
let has_protocol = mem_pseudo "protocol" t in
535
+
536
if not has_method then
537
Error (Missing_pseudo "method")
538
+
else if has_protocol && not is_connect then
539
+
(* :protocol pseudo-header requires :method to be CONNECT *)
540
+
Error (Invalid_pseudo "protocol (requires CONNECT method)")
541
else if not is_connect && not has_scheme then
542
Error (Missing_pseudo "scheme")
543
else if not is_connect && not has_path then
+14
lib/core/method.ml
+14
lib/core/method.ml
···
54
| `GET | `HEAD | `PUT | `DELETE | `OPTIONS | `TRACE -> true
55
| `POST | `PATCH | `CONNECT | `Other _ -> false
56
57
+
type body_semantics =
58
+
| Body_required
59
+
| Body_optional
60
+
| Body_forbidden
61
+
62
+
let request_body_semantics = function
63
+
| `POST | `PUT | `PATCH -> Body_required
64
+
| `DELETE | `OPTIONS -> Body_optional
65
+
| `GET -> Body_optional (* RFC 9110 Section 9.3.1: GET body has no defined semantics *)
66
+
| `HEAD -> Body_forbidden (* RFC 9110 Section 9.3.2: identical to GET but no body in response *)
67
+
| `TRACE -> Body_forbidden (* RFC 9110 Section 9.3.8: MUST NOT send body *)
68
+
| `CONNECT -> Body_forbidden (* RFC 9110 Section 9.3.6: no body in CONNECT request *)
69
+
| `Other _ -> Body_optional (* Unknown methods - allow body for flexibility *)
70
+
71
let has_request_body = function
72
| `POST | `PUT | `PATCH -> true
73
| `GET | `HEAD | `DELETE | `OPTIONS | `CONNECT | `TRACE -> false
+15
-1
lib/core/method.mli
+15
-1
lib/core/method.mli
···
58
(** Returns true for idempotent methods (GET, HEAD, PUT, DELETE, OPTIONS, TRACE).
59
Idempotent methods can be called multiple times with the same result. *)
60
61
val has_request_body : t -> bool
62
-
(** Returns true for methods that typically have a request body (POST, PUT, PATCH) *)
63
64
val is_cacheable : t -> bool
65
(** Returns true for methods whose responses are cacheable by default (GET, HEAD, POST).
···
58
(** Returns true for idempotent methods (GET, HEAD, PUT, DELETE, OPTIONS, TRACE).
59
Idempotent methods can be called multiple times with the same result. *)
60
61
+
(** Request body semantics per RFC 9110 Section 9.3 *)
62
+
type body_semantics =
63
+
| Body_required (** Method requires a body (POST, PUT, PATCH) *)
64
+
| Body_optional (** Method MAY have a body (DELETE, OPTIONS, GET) *)
65
+
| Body_forbidden (** Method MUST NOT have a body (HEAD, TRACE, CONNECT) *)
66
+
67
+
val request_body_semantics : t -> body_semantics
68
+
(** Returns the request body semantics for a method per RFC 9110.
69
+
70
+
- {!Body_required}: POST, PUT, PATCH - body is expected
71
+
- {!Body_optional}: DELETE, OPTIONS, GET - body allowed but has no defined semantics
72
+
- {!Body_forbidden}: HEAD, TRACE, CONNECT - body MUST NOT be sent *)
73
+
74
val has_request_body : t -> bool
75
+
(** Returns true for methods that typically have a request body (POST, PUT, PATCH).
76
+
@deprecated Use {!request_body_semantics} for more accurate RFC 9110 semantics. *)
77
78
val is_cacheable : t -> bool
79
(** Returns true for methods whose responses are cacheable by default (GET, HEAD, POST).
+4
-1
lib/core/status.ml
+4
-1
lib/core/status.ml
···
353
| `Bad_gateway
354
| `Service_unavailable
355
| `Gateway_timeout -> true
356
+
(* 501 and 505 indicate permanent conditions that won't be fixed by retrying *)
357
+
| `Not_implemented -> false (* 501: Server doesn't support the functionality *)
358
+
| `Http_version_not_supported -> false (* 505: Protocol version not supported *)
359
+
| _ -> is_server_error t (* Other 5xx errors are generally retryable *)
360
361
let should_retry_on_different_host t =
362
match t with
+21
-4
lib/features/auth.ml
+21
-4
lib/features/auth.ml
···
214
reason = "Digest algorithm SHA-512-256 is not supported. Server should offer SHA-256 or MD5."
215
}))
216
| other ->
217
-
Log.warn (fun m -> m "Unknown digest algorithm '%s', defaulting to MD5" other);
218
-
Digestif.MD5.(to_hex (digest_string s))
219
220
(** Generate a random client nonce *)
221
let generate_cnonce () =
···
227
in
228
String.concat "" (List.init (String.length bytes) (fun i -> hex_of_char bytes.[i]))
229
230
(** Compute digest response according to RFC 7616.
231
232
@param body Optional request body for auth-int qop (body hash included in HA2) *)
233
let compute_digest_response ~username ~password ~method_ ~uri ~challenge ~nc ~cnonce ?body () =
234
let algorithm = challenge.algorithm in
235
-
(* HA1 = hash(username:realm:password) *)
236
-
let ha1 = hash_string ~algorithm
237
(Printf.sprintf "%s:%s:%s" username challenge.realm password) in
238
(* Determine which qop to use *)
239
let selected_qop = match challenge.qop with
240
| Some qop ->
···
214
reason = "Digest algorithm SHA-512-256 is not supported. Server should offer SHA-256 or MD5."
215
}))
216
| other ->
217
+
(* RFC 7616: Unknown algorithms should be rejected to prevent security downgrades.
218
+
Silent fallback to MD5 could mask server misconfigurations. *)
219
+
Log.err (fun m -> m "Unknown digest algorithm '%s'" other);
220
+
raise (Error.err (Error.Authentication_failed {
221
+
url = "";
222
+
reason = Printf.sprintf "Unknown digest algorithm '%s'. Supported: MD5, SHA-256, SHA-512." other
223
+
}))
224
225
(** Generate a random client nonce *)
226
let generate_cnonce () =
···
232
in
233
String.concat "" (List.init (String.length bytes) (fun i -> hex_of_char bytes.[i]))
234
235
+
(** Check if algorithm is a -sess variant *)
236
+
let is_sess_algorithm algorithm =
237
+
let alg = String.uppercase_ascii algorithm in
238
+
String.ends_with ~suffix:"-SESS" alg
239
+
240
(** Compute digest response according to RFC 7616.
241
242
@param body Optional request body for auth-int qop (body hash included in HA2) *)
243
let compute_digest_response ~username ~password ~method_ ~uri ~challenge ~nc ~cnonce ?body () =
244
let algorithm = challenge.algorithm in
245
+
(* HA1 calculation differs for -sess algorithms (RFC 7616 Section 3.4.2) *)
246
+
let ha1_base = hash_string ~algorithm
247
(Printf.sprintf "%s:%s:%s" username challenge.realm password) in
248
+
let ha1 =
249
+
if is_sess_algorithm algorithm then
250
+
(* For -sess: HA1 = hash(hash(username:realm:password):nonce:cnonce) *)
251
+
hash_string ~algorithm (Printf.sprintf "%s:%s:%s" ha1_base challenge.nonce cnonce)
252
+
else
253
+
ha1_base
254
+
in
255
(* Determine which qop to use *)
256
let selected_qop = match challenge.qop with
257
| Some qop ->
+24
-5
lib/features/redirect.ml
+24
-5
lib/features/redirect.ml
···
13
14
(** {1 Cross-Origin Detection} *)
15
16
(** Check if two URIs have the same origin for security purposes.
17
Used to determine if sensitive headers (Authorization, Cookie) should be
18
stripped during redirects. Following Python requests behavior:
19
-
- Same host and same scheme = same origin
20
-
- http -> https upgrade on same host = allowed (more secure)
21
TODO: Support .netrc for re-acquiring auth credentials on new hosts *)
22
let same_origin uri1 uri2 =
23
let host1 = Uri.host uri1 |> Option.map String.lowercase_ascii in
24
let host2 = Uri.host uri2 |> Option.map String.lowercase_ascii in
25
let scheme1 = Uri.scheme uri1 |> Option.value ~default:"http" in
26
let scheme2 = Uri.scheme uri2 |> Option.value ~default:"http" in
27
match host1, host2 with
28
| Some h1, Some h2 when String.equal h1 h2 ->
29
-
(* Same host - allow same scheme or http->https upgrade *)
30
-
String.equal scheme1 scheme2 ||
31
-
(scheme1 = "http" && scheme2 = "https")
32
| _ -> false
33
34
(** {1 Sensitive Header Protection} *)
···
13
14
(** {1 Cross-Origin Detection} *)
15
16
+
(** Get the effective port for a URI, using default ports for http/https.
17
+
Per RFC 6454, the port is part of the origin tuple. *)
18
+
let effective_port uri =
19
+
match Uri.port uri with
20
+
| Some p -> p
21
+
| None ->
22
+
match Uri.scheme uri with
23
+
| Some "https" -> 443
24
+
| Some "http" | None -> 80
25
+
| Some _ -> 80 (* Default for unknown schemes *)
26
+
27
(** Check if two URIs have the same origin for security purposes.
28
+
Per RFC 6454 (Web Origin), origins are tuples of (scheme, host, port).
29
Used to determine if sensitive headers (Authorization, Cookie) should be
30
stripped during redirects. Following Python requests behavior:
31
+
- Same host, same scheme, same port = same origin
32
+
- http -> https upgrade on same host with default ports = allowed (more secure)
33
TODO: Support .netrc for re-acquiring auth credentials on new hosts *)
34
let same_origin uri1 uri2 =
35
let host1 = Uri.host uri1 |> Option.map String.lowercase_ascii in
36
let host2 = Uri.host uri2 |> Option.map String.lowercase_ascii in
37
let scheme1 = Uri.scheme uri1 |> Option.value ~default:"http" in
38
let scheme2 = Uri.scheme uri2 |> Option.value ~default:"http" in
39
+
let port1 = effective_port uri1 in
40
+
let port2 = effective_port uri2 in
41
match host1, host2 with
42
| Some h1, Some h2 when String.equal h1 h2 ->
43
+
if String.equal scheme1 scheme2 && port1 = port2 then
44
+
(* Same scheme, host, and port = same origin *)
45
+
true
46
+
else if scheme1 = "http" && scheme2 = "https" && port1 = 80 && port2 = 443 then
47
+
(* http->https upgrade on default ports is allowed (more secure) *)
48
+
true
49
+
else
50
+
false
51
| _ -> false
52
53
(** {1 Sensitive Header Protection} *)
+5
lib/h2/h2_connection.ml
+5
lib/h2/h2_connection.ml
···
76
(** SETTINGS_MAX_FRAME_SIZE (0x05): Default 16384, max 16777215. *)
77
max_header_list_size : int option;
78
(** SETTINGS_MAX_HEADER_LIST_SIZE (0x06): No limit by default. *)
79
}
80
81
(** Default settings per RFC 9113. *)
···
86
initial_window_size = 65535;
87
max_frame_size = 16384;
88
max_header_list_size = None;
89
}
90
91
(** Client-appropriate default settings (no push). *)
···
130
Ok { s with max_frame_size = v }
131
| H2_frame.Max_header_list_size v ->
132
Ok { s with max_header_list_size = Some v }
133
| H2_frame.Unknown_setting _ ->
134
(* Unknown settings MUST be ignored per RFC 9113 *)
135
Ok s
···
76
(** SETTINGS_MAX_FRAME_SIZE (0x05): Default 16384, max 16777215. *)
77
max_header_list_size : int option;
78
(** SETTINGS_MAX_HEADER_LIST_SIZE (0x06): No limit by default. *)
79
+
no_rfc7540_priorities : bool;
80
+
(** SETTINGS_NO_RFC7540_PRIORITIES (0x09): RFC 9113 deprecates RFC 7540 priorities. *)
81
}
82
83
(** Default settings per RFC 9113. *)
···
88
initial_window_size = 65535;
89
max_frame_size = 16384;
90
max_header_list_size = None;
91
+
no_rfc7540_priorities = false; (* RFC 7540 priorities enabled by default for compatibility *)
92
}
93
94
(** Client-appropriate default settings (no push). *)
···
133
Ok { s with max_frame_size = v }
134
| H2_frame.Max_header_list_size v ->
135
Ok { s with max_header_list_size = Some v }
136
+
| H2_frame.No_rfc7540_priorities v ->
137
+
Ok { s with no_rfc7540_priorities = v }
138
| H2_frame.Unknown_setting _ ->
139
(* Unknown settings MUST be ignored per RFC 9113 *)
140
Ok s
+2
lib/h2/h2_connection.mli
+2
lib/h2/h2_connection.mli
···
86
(** SETTINGS_MAX_FRAME_SIZE (default 16384, max 16777215). *)
87
max_header_list_size : int option;
88
(** SETTINGS_MAX_HEADER_LIST_SIZE (no limit by default). *)
89
+
no_rfc7540_priorities : bool;
90
+
(** SETTINGS_NO_RFC7540_PRIORITIES (RFC 9113 Section 5.3.2, default false). *)
91
}
92
93
val default_settings : settings
+5
lib/h2/h2_frame.ml
+5
lib/h2/h2_frame.ml
···
217
| Initial_window_size of int32
218
| Max_frame_size of int
219
| Max_header_list_size of int
220
| Unknown_setting of int * int32
221
222
let setting_to_pair = function
···
226
| Initial_window_size n -> (0x4, n)
227
| Max_frame_size n -> (0x5, Int32.of_int n)
228
| Max_header_list_size n -> (0x6, Int32.of_int n)
229
| Unknown_setting (id, value) -> (id, value)
230
231
let setting_of_pair id value =
···
236
| 0x4 -> Initial_window_size value
237
| 0x5 -> Max_frame_size (Int32.to_int value)
238
| 0x6 -> Max_header_list_size (Int32.to_int value)
239
| _ -> Unknown_setting (id, value)
240
241
let pp_setting ppf s =
···
252
Format.fprintf ppf "MAX_FRAME_SIZE=%d" n
253
| Max_header_list_size n ->
254
Format.fprintf ppf "MAX_HEADER_LIST_SIZE=%d" n
255
| Unknown_setting (id, value) ->
256
Format.fprintf ppf "UNKNOWN(%d)=%ld" id value
257
···
217
| Initial_window_size of int32
218
| Max_frame_size of int
219
| Max_header_list_size of int
220
+
| No_rfc7540_priorities of bool (** RFC 9113 Section 5.3.2: Deprecate RFC 7540 priorities *)
221
| Unknown_setting of int * int32
222
223
let setting_to_pair = function
···
227
| Initial_window_size n -> (0x4, n)
228
| Max_frame_size n -> (0x5, Int32.of_int n)
229
| Max_header_list_size n -> (0x6, Int32.of_int n)
230
+
| No_rfc7540_priorities b -> (0x9, if b then 1l else 0l)
231
| Unknown_setting (id, value) -> (id, value)
232
233
let setting_of_pair id value =
···
238
| 0x4 -> Initial_window_size value
239
| 0x5 -> Max_frame_size (Int32.to_int value)
240
| 0x6 -> Max_header_list_size (Int32.to_int value)
241
+
| 0x9 -> No_rfc7540_priorities (value <> 0l)
242
| _ -> Unknown_setting (id, value)
243
244
let pp_setting ppf s =
···
255
Format.fprintf ppf "MAX_FRAME_SIZE=%d" n
256
| Max_header_list_size n ->
257
Format.fprintf ppf "MAX_HEADER_LIST_SIZE=%d" n
258
+
| No_rfc7540_priorities b ->
259
+
Format.fprintf ppf "NO_RFC7540_PRIORITIES=%b" b
260
| Unknown_setting (id, value) ->
261
Format.fprintf ppf "UNKNOWN(%d)=%ld" id value
262
+1
lib/h2/h2_frame.mli
+1
lib/h2/h2_frame.mli
···
176
| Initial_window_size of int32 (** 0x04 - Initial flow control window *)
177
| Max_frame_size of int (** 0x05 - Maximum frame payload size *)
178
| Max_header_list_size of int (** 0x06 - Maximum header list size *)
179
| Unknown_setting of int * int32 (** Unknown setting (id, value) *)
180
181
val setting_to_pair : setting -> int * int32
···
176
| Initial_window_size of int32 (** 0x04 - Initial flow control window *)
177
| Max_frame_size of int (** 0x05 - Maximum frame payload size *)
178
| Max_header_list_size of int (** 0x06 - Maximum header list size *)
179
+
| No_rfc7540_priorities of bool (** 0x09 - RFC 9113: Deprecate RFC 7540 priorities *)
180
| Unknown_setting of int * int32 (** Unknown setting (id, value) *)
181
182
val setting_to_pair : setting -> int * int32
+1
test/test_h2_client.ml
+1
test/test_h2_client.ml