Skip to content

Commit 2d97213

Browse files
mgsloanmgsloan
authored
Merge pull request #3511 from NorfairKing/retry-info
Print retry information if stack needs to retry network requests
2 parents 763225c + 47d5311 commit 2d97213

File tree

4 files changed

+52
-27
lines changed

4 files changed

+52
-27
lines changed

‎src/Network/HTTP/Download.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ module Network.HTTP.Download
2121
) where
2222

2323
import Stack.Prelude
24+
import Stack.Types.Runner
2425
import qualified Data.ByteString.Lazy as L
2526
import Data.Conduit (yield)
2627
import Data.Conduit.Binary (sourceHandle)
@@ -43,7 +44,7 @@ import System.FilePath (takeDirectory, (<.>))
4344
-- appropriate destination.
4445
--
4546
-- Throws an exception if things go wrong
46-
download :: (MonadIO m, MonadLogger m)
47+
download :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
4748
=> Request
4849
-> Path Abs File -- ^ destination
4950
-> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
@@ -60,7 +61,7 @@ download req destpath = do
6061
-- | Same as 'download', but will download a file a second time if it is already present.
6162
--
6263
-- Returns 'True' if the file was downloaded, 'False' otherwise
63-
redownload :: (MonadIO m, MonadLogger m)
64+
redownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
6465
=> Request
6566
-> Path Abs File -- ^ destination
6667
-> m Bool
@@ -86,7 +87,7 @@ redownload req0 dest = do
8687
[("If-None-Match", L.toStrict etag)]
8788
}
8889
req2 = req1 { checkResponse = \_ _ -> return () }
89-
liftIO $ recoveringHttp drRetryPolicyDefault $
90+
recoveringHttp drRetryPolicyDefault $ liftIO $
9091
withResponse req2 $ \res -> case getResponseStatusCode res of
9192
200 -> do
9293
createDirectoryIfMissing True $ takeDirectory destFilePath

‎src/Network/HTTP/Download/Verified.hs

Lines changed: 36 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ import qualified Data.Text.Encoding as Text
3030
import Control.Monad
3131
import Control.Monad.Catch (Handler (..)) -- would be nice if retry exported this itself
3232
import Stack.Prelude hiding (Handler (..))
33-
import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
33+
import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay,RetryStatus(..))
3434
import Crypto.Hash
3535
import Crypto.Hash.Conduit (sinkHash)
3636
import Data.ByteArray as Mem (convert)
@@ -45,6 +45,8 @@ import Network.HTTP.Client (getUri, path)
4545
import Network.HTTP.Simple (Request, HttpException, httpSink, getResponseHeaders)
4646
import Network.HTTP.Types.Header (hContentLength, hContentMD5)
4747
import Path
48+
import Stack.Types.Runner
49+
import Stack.PrettyPrint
4850
import System.Directory
4951
import qualified System.FilePath as FP ((<.>))
5052
import System.IO (hFileSize)
@@ -179,21 +181,39 @@ hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteStr
179181
hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
180182

181183
-- 'Control.Retry.recovering' customized for HTTP failures
182-
recoveringHttp :: MonadUnliftIO m
184+
recoveringHttp :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
183185
=> RetryPolicy -> m a -> m a
184186
recoveringHttp retryPolicy =
185187
#if MIN_VERSION_retry(0,7,0)
186-
helper $ recovering retryPolicy handlers . const
188+
helper $ \run -> recovering retryPolicy (handlers run) . const
187189
#else
188-
helper $ recovering retryPolicy handlers
190+
helper $ \run -> recovering retryPolicy (handlers run)
189191
#endif
190192
where
191-
helper wrapper action = withRunInIO $ \run -> wrapper (run action)
192-
193-
handlers = [const $ Handler alwaysRetryHttp,const $ Handler retrySomeIO]
194-
195-
alwaysRetryHttp :: Monad m => HttpException -> m Bool
196-
alwaysRetryHttp _ = return True
193+
helper :: (MonadUnliftIO m, HasRunner env, MonadReader env m) => (UnliftIO m -> IO a -> IO a) -> m a -> m a
194+
helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action)
195+
196+
handlers :: (MonadLogger m, HasRunner env, MonadReader env m) => UnliftIO m -> [RetryStatus -> Handler IO Bool]
197+
handlers run = [Handler . alwaysRetryHttp (unliftIO run),const $ Handler retrySomeIO]
198+
199+
alwaysRetryHttp :: (MonadLogger m', Monad m, HasRunner env, MonadReader env m') => (m' () -> m ()) -> RetryStatus -> HttpException -> m Bool
200+
alwaysRetryHttp run rs _ = do
201+
run $
202+
prettyWarn $ vcat
203+
[ flow $ unwords
204+
[ "Retry number"
205+
, show (rsIterNumber rs)
206+
, "after a total delay of"
207+
, show (rsCumulativeDelay rs)
208+
, "us"
209+
]
210+
, flow $ unwords
211+
[ "If you see this warning and stack fails to download,"
212+
, "but running the command again solves the problem,"
213+
, "please report here: https://github.com/commercialhaskell/stack/issues/3510"
214+
]
215+
]
216+
return True
197217

198218
retrySomeIO :: Monad m => IOException -> m Bool
199219
retrySomeIO e = return $ case ioe_type e of
@@ -215,7 +235,7 @@ recoveringHttp retryPolicy =
215235
-- Throws VerifiedDownloadException.
216236
-- Throws IOExceptions related to file system operations.
217237
-- Throws HttpException.
218-
verifiedDownload :: (MonadIO m, MonadLogger m)
238+
verifiedDownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
219239
=> DownloadRequest
220240
-> Path Abs File -- ^ destination
221241
-> (Maybe Integer -> Sink ByteString IO ()) -- ^ custom hook to observe progress
@@ -224,12 +244,11 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
224244
let req = drRequest
225245
whenM' (liftIO getShouldDownload) $ do
226246
logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req)
227-
liftIO $ do
228-
createDirectoryIfMissing True dir
229-
recoveringHttp drRetryPolicy $
230-
withBinaryFile fptmp WriteMode $ \h ->
231-
httpSink req (go h)
232-
renameFile fptmp fp
247+
liftIO $ createDirectoryIfMissing True dir
248+
recoveringHttp drRetryPolicy $ liftIO $
249+
withBinaryFile fptmp WriteMode $ \h ->
250+
httpSink req (go h)
251+
liftIO $ renameFile fptmp fp
233252
where
234253
whenM' mp m = do
235254
p <- mp

‎src/Stack/Fetch.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,7 @@ import Stack.Types.Config
5959
import Stack.Types.PackageIdentifier
6060
import Stack.Types.PackageIndex
6161
import Stack.Types.PackageName
62+
import Stack.Types.Runner
6263
import Stack.Types.Version
6364
import qualified System.FilePath as FP
6465
import System.IO (hSeek, SeekMode (AbsoluteSeek))
@@ -505,7 +506,7 @@ fetchPackages' mdistDir toFetchAll = do
505506

506507
liftIO $ readTVarIO outputVar
507508
where
508-
go :: (MonadIO m,MonadThrow m,MonadLogger m)
509+
go :: (MonadUnliftIO m,MonadThrow m,MonadLogger m,HasRunner env, MonadReader env m)
509510
=> TVar (Map PackageIdentifier (Path Abs Dir))
510511
-> (m () -> IO ())
511512
-> (PackageIdentifier, ToFetch)

‎src/test/Network/HTTP/Download/VerifiedSpec.hs

Lines changed: 10 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import Network.HTTP.Download.Verified
99
import Path
1010
import Path.IO hiding (withSystemTempDir)
1111
import Stack.Prelude
12+
import Stack.Types.Runner
1213
import System.IO (writeFile, readFile)
1314
import Test.Hspec
1415

@@ -66,20 +67,23 @@ spec = do
6667
let exampleProgressHook _ = return ()
6768

6869
describe "verifiedDownload" $ do
70+
let run func = runStdoutLoggingT
71+
$ withRunner LevelError True True ColorNever Nothing False
72+
$ \runner -> runRIO runner func
6973
-- Preconditions:
7074
-- * the exampleReq server is running
7175
-- * the test runner has working internet access to it
7276
it "downloads the file correctly" $ withTempDir' $ \dir -> do
7377
examplePath <- getExamplePath dir
7478
doesFileExist examplePath `shouldReturn` False
75-
let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook
79+
let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook
7680
go `shouldReturn` True
7781
doesFileExist examplePath `shouldReturn` True
7882

7983
it "is idempotent, and doesn't redownload unnecessarily" $ withTempDir' $ \dir -> do
8084
examplePath <- getExamplePath dir
8185
doesFileExist examplePath `shouldReturn` False
82-
let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook
86+
let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook
8387
go `shouldReturn` True
8488
doesFileExist examplePath `shouldReturn` True
8589
go `shouldReturn` False
@@ -92,7 +96,7 @@ spec = do
9296
writeFile exampleFilePath exampleWrongContent
9397
doesFileExist examplePath `shouldReturn` True
9498
readFile exampleFilePath `shouldReturn` exampleWrongContent
95-
let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook
99+
let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook
96100
go `shouldReturn` True
97101
doesFileExist examplePath `shouldReturn` True
98102
readFile exampleFilePath `shouldNotReturn` exampleWrongContent
@@ -102,15 +106,15 @@ spec = do
102106
let wrongContentLengthReq = exampleReq
103107
{ drLengthCheck = Just exampleWrongContentLength
104108
}
105-
let go = runStdoutLoggingT $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook
109+
let go = run $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook
106110
go `shouldThrow` isWrongContentLength
107111
doesFileExist examplePath `shouldReturn` False
108112

109113
it "rejects incorrect digest" $ withTempDir' $ \dir -> do
110114
examplePath <- getExamplePath dir
111115
let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest }
112116
let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] }
113-
let go = runStdoutLoggingT $ verifiedDownload wrongDigestReq examplePath exampleProgressHook
117+
let go = run $ verifiedDownload wrongDigestReq examplePath exampleProgressHook
114118
go `shouldThrow` isWrongDigest
115119
doesFileExist examplePath `shouldReturn` False
116120

@@ -124,7 +128,7 @@ spec = do
124128
, drLengthCheck = Nothing
125129
, drRetryPolicy = limitRetries 1
126130
}
127-
let go = runStdoutLoggingT $ verifiedDownload dReq dest exampleProgressHook
131+
let go = run $ verifiedDownload dReq dest exampleProgressHook
128132
doesFileExist dest `shouldReturn` False
129133
go `shouldReturn` True
130134
doesFileExist dest `shouldReturn` True

0 commit comments

Comments
 (0)