Skip to content

Commit b778004

Browse files
raphael-proustraphael-proust
authored
Merge pull request #1032 from shonfeder/1028/lwt-retry
Add Lwt_retry library
2 parents 803a618 + 61697da commit b778004

File tree

7 files changed

+447
-0
lines changed

7 files changed

+447
-0
lines changed

‎dune-project‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,17 @@
1212
(source (github ocsigen/lwt))
1313
(documentation "https://ocsigen.org/lwt")
1414

15+
(package
16+
(name lwt_retry)
17+
(synopsis "Utilities for retrying Lwt computations")
18+
(authors "Shon Feder")
19+
(maintainers
20+
"Raphaël Proust <[email protected]>"
21+
"Shon Feder <[email protected]>")
22+
(depends
23+
(ocaml (>= 4.08))
24+
(lwt (>= 5.3.0))))
25+
1526
(package
1627
(name lwt_ppx)
1728
(synopsis "PPX syntax for Lwt, providing something similar to async/await from JavaScript")

‎lwt_retry.opam‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
# This file is generated by dune, edit dune-project instead
2+
opam-version: "2.0"
3+
synopsis: "Utilities for retrying Lwt computations"
4+
maintainer: [
5+
"Raphaël Proust <[email protected]>" "Shon Feder <[email protected]>"
6+
]
7+
authors: ["Shon Feder"]
8+
license: "MIT"
9+
homepage: "https://github.com/ocsigen/lwt"
10+
doc: "https://ocsigen.org/lwt"
11+
bug-reports: "https://github.com/ocsigen/lwt/issues"
12+
depends: [
13+
"dune" {>= "2.0"}
14+
"ocaml" {>= "4.08"}
15+
"lwt" {>= "5.3.0"}
16+
]
17+
build: [
18+
["dune" "subst"] {pinned}
19+
[
20+
"dune"
21+
"build"
22+
"-p"
23+
name
24+
"-j"
25+
jobs
26+
"@install"
27+
"@runtest" {with-test}
28+
"@doc" {with-doc}
29+
]
30+
]
31+
dev-repo: "git+https://github.com/ocsigen/lwt.git"

‎src/retry/dune‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
(* -*- tuareg -*- *)
2+
3+
let preprocess =
4+
match Sys.getenv "BISECT_ENABLE" with
5+
| "yes" -> "(preprocess (pps bisect_ppx))"
6+
| _ -> ""
7+
| exception _ -> ""
8+
9+
let () = Jbuild_plugin.V1.send @@ {|
10+
11+
(library
12+
(public_name lwt_retry)
13+
(synopsis "A utility for retrying Lwt computations")
14+
(wrapped false)
15+
(libraries lwt lwt.unix)
16+
|} ^ preprocess ^ {|
17+
(flags (:standard -w +A)))
18+
19+
|}

‎src/retry/lwt_retry.ml‎

Lines changed: 67 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
2+
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
3+
4+
5+
6+
open Lwt.Syntax
7+
8+
let default_sleep_duration n' =
9+
let base_sleep_time = 2.0 in
10+
let n = Int.to_float n' in
11+
n *. base_sleep_time *. Float.pow 2.0 n
12+
13+
type ('retry, 'fatal) error =
14+
[ `Retry of 'retry
15+
| `Fatal of 'fatal
16+
]
17+
18+
let pp_opaque fmt _ = Format.fprintf fmt "<opaque>"
19+
20+
let pp_error ?(retry = pp_opaque) ?(fatal = pp_opaque) fmt err =
21+
match err with
22+
| `Retry r -> Format.fprintf fmt "`Retry %a" retry r
23+
| `Fatal f -> Format.fprintf fmt "`Fatal %a" fatal f
24+
25+
let equal_error ~retry ~fatal a b =
26+
match a, b with
27+
| `Retry a', `Retry b' -> retry a' b'
28+
| `Fatal a', `Fatal b' -> fatal a' b'
29+
| _ -> false
30+
31+
type ('ok, 'retry, 'fatal) attempt = ('ok, ('retry, 'fatal) error * int) result
32+
33+
let on_error
34+
(f : unit -> ('ok, ('retry, 'fatal) error) result Lwt.t)
35+
: ('ok, 'retry, 'fatal) attempt Lwt_stream.t
36+
=
37+
let i = ref 0 in
38+
let stop = ref false in
39+
Lwt_stream.from begin fun () ->
40+
incr i;
41+
if !stop then
42+
Lwt.return None
43+
else
44+
let+ result = f () in
45+
match result with
46+
| Error (`Retry _ as retry) -> Some (Error (retry, !i))
47+
| Error (`Fatal _ as fatal) -> stop := true; Some (Error (fatal, !i))
48+
| Ok _ as ok -> stop := true; Some ok
49+
end
50+
51+
let with_sleep ?(duration=default_sleep_duration) (attempts : _ attempt Lwt_stream.t) : _ attempt Lwt_stream.t =
52+
attempts
53+
|> Lwt_stream.map_s begin function
54+
| Ok _ as ok -> Lwt.return ok
55+
| Error (_, n) as err ->
56+
let* () = Lwt_unix.sleep @@ duration n in
57+
Lwt.return err
58+
end
59+
60+
let n_times n attempts =
61+
if n < 0 then invalid_arg "Lwt_retry.n_times: n must be non-negative";
62+
(* The first attempt is a try, and re-tries start counting from n + 1 *)
63+
let retries = n + 1 in
64+
let+ attempts = Lwt_stream.nget retries attempts in
65+
match List.rev attempts with
66+
| last :: _ -> last
67+
| _ -> failwith "Lwt_retry.n_times: impossible"

‎src/retry/lwt_retry.mli‎

Lines changed: 157 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,157 @@
1+
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
2+
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
3+
4+
5+
6+
(** Utilities for retrying Lwt computations
7+
8+
These utilities are useful for dealing with failure-prone computations that
9+
are expected to succeed after some number of repeated attempts. E.g.,
10+
11+
{[
12+
let flaky_computation () = match try_to_get_resource () with
13+
| Flaky_error msg -> Error (`Retry msg)
14+
| Fatal_error err -> Error (`Fatal err)
15+
| Success result -> Ok result
16+
17+
let error_tolerant_computation () =
18+
Lwt_retry.(flaky_computation
19+
|> on_error (* Retry when [`Retry]able results are produced. *)
20+
|> with_sleep (* Add a delay between attempts, with an exponential backoff. *)
21+
|> n_times 10 (* Try up to 10 times, so long as errors are retryable. *)
22+
)
23+
]}
24+
25+
This library provides a few combinators, but retry attempts are produced on
26+
demand in an {!type:Lwt_stream.t}, and they can be consumed and traversed
27+
using the {!module:Lwt_stream} functions directly. *)
28+
29+
type ('retry, 'fatal) error =
30+
[ `Retry of 'retry
31+
| `Fatal of 'fatal
32+
]
33+
(** The type of errors that a retryable computation can produce.
34+
35+
- [`Retry r] when [r] represents an error that can be retried.
36+
- [`Fatal f] when [f] represents an error that cannot be retried. *)
37+
38+
type ('ok, 'retry, 'fatal) attempt = ('ok, ('retry, 'fatal) error * int) result
39+
(** A [('ok, 'retry, 'fatal) attempt] is the [result] of a retryable computation,
40+
with its the erroneous results enumerated.
41+
42+
- [Ok v] is a successfully computed value [v]
43+
- [Error (err, n)] is the {!type:error} [err] produced on the [n]th
44+
attempt
45+
46+
The enumeration of attempts is 1-based, because making 0 attempts means
47+
making no attempts all, making 1 attempt means {i trying} once, and (when
48+
[i>0]) making [n] attempts means trying once and then {i retrying} up to
49+
[n-1] times. *)
50+
51+
val pp_error :
52+
?retry:(Format.formatter -> 'retry -> unit) ->
53+
?fatal:(Format.formatter -> 'fatal -> unit) ->
54+
Format.formatter -> ('retry, 'fatal) error -> unit
55+
(** [pp_error ~retry ~fatal] is a pretty printer for {!type:error}s that formats
56+
fatal and retryable errors according to the provided printers.
57+
58+
If a printers is not provided, values of the type are represented as
59+
["<opaque>"]. *)
60+
61+
val equal_error :
62+
retry:('retry -> 'retry -> bool) ->
63+
fatal:('fatal -> 'fatal -> bool) ->
64+
('retry, 'fatal) error ->
65+
('retry, 'fatal) error ->
66+
bool
67+
68+
val on_error :
69+
(unit -> ('ok, ('retry, 'fatal) error) result Lwt.t) ->
70+
('ok, 'retry, 'fatal) attempt Lwt_stream.t
71+
(** [Lwt_retry.on_error f] is a stream of attempts to compute [f], with attempts
72+
made on demand. Attempts will be added to the stream when results are
73+
requested until the computation either succeeds or produces a fatal error.
74+
75+
Examples
76+
77+
{[
78+
# let success () = Lwt.return_ok ();;
79+
val success : unit -> (unit, 'a) result Lwt.t = <fun>
80+
# Lwt_retry.(success |> on_error) |> Lwt_stream.to_list;;
81+
- : (unit, 'a, 'b) Lwt_retry.attempt list = [Ok ()]
82+
83+
# let fatal_failure () = Lwt.return_error (`Fatal ());;
84+
val fatal_failure : unit -> ('a, [> `Fatal of unit ]) result Lwt.t = <fun>
85+
# Lwt_retry.(fatal_failure |> on_error) |> Lwt_stream.to_list;;
86+
- : ('a, 'b, unit) Lwt_retry.attempt list = [Error (`Fatal (), 1)]
87+
88+
# let retryable_error () = Lwt.return_error (`Retry ());;
89+
val retryable_error : unit -> ('a, [> `Retry of unit ]) result Lwt.t = <fun>
90+
# Lwt_retry.(retryable_error |> on_error) |> Lwt_stream.nget 3;;
91+
- : ('a, unit, 'b) Lwt_retry.attempt list =
92+
[Error (`Retry (), 1); Error (`Retry (), 2); Error (`Retry (), 3)]
93+
]}*)
94+
95+
val with_sleep :
96+
?duration:(int -> float) ->
97+
('ok, 'retry, 'fatal) attempt Lwt_stream.t ->
98+
('ok, 'retry, 'fatal) attempt Lwt_stream.t
99+
(** [with_sleep ~duration attempts] is the stream of [attempts] with a sleep of
100+
[duration n] seconds added before computing each [n]th retryable attempt.
101+
102+
@param duration the optional sleep duration calculation, defaulting to
103+
{!val:default_sleep_duration}.
104+
105+
Examples
106+
107+
{[
108+
# let f () = Lwt.return_error (`Retry ());;
109+
# let attempts_with_sleeps = Lwt_retry.(f |> on_error |> with_sleep);;
110+
111+
# Lwt_stream.get attempts_with_sleeps;;
112+
(* computed immediately *)
113+
Some (Error (`Retry (), 1))
114+
115+
# Lwt_stream.get attempts_with_sleeps;;
116+
(* computed after 3 seconds *)
117+
Some (Error (`Retry (), 2))
118+
119+
# Lwt_stream.get attempts_with_sleeps;;
120+
(* computed after 9 seconds *)
121+
Some (Error (`Retry (), 3))
122+
123+
(* a stream with a constant 1s sleep between attempts *)
124+
# let attempts_with_constant_sleeps =
125+
Lwt_retry.(f |> on_error |> with_sleep ~duration:(fun _ -> 1.0));;
126+
]} *)
127+
128+
val default_sleep_duration : int -> float
129+
(** [default_sleep_duration n] is an exponential backoff computed as [n] * 2 *
130+
(2 ^ [n]), which gives the sequence [ [0.; 4.; 16.; 48.; 128.; 320.; 768.;
131+
1792.; ...] ]. *)
132+
133+
val n_times :
134+
int ->
135+
('ok, 'retry, 'fatal) attempt Lwt_stream.t ->
136+
('ok, 'retry, 'fatal) attempt Lwt.t
137+
(** [n_times n attempts] is [Ok v] if one of the [attempts] succeeds within [n]
138+
retries (or [n+1] attempts), [Error (`Fatal f, n+1)] if any of the attempts
139+
results in the fatal error, or [Error (`Retry r, n+1)] if all [n] retries are
140+
exhausted and the [n+1]th attempt results in a retry error.
141+
142+
In particular [n_times 0 attempts] will *try* 1 attempt but *re-try* 0, so
143+
it is guaranteed to produce some result.
144+
145+
[n_times] forces up to [n] elements of the on-demand stream of attempts.
146+
147+
Examples
148+
149+
{[
150+
# let f () =
151+
let i = ref 0 in
152+
fun () -> Lwt.return_error (if !i < 3 then (incr i; `Retry ()) else `Fatal "error!");;
153+
# Lwt_retry.(f () |> on_error |> n_times 0);;
154+
Error (`Retry (), 1)
155+
# Lwt_retry.(f () |> on_error |> n_times 4);;
156+
Error (`Fatal "error!", 3)
157+
]} *)

‎test/retry/dune‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
(test
2+
(name main)
3+
(package lwt_retry)
4+
(libraries lwttester lwt_retry))

0 commit comments

Comments
 (0)