anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
recommendations
+234
-127
lib/error.ml
+234
-127
lib/error.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Centralized error handling for the Requests library *)
6
+
(** Centralized error handling for the Requests library using Eio.Io exceptions *)
7
7
8
8
let src = Logs.Src.create "requests.error" ~doc:"HTTP Request Errors"
9
9
module Log = (val Logs.src_log src : Logs.LOG)
10
10
11
-
(** {1 Exception Types} *)
11
+
(** {1 Error Type}
12
+
13
+
Following the Eio.Io exception pattern for structured error handling.
14
+
Each variant contains a record with contextual information. *)
15
+
16
+
type error =
17
+
(* Timeout errors *)
18
+
| Timeout of { operation: string; duration: float option }
19
+
20
+
(* Redirect errors *)
21
+
| Too_many_redirects of { url: string; count: int; max: int }
22
+
| Invalid_redirect of { url: string; reason: string }
23
+
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
+
34
+
(* Authentication errors *)
35
+
| Authentication_failed of { url: string; reason: string }
36
+
37
+
(* Connection errors - granular breakdown per Recommendation #17 *)
38
+
| Dns_resolution_failed of { hostname: string }
39
+
| Tcp_connect_failed of { host: string; port: int; reason: string }
40
+
| Tls_handshake_failed of { host: string; reason: string }
41
+
42
+
(* Security-related errors *)
43
+
| Invalid_header of { name: string; reason: string }
44
+
| Body_too_large of { limit: int64; actual: int64 option }
45
+
| Headers_too_large of { limit: int; actual: int }
46
+
| Decompression_bomb of { limit: int64; ratio: float }
47
+
| Content_length_mismatch of { expected: int64; actual: int64 }
48
+
49
+
(* Other errors *)
50
+
| Proxy_error of { host: string; reason: string }
51
+
| Encoding_error of { encoding: string; reason: string }
52
+
| Invalid_url of { url: string; reason: string }
53
+
| Invalid_request of { reason: string }
54
+
55
+
(** {1 URL and Credential Sanitization}
56
+
57
+
Per Recommendation #20: Remove sensitive info from error messages *)
58
+
59
+
let sanitize_url url =
60
+
try
61
+
let uri = Uri.of_string url in
62
+
let sanitized = Uri.with_userinfo uri None in
63
+
Uri.to_string sanitized
64
+
with _ -> url (* If parsing fails, return original *)
65
+
66
+
(** List of header names considered sensitive (lowercase) *)
67
+
let sensitive_header_names =
68
+
["authorization"; "cookie"; "proxy-authorization"; "x-api-key"; "api-key"; "set-cookie"]
69
+
70
+
(** Check if a header name is sensitive (case-insensitive) *)
71
+
let is_sensitive_header name =
72
+
List.mem (String.lowercase_ascii name) sensitive_header_names
73
+
74
+
(** Sanitize a header list by redacting sensitive values *)
75
+
let sanitize_headers headers =
76
+
List.map (fun (name, value) ->
77
+
if is_sensitive_header name then (name, "[REDACTED]")
78
+
else (name, value)
79
+
) headers
80
+
81
+
(** {1 Pretty Printing} *)
82
+
83
+
let pp_error ppf = function
84
+
| Timeout { operation; duration } ->
85
+
(match duration with
86
+
| Some d -> Format.fprintf ppf "Timeout during %s after %.2fs" operation d
87
+
| None -> Format.fprintf ppf "Timeout during %s" operation)
88
+
89
+
| Too_many_redirects { url; count; max } ->
90
+
Format.fprintf ppf "Too many redirects (%d/%d) for URL: %s" count max (sanitize_url url)
91
+
92
+
| Invalid_redirect { url; reason } ->
93
+
Format.fprintf ppf "Invalid redirect to %s: %s" (sanitize_url url) reason
94
+
95
+
| Http_error { url; status; reason; body_preview; headers = _ } ->
96
+
Format.fprintf ppf "@[<v>HTTP %d %s@ URL: %s" status reason (sanitize_url url);
97
+
Option.iter (fun body ->
98
+
let preview = if String.length body > 200
99
+
then String.sub body 0 200 ^ "..."
100
+
else body in
101
+
Format.fprintf ppf "@ Body: %s" preview
102
+
) body_preview;
103
+
Format.fprintf ppf "@]"
104
+
105
+
| Authentication_failed { url; reason } ->
106
+
Format.fprintf ppf "Authentication failed for %s: %s" (sanitize_url url) reason
107
+
108
+
| Dns_resolution_failed { hostname } ->
109
+
Format.fprintf ppf "DNS resolution failed for hostname: %s" hostname
110
+
111
+
| Tcp_connect_failed { host; port; reason } ->
112
+
Format.fprintf ppf "TCP connection to %s:%d failed: %s" host port reason
113
+
114
+
| Tls_handshake_failed { host; reason } ->
115
+
Format.fprintf ppf "TLS handshake with %s failed: %s" host reason
116
+
117
+
| Invalid_header { name; reason } ->
118
+
Format.fprintf ppf "Invalid header '%s': %s" name reason
119
+
120
+
| Body_too_large { limit; actual } ->
121
+
(match actual with
122
+
| Some a -> Format.fprintf ppf "Response body too large: %Ld bytes (limit: %Ld)" a limit
123
+
| None -> Format.fprintf ppf "Response body exceeds limit of %Ld bytes" limit)
124
+
125
+
| Headers_too_large { limit; actual } ->
126
+
Format.fprintf ppf "Response headers too large: %d (limit: %d)" actual limit
127
+
128
+
| Decompression_bomb { limit; ratio } ->
129
+
Format.fprintf ppf "Decompression bomb detected: ratio %.1f:1 exceeds limit, max size %Ld bytes"
130
+
ratio limit
131
+
132
+
| Content_length_mismatch { expected; actual } ->
133
+
Format.fprintf ppf "Content-Length mismatch: expected %Ld bytes, received %Ld bytes"
134
+
expected actual
135
+
136
+
| Proxy_error { host; reason } ->
137
+
Format.fprintf ppf "Proxy error for %s: %s" host reason
138
+
139
+
| Encoding_error { encoding; reason } ->
140
+
Format.fprintf ppf "Encoding error (%s): %s" encoding reason
141
+
142
+
| Invalid_url { url; reason } ->
143
+
Format.fprintf ppf "Invalid URL '%s': %s" (sanitize_url url) reason
144
+
145
+
| Invalid_request { reason } ->
146
+
Format.fprintf ppf "Invalid request: %s" reason
147
+
148
+
(** {1 Eio.Exn Integration}
149
+
150
+
Following the pattern from ocaml-conpool for structured Eio exceptions *)
151
+
152
+
type Eio.Exn.err += E of error
153
+
154
+
let err e = Eio.Exn.create (E e)
155
+
156
+
let () =
157
+
Eio.Exn.register_pp (fun f -> function
158
+
| E e ->
159
+
Format.fprintf f "Requests: ";
160
+
pp_error f e;
161
+
true
162
+
| _ -> false)
163
+
164
+
(** {1 Query Functions}
165
+
166
+
Per Recommendation #17: Enable smarter retry logic and error handling *)
167
+
168
+
let is_timeout = function
169
+
| Timeout _ -> true
170
+
| _ -> false
171
+
172
+
let is_dns = function
173
+
| Dns_resolution_failed _ -> true
174
+
| _ -> false
175
+
176
+
let is_tls = function
177
+
| Tls_handshake_failed _ -> true
178
+
| _ -> false
179
+
180
+
let is_connection = function
181
+
| Dns_resolution_failed _ -> true
182
+
| Tcp_connect_failed _ -> true
183
+
| Tls_handshake_failed _ -> true
184
+
| _ -> false
185
+
186
+
let is_http_error = function
187
+
| Http_error _ -> true
188
+
| _ -> false
189
+
190
+
let is_client_error = function
191
+
| Http_error { status; _ } -> status >= 400 && status < 500
192
+
| Authentication_failed _ -> true
193
+
| Invalid_url _ -> true
194
+
| Invalid_request _ -> true
195
+
| Invalid_header _ -> true
196
+
| _ -> false
12
197
13
-
exception Timeout
14
-
exception TooManyRedirects of { url: string; count: int; max: int }
15
-
exception ConnectionError of string
16
-
exception HTTPError of {
17
-
url: string;
18
-
status: int;
19
-
reason: string;
20
-
body: string option;
21
-
headers: Headers.t
22
-
}
23
-
exception AuthenticationError of string
24
-
exception SSLError of string
25
-
exception ProxyError of string
26
-
exception EncodingError of string
27
-
exception InvalidURL of string
28
-
exception InvalidRequest of string
198
+
let is_server_error = function
199
+
| Http_error { status; _ } -> status >= 500 && status < 600
200
+
| _ -> false
29
201
30
-
(** {1 Error Type} *)
202
+
let is_retryable = function
203
+
| Timeout _ -> true
204
+
| Dns_resolution_failed _ -> true
205
+
| Tcp_connect_failed _ -> true
206
+
| Tls_handshake_failed _ -> true
207
+
| Http_error { status; _ } ->
208
+
(* Retryable status codes: 408, 429, 500, 502, 503, 504 *)
209
+
List.mem status [408; 429; 500; 502; 503; 504]
210
+
| Proxy_error _ -> true
211
+
| _ -> false
31
212
32
-
type t = [
33
-
| `Timeout
34
-
| `TooManyRedirects of string * int * int (* url, count, max *)
35
-
| `ConnectionError of string
36
-
| `HTTPError of string * int * string * string option * Headers.t (* url, status, reason, body, headers *)
37
-
| `AuthenticationError of string
38
-
| `SSLError of string
39
-
| `ProxyError of string
40
-
| `EncodingError of string
41
-
| `InvalidURL of string
42
-
| `InvalidRequest of string
43
-
| `UnknownError of string
44
-
]
213
+
let is_security_error = function
214
+
| Invalid_header _ -> true
215
+
| Body_too_large _ -> true
216
+
| Headers_too_large _ -> true
217
+
| Decompression_bomb _ -> true
218
+
| Invalid_redirect _ -> true
219
+
| _ -> false
220
+
221
+
(** {1 Error Extraction}
45
222
46
-
(** {1 Conversion Functions} *)
223
+
Extract error from Eio.Io exception *)
47
224
48
-
let of_exn = function
49
-
| Timeout -> Some `Timeout
50
-
| TooManyRedirects { url; count; max } ->
51
-
Some (`TooManyRedirects (url, count, max))
52
-
| ConnectionError msg -> Some (`ConnectionError msg)
53
-
| HTTPError { url; status; reason; body; headers } ->
54
-
Some (`HTTPError (url, status, reason, body, headers))
55
-
| AuthenticationError msg -> Some (`AuthenticationError msg)
56
-
| SSLError msg -> Some (`SSLError msg)
57
-
| ProxyError msg -> Some (`ProxyError msg)
58
-
| EncodingError msg -> Some (`EncodingError msg)
59
-
| InvalidURL msg -> Some (`InvalidURL msg)
60
-
| InvalidRequest msg -> Some (`InvalidRequest msg)
225
+
let of_eio_exn = function
226
+
| Eio.Io (E e, _) -> Some e
61
227
| _ -> None
62
228
63
-
let to_exn = function
64
-
| `Timeout -> Timeout
65
-
| `TooManyRedirects (url, count, max) ->
66
-
TooManyRedirects { url; count; max }
67
-
| `ConnectionError msg -> ConnectionError msg
68
-
| `HTTPError (url, status, reason, body, headers) ->
69
-
HTTPError { url; status; reason; body; headers }
70
-
| `AuthenticationError msg -> AuthenticationError msg
71
-
| `SSLError msg -> SSLError msg
72
-
| `ProxyError msg -> ProxyError msg
73
-
| `EncodingError msg -> EncodingError msg
74
-
| `InvalidURL msg -> InvalidURL msg
75
-
| `InvalidRequest msg -> InvalidRequest msg
76
-
| `UnknownError msg -> Failure msg
229
+
(** {1 HTTP Status Helpers} *)
230
+
231
+
let get_http_status = function
232
+
| Http_error { status; _ } -> Some status
233
+
| _ -> None
234
+
235
+
let get_url = function
236
+
| Too_many_redirects { url; _ } -> Some url
237
+
| Invalid_redirect { url; _ } -> Some url
238
+
| Http_error { url; _ } -> Some url
239
+
| Authentication_failed { url; _ } -> Some url
240
+
| Invalid_url { url; _ } -> Some url
241
+
| _ -> None
77
242
78
-
let raise error = Stdlib.raise (to_exn error)
243
+
(** {1 Result Combinators} *)
79
244
80
-
(** {1 Combinators} *)
245
+
type 'a result = ('a, error) Result.t
81
246
82
247
let catch f =
83
248
try Ok (f ())
84
249
with
85
-
| exn ->
86
-
match of_exn exn with
87
-
| Some err -> Error err
88
-
| None -> Error (`UnknownError (Printexc.to_string exn))
89
-
90
-
let catch_async f = catch f (* In Eio, regular catch works for async too *)
250
+
| Eio.Io (E e, _) -> Error e
251
+
| exn -> Error (Invalid_request { reason = Printexc.to_string exn })
91
252
92
253
let map f = function
93
254
| Ok x -> Ok (f x)
···
105
266
106
267
let get_exn = function
107
268
| Ok x -> x
108
-
| Error e -> raise e
269
+
| Error e -> raise (err e)
109
270
110
271
let get_or ~default = function
111
272
| Ok x -> x
112
273
| Error _ -> default
113
274
114
-
let is_retryable = function
115
-
| `Timeout -> true
116
-
| `ConnectionError _ -> true
117
-
| `HTTPError (_, status, _, _, _) -> Status.is_retryable (Status.of_int status)
118
-
| `SSLError _ -> true
119
-
| `ProxyError _ -> true
120
-
| _ -> false
121
-
122
-
let is_client_error = function
123
-
| `HTTPError (_, status, _, _, _) -> Status.is_client_error (Status.of_int status)
124
-
| `AuthenticationError _
125
-
| `InvalidURL _
126
-
| `InvalidRequest _ -> true
127
-
| _ -> false
128
-
129
-
let is_server_error = function
130
-
| `HTTPError (_, status, _, _, _) -> Status.is_server_error (Status.of_int status)
131
-
| _ -> false
132
-
275
+
(** {1 String Conversion} *)
133
276
134
-
(** {1 Pretty Printing} *)
135
-
136
-
let pp ppf = function
137
-
| `Timeout ->
138
-
Format.fprintf ppf "@[<2>Request Timeout:@ The request timed out@]"
139
-
| `TooManyRedirects (url, count, max) ->
140
-
Format.fprintf ppf "@[<2>Too Many Redirects:@ Exceeded maximum redirects (%d/%d) for URL: %s@]"
141
-
count max url
142
-
| `ConnectionError msg ->
143
-
Format.fprintf ppf "@[<2>Connection Error:@ %s@]" msg
144
-
| `HTTPError (url, status, reason, body, _headers) ->
145
-
Format.fprintf ppf "@[<v>@[<2>HTTP Error %d (%s):@ URL: %s@]" status reason url;
146
-
Option.iter (fun b ->
147
-
Format.fprintf ppf "@,@[<2>Response Body:@ %s@]" b
148
-
) body;
149
-
Format.fprintf ppf "@]"
150
-
| `AuthenticationError msg ->
151
-
Format.fprintf ppf "@[<2>Authentication Error:@ %s@]" msg
152
-
| `SSLError msg ->
153
-
Format.fprintf ppf "@[<2>SSL/TLS Error:@ %s@]" msg
154
-
| `ProxyError msg ->
155
-
Format.fprintf ppf "@[<2>Proxy Error:@ %s@]" msg
156
-
| `EncodingError msg ->
157
-
Format.fprintf ppf "@[<2>Encoding Error:@ %s@]" msg
158
-
| `InvalidURL msg ->
159
-
Format.fprintf ppf "@[<2>Invalid URL:@ %s@]" msg
160
-
| `InvalidRequest msg ->
161
-
Format.fprintf ppf "@[<2>Invalid Request:@ %s@]" msg
162
-
| `UnknownError msg ->
163
-
Format.fprintf ppf "@[<2>Unknown Error:@ %s@]" msg
164
-
165
-
let pp_exn ppf exn =
166
-
match of_exn exn with
167
-
| Some err -> pp ppf err
168
-
| None -> Format.fprintf ppf "%s" (Printexc.to_string exn)
169
-
170
-
let to_string error =
171
-
Format.asprintf "%a" pp error
277
+
let to_string e =
278
+
Format.asprintf "%a" pp_error e
172
279
173
280
(** {1 Syntax Module} *)
174
281
···
176
283
let ( let* ) x f = bind f x
177
284
let ( let+ ) x f = map f x
178
285
let ( and* ) = both
179
-
end
286
+
end
+141
-82
lib/error.mli
+141
-82
lib/error.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Centralized error handling for the Requests library *)
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 handling,
9
+
providing granular error types and query functions for smart retry logic.
10
+
11
+
{2 Usage}
12
+
13
+
Errors are raised using the Eio.Io pattern:
14
+
{[
15
+
raise (Error.err (Error.Timeout { operation = "connect"; duration = Some 30.0 }))
16
+
]}
17
+
18
+
To catch and handle errors:
19
+
{[
20
+
try
21
+
(* ... HTTP request ... *)
22
+
with
23
+
| Eio.Io (Error.E e, _) when Error.is_retryable e ->
24
+
(* Retry the request *)
25
+
| Eio.Io (Error.E e, _) ->
26
+
Printf.eprintf "Request failed: %s\n" (Error.to_string e)
27
+
]}
28
+
*)
7
29
8
30
(** Log source for error reporting *)
9
31
val src : Logs.Src.t
10
32
11
-
(** {1 Exception Types} *)
33
+
(** {1 Error Type}
12
34
13
-
(** Raised when a request times out *)
14
-
exception Timeout
35
+
Granular error variants with contextual information.
36
+
Each variant contains a record with relevant details. *)
15
37
16
-
(** Raised when too many redirects are encountered *)
17
-
exception TooManyRedirects of { url: string; count: int; max: int }
38
+
type error =
39
+
(* Timeout errors *)
40
+
| Timeout of { operation: string; duration: float option }
18
41
19
-
(** Raised when a connection error occurs *)
20
-
exception ConnectionError of string
42
+
(* Redirect errors *)
43
+
| Too_many_redirects of { url: string; count: int; max: int }
44
+
| Invalid_redirect of { url: string; reason: string }
21
45
22
-
(** Raised when an HTTP error response is received *)
23
-
exception HTTPError of {
24
-
url: string;
25
-
status: int;
26
-
reason: string;
27
-
body: string option;
28
-
headers: Headers.t
29
-
}
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
+
}
30
55
31
-
(** Raised when authentication fails *)
32
-
exception AuthenticationError of string
56
+
(* Authentication errors *)
57
+
| Authentication_failed of { url: string; reason: string }
33
58
34
-
(** Raised when there's an SSL/TLS error *)
35
-
exception SSLError of string
59
+
(* Connection errors - granular breakdown *)
60
+
| Dns_resolution_failed of { hostname: string }
61
+
| Tcp_connect_failed of { host: string; port: int; reason: string }
62
+
| Tls_handshake_failed of { host: string; reason: string }
36
63
37
-
(** Raised when proxy connection fails *)
38
-
exception ProxyError of string
64
+
(* Security-related errors *)
65
+
| Invalid_header of { name: string; reason: string }
66
+
| Body_too_large of { limit: int64; actual: int64 option }
67
+
| Headers_too_large of { limit: int; actual: int }
68
+
| Decompression_bomb of { limit: int64; ratio: float }
69
+
| Content_length_mismatch of { expected: int64; actual: int64 }
39
70
40
-
(** Raised when content encoding/decoding fails *)
41
-
exception EncodingError of string
71
+
(* Other errors *)
72
+
| Proxy_error of { host: string; reason: string }
73
+
| Encoding_error of { encoding: string; reason: string }
74
+
| Invalid_url of { url: string; reason: string }
75
+
| Invalid_request of { reason: string }
76
+
77
+
(** {1 Eio.Exn Integration} *)
78
+
79
+
(** Extension of [Eio.Exn.err] for Requests errors *)
80
+
type Eio.Exn.err += E of error
81
+
82
+
(** Create an Eio exception from an error.
83
+
Usage: [raise (err (Timeout { operation = "read"; duration = Some 5.0 }))] *)
84
+
val err : error -> exn
85
+
86
+
(** {1 URL and Credential Sanitization} *)
87
+
88
+
(** Remove userinfo (username:password) from a URL for safe logging *)
89
+
val sanitize_url : string -> string
90
+
91
+
(** Redact sensitive headers (Authorization, Cookie, etc.) for safe logging.
92
+
Takes and returns a list of (name, value) pairs. *)
93
+
val sanitize_headers : (string * string) list -> (string * string) list
94
+
95
+
(** Check if a header name is sensitive (case-insensitive) *)
96
+
val is_sensitive_header : string -> bool
97
+
98
+
(** {1 Pretty Printing} *)
99
+
100
+
(** Pretty printer for error values *)
101
+
val pp_error : Format.formatter -> error -> unit
102
+
103
+
(** {1 Query Functions}
104
+
105
+
These functions enable smart error handling without pattern matching. *)
106
+
107
+
(** Returns [true] if the error is a timeout *)
108
+
val is_timeout : error -> bool
42
109
43
-
(** Raised when an invalid URL is provided *)
44
-
exception InvalidURL of string
110
+
(** Returns [true] if the error is a DNS resolution failure *)
111
+
val is_dns : error -> bool
45
112
46
-
(** Raised when request is invalid *)
47
-
exception InvalidRequest of string
113
+
(** Returns [true] if the error is a TLS handshake failure *)
114
+
val is_tls : error -> bool
48
115
49
-
(** {1 Error Type} *)
116
+
(** Returns [true] if the error is any connection-related failure
117
+
(DNS, TCP connect, or TLS handshake) *)
118
+
val is_connection : error -> bool
50
119
51
-
(** Unified error type for result-based error handling *)
52
-
type t = [
53
-
| `Timeout
54
-
| `TooManyRedirects of string * int * int (* url, count, max *)
55
-
| `ConnectionError of string
56
-
| `HTTPError of string * int * string * string option * Headers.t (* url, status, reason, body, headers *)
57
-
| `AuthenticationError of string
58
-
| `SSLError of string
59
-
| `ProxyError of string
60
-
| `EncodingError of string
61
-
| `InvalidURL of string
62
-
| `InvalidRequest of string
63
-
| `UnknownError of string
64
-
]
120
+
(** Returns [true] if the error is an HTTP response error *)
121
+
val is_http_error : error -> bool
65
122
66
-
(** {1 Conversion Functions} *)
123
+
(** Returns [true] if the error is a client error (4xx status or similar) *)
124
+
val is_client_error : error -> bool
67
125
68
-
(** Convert an exception to an error type *)
69
-
val of_exn : exn -> t option
126
+
(** Returns [true] if the error is a server error (5xx status) *)
127
+
val is_server_error : error -> bool
70
128
71
-
(** Convert an error type to an exception *)
72
-
val to_exn : t -> exn
129
+
(** Returns [true] if the error is typically retryable.
130
+
Retryable errors include: timeouts, connection errors,
131
+
and certain HTTP status codes (408, 429, 500, 502, 503, 504) *)
132
+
val is_retryable : error -> bool
73
133
74
-
(** Raise an error as an exception *)
75
-
val raise : t -> 'a
134
+
(** Returns [true] if the error is security-related
135
+
(header injection, body too large, decompression bomb, etc.) *)
136
+
val is_security_error : error -> bool
76
137
77
-
(** {1 Combinators} *)
138
+
(** {1 Error Extraction} *)
78
139
79
-
(** Wrap a function that may raise exceptions into a result type *)
80
-
val catch : (unit -> 'a) -> ('a, t) result
140
+
(** Extract error from an Eio.Io exception, if it's a Requests error *)
141
+
val of_eio_exn : exn -> error option
81
142
82
-
(** Wrap an async function that may raise exceptions *)
83
-
val catch_async : (unit -> 'a) -> ('a, t) result
143
+
(** {1 HTTP Status Helpers} *)
84
144
85
-
(** Map over the success case of a result *)
86
-
val map : ('a -> 'b) -> ('a, t) result -> ('b, t) result
145
+
(** Get the HTTP status code from an error, if applicable *)
146
+
val get_http_status : error -> int option
87
147
88
-
(** Bind for result types with error *)
89
-
val bind : ('a -> ('b, t) result) -> ('a, t) result -> ('b, t) result
148
+
(** Get the URL associated with an error, if applicable *)
149
+
val get_url : error -> string option
90
150
91
-
(** Applicative operator for combining results *)
92
-
val both : ('a, t) result -> ('b, t) result -> ('a * 'b, t) result
151
+
(** {1 Result Type and Combinators} *)
93
152
94
-
(** Get value or raise the error *)
95
-
val get_exn : ('a, t) result -> 'a
153
+
(** Result type for error handling *)
154
+
type 'a result = ('a, error) Result.t
96
155
97
-
(** Get value or use default *)
98
-
val get_or : default:'a -> ('a, t) result -> 'a
156
+
(** Wrap a function that may raise Eio.Io exceptions into a result type *)
157
+
val catch : (unit -> 'a) -> 'a result
99
158
100
-
(** Check if error is retryable *)
101
-
val is_retryable : t -> bool
159
+
(** Map over the success case of a result *)
160
+
val map : ('a -> 'b) -> 'a result -> 'b result
102
161
103
-
(** Check if error is a client error (4xx) *)
104
-
val is_client_error : t -> bool
162
+
(** Bind for result types with error *)
163
+
val bind : ('a -> 'b result) -> 'a result -> 'b result
105
164
106
-
(** Check if error is a server error (5xx) *)
107
-
val is_server_error : t -> bool
165
+
(** Applicative operator for combining results *)
166
+
val both : 'a result -> 'b result -> ('a * 'b) result
108
167
109
-
(** {1 Pretty Printing} *)
168
+
(** Get value or raise the error as an Eio exception *)
169
+
val get_exn : 'a result -> 'a
110
170
111
-
(** Pretty printer for errors *)
112
-
val pp : Format.formatter -> t -> unit
171
+
(** Get value or use default *)
172
+
val get_or : default:'a -> 'a result -> 'a
113
173
114
-
(** Pretty printer for exceptions (falls back to Printexc if not a known exception) *)
115
-
val pp_exn : Format.formatter -> exn -> unit
174
+
(** {1 String Conversion} *)
116
175
117
-
(** Convert error to string *)
118
-
val to_string : t -> string
176
+
(** Convert error to human-readable string *)
177
+
val to_string : error -> string
119
178
120
179
(** {1 Syntax Module} *)
121
180
122
181
(** Syntax module for let-operators *)
123
182
module Syntax : sig
124
183
(** Bind operator for result types *)
125
-
val ( let* ) : ('a, t) result -> ('a -> ('b, t) result) -> ('b, t) result
184
+
val ( let* ) : 'a result -> ('a -> 'b result) -> 'b result
126
185
127
186
(** Map operator for result types *)
128
-
val ( let+ ) : ('a, t) result -> ('a -> 'b) -> ('b, t) result
187
+
val ( let+ ) : 'a result -> ('a -> 'b) -> 'b result
129
188
130
189
(** Both operator for combining results *)
131
-
val ( and* ) : ('a, t) result -> ('b, t) result -> ('a * 'b, t) result
132
-
end
190
+
val ( and* ) : 'a result -> 'b result -> ('a * 'b) result
191
+
end
+28
lib/headers.ml
+28
lib/headers.ml
···
15
15
16
16
let normalize_key k = String.lowercase_ascii k
17
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 module.
24
+
The error will be caught and wrapped appropriately by higher-level code. *)
25
+
26
+
exception Invalid_header of { name: string; reason: string }
27
+
28
+
let validate_header_name name =
29
+
if String.contains name '\r' || String.contains name '\n' then
30
+
raise (Invalid_header {
31
+
name;
32
+
reason = "Header name contains CR/LF characters (potential HTTP smuggling)"
33
+
})
34
+
35
+
let validate_header_value name value =
36
+
if String.contains value '\r' || String.contains value '\n' then
37
+
raise (Invalid_header {
38
+
name;
39
+
reason = "Header value contains CR/LF characters (potential HTTP smuggling)"
40
+
})
41
+
18
42
let add key value t =
43
+
validate_header_name key;
44
+
validate_header_value key value;
19
45
let nkey = normalize_key key in
20
46
let existing =
21
47
match StringMap.find_opt nkey t with
···
26
52
StringMap.add nkey (key, existing @ [value]) t
27
53
28
54
let set key value t =
55
+
validate_header_name key;
56
+
validate_header_value key value;
29
57
let nkey = normalize_key key in
30
58
StringMap.add nkey (key, [value]) t
31
59
+14
-2
lib/headers.mli
+14
-2
lib/headers.mli
···
40
40
(** [to_list headers] converts headers to an association list.
41
41
The order of headers is preserved. *)
42
42
43
+
(** {1 Header Injection Prevention} *)
44
+
45
+
exception Invalid_header of { name: string; reason: string }
46
+
(** Raised when a header name or value contains invalid characters (CR/LF)
47
+
that could enable HTTP request smuggling attacks. *)
48
+
43
49
(** {1 Manipulation} *)
44
50
45
51
val add : string -> string -> t -> t
46
52
(** [add name value headers] adds a header value. Multiple values
47
-
for the same header name are allowed (e.g., for Set-Cookie). *)
53
+
for the same header name are allowed (e.g., for Set-Cookie).
54
+
55
+
@raise Invalid_header if the header name or value contains CR/LF characters
56
+
(to prevent HTTP header injection attacks). *)
48
57
49
58
val set : string -> string -> t -> t
50
59
(** [set name value headers] sets a header value, replacing any
51
-
existing values for that header name. *)
60
+
existing values for that header name.
61
+
62
+
@raise Invalid_header if the header name or value contains CR/LF characters
63
+
(to prevent HTTP header injection attacks). *)
52
64
53
65
val get : string -> t -> string option
54
66
(** [get name headers] returns the first value for a header name,
+148
-29
lib/http_client.ml
+148
-29
lib/http_client.ml
···
8
8
let src = Logs.Src.create "requests.http_client" ~doc:"Low-level HTTP client"
9
9
module Log = (val Logs.src_log src : Logs.LOG)
10
10
11
-
(** Decompression support using the decompress library *)
11
+
(** {1 Response Limits Configuration}
12
+
13
+
Per Recommendation #2: Configurable limits for response body size,
14
+
header count, and header length to prevent DoS attacks. *)
15
+
16
+
type limits = {
17
+
max_response_body_size: int64; (** Maximum response body size in bytes *)
18
+
max_header_size: int; (** Maximum size of a single header line *)
19
+
max_header_count: int; (** Maximum number of headers *)
20
+
max_decompressed_size: int64; (** Maximum decompressed size *)
21
+
max_compression_ratio: float; (** Maximum compression ratio allowed *)
22
+
}
23
+
24
+
let default_limits = {
25
+
max_response_body_size = 104_857_600L; (* 100MB *)
26
+
max_header_size = 16_384; (* 16KB *)
27
+
max_header_count = 100;
28
+
max_decompressed_size = 104_857_600L; (* 100MB *)
29
+
max_compression_ratio = 100.0; (* 100:1 *)
30
+
}
31
+
32
+
(** {1 Decompression Support} *)
12
33
13
34
(** Decompress gzip-encoded data *)
14
35
let decompress_gzip data =
···
93
114
Log.warn (fun m -> m "Zlib decompression failed: %s" e);
94
115
Error e
95
116
96
-
(** Decompress body based on Content-Encoding header *)
97
-
let decompress_body ~content_encoding body =
117
+
(** {1 Decompression Bomb Prevention}
118
+
119
+
Per Recommendation #25: Check decompressed size and ratio limits *)
120
+
121
+
let check_decompression_limits ~limits ~compressed_size decompressed =
122
+
let decompressed_size = Int64.of_int (String.length decompressed) in
123
+
let compressed_size_i64 = Int64.of_int compressed_size in
124
+
125
+
(* Check absolute size *)
126
+
if decompressed_size > limits.max_decompressed_size then begin
127
+
let ratio = Int64.to_float decompressed_size /. Int64.to_float compressed_size_i64 in
128
+
raise (Error.err (Error.Decompression_bomb {
129
+
limit = limits.max_decompressed_size;
130
+
ratio
131
+
}))
132
+
end;
133
+
134
+
(* Check ratio - only if compressed size is > 0 to avoid division by zero *)
135
+
if compressed_size > 0 then begin
136
+
let ratio = Int64.to_float decompressed_size /. Int64.to_float compressed_size_i64 in
137
+
if ratio > limits.max_compression_ratio then
138
+
raise (Error.err (Error.Decompression_bomb {
139
+
limit = limits.max_decompressed_size;
140
+
ratio
141
+
}))
142
+
end;
143
+
144
+
decompressed
145
+
146
+
(** Decompress body based on Content-Encoding header with limits *)
147
+
let decompress_body ~limits ~content_encoding body =
98
148
let encoding = String.lowercase_ascii (String.trim content_encoding) in
149
+
let compressed_size = String.length body in
99
150
match encoding with
100
151
| "gzip" | "x-gzip" ->
101
152
(match decompress_gzip body with
102
-
| Ok decompressed -> decompressed
153
+
| Ok decompressed -> check_decompression_limits ~limits ~compressed_size decompressed
103
154
| Error _ -> body) (* Fall back to raw body on error *)
104
155
| "deflate" ->
105
156
(* "deflate" in HTTP can mean either raw DEFLATE or zlib-wrapped.
106
157
Many servers send zlib-wrapped data despite the spec. Try zlib first,
107
158
then fall back to raw deflate. *)
108
159
(match decompress_zlib body with
109
-
| Ok decompressed -> decompressed
160
+
| Ok decompressed -> check_decompression_limits ~limits ~compressed_size decompressed
110
161
| Error _ ->
111
162
match decompress_deflate body with
112
-
| Ok decompressed -> decompressed
163
+
| Ok decompressed -> check_decompression_limits ~limits ~compressed_size decompressed
113
164
| Error _ -> body)
114
165
| "identity" | "" -> body
115
166
| other ->
116
167
Log.warn (fun m -> m "Unknown Content-Encoding '%s', returning raw body" other);
117
168
body
169
+
170
+
(** {1 Request Building} *)
118
171
119
172
(** Build HTTP/1.1 request as a string *)
120
173
let build_request ~method_ ~uri ~headers ~body_str =
···
128
181
129
182
let host = match Uri.host uri with
130
183
| Some h -> h
131
-
| None -> failwith "URI must have a host"
184
+
| None -> raise (Error.err (Error.Invalid_url {
185
+
url = Uri.to_string uri;
186
+
reason = "URI must have a host"
187
+
}))
132
188
in
133
189
134
190
(* RFC 7230: default ports should be omitted from Host header *)
···
169
225
170
226
request_line ^ headers_str ^ "\r\n" ^ body_str
171
227
228
+
(** {1 Response Parsing} *)
229
+
172
230
(** Parse HTTP response status line *)
173
231
let parse_status_line line =
174
232
match String.split_on_char ' ' line with
175
233
| "HTTP/1.1" :: code :: _ | "HTTP/1.0" :: code :: _ ->
176
234
(try int_of_string code
177
-
with _ -> failwith ("Invalid status code: " ^ code))
178
-
| _ -> failwith ("Invalid status line: " ^ line)
235
+
with _ -> raise (Error.err (Error.Invalid_request {
236
+
reason = "Invalid status code: " ^ code
237
+
})))
238
+
| _ -> raise (Error.err (Error.Invalid_request {
239
+
reason = "Invalid status line: " ^ line
240
+
}))
241
+
242
+
(** Parse HTTP headers from buffer reader with limits
179
243
180
-
(** Parse HTTP headers from buffer reader *)
181
-
let parse_headers buf_read =
182
-
let rec read_headers acc =
244
+
Per Recommendation #2: Enforce header count and size limits *)
245
+
let parse_headers ~limits buf_read =
246
+
let rec read_headers acc count =
183
247
let line = Eio.Buf_read.line buf_read in
248
+
249
+
(* Check for end of headers *)
184
250
if line = "" then List.rev acc
185
251
else begin
252
+
(* Check header count limit *)
253
+
if count >= limits.max_header_count then
254
+
raise (Error.err (Error.Headers_too_large {
255
+
limit = limits.max_header_count;
256
+
actual = count + 1
257
+
}));
258
+
259
+
(* Check header line size limit *)
260
+
if String.length line > limits.max_header_size then
261
+
raise (Error.err (Error.Headers_too_large {
262
+
limit = limits.max_header_size;
263
+
actual = String.length line
264
+
}));
265
+
186
266
match String.index_opt line ':' with
187
-
| None -> read_headers acc
267
+
| None -> read_headers acc (count + 1)
188
268
| Some idx ->
189
269
let name = String.sub line 0 idx |> String.trim |> String.lowercase_ascii in
190
270
let value = String.sub line (idx + 1) (String.length line - idx - 1) |> String.trim in
191
-
read_headers ((name, value) :: acc)
271
+
read_headers ((name, value) :: acc) (count + 1)
192
272
end
193
273
in
194
-
read_headers [] |> Headers.of_list
274
+
read_headers [] 0 |> Headers.of_list
195
275
196
-
(** Read body with Content-Length *)
197
-
let read_fixed_body buf_read length =
276
+
(** Read body with Content-Length and size limit
277
+
278
+
Per Recommendation #26: Validate Content-Length matches actual body size
279
+
Per Recommendation #2: Enforce body size limits *)
280
+
let read_fixed_body ~limits buf_read length =
281
+
(* Check size limit before allocating *)
282
+
if length > limits.max_response_body_size then
283
+
raise (Error.err (Error.Body_too_large {
284
+
limit = limits.max_response_body_size;
285
+
actual = Some length
286
+
}));
287
+
198
288
let buf = Buffer.create (Int64.to_int length) in
289
+
let bytes_read = ref 0L in
290
+
199
291
let rec read_n remaining =
200
292
if remaining > 0L then begin
201
293
let to_read = min 8192 (Int64.to_int remaining) in
202
294
let chunk = Eio.Buf_read.take to_read buf_read in
203
-
Buffer.add_string buf chunk;
204
-
read_n (Int64.sub remaining (Int64.of_int (String.length chunk)))
295
+
let chunk_len = String.length chunk in
296
+
297
+
if chunk_len = 0 then
298
+
(* Connection closed prematurely - Content-Length mismatch *)
299
+
raise (Error.err (Error.Content_length_mismatch {
300
+
expected = length;
301
+
actual = !bytes_read
302
+
}))
303
+
else begin
304
+
Buffer.add_string buf chunk;
305
+
bytes_read := Int64.add !bytes_read (Int64.of_int chunk_len);
306
+
read_n (Int64.sub remaining (Int64.of_int chunk_len))
307
+
end
205
308
end
206
309
in
207
310
read_n length;
208
311
Buffer.contents buf
209
312
210
-
(** Read chunked body *)
211
-
let read_chunked_body buf_read =
313
+
(** Read chunked body with size limit
314
+
315
+
Per Recommendation #2: Enforce body size limits *)
316
+
let read_chunked_body ~limits buf_read =
212
317
let buf = Buffer.create 4096 in
318
+
let total_size = ref 0L in
319
+
213
320
let rec read_chunks () =
214
321
let size_line = Eio.Buf_read.line buf_read in
215
322
(* Parse hex chunk size, ignore extensions after ';' *)
···
218
325
| None -> size_line
219
326
in
220
327
let chunk_size = int_of_string ("0x" ^ size_str) in
328
+
221
329
if chunk_size = 0 then begin
222
330
(* Read trailing headers (if any) until empty line *)
223
331
let rec skip_trailers () =
···
226
334
in
227
335
skip_trailers ()
228
336
end else begin
337
+
(* Check size limit before reading chunk *)
338
+
let new_total = Int64.add !total_size (Int64.of_int chunk_size) in
339
+
if new_total > limits.max_response_body_size then
340
+
raise (Error.err (Error.Body_too_large {
341
+
limit = limits.max_response_body_size;
342
+
actual = Some new_total
343
+
}));
344
+
229
345
let chunk = Eio.Buf_read.take chunk_size buf_read in
230
346
Buffer.add_string buf chunk;
347
+
total_size := new_total;
231
348
let _crlf = Eio.Buf_read.line buf_read in (* Read trailing CRLF *)
232
349
read_chunks ()
233
350
end
234
351
in
235
352
read_chunks ();
236
353
Buffer.contents buf
354
+
355
+
(** {1 Request Execution} *)
237
356
238
357
(** Make HTTP request over a pooled connection *)
239
-
let make_request ~method_ ~uri ~headers ~body_str flow =
358
+
let make_request ?(limits=default_limits) ~method_ ~uri ~headers ~body_str flow =
240
359
Log.debug (fun m -> m "Making %s request to %s" method_ (Uri.to_string uri));
241
360
242
361
(* Build and send request *)
···
252
371
253
372
Log.debug (fun m -> m "Received response status: %d" status);
254
373
255
-
(* Parse headers *)
256
-
let resp_headers = parse_headers buf_read in
374
+
(* Parse headers with limits *)
375
+
let resp_headers = parse_headers ~limits buf_read in
257
376
258
377
(* Determine how to read body *)
259
378
let transfer_encoding = Headers.get "transfer-encoding" resp_headers in
···
262
381
let body_str = match transfer_encoding, content_length with
263
382
| Some te, _ when String.lowercase_ascii te |> String.trim = "chunked" ->
264
383
Log.debug (fun m -> m "Reading chunked response body");
265
-
read_chunked_body buf_read
384
+
read_chunked_body ~limits buf_read
266
385
| _, Some len ->
267
386
Log.debug (fun m -> m "Reading fixed-length response body (%Ld bytes)" len);
268
-
read_fixed_body buf_read len
387
+
read_fixed_body ~limits buf_read len
269
388
| Some other_te, None ->
270
389
Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" other_te);
271
390
""
···
277
396
(status, resp_headers, body_str)
278
397
279
398
(** Make HTTP request with optional auto-decompression *)
280
-
let make_request_decompress ~method_ ~uri ~headers ~body_str ~auto_decompress flow =
281
-
let (status, resp_headers, body_str) = make_request ~method_ ~uri ~headers ~body_str flow in
399
+
let make_request_decompress ?(limits=default_limits) ~method_ ~uri ~headers ~body_str ~auto_decompress flow =
400
+
let (status, resp_headers, body_str) = make_request ~limits ~method_ ~uri ~headers ~body_str flow in
282
401
if auto_decompress then
283
402
let body_str = match Headers.get "content-encoding" resp_headers with
284
-
| Some encoding -> decompress_body ~content_encoding:encoding body_str
403
+
| Some encoding -> decompress_body ~limits ~content_encoding:encoding body_str
285
404
| None -> body_str
286
405
in
287
406
(* Remove Content-Encoding header after decompression since body is now uncompressed *)
+71
-30
lib/one.ml
+71
-30
lib/one.ml
···
24
24
(scheme1 = "http" && scheme2 = "https")
25
25
| _ -> false
26
26
27
-
(* Strip sensitive headers for cross-origin redirects to prevent credential leakage *)
27
+
(* Strip sensitive headers for cross-origin redirects to prevent credential leakage
28
+
Per Recommendation #1: Also strip Cookie, Proxy-Authorization, WWW-Authenticate *)
28
29
let strip_sensitive_headers headers =
29
30
headers
30
31
|> Headers.remove "Authorization"
32
+
|> Headers.remove "Cookie"
33
+
|> Headers.remove "Proxy-Authorization"
34
+
|> Headers.remove "WWW-Authenticate"
35
+
36
+
(* Validate redirect URL scheme to prevent SSRF attacks
37
+
Per Recommendation #5: Only allow http:// and https:// schemes *)
38
+
let allowed_redirect_schemes = ["http"; "https"]
39
+
40
+
let validate_redirect_url location =
41
+
let uri = Uri.of_string location in
42
+
match Uri.scheme uri with
43
+
| Some scheme when List.mem (String.lowercase_ascii scheme) allowed_redirect_schemes ->
44
+
Ok uri
45
+
| Some scheme ->
46
+
Error (Error.err (Error.Invalid_redirect {
47
+
url = location;
48
+
reason = Printf.sprintf "Disallowed redirect scheme: %s" scheme
49
+
}))
50
+
| None ->
51
+
Ok uri (* Relative URLs are OK - they will be resolved against current URL *)
31
52
32
53
(* Helper to create TCP connection to host:port *)
33
54
let connect_tcp ~sw ~net ~host ~port =
···
43
64
Log.err (fun m -> m "%s" msg);
44
65
failwith msg
45
66
67
+
(** Minimum TLS version configuration.
68
+
Per Recommendation #6: Allow enforcing minimum TLS version. *)
69
+
type tls_version =
70
+
| TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *)
71
+
| TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *)
72
+
73
+
let tls_version_to_tls = function
74
+
| TLS_1_2 -> `TLS_1_2
75
+
| TLS_1_3 -> `TLS_1_3
76
+
46
77
(* Helper to wrap connection with TLS if needed *)
47
-
let wrap_tls flow ~host ~verify_tls ~tls_config =
78
+
let wrap_tls flow ~host ~verify_tls ~tls_config ~min_tls_version =
48
79
Log.debug (fun m -> m "Wrapping connection with TLS for %s (verify=%b)" host verify_tls);
49
80
50
-
(* Get or create TLS config *)
81
+
(* Get or create TLS config with minimum version enforcement *)
82
+
let min_version = tls_version_to_tls min_tls_version in
51
83
let tls_cfg = match tls_config, verify_tls with
52
84
| Some cfg, _ -> cfg
53
85
| None, true ->
54
-
(* Use CA certificates for verification *)
86
+
(* Use CA certificates for verification with minimum TLS version *)
55
87
(match Ca_certs.authenticator () with
56
88
| Ok authenticator ->
57
-
(match Tls.Config.client ~authenticator () with
89
+
(match Tls.Config.client ~authenticator ~version:(min_version, `TLS_1_3) () with
58
90
| Ok cfg -> cfg
59
91
| Error (`Msg msg) ->
60
92
Log.err (fun m -> m "Failed to create TLS config: %s" msg);
···
63
95
Log.err (fun m -> m "Failed to load CA certificates: %s" msg);
64
96
failwith ("CA certificates error: " ^ msg))
65
97
| None, false ->
66
-
(* No verification *)
67
-
match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
98
+
(* No verification but still enforce minimum TLS version *)
99
+
match Tls.Config.client
100
+
~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None)
101
+
~version:(min_version, `TLS_1_3)
102
+
() with
68
103
| Ok cfg -> cfg
69
104
| Error (`Msg msg) -> failwith ("TLS config error: " ^ msg)
70
105
in
···
84
119
(Tls_eio.client_of_flow ~host:domain tls_cfg flow :> [`Close | `Flow | `R | `Shutdown | `W] Eio.Resource.t)
85
120
86
121
(* Parse URL and connect directly (no pooling) *)
87
-
let connect_to_url ~sw ~clock ~net ~url ~timeout ~verify_tls ~tls_config =
122
+
let connect_to_url ~sw ~clock ~net ~url ~timeout ~verify_tls ~tls_config ~min_tls_version =
88
123
let uri = Uri.of_string url in
89
124
90
125
(* Extract host and port *)
···
101
136
let connect_fn () =
102
137
let tcp_flow = connect_tcp ~sw ~net ~host ~port in
103
138
if is_https then
104
-
wrap_tls tcp_flow ~host ~verify_tls ~tls_config
139
+
wrap_tls tcp_flow ~host ~verify_tls ~tls_config ~min_tls_version
105
140
else
106
141
(tcp_flow :> [`Close | `Flow | `R | `Shutdown | `W] Eio.Resource.t)
107
142
in
···
115
150
(* Main request implementation - completely stateless *)
116
151
let request ~sw ~clock ~net ?headers ?body ?auth ?timeout
117
152
?(follow_redirects = true) ?(max_redirects = 10)
118
-
?(verify_tls = true) ?tls_config ?(auto_decompress = true) ~method_ url =
153
+
?(verify_tls = true) ?tls_config ?(auto_decompress = true)
154
+
?(min_tls_version = TLS_1_2) ~method_ url =
119
155
120
156
let start_time = Unix.gettimeofday () in
121
157
let method_str = Method.to_string method_ in
···
156
192
157
193
(* Connect to URL (opens new TCP connection) *)
158
194
let flow = connect_to_url ~sw ~clock ~net ~url:url_to_fetch
159
-
~timeout ~verify_tls ~tls_config in
195
+
~timeout ~verify_tls ~tls_config ~min_tls_version in
160
196
161
197
(* Make HTTP request using low-level client with optional auto-decompression *)
162
198
let status, resp_headers, response_body_str =
···
171
207
if follow_redirects && (status >= 300 && status < 400) then begin
172
208
if redirects_left <= 0 then begin
173
209
Log.err (fun m -> m "Too many redirects (%d) for %s" max_redirects url);
174
-
raise (Error.TooManyRedirects { url; count = max_redirects; max = max_redirects })
210
+
raise (Error.err (Error.Too_many_redirects { url; count = max_redirects; max = max_redirects }))
175
211
end;
176
212
177
213
match Headers.get "location" resp_headers with
···
179
215
Log.debug (fun m -> m "Redirect response missing Location header");
180
216
(status, resp_headers, response_body_str, url_to_fetch)
181
217
| Some location ->
218
+
(* Validate redirect URL scheme - Per Recommendation #5 *)
219
+
(match validate_redirect_url location with
220
+
| Error exn -> raise exn
221
+
| Ok _ -> ());
222
+
182
223
Log.info (fun m -> m "Following redirect to %s (%d remaining)" location redirects_left);
183
224
(* Strip sensitive headers on cross-origin redirects (security)
184
-
Following Python requests behavior: auth headers should not leak to other hosts *)
225
+
Per Recommendation #1: Strip auth headers to prevent credential leakage *)
185
226
let redirect_uri = Uri.of_string location in
186
227
let headers_for_redirect =
187
228
if same_origin original_uri redirect_uri then
188
229
headers_for_request
189
230
else begin
190
-
Log.debug (fun m -> m "Cross-origin redirect detected: stripping Authorization header");
231
+
Log.debug (fun m -> m "Cross-origin redirect detected: stripping sensitive headers");
191
232
strip_sensitive_headers headers_for_request
192
233
end
193
234
in
···
216
257
217
258
(* Convenience methods *)
218
259
let get ~sw ~clock ~net ?headers ?auth ?timeout
219
-
?follow_redirects ?max_redirects ?verify_tls ?tls_config url =
260
+
?follow_redirects ?max_redirects ?verify_tls ?tls_config ?min_tls_version url =
220
261
request ~sw ~clock ~net ?headers ?auth ?timeout
221
-
?follow_redirects ?max_redirects ?verify_tls ?tls_config
262
+
?follow_redirects ?max_redirects ?verify_tls ?tls_config ?min_tls_version
222
263
~method_:`GET url
223
264
224
265
let post ~sw ~clock ~net ?headers ?body ?auth ?timeout
225
-
?verify_tls ?tls_config url =
266
+
?verify_tls ?tls_config ?min_tls_version url =
226
267
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
227
-
?verify_tls ?tls_config ~method_:`POST url
268
+
?verify_tls ?tls_config ?min_tls_version ~method_:`POST url
228
269
229
270
let put ~sw ~clock ~net ?headers ?body ?auth ?timeout
230
-
?verify_tls ?tls_config url =
271
+
?verify_tls ?tls_config ?min_tls_version url =
231
272
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
232
-
?verify_tls ?tls_config ~method_:`PUT url
273
+
?verify_tls ?tls_config ?min_tls_version ~method_:`PUT url
233
274
234
275
let delete ~sw ~clock ~net ?headers ?auth ?timeout
235
-
?verify_tls ?tls_config url =
276
+
?verify_tls ?tls_config ?min_tls_version url =
236
277
request ~sw ~clock ~net ?headers ?auth ?timeout
237
-
?verify_tls ?tls_config ~method_:`DELETE url
278
+
?verify_tls ?tls_config ?min_tls_version ~method_:`DELETE url
238
279
239
280
let head ~sw ~clock ~net ?headers ?auth ?timeout
240
-
?verify_tls ?tls_config url =
281
+
?verify_tls ?tls_config ?min_tls_version url =
241
282
request ~sw ~clock ~net ?headers ?auth ?timeout
242
-
?verify_tls ?tls_config ~method_:`HEAD url
283
+
?verify_tls ?tls_config ?min_tls_version ~method_:`HEAD url
243
284
244
285
let patch ~sw ~clock ~net ?headers ?body ?auth ?timeout
245
-
?verify_tls ?tls_config url =
286
+
?verify_tls ?tls_config ?min_tls_version url =
246
287
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
247
-
?verify_tls ?tls_config ~method_:`PATCH url
288
+
?verify_tls ?tls_config ?min_tls_version ~method_:`PATCH url
248
289
249
290
let upload ~sw ~clock ~net ?headers ?auth ?timeout ?method_ ?mime ?length
250
-
?on_progress ?verify_tls ?tls_config ~source url =
291
+
?on_progress ?verify_tls ?tls_config ?min_tls_version ~source url =
251
292
let method_ = Option.value method_ ~default:`POST in
252
293
let mime = Option.value mime ~default:Mime.octet_stream in
253
294
···
264
305
265
306
let body = Body.of_stream ?length mime tracked_source in
266
307
request ~sw ~clock ~net ?headers ~body ?auth ?timeout
267
-
?verify_tls ?tls_config ~method_ url
308
+
?verify_tls ?tls_config ?min_tls_version ~method_ url
268
309
269
310
let download ~sw ~clock ~net ?headers ?auth ?timeout ?on_progress
270
-
?verify_tls ?tls_config url ~sink =
311
+
?verify_tls ?tls_config ?min_tls_version url ~sink =
271
312
let response = get ~sw ~clock ~net ?headers ?auth ?timeout
272
-
?verify_tls ?tls_config url in
313
+
?verify_tls ?tls_config ?min_tls_version url in
273
314
274
315
try
275
316
(* Get content length for progress tracking *)
+20
-2
lib/one.mli
+20
-2
lib/one.mli
···
46
46
(** Log source for one-shot request operations *)
47
47
val src : Logs.Src.t
48
48
49
+
(** {1 TLS Configuration} *)
50
+
51
+
(** Minimum TLS version configuration.
52
+
Per security recommendations, allows enforcing minimum TLS version. *)
53
+
type tls_version =
54
+
| TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *)
55
+
| TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *)
56
+
49
57
(** {1 HTTP Request Methods}
50
58
51
59
All functions are stateless - they open a new TCP connection for each request
···
64
72
?verify_tls:bool ->
65
73
?tls_config:Tls.Config.client ->
66
74
?auto_decompress:bool ->
75
+
?min_tls_version:tls_version ->
67
76
method_:Method.t ->
68
77
string ->
69
78
Response.t
70
79
(** [request ~sw ~clock ~net ?headers ?body ?auth ?timeout ?follow_redirects
71
-
?max_redirects ?verify_tls ?tls_config ?auto_decompress ~method_ url] makes
72
-
a single HTTP request without connection pooling.
80
+
?max_redirects ?verify_tls ?tls_config ?auto_decompress ?min_tls_version
81
+
~method_ url] makes a single HTTP request without connection pooling.
73
82
74
83
Each call opens a new TCP connection (with TLS if https://), makes the
75
84
request, and closes the connection when the switch closes.
···
86
95
@param verify_tls Whether to verify TLS certificates (default: true)
87
96
@param tls_config Custom TLS configuration (default: system CA certs)
88
97
@param auto_decompress Whether to automatically decompress gzip/deflate responses (default: true)
98
+
@param min_tls_version Minimum TLS version to accept (default: TLS_1_2)
89
99
@param method_ HTTP method (GET, POST, etc.)
90
100
@param url URL to request
91
101
*)
···
101
111
?max_redirects:int ->
102
112
?verify_tls:bool ->
103
113
?tls_config:Tls.Config.client ->
114
+
?min_tls_version:tls_version ->
104
115
string ->
105
116
Response.t
106
117
(** GET request. See {!request} for parameter details. *)
···
115
126
?timeout:Timeout.t ->
116
127
?verify_tls:bool ->
117
128
?tls_config:Tls.Config.client ->
129
+
?min_tls_version:tls_version ->
118
130
string ->
119
131
Response.t
120
132
(** POST request. See {!request} for parameter details. *)
···
129
141
?timeout:Timeout.t ->
130
142
?verify_tls:bool ->
131
143
?tls_config:Tls.Config.client ->
144
+
?min_tls_version:tls_version ->
132
145
string ->
133
146
Response.t
134
147
(** PUT request. See {!request} for parameter details. *)
···
142
155
?timeout:Timeout.t ->
143
156
?verify_tls:bool ->
144
157
?tls_config:Tls.Config.client ->
158
+
?min_tls_version:tls_version ->
145
159
string ->
146
160
Response.t
147
161
(** DELETE request. See {!request} for parameter details. *)
···
155
169
?timeout:Timeout.t ->
156
170
?verify_tls:bool ->
157
171
?tls_config:Tls.Config.client ->
172
+
?min_tls_version:tls_version ->
158
173
string ->
159
174
Response.t
160
175
(** HEAD request. See {!request} for parameter details. *)
···
169
184
?timeout:Timeout.t ->
170
185
?verify_tls:bool ->
171
186
?tls_config:Tls.Config.client ->
187
+
?min_tls_version:tls_version ->
172
188
string ->
173
189
Response.t
174
190
(** PATCH request. See {!request} for parameter details. *)
···
186
202
?on_progress:(sent:int64 -> total:int64 option -> unit) ->
187
203
?verify_tls:bool ->
188
204
?tls_config:Tls.Config.client ->
205
+
?min_tls_version:tls_version ->
189
206
source:Eio.Flow.source_ty Eio.Resource.t ->
190
207
string ->
191
208
Response.t
···
201
218
?on_progress:(received:int64 -> total:int64 option -> unit) ->
202
219
?verify_tls:bool ->
203
220
?tls_config:Tls.Config.client ->
221
+
?min_tls_version:tls_version ->
204
222
string ->
205
223
sink:Eio.Flow.sink_ty Eio.Resource.t ->
206
224
unit
+70
-12
lib/requests.ml
+70
-12
lib/requests.ml
···
21
21
module Error = Error
22
22
module Retry = Retry
23
23
24
+
(** Minimum TLS version configuration.
25
+
Per Recommendation #6: Allow enforcing minimum TLS version. *)
26
+
type tls_version =
27
+
| TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *)
28
+
| TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *)
29
+
30
+
let tls_version_to_tls = function
31
+
| TLS_1_2 -> `TLS_1_2
32
+
| TLS_1_3 -> `TLS_1_3
33
+
24
34
(* Note: RNG initialization should be done by the application using
25
35
Mirage_crypto_rng_unix.initialize before calling Eio_main.run.
26
36
We don't call use_default() here as it spawns background threads
···
69
79
?(max_redirects = 10)
70
80
?(verify_tls = true)
71
81
?tls_config
82
+
?(min_tls_version = TLS_1_2)
72
83
?(max_connections_per_host = 10)
73
84
?(connection_idle_timeout = 60.0)
74
85
?(connection_lifetime = 300.0)
···
87
98
| None, false -> None
88
99
in
89
100
90
-
(* Create TLS config for HTTPS pool if needed *)
101
+
(* Create TLS config for HTTPS pool if needed
102
+
Per Recommendation #6: Enforce minimum TLS version *)
103
+
let min_version = tls_version_to_tls min_tls_version in
91
104
let tls_config = match tls_config, verify_tls with
92
105
| Some cfg, _ -> Some cfg
93
106
| None, true ->
94
-
(* Use CA certificates for verification *)
107
+
(* Use CA certificates for verification with minimum TLS version *)
95
108
(match Ca_certs.authenticator () with
96
109
| Ok authenticator ->
97
-
(match Tls.Config.client ~authenticator () with
110
+
(match Tls.Config.client ~authenticator ~version:(min_version, `TLS_1_3) () with
98
111
| Ok cfg -> Some cfg
99
112
| Error (`Msg msg) ->
100
113
Log.warn (fun m -> m "Failed to create TLS config: %s" msg);
···
102
115
| Error (`Msg msg) ->
103
116
Log.warn (fun m -> m "Failed to load CA certificates: %s" msg);
104
117
None)
105
-
| None, false -> None
118
+
| None, false ->
119
+
(* No verification but still enforce minimum TLS version *)
120
+
(match Tls.Config.client
121
+
~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None)
122
+
~version:(min_version, `TLS_1_3)
123
+
() with
124
+
| Ok cfg -> Some cfg
125
+
| Error (`Msg msg) ->
126
+
Log.warn (fun m -> m "Failed to create TLS config: %s" msg);
127
+
None)
106
128
in
107
129
108
130
(* Create connection pools if not provided *)
···
207
229
(scheme1 = "http" && scheme2 = "https")
208
230
| _ -> false
209
231
210
-
(* Strip sensitive headers for cross-origin redirects to prevent credential leakage *)
232
+
(* Strip sensitive headers for cross-origin redirects to prevent credential leakage
233
+
Per Recommendation #1: Also strip Cookie, Proxy-Authorization, WWW-Authenticate *)
211
234
let strip_sensitive_headers headers =
212
235
headers
213
236
|> Headers.remove "Authorization"
237
+
|> Headers.remove "Cookie"
238
+
|> Headers.remove "Proxy-Authorization"
239
+
|> Headers.remove "WWW-Authenticate"
240
+
241
+
(* Validate redirect URL scheme to prevent SSRF attacks
242
+
Per Recommendation #5: Only allow http:// and https:// schemes *)
243
+
let allowed_redirect_schemes = ["http"; "https"]
244
+
245
+
let validate_redirect_url location =
246
+
let uri = Uri.of_string location in
247
+
match Uri.scheme uri with
248
+
| Some scheme when List.mem (String.lowercase_ascii scheme) allowed_redirect_schemes ->
249
+
Ok uri
250
+
| Some scheme ->
251
+
Error (Error.err (Error.Invalid_redirect {
252
+
url = location;
253
+
reason = Printf.sprintf "Disallowed redirect scheme: %s" scheme
254
+
}))
255
+
| None ->
256
+
Ok uri (* Relative URLs are OK - they will be resolved against current URL *)
214
257
215
258
(* Internal request function using connection pools *)
216
259
let make_request_internal (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
···
387
430
if follow && (status >= 300 && status < 400) then begin
388
431
if redirects_left <= 0 then begin
389
432
Log.err (fun m -> m "Too many redirects (%d) for %s" max_redir url);
390
-
raise (Error.TooManyRedirects { url; count = max_redir; max = max_redir })
433
+
raise (Error.err (Error.Too_many_redirects { url; count = max_redir; max = max_redir }))
391
434
end;
392
435
393
436
match Headers.get "location" resp_headers with
···
395
438
Log.debug (fun m -> m "Redirect response missing Location header");
396
439
(status, resp_headers, response_body_str, url_to_fetch)
397
440
| Some location ->
441
+
(* Validate redirect URL scheme - Per Recommendation #5 *)
442
+
(match validate_redirect_url location with
443
+
| Error exn -> raise exn
444
+
| Ok _ -> ());
445
+
398
446
(* Resolve relative redirects against the current URL *)
399
447
let location_uri = Uri.of_string location in
400
448
let absolute_location =
···
409
457
in
410
458
Log.info (fun m -> m "Following redirect to %s (%d remaining)" absolute_location redirects_left);
411
459
(* Strip sensitive headers on cross-origin redirects (security)
412
-
Following Python requests behavior: auth headers should not leak to other hosts *)
460
+
Per Recommendation #1: Strip auth headers to prevent credential leakage *)
413
461
let redirect_uri = Uri.of_string absolute_location in
414
462
let headers_for_redirect =
415
463
if same_origin original_uri redirect_uri then
416
464
headers_for_request
417
465
else begin
418
-
Log.debug (fun m -> m "Cross-origin redirect detected: stripping Authorization header");
466
+
Log.debug (fun m -> m "Cross-origin redirect detected: stripping sensitive headers");
419
467
strip_sensitive_headers headers_for_request
420
468
end
421
469
in
···
516
564
with_digest_handling response
517
565
| Some retry_config ->
518
566
(* Wrap in retry logic *)
567
+
(* Check if an Eio.Io exception is retryable using the new error types *)
519
568
let should_retry_exn = function
520
-
| Error.Timeout -> true
521
-
| Error.ConnectionError _ -> true
522
-
| Error.SSLError _ -> true
569
+
| Eio.Io (Error.E e, _) -> Error.is_retryable e
570
+
| Eio.Time.Timeout -> true
523
571
| _ -> false
524
572
in
525
573
···
540
588
if attempt <= retry_config.Retry.max_retries &&
541
589
Retry.should_retry ~config:retry_config ~method_ ~status
542
590
then begin
543
-
let delay = Retry.calculate_backoff ~config:retry_config ~attempt in
591
+
(* Per Recommendation #4: Use Retry-After header when available *)
592
+
let delay =
593
+
if retry_config.respect_retry_after && (status = 429 || status = 503) then
594
+
match Response.header "retry-after" response with
595
+
| Some value ->
596
+
Retry.parse_retry_after value
597
+
|> Option.value ~default:(Retry.calculate_backoff ~config:retry_config ~attempt)
598
+
| None -> Retry.calculate_backoff ~config:retry_config ~attempt
599
+
else
600
+
Retry.calculate_backoff ~config:retry_config ~attempt
601
+
in
544
602
Log.warn (fun m -> m "Request returned status %d (attempt %d/%d). Retrying in %.2f seconds..."
545
603
status attempt (retry_config.Retry.max_retries + 1) delay);
546
604
Eio.Time.sleep t.clock delay;
+10
lib/requests.mli
+10
lib/requests.mli
···
208
208
connection pools across requests. The clock and network resources are
209
209
existentially quantified and hidden behind this abstract type. *)
210
210
211
+
(** {2 TLS Configuration} *)
212
+
213
+
type tls_version =
214
+
| TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *)
215
+
| TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *)
216
+
(** Minimum TLS version to require for HTTPS connections.
217
+
Per Recommendation #6: Allow enforcing minimum TLS version for security. *)
218
+
211
219
(** {2 Creation and Configuration} *)
212
220
213
221
val create :
···
222
230
?max_redirects:int ->
223
231
?verify_tls:bool ->
224
232
?tls_config:Tls.Config.client ->
233
+
?min_tls_version:tls_version ->
225
234
?max_connections_per_host:int ->
226
235
?connection_idle_timeout:float ->
227
236
?connection_lifetime:float ->
···
245
254
@param max_redirects Maximum redirects to follow (default: 10)
246
255
@param verify_tls Whether to verify TLS certificates (default: true)
247
256
@param tls_config Custom TLS configuration for HTTPS pool (default: system CA certs)
257
+
@param min_tls_version Minimum TLS version to require (default: TLS_1_2)
248
258
@param max_connections_per_host Maximum pooled connections per host:port (default: 10)
249
259
@param connection_idle_timeout Max idle time before closing pooled connection (default: 60s)
250
260
@param connection_lifetime Max lifetime of any pooled connection (default: 300s)
+4
-4
lib/response.ml
+4
-4
lib/response.ml
···
80
80
81
81
let raise_for_status t =
82
82
if t.status >= 400 then
83
-
raise (Error.HTTPError {
83
+
raise (Error.err (Error.Http_error {
84
84
url = t.url;
85
85
status = t.status;
86
86
reason = Status.reason_phrase (Status.of_int t.status);
87
-
body = None;
88
-
headers = t.headers;
89
-
})
87
+
body_preview = None;
88
+
headers = Headers.to_list t.headers; (* Convert to list for error type *)
89
+
}))
90
90
else
91
91
t
92
92