retries: Add a retry vocabulary that tries n times or each element of a sequence...

diff --git a/basis/retries/authors.txt b/basis/retries/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/basis/retries/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/basis/retries/retries-tests.factor b/basis/retries/retries-tests.factor
new file mode 100644 (file)
index 0000000..8709276
--- /dev/null
+++ b/basis/retries/retries-tests.factor
@@ -0,0 +1,71 @@
+! Copyright (C) 2021 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces retries tools.test ;
+IN: retries.tests
+
+! try every value in a sequence with no sleeps
+[
+    [ dup 2 = [ "not 2!" throw ] unless ]
+    { 1 } <immediate> retries
+] [ retries-failed? ] must-fail-with
+
+{ 2 } [
+    [ dup 2 = [ "not 2!" throw ] unless ]
+    { 1 2 } <immediate> retries
+] unit-test
+
+! try every value in a sequence with a random sleep
+[
+    [ dup 2 = [ "not 2!" throw ] unless ]
+    { 1 } 10 20 <random-wait> retries
+] [ retries-failed? ] must-fail-with
+
+{ 2 } [
+    [ dup 2 = [ "not 2!" throw ] unless ]
+    { 1 2 } 10 20 <random-wait> retries
+] unit-test
+
+! try every value in a sequence with an exponentially increasing sleep
+[
+    [ dup 2 = [ "not 2!" throw ] unless ]
+    { 1 } 1.1 100 <exponential-wait> retries
+] [ retries-failed? ] must-fail-with
+
+{ 2 } [
+    [ dup 2 = [ "not 2!" throw ] unless ]
+    { 1 2 } 1.1 100 <exponential-wait> retries
+] unit-test
+
+
+! try n times with no sleeps
+[
+    [ 2 = [ "not 2!" throw ] unless ]
+    2 <immediate> retries
+] [ retries-failed? ] must-fail-with
+
+{ } [
+    [ 2 = [ "not 2!" throw ] unless ]
+    3 <immediate> retries
+] unit-test
+
+! try n times with a random sleep
+[
+    [ 2 = [ "not 2!" throw ] unless ]
+    2 10 20 <random-wait> retries
+] [ retries-failed? ] must-fail-with
+
+{ } [
+    [ 2 = [ "not 2!" throw ] unless ]
+    3 10 20 <random-wait> retries
+] unit-test
+
+! try n times with an exponentially increasing sleep
+[
+    [ 2 = [ "not 2!" throw ] unless ]
+    2 1.1 100 <exponential-wait> retries
+] [ retries-failed? ] must-fail-with
+
+{ } [
+    [ 2 = [ "not 2!" throw ] unless ]
+    3 1.1 100 <exponential-wait> retries
+] unit-test
\ No newline at end of file

diff --git a/basis/retries/retries.factor b/basis/retries/retries.factor
new file mode 100644 (file)
index 0000000..c16ac87
--- /dev/null
+++ b/basis/retries/retries.factor
@@ -0,0 +1,76 @@
+! Copyright (C) 2021 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar combinators combinators.extras
+continuations kernel math math.functions math.parser math.ranges
+namespaces prettyprint random sequences system threads ;
+IN: retries
+
+TUPLE: retries count time-strategy errors ;
+: new-retries ( time-strategy class -- obj )
+    new
+        swap >>time-strategy
+        0 >>count
+        V{ } clone >>errors ; inline
+
+TUPLE: counted-retries < retries max-retries ;
+: <counted-retries> ( max time-strategy -- retries )
+    counted-retries new-retries
+        swap >>max-retries ;
+
+TUPLE: sequence-retries < retries seq ;
+: <sequence-retries> ( seq time-strategy -- retries )
+    sequence-retries new-retries
+        swap >>seq ;
+
+GENERIC#: retries* 1 ( seq/n time-strategy -- obj )
+M: integer retries* <counted-retries> ;
+M: sequence retries* <sequence-retries> ;
+
+TUPLE: time-strategy ;
+TUPLE: immediate < time-strategy ;
+C: <immediate> immediate
+
+TUPLE: random-wait < time-strategy lo hi ;
+C: <random-wait> random-wait
+
+TUPLE: exponential-wait < time-strategy exp nanos ;
+C: <exponential-wait> exponential-wait
+
+GENERIC: retry-obj ( retries -- elt/obj/index retry? )
+GENERIC: retry-sleep-time ( retries time-strategy -- nanos/timestamp/0 )
+: next-retry ( retries -- elt/obj/index nanos/timestamp/0 ? )
+    {
+        [ retry-obj ]
+        [ [ ] [ time-strategy>> ] bi retry-sleep-time ]
+        [ pick [ [ 1 + ] change-count drop ] [ drop ] if swap ]
+    } cleave ;
+
+M: immediate retry-sleep-time 2drop 0 ;
+M: random-wait retry-sleep-time nip [ lo>> ] [ hi>> ] bi [a,b] random ;
+M: exponential-wait retry-sleep-time [ count>> ] [ [ exp>> ^ ] [ nanos>> * ] bi ] bi* ;
+
+: nth* ( n seq -- elt/f ? ) 2dup bounds-check? [ nth t ] [ 2drop f f ] if ;
+
+M: counted-retries retry-obj [ count>> ] [ max-retries>> ] bi dupd < ;
+M: sequence-retries retry-obj [ count>> ] [ seq>> ] bi nth* ;
+
+SYMBOL: current-retries
+ERROR: retries-failed retries quot ;
+
+: with-retries ( retries quot -- result )
+    [ current-retries ] dip dup '[
+        [
+            current-retries get next-retry [
+                [ sleep ] unless-zero
+                _ [ f ] compose [
+                    current-retries get count>>
+                    now 4array current-retries get errors>> push f t
+                ] recover
+            ] [
+                current-retries get _ retries-failed
+            ] if
+        ] loop1
+    ] with-variable ; inline
+
+: retries ( quot time-strategy -- result )
+    retries* swap with-retries ; inline