basis/retries/retries.factor

   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 ;
   6 IN: retries
   7
   8 TUPLE: retries count time-strategy errors ;
   9 : new-retries ( class -- obj )
  10     new
  11         0 >>count
  12         V{ } clone >>errors ; inline
  13
  14 TUPLE: counted-retries < retries max-retries ;
  15 : <counted-retries> ( time-strategy max-retries -- retries )
  16     counted-retries new-retries
  17         swap >>max-retries
  18         swap >>time-strategy ; inline
  19
  20 TUPLE: sequence-retries < retries seq ;
  21 : <sequence-retries> ( time-strategy seq -- retries )
  22     sequence-retries new-retries
  23         swap >>seq
  24         swap >>time-strategy ; inline
  25
  26 GENERIC: retries* ( time-strategy seq/n -- obj )
  27 M: integer retries* <counted-retries> ;
  28 M: sequence retries* <sequence-retries> ;
  29
  30 TUPLE: time-strategy ;
  31 TUPLE: immediate < time-strategy ;
  32 C: <immediate> immediate
  33
  34 TUPLE: random-wait < time-strategy lo hi ;
  35 C: <random-wait> random-wait
  36
  37 TUPLE: exponential-wait < time-strategy exp nanos ;
  38 C: <exponential-wait> exponential-wait
  39
  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 ? )
  43     {
  44         [ retry-obj ]
  45         [ [ ] [ time-strategy>> ] bi retry-sleep-time ]
  46         [ pick [ [ 1 + ] change-count drop ] [ drop ] if swap ]
  47     } cleave ;
  48
  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* ;
  52
  53 : nth* ( n seq -- elt/f ? ) 2dup bounds-check? [ nth t ] [ 2drop f f ] if ;
  54
  55 M: counted-retries retry-obj [ count>> ] [ max-retries>> ] bi dupd < ;
  56 M: sequence-retries retry-obj [ count>> ] [ seq>> ] bi nth* ;
  57
  58 SYMBOL: current-retries
  59 ERROR: retries-failed retries quot ;
  60
  61 : with-retries ( retries quot -- result )
  62     [ current-retries ] dip dup '[
  63         f [
  64             drop
  65             current-retries get next-retry [
  66                 [ sleep ] unless-zero
  67                 _ [ f ] compose [
  68                     current-retries get count>>
  69                     now 4array current-retries get errors>> push f t
  70                 ] recover
  71             ] [
  72                 current-retries get _ retries-failed
  73             ] if
  74         ] loop
  75     ] with-variable ; inline
  76
  77 : retries ( quot time-strategy n/seq -- result )
  78     retries* swap with-retries ; inline