SCP-4883 Support for retries.

input-output-hk · Jan 24, 2023 · 0efa40c · 0efa40c
1 parent c2846b6
commit 0efa40c
Show file tree

Hide file tree

Showing 3 changed files with 49 additions and 6 deletions.
diff --git a/marlowe-apps/src/Language/Marlowe/Runtime/App/Parser.hs b/marlowe-apps/src/Language/Marlowe/Runtime/App/Parser.hs
@@ -8,7 +8,8 @@ module Language.Marlowe.Runtime.App.Parser
 
 
 import Data.Default (def)
-import Language.Marlowe.Runtime.App.Types (Config(Config, buildSeconds, confirmSeconds, timeoutSeconds))
+import Language.Marlowe.Runtime.App.Types
+  (Config(Config, buildSeconds, confirmSeconds, retryLimit, retrySeconds, timeoutSeconds))
 import Language.Marlowe.Runtime.CLI.Option (CliOption, host, optParserWithEnvDefault, port)
 import Language.Marlowe.Runtime.ChainSync.Api (Address, fromBech32)
 import Network.Socket (HostName, PortNumber)
@@ -56,6 +57,20 @@ getConfigParser =
           <> O.value (confirmSeconds def)
           <> O.showDefault
           <> O.help "Wait specified seconds after transaction confirmation."
+      retrySecondsParser =
+        O.option O.auto
+          $  O.long "retry-seconds"
+          <> O.metavar "INTEGER"
+          <> O.value (retrySeconds def)
+          <> O.showDefault
+          <> O.help "Wait specified seconds after after a failed transaction before trying again."
+      retryLimitParser =
+        O.option O.auto
+          $  O.long "retry-limit"
+          <> O.metavar "INTEGER"
+          <> O.value (retryLimit def)
+          <> O.showDefault
+          <> O.help "Maximum number of attempts for trying a failed transaction again."
     pure
       $ Config
       <$> chainSeekHostParser
@@ -74,6 +89,8 @@ getConfigParser =
       <*> timeoutSecondsParser
       <*> buildSecondsParser
       <*> confirmSecondsParser
+      <*> retrySecondsParser
+      <*> retryLimitParser
 
 
 chainSeekHost :: CliOption O.OptionFields HostName

diff --git a/marlowe-apps/src/Language/Marlowe/Runtime/App/Transact.hs b/marlowe-apps/src/Language/Marlowe/Runtime/App/Transact.hs
@@ -25,15 +25,15 @@ module Language.Marlowe.Runtime.App.Transact
 
 import Control.Concurrent (threadDelay)
 import Control.Monad (when)
-import Control.Monad.Except (ExceptT(..), liftIO, throwError)
+import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError)
 import Language.Marlowe.Core.V1.Semantics.Types (Contract, Input)
 import Language.Marlowe.Runtime.App.Types
-  (App, Config(Config, buildSeconds, confirmSeconds), MarloweRequest(..), MarloweResponse(..))
+  (App, Config(Config, buildSeconds, confirmSeconds, retryLimit, retrySeconds), MarloweRequest(..), MarloweResponse(..))
 import Language.Marlowe.Runtime.ChainSync.Api (Address, Lovelace)
 import Language.Marlowe.Runtime.Core.Api (ContractId, MarloweVersionTag(V1))
 import Observe.Event (Event, addField, newEvent, withSubEvent)
 import Observe.Event.Backend (unitEventBackend)
-import Observe.Event.Dynamic (DynamicEvent, DynamicEventSelector(..))
+import Observe.Event.Dynamic (DynamicEvent, DynamicEventSelector(..), DynamicField)
 import Observe.Event.Syntax ((≔))
 import System.Random (randomRIO)
 
@@ -149,12 +149,12 @@ transactWithEvents
   -> C.SigningKey C.PaymentExtendedKey
   -> MarloweRequest 'V1
   -> App ContractId
-transactWithEvents event config@Config{buildSeconds, confirmSeconds} key request =
+transactWithEvents event config@Config{buildSeconds, confirmSeconds, retryLimit, retrySeconds} key request =
   let
     show' = LBS8.unpack . A.encode
     unexpected response = throwError $ "Unexpected response: " <> show' response
   in
-    withSubEvent event (DynamicEventSelector "Transact")
+    retry "Transact" event [retrySeconds * 2^(i-1) | i <- [1..retryLimit]]
       $ \subEvent ->
         do
           when (buildSeconds > 0)
@@ -189,6 +189,28 @@ transactWithEvents event config@Config{buildSeconds, confirmSeconds} key request
           pure contractId
 
 
+retry
+  :: T.Text
+  -> Event App r DynamicEventSelector f
+  -> [Int]
+  -> (Event App r DynamicEventSelector DynamicField -> App a)
+  -> App a
+retry name event [] action = withSubEvent event (DynamicEventSelector name) action
+retry name event (delay : delays) action =
+  withSubEvent event (DynamicEventSelector name)
+    $ \subEvent ->
+      ExceptT
+        $ runExceptT (action subEvent)
+        >>= \case
+          Right result -> pure $ Right result
+          Left message -> runExceptT
+                            $ do
+                              addField subEvent $ ("failure" :: T.Text) ≔ message
+                              addField subEvent $ ("waitForRetry" :: T.Text) ≔ delay
+                              liftIO . threadDelay $ delay * 1_000_000
+                              retry name event delays action
+
+
 handleWithEvents
   :: Event App r DynamicEventSelector f
   -> T.Text

diff --git a/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs b/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs
@@ -110,6 +110,8 @@ data Config =
   , timeoutSeconds :: Int
   , buildSeconds :: Int
   , confirmSeconds :: Int
+  , retrySeconds :: Int
+  , retryLimit :: Int
   }
     deriving (Read, Show)
 
@@ -132,6 +134,8 @@ instance Default Config where
     , timeoutSeconds = 600
     , buildSeconds = 3
     , confirmSeconds = 3
+    , retrySeconds = 10
+    , retryLimit = 4
     }