From d7d954335e1f29fbbbcbe259c42e3064f5a069bd Mon Sep 17 00:00:00 2001
From: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>
Date: Wed, 3 Feb 2021 12:04:59 +0100
Subject: [PATCH] Retry asset downloads in check_releases (#8730)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

We’ve seen a number of "resource vanished (connection reset by peer)"
errors. Slapping some retries on that should hopefully make the CI job
a bit more robust.

changelog_begin
changelog_end
---
 ci/cron/BUILD.bazel |  1 +
 ci/cron/src/Main.hs | 23 ++++++++++++++++++-----
 2 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/ci/cron/BUILD.bazel b/ci/cron/BUILD.bazel
index 4564de6bb65..1412b54c90e 100644
--- a/ci/cron/BUILD.bazel
+++ b/ci/cron/BUILD.bazel
@@ -28,6 +28,7 @@ da_haskell_binary(
         "proto3-suite",
         "regex-tdfa",
         "resourcet",
+        "retry",
         "safe",
         "safe-exceptions",
         "semver",
diff --git a/ci/cron/src/Main.hs b/ci/cron/src/Main.hs
index 59df3669ec8..ae63336a438 100644
--- a/ci/cron/src/Main.hs
+++ b/ci/cron/src/Main.hs
@@ -14,6 +14,7 @@ import Control.Exception.Safe
 import qualified Control.Monad as Control
 import qualified Control.Monad.Extra
 import qualified Control.Monad.Loops
+import Control.Retry
 import qualified Data.Aeson as JSON
 import qualified Data.ByteString
 import qualified Data.ByteString.UTF8 as BS
@@ -317,20 +318,32 @@ download_assets :: FilePath -> GitHubRelease -> IO ()
 download_assets tmp release = do
     manager <- HTTP.newManager TLS.tlsManagerSettings
     tokens <- Control.Concurrent.QSem.newQSem 20
-    Control.Concurrent.Async.forConcurrently_ (map uri $ assets release) (\url ->
+    Control.Concurrent.Async.forConcurrently_ (map uri $ assets release) $ \url ->
         bracket_
           (Control.Concurrent.QSem.waitQSem tokens)
           (Control.Concurrent.QSem.signalQSem tokens)
           (do
               req <- add_github_contact_header <$> HTTP.parseRequest (show url)
-              HTTP.withResponse req manager (\resp -> do
-                  let body = HTTP.responseBody resp
-                  IO.withBinaryFile (tmp </> (last $ Network.URI.pathSegments url)) IO.AppendMode (\handle -> do
-                      while (readFrom body) (writeTo handle)))))
+              recovering
+                retryPolicy
+                [retryHandler]
+                (\_ -> downloadFile req manager url)
+          )
   where while = Control.Monad.Loops.whileJust_
         readFrom body = ifNotEmpty <$> HTTP.brRead body
         ifNotEmpty bs = if Data.ByteString.null bs then Nothing else Just bs
         writeTo = Data.ByteString.hPut
+        -- Retry for 5 minutes total, doubling delay starting with 20ms
+        retryPolicy = limitRetriesByCumulativeDelay (5 * 60 * 1000 * 1000) (exponentialBackoff (20 * 1000))
+        retryHandler status =
+          logRetries
+            (\(_ :: IOException) -> pure True) -- Don’t try to be clever, just retry
+            (\shouldRetry err status -> IO.hPutStrLn IO.stderr $ defaultLogMsg shouldRetry err status)
+            status
+        downloadFile req manager url = HTTP.withResponse req manager $ \resp -> do
+            let body = HTTP.responseBody resp
+            IO.withBinaryFile (tmp </> (last $ Network.URI.pathSegments url)) IO.AppendMode $ \handle -> do
+                while (readFrom body) (writeTo handle)
 
 verify_signatures :: FilePath -> FilePath -> String -> IO String
 verify_signatures bash_lib tmp version_tag = do