Replace drRetries with drRetryPolicy in DownloadRequest

markus1189 · markus1189 · commit 4f69d1d04b14 · 2015-07-21T10:14:41.000+02:00
diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs
@@ -4,7 +4,7 @@
 module Network.HTTP.Download
     ( verifiedDownload
     , DownloadRequest(..)
-    , drRetriesDefault
+    , drRetryPolicyDefault
     , HashCheck(..)
     , CheckHexDigest(..)
     , LengthCheck
@@ -70,7 +70,7 @@ download req destpath = do
             { drRequest = req
             , drHashChecks = []
             , drLengthCheck = Nothing
-            , drRetries = drRetriesDefault
+            , drRetryPolicy = drRetryPolicyDefault
             }
     let progressHook _ = return ()
     verifiedDownload downloadReq destpath progressHook
diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs
@@ -9,7 +9,7 @@
 module Network.HTTP.Download.Verified
   ( verifiedDownload
   , DownloadRequest(..)
-  , drRetriesDefault
+  , drRetryPolicyDefault
   , HashCheck(..)
   , CheckHexDigest(..)
   , LengthCheck
@@ -28,7 +28,7 @@ import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
 import Control.Monad.Reader
-import Control.Retry (recovering,limitRetries)
+import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
 import Control.Applicative
 import Crypto.Hash
 import Crypto.Hash.Conduit (sinkHash)
@@ -53,13 +53,13 @@ data DownloadRequest = DownloadRequest
     { drRequest :: Request
     , drHashChecks :: [HashCheck]
     , drLengthCheck :: Maybe LengthCheck
-    , drRetries :: Int
+    , drRetryPolicy :: RetryPolicy
     }
-  deriving Show
 
--- | Default to retrying thrice.
-drRetriesDefault :: Int
-drRetriesDefault = 3
+-- | Default to retrying thrice with a short constant delay.
+drRetryPolicyDefault :: RetryPolicy
+drRetryPolicyDefault = limitRetries 3 <> constantDelay onehundredMilliseconds
+  where onehundredMilliseconds = 100000
 
 data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck
   { hashCheckAlgorithm :: a
@@ -200,7 +200,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
     liftIO $ whenM' getShouldDownload $ do
         createDirectoryIfMissing True dir
         withBinaryFile fptmp WriteMode $ \h -> do
-            recovering (limitRetries drRetries) [const $ Handler alwaysRetryHttp] $
+            recovering drRetryPolicy [const $ Handler alwaysRetryHttp] $
                 flip runReaderT env $
                     withResponse req (go h)
         renameFile fptmp fp
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
@@ -432,7 +432,7 @@ fetchPackages' mdistDir toFetchAll = do
                 { drRequest = req
                 , drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch)
                 , drLengthCheck = fmap fromIntegral $ tfSize toFetch
-                , drRetries = drRetriesDefault
+                , drRetryPolicy = drRetryPolicyDefault
                 }
         let progressSink _ = do
                 liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -49,7 +49,7 @@ import qualified Data.Yaml as Yaml
 import           Distribution.System (OS (..), Arch (..), Platform (..))
 import           Distribution.Text (simpleParse)
 import           Network.HTTP.Client.Conduit
-import           Network.HTTP.Download (verifiedDownload, DownloadRequest(..), drRetriesDefault)
+import           Network.HTTP.Download (verifiedDownload, DownloadRequest(..), drRetryPolicyDefault)
 import           Path
 import           Path.IO
 import           Prelude -- Fix AMP warning
@@ -720,7 +720,7 @@ chattyDownload label url path = do
             { drRequest = req
             , drHashChecks = []
             , drLengthCheck = Nothing
-            , drRetries = drRetriesDefault
+            , drRetryPolicy = drRetryPolicyDefault
             }
     runInBase <- liftBaseWith $ \run -> return (void . run)
     x <- verifiedDownload dReq path (chattyDownloadProgress runInBase)
diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs
@@ -4,6 +4,7 @@ module Network.HTTP.Download.VerifiedSpec where
 import Crypto.Hash
 import Control.Monad (unless)
 import Control.Monad.Trans.Reader
+import Control.Retry (limitRetries)
 import Data.Maybe
 import Network.HTTP.Client.Conduit
 import Network.HTTP.Download.Verified
@@ -34,7 +35,7 @@ exampleReq = fromMaybe (error "exampleReq") $ do
         { drRequest = req
         , drHashChecks = [exampleHashCheck]
         , drLengthCheck = Just exampleLengthCheck
-        , drRetries = 1
+        , drRetryPolicy = limitRetries 1
         }
 
 exampleHashCheck :: HashCheck
@@ -155,7 +156,7 @@ spec = beforeAll setup $ afterAll teardown $ do
             { drRequest = req
             , drHashChecks = []
             , drLengthCheck = Nothing
-            , drRetries = 1
+            , drRetryPolicy = limitRetries 1
             }
       let go = runWith manager $ verifiedDownload dReq dest exampleProgressHook
       doesFileExist destFp `shouldReturn` False
diff --git a/stack.cabal b/stack.cabal
@@ -235,6 +235,7 @@ test-suite stack-test
                 , optparse-applicative
                 , bytestring
                 , QuickCheck
+                , retry >= 0.6
   default-language:    Haskell2010
 
 test-suite stack-integration-test

Original file line number	Diff line number	Diff line change
`@@ -432,7 +432,7 @@ fetchPackages' mdistDir toFetchAll = do`
`432`	`432`	`{ drRequest = req`
`433`	`433`	`, drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch)`
`434`	`434`	`, drLengthCheck = fmap fromIntegral $ tfSize toFetch`
`435`		`- , drRetries = drRetriesDefault`
	`435`	`+ , drRetryPolicy = drRetryPolicyDefault`
`436`	`436`	`}`
`437`	`437`	`let progressSink _ = do`
`438`	`438`	`liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"`