anil.recoil.org
My aggregated monorepo of OCaml code, automaintained
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
8let src = Logs.Src.create "requests.error" ~doc:"HTTP Request Errors"
9module Log = (val Logs.src_log src : Logs.LOG)
10
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
16type 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 | Insecure_auth of { url: string; auth_type: string }
49 (** Per RFC 7617 Section 4 and RFC 6750 Section 5.1:
50 Basic, Bearer, and Digest authentication over unencrypted HTTP
51 exposes credentials to eavesdropping. *)
52
53 (* JSON errors *)
54 | Json_parse_error of { body_preview: string; reason: string }
55 | Json_encode_error of { reason: string }
56
57 (* Other errors *)
58 | Proxy_error of { host: string; reason: string }
59 | Encoding_error of { encoding: string; reason: string }
60 | Invalid_url of { url: string; reason: string }
61 | Invalid_request of { reason: string }
62
63 (* OAuth 2.0 errors - per RFC 6749 Section 5.2 *)
64 | Oauth_error of { error_code: string; description: string option; uri: string option }
65 (** OAuth 2.0 error response from authorization server.
66 Per {{:https://datatracker.ietf.org/doc/html/rfc6749#section-5.2}RFC 6749 Section 5.2}. *)
67 | Token_refresh_failed of { reason: string }
68 (** Token refresh operation failed. *)
69 | Token_expired
70 (** Access token has expired and no refresh token is available. *)
71
72 (* HTTP/2 protocol errors - per RFC 9113 *)
73 | H2_protocol_error of { code: int32; message: string }
74 (** HTTP/2 connection error per
75 {{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.4.1}RFC 9113 Section 5.4.1}.
76 Error codes are defined in RFC 9113 Section 7. *)
77 | H2_stream_error of { stream_id: int32; code: int32; message: string }
78 (** HTTP/2 stream error per
79 {{:https://datatracker.ietf.org/doc/html/rfc9113#section-5.4.2}RFC 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 Section 5.2}. *)
83 | H2_compression_error of { message: string }
84 (** HPACK decompression failed per
85 {{:https://datatracker.ietf.org/doc/html/rfc7541}RFC 7541}. *)
86 | H2_settings_timeout
87 (** SETTINGS acknowledgment timeout per
88 {{:https://datatracker.ietf.org/doc/html/rfc9113#section-6.5.3}RFC 9113 Section 6.5.3}. *)
89 | H2_goaway of { last_stream_id: int32; code: int32; debug: string }
90 (** Server sent GOAWAY frame per
91 {{:https://datatracker.ietf.org/doc/html/rfc9113#section-6.8}RFC 9113 Section 6.8}. *)
92 | H2_frame_error of { frame_type: int; message: string }
93 (** Invalid frame received per RFC 9113 Section 4-6. *)
94 | H2_header_validation_error of { message: string }
95 (** HTTP/2 header validation failed per RFC 9113 Section 8.2-8.3. *)
96
97(** {1 URL and Credential Sanitization}
98
99 Per Recommendation #20: Remove sensitive info from error messages *)
100
101let sanitize_url url =
102 try
103 let uri = Uri.of_string url in
104 let sanitized = Uri.with_userinfo uri None in
105 Uri.to_string sanitized
106 with _ -> url (* If parsing fails, return original *)
107
108(** List of header names considered sensitive (lowercase) *)
109let sensitive_header_names =
110 ["authorization"; "cookie"; "proxy-authorization"; "x-api-key"; "api-key"; "set-cookie"]
111
112(** Check if a header name is sensitive (case-insensitive) *)
113let is_sensitive_header name =
114 List.mem (String.lowercase_ascii name) sensitive_header_names
115
116(** Sanitize a header list by redacting sensitive values *)
117let sanitize_headers headers =
118 List.map (fun (name, value) ->
119 if is_sensitive_header name then (name, "[REDACTED]")
120 else (name, value)
121 ) headers
122
123(** {1 Pretty Printing} *)
124
125let pp_error ppf = function
126 | Timeout { operation; duration } ->
127 (match duration with
128 | Some d -> Format.fprintf ppf "Timeout during %s after %.2fs" operation d
129 | None -> Format.fprintf ppf "Timeout during %s" operation)
130
131 | Too_many_redirects { url; count; max } ->
132 Format.fprintf ppf "Too many redirects (%d/%d) for URL: %s" count max (sanitize_url url)
133
134 | Invalid_redirect { url; reason } ->
135 Format.fprintf ppf "Invalid redirect to %s: %s" (sanitize_url url) reason
136
137 | Http_error { url; status; reason; body_preview; headers = _ } ->
138 Format.fprintf ppf "@[<v>HTTP %d %s@ URL: %s" status reason (sanitize_url url);
139 Option.iter (fun body ->
140 let preview = if String.length body > 200
141 then String.sub body 0 200 ^ "..."
142 else body in
143 Format.fprintf ppf "@ Body: %s" preview
144 ) body_preview;
145 Format.fprintf ppf "@]"
146
147 | Authentication_failed { url; reason } ->
148 Format.fprintf ppf "Authentication failed for %s: %s" (sanitize_url url) reason
149
150 | Dns_resolution_failed { hostname } ->
151 Format.fprintf ppf "DNS resolution failed for hostname: %s" hostname
152
153 | Tcp_connect_failed { host; port; reason } ->
154 Format.fprintf ppf "TCP connection to %s:%d failed: %s" host port reason
155
156 | Tls_handshake_failed { host; reason } ->
157 Format.fprintf ppf "TLS handshake with %s failed: %s" host reason
158
159 | Invalid_header { name; reason } ->
160 Format.fprintf ppf "Invalid header '%s': %s" name reason
161
162 | Body_too_large { limit; actual } ->
163 (match actual with
164 | Some a -> Format.fprintf ppf "Response body too large: %Ld bytes (limit: %Ld)" a limit
165 | None -> Format.fprintf ppf "Response body exceeds limit of %Ld bytes" limit)
166
167 | Headers_too_large { limit; actual } ->
168 Format.fprintf ppf "Response headers too large: %d (limit: %d)" actual limit
169
170 | Decompression_bomb { limit; ratio } ->
171 Format.fprintf ppf "Decompression bomb detected: ratio %.1f:1 exceeds limit, max size %Ld bytes"
172 ratio limit
173
174 | Content_length_mismatch { expected; actual } ->
175 Format.fprintf ppf "Content-Length mismatch: expected %Ld bytes, received %Ld bytes"
176 expected actual
177
178 | Insecure_auth { url; auth_type } ->
179 Format.fprintf ppf "%s authentication over unencrypted HTTP rejected for %s. \
180 Use HTTPS or set allow_insecure_auth=true (not recommended)"
181 auth_type (sanitize_url url)
182
183 | Json_parse_error { body_preview; reason } ->
184 let preview = if String.length body_preview > 100
185 then String.sub body_preview 0 100 ^ "..."
186 else body_preview in
187 Format.fprintf ppf "@[<v>JSON parse error: %s@ Body preview: %s@]" reason preview
188
189 | Json_encode_error { reason } ->
190 Format.fprintf ppf "JSON encode error: %s" reason
191
192 | Proxy_error { host; reason } ->
193 Format.fprintf ppf "Proxy error for %s: %s" host reason
194
195 | Encoding_error { encoding; reason } ->
196 Format.fprintf ppf "Encoding error (%s): %s" encoding reason
197
198 | Invalid_url { url; reason } ->
199 Format.fprintf ppf "Invalid URL '%s': %s" (sanitize_url url) reason
200
201 | Invalid_request { reason } ->
202 Format.fprintf ppf "Invalid request: %s" reason
203
204 | Oauth_error { error_code; description; uri } ->
205 Format.fprintf ppf "OAuth error: %s" error_code;
206 Option.iter (fun desc -> Format.fprintf ppf " - %s" desc) description;
207 Option.iter (fun u -> Format.fprintf ppf " (see: %s)" u) uri
208
209 | Token_refresh_failed { reason } ->
210 Format.fprintf ppf "Token refresh failed: %s" reason
211
212 | Token_expired ->
213 Format.fprintf ppf "Access token expired and no refresh token available"
214
215 (* HTTP/2 errors *)
216 | H2_protocol_error { code; message } ->
217 Format.fprintf ppf "HTTP/2 protocol error (code 0x%02lx): %s" code message
218
219 | H2_stream_error { stream_id; code; message } ->
220 Format.fprintf ppf "HTTP/2 stream %ld error (code 0x%02lx): %s" stream_id code message
221
222 | H2_flow_control_error { stream_id } ->
223 (match stream_id with
224 | Some id -> Format.fprintf ppf "HTTP/2 flow control error on stream %ld" id
225 | None -> Format.fprintf ppf "HTTP/2 connection flow control error")
226
227 | H2_compression_error { message } ->
228 Format.fprintf ppf "HTTP/2 HPACK compression error: %s" message
229
230 | H2_settings_timeout ->
231 Format.fprintf ppf "HTTP/2 SETTINGS acknowledgment timeout"
232
233 | H2_goaway { last_stream_id; code; debug } ->
234 Format.fprintf ppf "HTTP/2 GOAWAY received (last_stream=%ld, code=0x%02lx): %s"
235 last_stream_id code debug
236
237 | H2_frame_error { frame_type; message } ->
238 Format.fprintf ppf "HTTP/2 frame error (type 0x%02x): %s" frame_type message
239
240 | H2_header_validation_error { message } ->
241 Format.fprintf ppf "HTTP/2 header validation error: %s" message
242
243(** {1 Eio.Exn Integration}
244
245 Following the pattern from ocaml-conpool for structured Eio exceptions *)
246
247type Eio.Exn.err += E of error
248
249let err e = Eio.Exn.create (E e)
250
251let () =
252 Eio.Exn.register_pp (fun f -> function
253 | E e ->
254 Format.fprintf f "Requests: ";
255 pp_error f e;
256 true
257 | _ -> false)
258
259(** {1 Query Functions}
260
261 Per Recommendation #17: Enable smarter retry logic and error handling *)
262
263let is_timeout = function
264 | Timeout _ -> true
265 | _ -> false
266
267let is_dns = function
268 | Dns_resolution_failed _ -> true
269 | _ -> false
270
271let is_tls = function
272 | Tls_handshake_failed _ -> true
273 | _ -> false
274
275let is_connection = function
276 | Dns_resolution_failed _ -> true
277 | Tcp_connect_failed _ -> true
278 | Tls_handshake_failed _ -> true
279 | _ -> false
280
281let is_http_error = function
282 | Http_error _ -> true
283 | _ -> false
284
285let is_client_error = function
286 | Http_error { status; _ } -> status >= 400 && status < 500
287 | Authentication_failed _ -> true
288 | Invalid_url _ -> true
289 | Invalid_request _ -> true
290 | Invalid_header _ -> true
291 | _ -> false
292
293let is_server_error = function
294 | Http_error { status; _ } -> status >= 500 && status < 600
295 | _ -> false
296
297let is_retryable = function
298 | Timeout _ -> true
299 | Dns_resolution_failed _ -> true
300 | Tcp_connect_failed _ -> true
301 | Tls_handshake_failed _ -> true
302 | Http_error { status; _ } ->
303 (* Retryable status codes: 408, 429, 500, 502, 503, 504 *)
304 List.mem status [408; 429; 500; 502; 503; 504]
305 | Proxy_error _ -> true
306 | _ -> false
307
308let is_security_error = function
309 | Invalid_header _ -> true
310 | Body_too_large _ -> true
311 | Headers_too_large _ -> true
312 | Decompression_bomb _ -> true
313 | Invalid_redirect _ -> true
314 | Insecure_auth _ -> true
315 | _ -> false
316
317let is_json_error = function
318 | Json_parse_error _ -> true
319 | Json_encode_error _ -> true
320 | _ -> false
321
322let is_oauth_error = function
323 | Oauth_error _ -> true
324 | Token_refresh_failed _ -> true
325 | Token_expired -> true
326 | _ -> false
327
328(** {1 HTTP/2 Error Query Functions} *)
329
330let is_h2_error = function
331 | H2_protocol_error _ -> true
332 | H2_stream_error _ -> true
333 | H2_flow_control_error _ -> true
334 | H2_compression_error _ -> true
335 | H2_settings_timeout -> true
336 | H2_goaway _ -> true
337 | H2_frame_error _ -> true
338 | H2_header_validation_error _ -> true
339 | _ -> false
340
341let is_h2_connection_error = function
342 | H2_protocol_error _ -> true
343 | H2_flow_control_error { stream_id = None } -> true
344 | H2_compression_error _ -> true
345 | H2_settings_timeout -> true
346 | H2_goaway _ -> true
347 | _ -> false
348
349let is_h2_stream_error = function
350 | H2_stream_error _ -> true
351 | H2_flow_control_error { stream_id = Some _ } -> true
352 | _ -> false
353
354let is_h2_retryable = function
355 (* GOAWAY with NO_ERROR is graceful shutdown - safe to retry *)
356 | H2_goaway { code = 0l; _ } -> true
357 (* REFUSED_STREAM means server didn't process, safe to retry *)
358 | H2_stream_error { code = 0x7l; _ } -> true
359 | H2_protocol_error { code = 0x7l; _ } -> true
360 (* ENHANCE_YOUR_CALM might be retryable after backoff *)
361 | H2_stream_error { code = 0xbl; _ } -> true
362 | _ -> false
363
364let get_h2_error_code = function
365 | H2_protocol_error { code; _ } -> Some code
366 | H2_stream_error { code; _ } -> Some code
367 | H2_goaway { code; _ } -> Some code
368 | _ -> None
369
370let get_h2_stream_id = function
371 | H2_stream_error { stream_id; _ } -> Some stream_id
372 | H2_flow_control_error { stream_id } -> stream_id
373 | H2_goaway { last_stream_id; _ } -> Some last_stream_id
374 | _ -> None
375
376(** {1 Error Extraction}
377
378 Extract error from Eio.Io exception *)
379
380let of_eio_exn = function
381 | Eio.Io (E e, _) -> Some e
382 | _ -> None
383
384(** {1 HTTP Status Helpers} *)
385
386let get_http_status = function
387 | Http_error { status; _ } -> Some status
388 | _ -> None
389
390let get_url = function
391 | Too_many_redirects { url; _ } -> Some url
392 | Invalid_redirect { url; _ } -> Some url
393 | Http_error { url; _ } -> Some url
394 | Authentication_failed { url; _ } -> Some url
395 | Invalid_url { url; _ } -> Some url
396 | _ -> None
397
398(** {1 String Conversion} *)
399
400let to_string e =
401 Format.asprintf "%a" pp_error e
402
403(** {1 Convenience Constructors}
404
405 These functions provide a more concise way to raise common errors
406 compared to the verbose [raise (err (Error_type { field = value; ... }))] pattern. *)
407
408let invalid_request ~reason =
409 err (Invalid_request { reason })
410
411let invalid_redirect ~url ~reason =
412 err (Invalid_redirect { url; reason })
413
414let invalid_url ~url ~reason =
415 err (Invalid_url { url; reason })
416
417let timeout ~operation ?duration () =
418 err (Timeout { operation; duration })
419
420let body_too_large ~limit ?actual () =
421 err (Body_too_large { limit; actual })
422
423let headers_too_large ~limit ~actual =
424 err (Headers_too_large { limit; actual })
425
426let proxy_error ~host ~reason =
427 err (Proxy_error { host; reason })
428
429let tls_handshake_failed ~host ~reason =
430 err (Tls_handshake_failed { host; reason })
431
432let tcp_connect_failed ~host ~port ~reason =
433 err (Tcp_connect_failed { host; port; reason })
434
435(** {1 Format String Constructors}
436
437 These functions accept printf-style format strings for the reason field,
438 making error construction more concise when messages need interpolation. *)
439
440let invalid_requestf fmt =
441 Printf.ksprintf (fun reason -> err (Invalid_request { reason })) fmt
442
443let invalid_redirectf ~url fmt =
444 Printf.ksprintf (fun reason -> err (Invalid_redirect { url; reason })) fmt
445
446let invalid_urlf ~url fmt =
447 Printf.ksprintf (fun reason -> err (Invalid_url { url; reason })) fmt
448
449let proxy_errorf ~host fmt =
450 Printf.ksprintf (fun reason -> err (Proxy_error { host; reason })) fmt
451
452let tls_handshake_failedf ~host fmt =
453 Printf.ksprintf (fun reason -> err (Tls_handshake_failed { host; reason })) fmt
454
455let tcp_connect_failedf ~host ~port fmt =
456 Printf.ksprintf (fun reason -> err (Tcp_connect_failed { host; port; reason })) fmt
457
458(** {1 OAuth Error Constructors} *)
459
460let oauth_error ~error_code ?description ?uri () =
461 err (Oauth_error { error_code; description; uri })
462
463let token_refresh_failed ~reason =
464 err (Token_refresh_failed { reason })
465
466let token_expired () =
467 err Token_expired
468
469(** {1 HTTP/2 Error Constructors}
470
471 Per {{:https://datatracker.ietf.org/doc/html/rfc9113#section-7}RFC 9113 Section 7}. *)
472
473let h2_protocol_error ~code ~message =
474 err (H2_protocol_error { code; message })
475
476let h2_stream_error ~stream_id ~code ~message =
477 err (H2_stream_error { stream_id; code; message })
478
479let h2_flow_control_error ?stream_id () =
480 err (H2_flow_control_error { stream_id })
481
482let h2_compression_error ~message =
483 err (H2_compression_error { message })
484
485let h2_settings_timeout () =
486 err H2_settings_timeout
487
488let h2_goaway ~last_stream_id ~code ~debug =
489 err (H2_goaway { last_stream_id; code; debug })
490
491let h2_frame_error ~frame_type ~message =
492 err (H2_frame_error { frame_type; message })
493
494let h2_header_validation_error ~message =
495 err (H2_header_validation_error { message })
496
497(** {2 HTTP/2 Error Code Names}
498
499 Per {{:https://datatracker.ietf.org/doc/html/rfc9113#section-7}RFC 9113 Section 7}. *)
500
501let h2_error_code_name = function
502 | 0x0l -> "NO_ERROR"
503 | 0x1l -> "PROTOCOL_ERROR"
504 | 0x2l -> "INTERNAL_ERROR"
505 | 0x3l -> "FLOW_CONTROL_ERROR"
506 | 0x4l -> "SETTINGS_TIMEOUT"
507 | 0x5l -> "STREAM_CLOSED"
508 | 0x6l -> "FRAME_SIZE_ERROR"
509 | 0x7l -> "REFUSED_STREAM"
510 | 0x8l -> "CANCEL"
511 | 0x9l -> "COMPRESSION_ERROR"
512 | 0xal -> "CONNECT_ERROR"
513 | 0xbl -> "ENHANCE_YOUR_CALM"
514 | 0xcl -> "INADEQUATE_SECURITY"
515 | 0xdl -> "HTTP_1_1_REQUIRED"
516 | code -> Printf.sprintf "UNKNOWN(0x%lx)" code