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
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(** {1 URL and Credential Sanitization}
64
65 Per Recommendation #20: Remove sensitive info from error messages *)
66
67let sanitize_url url =
68 try
69 let uri = Uri.of_string url in
70 let sanitized = Uri.with_userinfo uri None in
71 Uri.to_string sanitized
72 with _ -> url (* If parsing fails, return original *)
73
74(** List of header names considered sensitive (lowercase) *)
75let sensitive_header_names =
76 ["authorization"; "cookie"; "proxy-authorization"; "x-api-key"; "api-key"; "set-cookie"]
77
78(** Check if a header name is sensitive (case-insensitive) *)
79let is_sensitive_header name =
80 List.mem (String.lowercase_ascii name) sensitive_header_names
81
82(** Sanitize a header list by redacting sensitive values *)
83let sanitize_headers headers =
84 List.map (fun (name, value) ->
85 if is_sensitive_header name then (name, "[REDACTED]")
86 else (name, value)
87 ) headers
88
89(** {1 Pretty Printing} *)
90
91let pp_error ppf = function
92 | Timeout { operation; duration } ->
93 (match duration with
94 | Some d -> Format.fprintf ppf "Timeout during %s after %.2fs" operation d
95 | None -> Format.fprintf ppf "Timeout during %s" operation)
96
97 | Too_many_redirects { url; count; max } ->
98 Format.fprintf ppf "Too many redirects (%d/%d) for URL: %s" count max (sanitize_url url)
99
100 | Invalid_redirect { url; reason } ->
101 Format.fprintf ppf "Invalid redirect to %s: %s" (sanitize_url url) reason
102
103 | Http_error { url; status; reason; body_preview; headers = _ } ->
104 Format.fprintf ppf "@[<v>HTTP %d %s@ URL: %s" status reason (sanitize_url url);
105 Option.iter (fun body ->
106 let preview = if String.length body > 200
107 then String.sub body 0 200 ^ "..."
108 else body in
109 Format.fprintf ppf "@ Body: %s" preview
110 ) body_preview;
111 Format.fprintf ppf "@]"
112
113 | Authentication_failed { url; reason } ->
114 Format.fprintf ppf "Authentication failed for %s: %s" (sanitize_url url) reason
115
116 | Dns_resolution_failed { hostname } ->
117 Format.fprintf ppf "DNS resolution failed for hostname: %s" hostname
118
119 | Tcp_connect_failed { host; port; reason } ->
120 Format.fprintf ppf "TCP connection to %s:%d failed: %s" host port reason
121
122 | Tls_handshake_failed { host; reason } ->
123 Format.fprintf ppf "TLS handshake with %s failed: %s" host reason
124
125 | Invalid_header { name; reason } ->
126 Format.fprintf ppf "Invalid header '%s': %s" name reason
127
128 | Body_too_large { limit; actual } ->
129 (match actual with
130 | Some a -> Format.fprintf ppf "Response body too large: %Ld bytes (limit: %Ld)" a limit
131 | None -> Format.fprintf ppf "Response body exceeds limit of %Ld bytes" limit)
132
133 | Headers_too_large { limit; actual } ->
134 Format.fprintf ppf "Response headers too large: %d (limit: %d)" actual limit
135
136 | Decompression_bomb { limit; ratio } ->
137 Format.fprintf ppf "Decompression bomb detected: ratio %.1f:1 exceeds limit, max size %Ld bytes"
138 ratio limit
139
140 | Content_length_mismatch { expected; actual } ->
141 Format.fprintf ppf "Content-Length mismatch: expected %Ld bytes, received %Ld bytes"
142 expected actual
143
144 | Insecure_auth { url; auth_type } ->
145 Format.fprintf ppf "%s authentication over unencrypted HTTP rejected for %s. \
146 Use HTTPS or set allow_insecure_auth=true (not recommended)"
147 auth_type (sanitize_url url)
148
149 | Json_parse_error { body_preview; reason } ->
150 let preview = if String.length body_preview > 100
151 then String.sub body_preview 0 100 ^ "..."
152 else body_preview in
153 Format.fprintf ppf "@[<v>JSON parse error: %s@ Body preview: %s@]" reason preview
154
155 | Json_encode_error { reason } ->
156 Format.fprintf ppf "JSON encode error: %s" reason
157
158 | Proxy_error { host; reason } ->
159 Format.fprintf ppf "Proxy error for %s: %s" host reason
160
161 | Encoding_error { encoding; reason } ->
162 Format.fprintf ppf "Encoding error (%s): %s" encoding reason
163
164 | Invalid_url { url; reason } ->
165 Format.fprintf ppf "Invalid URL '%s': %s" (sanitize_url url) reason
166
167 | Invalid_request { reason } ->
168 Format.fprintf ppf "Invalid request: %s" reason
169
170(** {1 Eio.Exn Integration}
171
172 Following the pattern from ocaml-conpool for structured Eio exceptions *)
173
174type Eio.Exn.err += E of error
175
176let err e = Eio.Exn.create (E e)
177
178let () =
179 Eio.Exn.register_pp (fun f -> function
180 | E e ->
181 Format.fprintf f "Requests: ";
182 pp_error f e;
183 true
184 | _ -> false)
185
186(** {1 Query Functions}
187
188 Per Recommendation #17: Enable smarter retry logic and error handling *)
189
190let is_timeout = function
191 | Timeout _ -> true
192 | _ -> false
193
194let is_dns = function
195 | Dns_resolution_failed _ -> true
196 | _ -> false
197
198let is_tls = function
199 | Tls_handshake_failed _ -> true
200 | _ -> false
201
202let is_connection = function
203 | Dns_resolution_failed _ -> true
204 | Tcp_connect_failed _ -> true
205 | Tls_handshake_failed _ -> true
206 | _ -> false
207
208let is_http_error = function
209 | Http_error _ -> true
210 | _ -> false
211
212let is_client_error = function
213 | Http_error { status; _ } -> status >= 400 && status < 500
214 | Authentication_failed _ -> true
215 | Invalid_url _ -> true
216 | Invalid_request _ -> true
217 | Invalid_header _ -> true
218 | _ -> false
219
220let is_server_error = function
221 | Http_error { status; _ } -> status >= 500 && status < 600
222 | _ -> false
223
224let is_retryable = function
225 | Timeout _ -> true
226 | Dns_resolution_failed _ -> true
227 | Tcp_connect_failed _ -> true
228 | Tls_handshake_failed _ -> true
229 | Http_error { status; _ } ->
230 (* Retryable status codes: 408, 429, 500, 502, 503, 504 *)
231 List.mem status [408; 429; 500; 502; 503; 504]
232 | Proxy_error _ -> true
233 | _ -> false
234
235let is_security_error = function
236 | Invalid_header _ -> true
237 | Body_too_large _ -> true
238 | Headers_too_large _ -> true
239 | Decompression_bomb _ -> true
240 | Invalid_redirect _ -> true
241 | Insecure_auth _ -> true
242 | _ -> false
243
244let is_json_error = function
245 | Json_parse_error _ -> true
246 | Json_encode_error _ -> true
247 | _ -> false
248
249(** {1 Error Extraction}
250
251 Extract error from Eio.Io exception *)
252
253let of_eio_exn = function
254 | Eio.Io (E e, _) -> Some e
255 | _ -> None
256
257(** {1 HTTP Status Helpers} *)
258
259let get_http_status = function
260 | Http_error { status; _ } -> Some status
261 | _ -> None
262
263let get_url = function
264 | Too_many_redirects { url; _ } -> Some url
265 | Invalid_redirect { url; _ } -> Some url
266 | Http_error { url; _ } -> Some url
267 | Authentication_failed { url; _ } -> Some url
268 | Invalid_url { url; _ } -> Some url
269 | _ -> None
270
271(** {1 String Conversion} *)
272
273let to_string e =
274 Format.asprintf "%a" pp_error e