diff --git a/.gitignore b/.gitignore index 90c9393..8d772b7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.cabal dist-newstyle dist dist-* diff --git a/README.md b/README.md index 83a5b57..4ee5883 100644 --- a/README.md +++ b/README.md @@ -42,7 +42,7 @@ main :: IO () main = do - env <- mkMaestroEnv @'V1 "" Preprod -- This is how we create an environment against which we'll query endpoints. + env <- mkMaestroEnv @'V1 "" 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`. diff --git a/maestro-sdk.cabal b/maestro-sdk.cabal index abbcef9..414d74e 100644 --- a/maestro-sdk.cabal +++ b/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 \ No newline at end of file diff --git a/src/Maestro/Client/Env.hs b/src/Maestro/Client/Env.hs index 9a4e61a..3ae8147 100644 --- a/src/Maestro/Client/Env.hs +++ b/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) \ No newline at end of file diff --git a/src/Maestro/Client/V1/Core.hs b/src/Maestro/Client/V1/Core.hs index e38d591..16fe4cb 100644 --- a/src/Maestro/Client/V1/Core.hs +++ b/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 diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 index 0000000..70c55f5 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/Maestro/Test/Backoff.hs b/test/Maestro/Test/Backoff.hs new file mode 100644 index 0000000..2d54918 --- /dev/null +++ b/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 + +