Merge pull request #40 from mlabs-haskell/euonymos/jitter-backoff

Support for Backoff

.gitignore

@@ -1,3 +1,4 @@
+.cabal
 dist-newstyle
 dist
 dist-*

README.md

@@ -42,7 +42,7 @@
 
   main :: IO ()
   main = do
-    env <- mkMaestroEnv @'V1 "<Your-API-Key>" Preprod  -- This is how we create an environment against which we'll query endpoints.
+    env <- mkMaestroEnv @'V1 "<Your-API-Key>" Preprod defaultBackoff -- This is how we create an environment against which we'll query endpoints.
     chainTip :: ChainTip <- getTimestampedData <$> getChainTip env  -- Maestro endpoint to get for chain-tip has data & timestamp against which data was calculated. All endpoints which are timestamped, has functions `getTimestampedData` to get for underlying data & `getTimestamp` to get the timestamp.
     addressesUTxOs :: Either MaestroError [UtxoWithSlot] <-
       try  -- To catch for any errors, given in type `MaestroError`.

maestro-sdk.cabal

@@ -84,21 +84,43 @@ library
       Maestro.Types.V1.Transactions
 
     build-depends:
+      , aeson
       , base                >= 4.14.3.0  &&  < 4.19
       , bytestring
-      , aeson
       , containers
+      , data-default-class
       , deriving-aeson
+      , http-api-data
+      , http-client
+      , http-client-tls
+      , http-types
+      , retry
       , servant
       , servant-client
       , servant-client-core
       , text
       , time
-      , http-client
-      , http-client-tls
-      , http-types
-      , http-api-data
-      , data-default-class
 
     hs-source-dirs:   src
     default-language: Haskell2010
+
+test-suite maestro-sdk-tests
+    import:           common
+    default-language: Haskell2010
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Driver.hs
+    other-modules:
+        Maestro.Test.Backoff
+
+    build-depends:
+        base
+      , maestro-sdk
+      , containers
+      , hspec
+      , tasty
+      , tasty-hspec
+      , text
+      , time
+    build-tool-depends:
+        tasty-discover:tasty-discover

src/Maestro/Client/Env.hs

@@ -4,12 +4,12 @@ module Maestro.Client.Env
   , MaestroNetwork (..)
   , MaestroApiVersion (..)
   , mkMaestroEnv
+  , defaultBackoff
   ) where
 
 import           Data.Text               (Text)
 import           Network.HTTP.Client     (newManager)
 import           Network.HTTP.Client.TLS (tlsManagerSettings)
-
 import qualified Servant.Client          as Servant
 
 type MaestroToken = Text
@@ -35,8 +35,14 @@ instance SingMaestroApiVersionI 'V0 where singMaestroApiVersion = SingV0
 instance SingMaestroApiVersionI 'V1 where singMaestroApiVersion = SingV1
 
 data MaestroEnv (v :: MaestroApiVersion) = MaestroEnv
-  { maeClientEnv :: !Servant.ClientEnv
-  , maeToken     :: !MaestroToken
+  { _maeClientEnv :: !Servant.ClientEnv
+  , _maeToken     :: !MaestroToken
+  , _maeBaseDelay :: !(Maybe Int)
+  -- ^ Base delay in microseconds to use with jitter backoff.
+  -- https://hackage.haskell.org/package/retry-0.9.3.1/docs/Control-Retry.html#v:exponentialBackoff
+  , _maeMaxDelay  :: !(Maybe Int)
+  -- ^ Maximum waiting time in microseconds.
+  -- https://hackage.haskell.org/package/retry-0.9.3.1/docs/Control-Retry.html#v:limitRetriesByCumulativeDelay
   }
 
 data MaestroNetwork = Mainnet | Preprod | Preview
@@ -46,13 +52,29 @@ maestroBaseUrl Preview v = "https://preview.gomaestro-api.org/" <> show v
 maestroBaseUrl Preprod v = "https://preprod.gomaestro-api.org/" <> show v
 maestroBaseUrl Mainnet v = "https://mainnet.gomaestro-api.org/" <> show v
 
-mkMaestroEnv :: forall (apiVersion :: MaestroApiVersion). SingMaestroApiVersionI apiVersion => MaestroToken -> MaestroNetwork -> IO (MaestroEnv apiVersion)
-mkMaestroEnv token nid = do
+mkMaestroEnv
+  :: forall (apiVersion :: MaestroApiVersion).
+  ( SingMaestroApiVersionI apiVersion
+  ) =>
+  MaestroToken ->
+  MaestroNetwork ->
+  Maybe (Int, Int) ->
+  IO (MaestroEnv apiVersion)
+mkMaestroEnv token nid mbDelays = do
   clientEnv <- servantClientEnv $ maestroBaseUrl nid (fromSingMaestroApiVersion $ singMaestroApiVersion @apiVersion)
-  pure $ MaestroEnv { maeClientEnv = clientEnv, maeToken = token }
+  pure $ MaestroEnv
+    { _maeClientEnv = clientEnv
+    , _maeToken = token
+    , _maeBaseDelay = mbDelays >>= pure . fst
+    , _maeMaxDelay = mbDelays >>= pure . snd
+    }
 
 servantClientEnv :: String -> IO Servant.ClientEnv
 servantClientEnv url = do
   baseUrl <- Servant.parseBaseUrl url
   manager <- newManager tlsManagerSettings
   pure $ Servant.mkClientEnv manager baseUrl
+
+-- | Base delay, Maximum waiting in microseconds
+defaultBackoff :: Maybe (Int, Int)
+defaultBackoff = Just (50000, 10000000)

src/Maestro/Client/V1/Core.hs

@@ -1,19 +1,39 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Maestro.Client.V1.Core
   ( apiV1Client
   , module Maestro.Client.V1.Core.Pagination
   ) where
-
 import           Control.Exception                 (throwIO)
+import           Control.Retry                     (retrying, limitRetriesByCumulativeDelay, exponentialBackoff)
 import           Maestro.API.V1
 import           Maestro.Client.Env
-import           Maestro.Client.Error              (fromServantClientError)
+import           Maestro.Client.Error              (fromServantClientError, MaestroError (..))
 import           Maestro.Client.V1.Core.Pagination
 import           Servant.API.Generic               (fromServant)
 import           Servant.Client
 import           Servant.Client.Generic
+import Control.Monad ((>=>))
+
 
 apiV1ClientAuth :: MaestroEnv 'V1 -> MaestroApiV1Auth (AsClientT IO)
-apiV1ClientAuth MaestroEnv{..} = genericClientHoist $ \x -> runClientM x maeClientEnv >>= either (throwIO . fromServantClientError) pure
+apiV1ClientAuth MaestroEnv{..} =
+  genericClientHoist $
+    do
+      let handler = case (_maeBaseDelay , _maeMaxDelay) of
+            (Just bDelay, Just mDelay) ->
+              \x ->
+                retrying
+                  (limitRetriesByCumulativeDelay mDelay$ exponentialBackoff bDelay)
+                  (\_retryStatus -> \case
+                      Right _ -> pure False
+                      Left clientErr -> case fromServantClientError clientErr of
+                        MaestroUsageLimitReached -> pure True
+                        _ -> pure False
+                  )
+                  (\_ -> runClientM x _maeClientEnv)
+            _ -> \x -> runClientM x _maeClientEnv
+      handler >=> either (throwIO . fromServantClientError) pure
 
 apiV1Client :: MaestroEnv 'V1 -> MaestroApiV1 (AsClientT IO)
-apiV1Client mEnv@MaestroEnv {..} = fromServant $ apiV1 (apiV1ClientAuth mEnv) maeToken
+apiV1Client mEnv@MaestroEnv {..} = fromServant $ apiV1 (apiV1ClientAuth mEnv) _maeToken

test/Driver.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}

test/Maestro/Test/Backoff.hs

@@ -0,0 +1,64 @@
+module Maestro.Test.Backoff where
+
+import Test.Hspec
+
+import Control.Concurrent (MVar, ThreadId, newMVar, takeMVar, putMVar, newEmptyMVar, forkFinally)
+import Control.Exception (try)
+import Control.Monad (void)
+import Data.Text (pack)
+import Maestro.Client.V1
+import Maestro.Types.V1
+import System.Environment (getEnv)
+
+
+spec_backoff :: Spec
+spec_backoff = do
+  it "errors without backoff" $ do
+    shouldThrow  (doConcCall Nothing) anyErrorCall
+
+  it "works with default backoff settings" $ do
+    doConcCall defaultBackoff
+
+type Ret = Either MaestroError [UtxoWithSlot]
+
+doConcCall :: Maybe (Int, Int) -> IO ()
+doConcCall backoffSettings = do
+    maestroKey <- pack <$> getEnv  "MAESTRO_API_KEY"
+    env <- mkMaestroEnv @'V1 maestroKey Preprod backoffSettings
+    children <- newMVar []
+    void $ mapM (forkChild children) $ replicate 30 $ task env
+    waitForChildren children
+  where
+    task :: MaestroEnv 'V1 -> IO Ret
+    task env =
+      try
+      $ allPages
+      $ flip
+        (
+          utxosAtMultiAddresses env
+            (Just True)
+            (Just False)
+        ) ["addr_test1vqj247zdmh7n9g46ukk59k2yxeslevzhah0uj3t0t450x3ggycpxj"]
+
+forkChild :: MVar [MVar Ret] -> IO (Ret) -> IO ThreadId
+forkChild children action = do
+    mvar :: MVar Ret <- newEmptyMVar
+    childs <- takeMVar children
+    putMVar children (mvar:childs)
+    forkFinally action $ \ret -> case ret of
+      Left _ -> putMVar mvar $ Left $ MaestroError "client finished abruptly"
+      Right ret' -> putMVar mvar ret'
+
+waitForChildren :: MVar [MVar Ret] -> IO ()
+waitForChildren children = do
+  cs <- takeMVar children
+  case cs of
+    []   -> return ()
+    m:ms -> do
+      putMVar children ms
+      ret <- takeMVar m
+      case ret of
+        Left _ -> error "failed"
+        _ -> waitForChildren children
+
+