anil.recoil.org
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
6let src = Logs.Src.create "requests.retry" ~doc:"HTTP Request Retry Logic"
7module Log = (val Logs.src_log src : Logs.LOG)
8
9(** Custom retry predicate for responses.
10 Per Recommendation #14: Allow user-defined retry logic.
11 The predicate receives (method, status, headers) and returns true to retry.
12 This runs in addition to the built-in status_forcelist check. *)
13type response_predicate = Method.t -> int -> Headers.t -> bool
14
15(** Custom retry predicate for exceptions.
16 Returns true if the exception should trigger a retry. *)
17type exception_predicate = exn -> bool
18
19type config = {
20 max_retries : int;
21 backoff_factor : float;
22 backoff_max : float;
23 status_forcelist : int list;
24 allowed_methods : Method.t list;
25 respect_retry_after : bool;
26 jitter : bool;
27 retry_response : response_predicate option; (** Per Recommendation #14 *)
28 retry_exception : exception_predicate option; (** Per Recommendation #14 *)
29 strict_method_semantics : bool;
30 (** When true, raise an error if asked to retry a non-idempotent method.
31 Per RFC 9110 Section 9.2.2: Non-idempotent methods should not be retried.
32 Default is false (just log a debug message). *)
33}
34
35let default_config = {
36 max_retries = 3;
37 backoff_factor = 0.3;
38 backoff_max = 120.0;
39 status_forcelist = [408; 429; 500; 502; 503; 504];
40 allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE];
41 respect_retry_after = true;
42 jitter = true;
43 retry_response = None;
44 retry_exception = None;
45 strict_method_semantics = false;
46}
47
48let create_config
49 ?(max_retries = 3)
50 ?(backoff_factor = 0.3)
51 ?(backoff_max = 120.0)
52 ?(status_forcelist = [408; 429; 500; 502; 503; 504])
53 ?(allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE])
54 ?(respect_retry_after = true)
55 ?(jitter = true)
56 ?retry_response
57 ?retry_exception
58 ?(strict_method_semantics = false)
59 () =
60 Log.debug (fun m -> m "Creating retry config: max_retries=%d backoff_factor=%.2f \
61 strict_method_semantics=%b custom_predicates=%b"
62 max_retries backoff_factor strict_method_semantics
63 (Option.is_some retry_response || Option.is_some retry_exception));
64 {
65 max_retries;
66 backoff_factor;
67 backoff_max;
68 status_forcelist;
69 allowed_methods;
70 respect_retry_after;
71 jitter;
72 retry_response;
73 retry_exception;
74 strict_method_semantics;
75 }
76
77(** Check if a response should be retried based on built-in rules only.
78 Use [should_retry_response] for full custom predicate support.
79 @raise Error.t if strict_method_semantics is enabled and method is not idempotent *)
80let should_retry ~config ~method_ ~status =
81 let method_allowed = List.mem method_ config.allowed_methods in
82 let status_retryable = List.mem status config.status_forcelist in
83 let should = method_allowed && status_retryable in
84 (* Per RFC 9110 Section 9.2.2: Only idempotent methods should be retried automatically *)
85 if status_retryable && not method_allowed then begin
86 if config.strict_method_semantics then
87 raise (Error.invalid_requestf
88 "Cannot retry %s request: method is not idempotent \
89 (RFC 9110 Section 9.2.2). Disable strict_method_semantics to allow."
90 (Method.to_string method_))
91 else
92 Log.debug (fun m -> m "Not retrying %s request (status %d): method is not idempotent \
93 (RFC 9110 Section 9.2.2)" (Method.to_string method_) status)
94 end else
95 Log.debug (fun m -> m "Should retry? method=%s status=%d -> %b"
96 (Method.to_string method_) status should);
97 should
98
99(** Check if a response should be retried, including custom predicates.
100 Per Recommendation #14: User-defined retry logic.
101 Returns true if either built-in rules or custom predicate says to retry. *)
102let should_retry_response ~config ~method_ ~status ~headers =
103 (* Check built-in rules first *)
104 let builtin_should_retry =
105 List.mem method_ config.allowed_methods &&
106 List.mem status config.status_forcelist
107 in
108 (* Check custom predicate if provided *)
109 let custom_should_retry = match config.retry_response with
110 | Some predicate -> predicate method_ status headers
111 | None -> false
112 in
113 let should = builtin_should_retry || custom_should_retry in
114 Log.debug (fun m -> m "Should retry response? method=%s status=%d builtin=%b custom=%b -> %b"
115 (Method.to_string method_) status builtin_should_retry custom_should_retry should);
116 should
117
118(** Check if an exception should trigger a retry, including custom predicates.
119 Per Recommendation #14: User-defined retry logic. *)
120let should_retry_exn ~config exn =
121 match config.retry_exception with
122 | Some predicate -> predicate exn
123 | None -> false
124
125let calculate_backoff ~config ~attempt =
126 let base_delay = config.backoff_factor *. (2.0 ** float_of_int attempt) in
127 let delay =
128 if config.jitter then
129 (* Add random jitter between 0 and base_delay *)
130 base_delay +. Random.float base_delay
131 else
132 base_delay
133 in
134 let final_delay = min delay config.backoff_max in
135 Log.debug (fun m -> m "Backoff calculation: attempt=%d base=%.2f jitter=%b -> %.2f seconds"
136 attempt base_delay config.jitter final_delay);
137 final_delay
138
139(** Parse Retry-After header and cap to backoff_max to prevent DoS.
140 Per RFC 9110 Section 10.2.3 and Recommendation #5:
141 Cap server-specified Retry-After values to prevent malicious servers
142 from causing indefinite client blocking. *)
143let parse_retry_after ?(backoff_max = 120.0) value =
144 Log.debug (fun m -> m "Parsing Retry-After header: %s" value);
145
146 let raw_delay =
147 (* First try to parse as integer (delay in seconds) *)
148 match int_of_string_opt value with
149 | Some seconds ->
150 Log.debug (fun m -> m "Retry-After is %d seconds" seconds);
151 Some (float_of_int seconds)
152 | None ->
153 (* Try to parse as HTTP-date (IMF-fixdate per RFC 9110 Section 5.6.7) *)
154 match Http_date.parse value with
155 | Some time ->
156 let now = Unix.time () in
157 let target = Ptime.to_float_s time in
158 let delay = max 0.0 (target -. now) in
159 Log.debug (fun m -> m "Retry-After is HTTP date, delay=%.2f seconds" delay);
160 Some delay
161 | None ->
162 Log.warn (fun m -> m "Failed to parse Retry-After header: %s" value);
163 None
164 in
165 (* Cap to backoff_max to prevent DoS from malicious Retry-After values *)
166 match raw_delay with
167 | Some delay when delay > backoff_max ->
168 Log.warn (fun m -> m "Retry-After delay %.2fs exceeds backoff_max %.2fs, capping"
169 delay backoff_max);
170 Some backoff_max
171 | other -> other
172
173let with_retry ~sw:_ ~clock ~config ~f ~should_retry_exn =
174 let rec attempt_with_retry attempt =
175 Log.info (fun m -> m "Attempt %d/%d" attempt (config.max_retries + 1));
176
177 match f () with
178 | result ->
179 if attempt > 1 then
180 Log.info (fun m -> m "Request succeeded after %d attempts" attempt);
181 result
182 | exception exn when attempt <= config.max_retries && should_retry_exn exn ->
183 let delay = calculate_backoff ~config ~attempt in
184
185 Log.warn (fun m -> m "Request failed (attempt %d/%d): %s. Retrying in %.2f seconds..."
186 attempt (config.max_retries + 1) (Printexc.to_string exn) delay);
187
188 (* Sleep for the backoff duration *)
189 Eio.Time.sleep clock delay;
190
191 attempt_with_retry (attempt + 1)
192 | exception exn ->
193 if attempt > config.max_retries then
194 Log.err (fun m -> m "Request failed after %d attempts: %s"
195 attempt (Printexc.to_string exn))
196 else
197 Log.err (fun m -> m "Request failed and won't be retried: %s"
198 (Printexc.to_string exn));
199 raise exn
200 in
201 attempt_with_retry 1
202
203let pp_config ppf config =
204 Format.fprintf ppf "@[<v>Retry Configuration:@,\
205 @[<v 2>\
206 max_retries: %d@,\
207 backoff_factor: %.2f@,\
208 backoff_max: %.1f seconds@,\
209 status_forcelist: [%a]@,\
210 allowed_methods: [%a]@,\
211 respect_retry_after: %b@,\
212 jitter: %b\
213 @]@]"
214 config.max_retries
215 config.backoff_factor
216 config.backoff_max
217 Format.(pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ") pp_print_int) config.status_forcelist
218 Format.(pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ")
219 (fun ppf m -> pp_print_string ppf (Method.to_string m))) config.allowed_methods
220 config.respect_retry_after
221 config.jitter
222
223let log_retry ~attempt ~delay ~reason =
224 Log.info (fun m -> m "Retry attempt %d scheduled in %.2f seconds. Reason: %s"
225 attempt delay reason)