1 ! Copyright (C) 2021 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays calendar combinators combinators.smart
4 continuations kernel math math.functions math.parser ranges
5 namespaces prettyprint random sequences system threads ;
8 TUPLE: retries count time-strategy errors ;
9 : new-retries ( class -- obj )
12 V{ } clone >>errors ; inline
14 TUPLE: counted-retries < retries max-retries ;
15 : <counted-retries> ( time-strategy max-retries -- retries )
16 counted-retries new-retries
18 swap >>time-strategy ; inline
20 TUPLE: sequence-retries < retries seq ;
21 : <sequence-retries> ( time-strategy seq -- retries )
22 sequence-retries new-retries
24 swap >>time-strategy ; inline
26 GENERIC: retries* ( time-strategy seq/n -- obj )
27 M: integer retries* <counted-retries> ;
28 M: sequence retries* <sequence-retries> ;
30 TUPLE: time-strategy ;
31 TUPLE: immediate < time-strategy ;
32 C: <immediate> immediate
34 TUPLE: random-wait < time-strategy lo hi ;
35 C: <random-wait> random-wait
37 TUPLE: exponential-wait < time-strategy exp nanos ;
38 C: <exponential-wait> exponential-wait
40 GENERIC: retry-obj ( retries -- elt/obj/index retry? )
41 GENERIC: retry-sleep-time ( retries time-strategy -- nanos/timestamp/0 )
42 : next-retry ( retries -- elt/obj/index nanos/timestamp/0 ? )
45 [ [ ] [ time-strategy>> ] bi retry-sleep-time ]
46 [ pick [ [ 1 + ] change-count drop ] [ drop ] if swap ]
49 M: immediate retry-sleep-time 2drop 0 ;
50 M: random-wait retry-sleep-time nip [ lo>> ] [ hi>> ] bi [a..b] random ;
51 M: exponential-wait retry-sleep-time [ count>> ] [ [ exp>> ^ ] [ nanos>> * ] bi ] bi* ;
53 : nth* ( n seq -- elt/f ? ) 2dup bounds-check? [ nth t ] [ 2drop f f ] if ;
55 M: counted-retries retry-obj [ count>> ] [ max-retries>> ] bi dupd < ;
56 M: sequence-retries retry-obj [ count>> ] [ seq>> ] bi nth* ;
58 SYMBOL: current-retries
59 ERROR: retries-failed retries quot ;
61 : with-retries ( retries quot -- result )
62 [ current-retries ] dip dup '[
65 current-retries get next-retry [
68 current-retries get count>>
69 now 4array current-retries get errors>> push f t
72 current-retries get _ retries-failed
75 ] with-variable ; inline
77 : retries ( quot time-strategy n/seq -- result )
78 retries* swap with-retries ; inline