gazagnaire.org
forked from
anil.recoil.org/ocaml-requests
A batteries included HTTP/1.1 client in OCaml
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
9let src = Logs.Src.create "requests.error" ~doc:"HTTP Request Errors"
10
11module 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
18type 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
104let 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) *)
113let 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) *)
127let is_sensitive_header name =
128 List.mem (String.lowercase_ascii name) sensitive_header_names
129
130(** Sanitize a header list by redacting sensitive values *)
131let 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
139let 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
239type Eio.Exn.err += E of t
240
241let err e = Eio.Exn.create (E e)
242
243let () =
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
255let is_timeout = function Timeout _ -> true | _ -> false
256let is_dns = function Dns_resolution_failed _ -> true | _ -> false
257let is_tls = function Tls_handshake_failed _ -> true | _ -> false
258
259let is_connection = function
260 | Dns_resolution_failed _ -> true
261 | Tcp_connect_failed _ -> true
262 | Tls_handshake_failed _ -> true
263 | _ -> false
264
265let is_http_error = function Http_error _ -> true | _ -> false
266
267let 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
275let is_server_error = function
276 | Http_error { status; _ } -> status >= 500 && status < 600
277 | _ -> false
278
279let 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
290let 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
299let is_json_error = function
300 | Json_parse_error _ -> true
301 | Json_encode_error _ -> true
302 | _ -> false
303
304let 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
312let 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
323let 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
331let is_h2_stream_error = function
332 | H2_stream_error _ -> true
333 | H2_flow_control_error { stream_id = Some _ } -> true
334 | _ -> false
335
336let 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
346let 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
352let 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
362let of_eio_exn = function Eio.Io (E e, _) -> Some e | _ -> None
363
364(** {1 HTTP Status Helpers} *)
365
366let http_status = function Http_error { status; _ } -> Some status | _ -> None
367
368let 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
378let pp = pp_error
379let 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
386let invalid_request ~reason = err (Invalid_request { reason })
387let invalid_redirect ~url ~reason = err (Invalid_redirect { url; reason })
388let invalid_url ~url ~reason = err (Invalid_url { url; reason })
389let timeout ~operation ?duration () = err (Timeout { operation; duration })
390let body_too_large ~limit ?actual () = err (Body_too_large { limit; actual })
391let headers_too_large ~limit ~actual = err (Headers_too_large { limit; actual })
392let proxy_error ~host ~reason = err (Proxy_error { host; reason })
393
394let tls_handshake_failed ~host ~reason =
395 err (Tls_handshake_failed { host; reason })
396
397let 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
405let invalid_requestf fmt =
406 Fmt.kstr (fun reason -> err (Invalid_request { reason })) fmt
407
408let invalid_redirectf ~url fmt =
409 Fmt.kstr (fun reason -> err (Invalid_redirect { url; reason })) fmt
410
411let invalid_urlf ~url fmt =
412 Fmt.kstr (fun reason -> err (Invalid_url { url; reason })) fmt
413
414let proxy_errorf ~host fmt =
415 Fmt.kstr (fun reason -> err (Proxy_error { host; reason })) fmt
416
417let tls_handshake_failedf ~host fmt =
418 Fmt.kstr (fun reason -> err (Tls_handshake_failed { host; reason })) fmt
419
420let 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
425let oauth_error ~error_code ?description ?uri () =
426 err (Oauth_error { error_code; description; uri })
427
428let token_refresh_failed ~reason = err (Token_refresh_failed { reason })
429let 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
437let h2_protocol_error ~code ~message = err (H2_protocol_error { code; message })
438
439let h2_stream_error ~stream_id ~code ~message =
440 err (H2_stream_error { stream_id; code; message })
441
442let h2_flow_control_error ?stream_id () =
443 err (H2_flow_control_error { stream_id })
444
445let h2_compression_error ~message = err (H2_compression_error { message })
446let h2_settings_timeout () = err H2_settings_timeout
447
448let h2_goaway ~last_stream_id ~code ~debug =
449 err (H2_goaway { last_stream_id; code; debug })
450
451let h2_frame_error ~frame_type ~message =
452 err (H2_frame_error { frame_type; message })
453
454let 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
463let 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