From 38fc5d582340976076cce932a55b85a9944f4095 Mon Sep 17 00:00:00 2001 From: Thomas Honeyman Date: Thu, 27 Jul 2023 13:40:48 -0400 Subject: [PATCH] Replace withBackoff with more explicit alternatives (#638) --- app/src/App/Effect/GitHub.purs | 29 ++++--- app/src/App/Effect/Pursuit.purs | 78 +++++++++--------- app/src/App/Effect/Source.purs | 19 +++-- app/src/App/Effect/Storage.purs | 86 ++++++++++---------- app/src/App/Prelude.purs | 136 ++++++++++++++++++++++---------- 5 files changed, 201 insertions(+), 147 deletions(-) diff --git a/app/src/App/Effect/GitHub.purs b/app/src/App/Effect/GitHub.purs index b53d0a47d..c78516667 100644 --- a/app/src/App/Effect/GitHub.purs +++ b/app/src/App/Effect/GitHub.purs @@ -258,18 +258,25 @@ request octokit githubRequest@{ route: route@(GitHubRoute method _ _), codec } = requestWithBackoff :: forall a r. Octokit -> Request a -> Run (LOG + AFF + r) (Either Octokit.GitHubError a) requestWithBackoff octokit githubRequest = do Log.debug $ "Making request to " <> Octokit.printGitHubRoute githubRequest.route - let action = Octokit.request octokit githubRequest - result <- Run.liftAff $ withBackoff - { delay: Duration.Milliseconds 5_000.0 - , action - , shouldCancel: \_ -> Octokit.request octokit Octokit.rateLimitRequest >>= case _ of - Right { remaining } | remaining == 0 -> pure false - _ -> pure true - , shouldRetry: \attempt -> if attempt <= 3 then pure (Just action) else pure Nothing - } + result <- Run.liftAff do + let + retryOptions = + { timeout: defaultRetry.timeout + , retryOnCancel: defaultRetry.retryOnCancel + , retryOnFailure: \attempt err -> case err of + UnexpectedError _ -> false + DecodeError _ -> false + -- https://docs.github.com/en/rest/overview/resources-in-the-rest-api?apiVersion=2022-11-28#exceeding-the-rate-limit + APIError { statusCode } | statusCode >= 400 && statusCode <= 500 -> false + APIError _ -> attempt <= 3 + } + withRetry retryOptions (Octokit.request octokit githubRequest) case result of - Nothing -> pure $ Left $ APIError { statusCode: 400, message: "Unable to reach GitHub servers." } - Just accepted -> pure accepted + Cancelled -> pure $ Left $ APIError { statusCode: 400, message: "Unable to reach GitHub servers." } + Failed err -> do + Log.debug $ "Request failed with error: " <> Octokit.printGitHubError err + pure $ Left err + Succeeded success -> pure $ Right success type RequestResult = { modified :: DateTime diff --git a/app/src/App/Effect/Pursuit.purs b/app/src/App/Effect/Pursuit.purs index 2c2854c62..183bbf9f3 100644 --- a/app/src/App/Effect/Pursuit.purs +++ b/app/src/App/Effect/Pursuit.purs @@ -16,8 +16,6 @@ import Data.HTTP.Method as Method import Data.Map as Map import Data.MediaType.Common as MediaType import Data.Profunctor as Profunctor -import Effect.Aff (Milliseconds(..)) -import Effect.Aff as Aff import Registry.App.Effect.Log (LOG) import Registry.App.Effect.Log as Log import Registry.App.Legacy.LenientVersion (LenientVersion(..)) @@ -64,50 +62,46 @@ handleAff (GitHubToken token) = case _ of Publish payload reply -> do Log.debug "Pushing to Pursuit..." - let - loop n = do - result <- Run.liftAff $ withBackoff' $ Affjax.Node.request - { content: Just $ RequestBody.json payload - , headers: - [ RequestHeader.Accept MediaType.applicationJSON - , RequestHeader.RequestHeader "Authorization" ("token " <> token) - ] - , method: Left Method.POST - , username: Nothing - , withCredentials: false - , password: Nothing - , responseFormat: ResponseFormat.string - , timeout: Nothing - , url: "https://pursuit.purescript.org/packages" - } - - case result of - Nothing -> do - Log.error $ "Pursuit failed to connect after several retries." - pure $ Left $ "Expected to receive a 201 status from Pursuit, but failed to connect after several retries." - Just (Right { status: StatusCode status }) - | status == 201 -> do - Log.debug "Received 201 status, which indicates the upload was successful." - pure $ Right unit - | n > 0, status == 400 || status == 502 -> do - Log.debug $ "Received " <> show status <> ", retrying..." - Run.liftAff $ Aff.delay $ Milliseconds 1000.0 - loop (n - 1) - Just (Right { body, status: StatusCode status }) -> do + result <- Run.liftAff $ withRetryRequest' + { content: Just $ RequestBody.json payload + , headers: + [ RequestHeader.Accept MediaType.applicationJSON + , RequestHeader.RequestHeader "Authorization" ("token " <> token) + ] + , method: Left Method.POST + , username: Nothing + , withCredentials: false + , password: Nothing + , responseFormat: ResponseFormat.string + , timeout: Nothing + , url: "https://pursuit.purescript.org/packages" + } + + result' <- case result of + Cancelled -> do + Log.error $ "Pursuit failed to connect after several retries." + pure $ Left $ "Expected to receive a 201 status from Pursuit, but failed to connect after several retries." + Failed reqError -> case reqError of + AffjaxError err -> do + pure $ Left $ "Pursuit publishing failed with an HTTP error: " <> Affjax.Node.printError err + StatusError { body, status: StatusCode status } -> do + Log.error $ "Pursuit publishing failed with status " <> show status <> " and body\n" <> body + pure $ Left $ "Expected to receive a 201 status from Pursuit, but received " <> show status <> " instead." + Succeeded { body, status: StatusCode status } + | status == 201 -> do + Log.debug "Received 201 status, which indicates the upload was successful." + pure $ Right unit + | otherwise -> do Log.error $ "Pursuit publishing failed with status " <> show status <> " and body\n" <> body pure $ Left $ "Expected to receive a 201 status from Pursuit, but received " <> show status <> " instead." - Just (Left httpError) -> do - let printedError = Affjax.Node.printError httpError - Log.error $ "Pursuit publishing failed because of an HTTP error: " <> printedError - pure $ Left "Could not reach Pursuit due to an HTTP error." - reply <$> loop 2 + pure $ reply result' GetPublishedVersions pname reply -> do let name = PackageName.print pname let url = "https://pursuit.purescript.org/packages/purescript-" <> name <> "/available-versions" Log.debug $ "Checking if package docs for " <> name <> " are published on Pursuit using endpoint " <> url - result <- Run.liftAff $ withBackoff' $ Affjax.Node.request + result <- Run.liftAff $ withRetryRequest' { content: Nothing , headers: [ RequestHeader.Accept MediaType.applicationJSON ] , method: Left Method.GET @@ -120,17 +114,17 @@ handleAff (GitHubToken token) = case _ of } case result of - Nothing -> do + Cancelled -> do Log.error $ "Could not reach Pursuit after multiple retries at URL " <> url pure $ reply $ Left $ "Could not reach Pursuit to determine published versions for " <> name - Just (Left httpError) -> do + Failed (AffjaxError httpError) -> do let printedError = Affjax.Node.printError httpError Log.error $ "Pursuit publishing failed because of an HTTP error: " <> printedError pure $ reply $ Left "Could not reach Pursuit due to an HTTP error." - Just (Right { body, status: StatusCode status }) | status /= 200 -> do + Failed (StatusError { body, status: StatusCode status }) -> do Log.error $ "Could not fetch published versions from Pursuit (received non-200 response) " <> show status <> " and body\n" <> Argonaut.stringify body pure $ reply $ Left $ "Received non-200 response from Pursuit: " <> show status - Just (Right { body }) -> case CA.decode availableVersionsCodec body of + Succeeded { body } -> case CA.decode availableVersionsCodec body of Left error -> do let printed = CA.printJsonDecodeError error Log.error $ "Failed to decode body " <> Argonaut.stringify body <> "\n with error: " <> printed diff --git a/app/src/App/Effect/Source.purs b/app/src/App/Effect/Source.purs index a150378ac..711a4983f 100644 --- a/app/src/App/Effect/Source.purs +++ b/app/src/App/Effect/Source.purs @@ -5,7 +5,6 @@ import Registry.App.Prelude import Affjax.Node as Affjax.Node import Affjax.ResponseFormat as ResponseFormat -import Affjax.StatusCode (StatusCode(..)) import Data.Array as Array import Data.DateTime (DateTime) import Data.HTTP.Method (Method(..)) @@ -79,10 +78,10 @@ handle = case _ of clonePackageAtTag = do let url = Array.fold [ "https://github.com/", owner, "/", repo ] let args = [ "clone", url, "--branch", ref, "--single-branch", "-c", "advice.detachedHead=false", repoDir ] - withBackoff' (Git.gitCLI args Nothing) >>= case _ of - Nothing -> Aff.throwError $ Aff.error $ "Timed out attempting to clone git tag: " <> url <> " " <> ref - Just (Left err) -> Aff.throwError $ Aff.error err - Just (Right _) -> pure unit + withRetryOnTimeout (Git.gitCLI args Nothing) >>= case _ of + Cancelled -> Aff.throwError $ Aff.error $ "Timed out attempting to clone git tag: " <> url <> " " <> ref + Failed err -> Aff.throwError $ Aff.error err + Succeeded _ -> pure unit Run.liftAff (Aff.attempt clonePackageAtTag) >>= case _ of Left error -> do @@ -131,23 +130,23 @@ handle = case _ of let archiveUrl = "https://github.com/" <> owner <> "/" <> repo <> "/archive/" <> tarballName Log.debug $ "Fetching tarball from GitHub: " <> archiveUrl - response <- Run.liftAff $ withBackoff' $ Affjax.Node.request $ Affjax.Node.defaultRequest + response <- Run.liftAff $ withRetryRequest' $ Affjax.Node.defaultRequest { method = Left GET , responseFormat = ResponseFormat.arrayBuffer , url = archiveUrl } case response of - Nothing -> Except.throw $ "Could not download " <> archiveUrl - Just (Left error) -> do + Cancelled -> Except.throw $ "Could not download " <> archiveUrl + Failed (AffjaxError error) -> do Log.error $ "Failed to download " <> archiveUrl <> " because of an HTTP error: " <> Affjax.Node.printError error Except.throw $ "Could not download " <> archiveUrl - Just (Right { status, body }) | status /= StatusCode 200 -> do + Failed (StatusError { status, body }) -> do buffer <- Run.liftEffect $ Buffer.fromArrayBuffer body bodyString <- Run.liftEffect $ Buffer.toString UTF8 (buffer :: Buffer) Log.error $ "Failed to download " <> archiveUrl <> " because of a non-200 status code (" <> show status <> ") with body " <> bodyString Except.throw $ "Could not download " <> archiveUrl - Just (Right { body }) -> do + Succeeded { body } -> do Log.debug $ "Successfully downloaded " <> archiveUrl <> " into a buffer." buffer <- Run.liftEffect $ Buffer.fromArrayBuffer body Run.liftAff (Aff.attempt (FS.Aff.writeFile absoluteTarballPath buffer)) >>= case _ of diff --git a/app/src/App/Effect/Storage.purs b/app/src/App/Effect/Storage.purs index 167e519e8..cc32bdaf8 100644 --- a/app/src/App/Effect/Storage.purs +++ b/app/src/App/Effect/Storage.purs @@ -20,7 +20,6 @@ import Registry.App.Prelude import Affjax.Node as Affjax.Node import Affjax.ResponseFormat as ResponseFormat -import Affjax.StatusCode (StatusCode(..)) import Data.Array as Array import Data.Exists as Exists import Data.HTTP.Method (Method(..)) @@ -34,6 +33,7 @@ import Registry.App.Effect.Cache as Cache import Registry.App.Effect.Log (LOG) import Registry.App.Effect.Log as Log import Registry.Constants as Constants +import Registry.Foreign.S3 (Space) import Registry.Foreign.S3 as S3 import Registry.PackageName as PackageName import Registry.Version as Version @@ -106,13 +106,13 @@ connectS3 key = do let bucket = "purescript-registry" let space = "ams3.digitaloceanspaces.com" Log.debug $ "Connecting to the bucket " <> bucket <> " at space " <> space <> " with public key " <> key.key - Run.liftAff (withBackoff' (Aff.attempt (S3.connect key "ams3.digitaloceanspaces.com" bucket))) >>= case _ of - Nothing -> + Run.liftAff (withRetryOnTimeout (Aff.attempt (S3.connect key "ams3.digitaloceanspaces.com" bucket))) >>= case _ of + Cancelled -> Except.throw "Timed out when attempting to connect to S3 storage backend." - Just (Left err) -> do + Failed err -> do Log.error $ "Failed to connect to S3 due to an exception: " <> Aff.message err Except.throw "Could not connect to storage backend." - Just (Right connection) -> do + Succeeded connection -> do Log.debug "Connected to S3!" pure connection @@ -126,17 +126,10 @@ handleS3 :: forall r a. S3Env -> Storage a -> Run (LOG + AFF + EFFECT + r) a handleS3 env = Cache.interpret _storageCache (Cache.handleFs env.cache) <<< case _ of Query name reply -> map (map reply) Except.runExcept do s3 <- connectS3 env.s3 - resources <- Run.liftAff (withBackoff' (S3.listObjects s3 { prefix: PackageName.print name <> "/" })) >>= case _ of - Nothing -> do - Log.error $ "Failed to list S3 objects for " <> PackageName.print name <> " because the process timed out." - Except.throw $ "Could not upload package " <> PackageName.print name <> " due to an error connecting to the storage backend." - Just objects -> - pure $ map _.key objects - pure $ Set.fromFoldable - $ resources - >>= \resource -> do - { name: parsedName, version } <- Array.fromFoldable $ parsePackagePath resource - version <$ guard (name == parsedName) + resources <- Except.rethrow =<< Run.liftAff (withRetryListObjects s3 name) + pure $ Set.fromFoldable $ resources >>= \resource -> do + { name: parsedName, version } <- Array.fromFoldable $ parsePackagePath resource + version <$ guard (name == parsedName) Download name version path reply -> map (map reply) Except.runExcept do let package = formatPackageVersion name version @@ -167,24 +160,21 @@ handleS3 env = Cache.interpret _storageCache (Cache.handleFs env.cache) <<< case Log.debug $ "Read file for " <> package <> ", now uploading to " <> packagePath <> "..." s3 <- connectS3 env.s3 - published <- Run.liftAff (withBackoff' (S3.listObjects s3 { prefix: PackageName.print name <> "/" })) >>= case _ of - Nothing -> do - Log.error $ "Failed to list S3 objects for " <> PackageName.print name <> " because the process timed out." - Except.throw $ "Could not upload package " <> package <> " due to an error connecting to the storage backend." - Just objects -> - pure $ map _.key objects - + published <- Except.rethrow =<< Run.liftAff (withRetryListObjects s3 name) if Array.elem packagePath published then do Log.error $ packagePath <> " already exists on S3." Except.throw $ "Could not upload " <> package <> " because a package at " <> formatPackageUrl name version <> " already exists." else do Log.debug $ "Uploading release to the bucket at path " <> packagePath let putParams = { key: packagePath, body: buffer, acl: S3.PublicRead } - Run.liftAff (withBackoff' (S3.putObject s3 putParams)) >>= case _ of - Nothing -> do - Log.error "Failed to put object to S3 because the process timed out." + Run.liftAff (withRetryOnTimeout (Aff.attempt (S3.putObject s3 putParams))) >>= case _ of + Cancelled -> do + Log.error "Failed to upload object to S3 because the process timed out." + Except.throw $ "Could not upload package " <> package <> " due to an error connecting to the storage backend." + Failed error -> do + Log.error $ "Failed to upload object to S3 because of an exception: " <> Aff.message error Except.throw $ "Could not upload package " <> package <> " due to an error connecting to the storage backend." - Just _ -> + Succeeded _ -> Log.info $ "Uploaded " <> package <> " to the bucket at path " <> packagePath Delete name version reply -> map (map reply) Except.runExcept do @@ -194,21 +184,18 @@ handleS3 env = Cache.interpret _storageCache (Cache.handleFs env.cache) <<< case Log.debug $ "Deleting " <> package s3 <- connectS3 env.s3 - published <- Run.liftAff (withBackoff' (S3.listObjects s3 { prefix: PackageName.print name <> "/" })) >>= case _ of - Nothing -> do - Log.error $ "Failed to delete " <> package <> " because the process timed out when attempting to list objects at " <> packagePath <> " from S3." - Except.throw $ "Could not delete " <> package <> " from the storage backend." - Just objects -> - pure $ map _.key objects - + published <- Except.rethrow =<< Run.liftAff (withRetryListObjects s3 name) if Array.elem packagePath published then do Log.debug $ "Deleting release from the bucket at path " <> packagePath let deleteParams = { key: packagePath } - Run.liftAff (withBackoff' (S3.deleteObject s3 deleteParams)) >>= case _ of - Nothing -> do + Run.liftAff (withRetryOnTimeout (Aff.attempt (S3.deleteObject s3 deleteParams))) >>= case _ of + Cancelled -> do Log.error $ "Timed out when attempting to delete the release of " <> package <> " from S3 at the path " <> packagePath Except.throw $ "Could not delete " <> package <> " from the storage backend." - Just _ -> do + Failed error -> do + Log.error $ "Failed to delete object from S3 because of an exception: " <> Aff.message error + Except.throw $ "Could not delete package " <> package <> " due to an error connecting to the storage backend." + Succeeded _ -> do Log.debug $ "Deleted release of " <> package <> " from S3 at the path " <> packagePath pure unit else do @@ -253,7 +240,7 @@ downloadS3 name version = do packageUrl = formatPackageUrl name version Log.debug $ "Downloading " <> package <> " from " <> packageUrl - response <- Run.liftAff $ withBackoff' $ Affjax.Node.request $ Affjax.Node.defaultRequest + response <- Run.liftAff $ withRetryRequest' $ Affjax.Node.defaultRequest { method = Left GET , responseFormat = ResponseFormat.arrayBuffer , url = packageUrl @@ -262,22 +249,35 @@ downloadS3 name version = do -- TODO: Rely on the metadata to check the size and hash? Or do we not care -- for registry-internal operations? case response of - Nothing -> do + Cancelled -> do Log.error $ "Failed to download " <> package <> " from " <> packageUrl <> " because of a connection timeout." Except.throw $ "Failed to download " <> package <> " from the storage backend." - Just (Left error) -> do + Failed (AffjaxError error) -> do Log.error $ "Failed to download " <> package <> " from " <> packageUrl <> " because of an HTTP error: " <> Affjax.Node.printError error Except.throw $ "Could not download " <> package <> " from the storage backend." - Just (Right { status, body }) | status /= StatusCode 200 -> do + Failed (StatusError { status, body }) -> do buffer <- Run.liftEffect $ Buffer.fromArrayBuffer body bodyString <- Run.liftEffect $ Buffer.toString UTF8 (buffer :: Buffer) - Log.error $ "Failed to download " <> package <> " from " <> packageUrl <> " because of a non-200 status code (" <> show status <> ") with body " <> bodyString + Log.error $ "Failed to download " <> package <> " from " <> packageUrl <> " because of a bad status code (" <> show status <> ") with body " <> bodyString Except.throw $ "Could not download " <> package <> " from the storage backend." - Just (Right { body }) -> do + Succeeded { body } -> do Log.debug $ "Successfully downloaded " <> package <> " into a buffer." buffer :: Buffer <- Run.liftEffect $ Buffer.fromArrayBuffer body pure buffer +withRetryListObjects :: Space -> PackageName -> Aff (Either String (Array String)) +withRetryListObjects s3 name = do + let package = PackageName.print name + result <- withRetry (defaultRetry { retryOnFailure = \attempt _ -> attempt < 3 }) do + Aff.attempt (S3.listObjects s3 { prefix: package <> "/" }) + pure $ case result of + Cancelled -> do + Left $ "Failed to list S3 objects for " <> package <> " because the process timed out." + Failed error -> do + Left $ "Failed to list S3 objects for " <> package <> " because of an exception: " <> Aff.message error + Succeeded objects -> + pure $ map _.key objects + -- | A key type for the storage cache. Only supports packages identified by -- | their name and version. data StorageCache (c :: Type -> Type -> Type) a = Package PackageName Version (c Buffer a) diff --git a/app/src/App/Prelude.purs b/app/src/App/Prelude.purs index bff8bac8c..8c98a2cde 100644 --- a/app/src/App/Prelude.purs +++ b/app/src/App/Prelude.purs @@ -1,8 +1,11 @@ module Registry.App.Prelude - ( Backoff - , LogVerbosity(..) + ( LogVerbosity(..) , PursPublishMethod(..) + , RetryRequestError(..) + , Retry + , RetryResult(..) , class Functor2 + , defaultRetry , formatPackageVersion , fromJust' , map2 @@ -25,13 +28,18 @@ module Registry.App.Prelude , traverseKeys , unsafeFromJust , unsafeFromRight - , withBackoff - , withBackoff' + , withRetry + , withRetryOnTimeout + , withRetryRequest + , withRetryRequest' , writeJsonFile ) where import Prelude +import Affjax as Affjax +import Affjax.Node as Affjax.Node +import Affjax.StatusCode (StatusCode(..)) import Control.Alt ((<|>)) as Extra import Control.Alternative (guard) as Extra import Control.Monad.Except (ExceptT(..)) as Extra @@ -147,52 +155,98 @@ mapKeys k = Map.fromFoldable <<< map (Extra.lmap k) <<< (Map.toUnfoldable :: _ - traverseKeys :: forall a b v. Ord a => Ord b => (a -> Either.Either String b) -> Extra.Map a v -> Either.Either String (Extra.Map b v) traverseKeys k = map Map.fromFoldable <<< Extra.traverse (Extra.ltraverse k) <<< (Map.toUnfoldable :: _ -> Array _) --- | Attempt an effectful computation with exponential backoff. -withBackoff' :: forall a. Extra.Aff a -> Extra.Aff (Maybe.Maybe a) -withBackoff' action = withBackoff - { delay: Aff.Milliseconds 5_000.0 - , action - , shouldCancel: \_ -> pure true - , shouldRetry: \attempt -> if attempt > 3 then pure Maybe.Nothing else pure (Maybe.Just action) +data RetryRequestError a + = AffjaxError (Affjax.Error) + | StatusError (Affjax.Response a) + +withRetryRequest' :: forall a. Affjax.Request a -> Extra.Aff (RetryResult (RetryRequestError a) (Affjax.Response a)) +withRetryRequest' = withRetryRequest + { timeout: defaultRetry.timeout + , retryOnCancel: defaultRetry.retryOnCancel + , retryOnFailure: \attempt -> case _ of + AffjaxError _ -> false + StatusError { status: StatusCode status } -> + -- We retry on 500-level errors in case the server is temporarily + -- unresponsive, and fail otherwise. + if status >= 500 then + attempt < 3 + else false + } + (\error -> AffjaxError error) + (\response@{ status: StatusCode status } -> if status >= 400 then Either.Left (StatusError response) else Either.Right response) + +withRetryRequest + :: forall e a b + . Retry e + -> (Affjax.Error -> e) + -> (Affjax.Response a -> Either.Either e b) + -> Affjax.Request a + -> Extra.Aff (RetryResult e b) +withRetryRequest retry onAffjaxError onAffjaxResponse request = + withRetry retry (map (Either.either (Either.Left <<< onAffjaxError) onAffjaxResponse) (Affjax.Node.request request)) + +withRetryOnTimeout :: forall err a. Extra.Aff (Either.Either err a) -> Extra.Aff (RetryResult err a) +withRetryOnTimeout = withRetry defaultRetry + +type Retry err = + { timeout :: Aff.Milliseconds + , retryOnCancel :: Int -> Boolean + , retryOnFailure :: Int -> err -> Boolean } -type Backoff a = - { delay :: Aff.Milliseconds - , action :: Extra.Aff a - , shouldCancel :: Int -> Extra.Aff Boolean - , shouldRetry :: Int -> Extra.Aff (Maybe.Maybe (Extra.Aff a)) +-- | Default retry configuration, which retries on cancellation but does not +-- | retry on failure. +defaultRetry :: forall err. Retry err +defaultRetry = + { timeout: Aff.Milliseconds 5000.0 + , retryOnCancel: \attempt -> attempt <= 3 + , retryOnFailure: \_ _ -> false } --- | Attempt an effectful computation with exponential backoff, starting with --- | the provided timeout. -withBackoff :: forall a. Backoff a -> Extra.Aff (Maybe.Maybe a) -withBackoff { delay: Aff.Milliseconds timeout, action, shouldCancel, shouldRetry } = do +data RetryResult err a + = Cancelled + | Failed err + | Succeeded a + +derive instance (Eq err, Eq a) => Eq (RetryResult err a) + +-- | Attempt an effectful computation that can fail by specifying how to retry +-- | the request and whether it should time out. +withRetry :: forall err a. Retry err -> Extra.Aff (Either.Either err a) -> Extra.Aff (RetryResult err a) +withRetry { timeout: Aff.Milliseconds timeout, retryOnCancel, retryOnFailure } action = do let - runAction attempt action' ms = + runAction :: Extra.Aff (Either.Either err a) -> Int -> Extra.Aff (RetryResult err a) + runAction action' ms = do Parallel.sequential $ Foldable.oneOf - [ Parallel.parallel (map Maybe.Just action') - , Parallel.parallel (runTimeout attempt ms) + [ Parallel.parallel $ action' >>= case _ of + Either.Left err -> pure $ Failed err + Either.Right val -> pure $ Succeeded val + , Parallel.parallel (runTimeout ms) ] - runTimeout attempt ms = do + runTimeout :: Int -> Extra.Aff (RetryResult err a) + runTimeout ms = do _ <- Aff.delay (Aff.Milliseconds (Int.toNumber ms)) - shouldCancel attempt >>= if _ then pure Maybe.Nothing else runTimeout attempt (ms * 2) - - loop :: Int -> Maybe.Maybe a -> Extra.Aff (Maybe.Maybe a) - loop attempt = case _ of - Maybe.Nothing -> do - maybeRetry <- shouldRetry attempt - case maybeRetry of - Maybe.Nothing -> pure Maybe.Nothing - Maybe.Just newAction -> do - let newTimeout = Int.floor timeout `Int.pow` (attempt + 1) - maybeResult <- runAction attempt newAction newTimeout - loop (attempt + 1) maybeResult - Maybe.Just result -> - pure (Maybe.Just result) - - maybeResult <- runAction 0 action (Int.floor timeout) - loop 1 maybeResult + pure Cancelled + + retry :: Int -> RetryResult err a -> Extra.Aff (RetryResult err a) + retry attempt = case _ of + Cancelled -> + if retryOnCancel attempt then do + let newTimeout = Int.floor timeout `Int.pow` (attempt + 1) + retry (attempt + 1) =<< runAction action newTimeout + else + pure Cancelled + Failed err -> + if retryOnFailure attempt err then do + let newTimeout = Int.floor timeout `Int.pow` (attempt + 1) + retry (attempt + 1) =<< runAction action newTimeout + else + pure (Failed err) + Succeeded result -> + pure (Succeeded result) + + retry 1 =<< runAction action (Int.floor timeout) -- | Get the current time, standardizing on the UTC timezone to avoid ambiguity -- | when running on different machines.