Retry asset downloads in check_releases (#8730)

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
This commit is contained in:
Moritz Kiefer 2021-02-03 12:04:59 +01:00 committed by GitHub
parent 42e071f2c2
commit d7d954335e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 19 additions and 5 deletions

View File

@ -28,6 +28,7 @@ da_haskell_binary(
"proto3-suite",
"regex-tdfa",
"resourcet",
"retry",
"safe",
"safe-exceptions",
"semver",

View File

@ -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) -- Dont 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