From 005c6f8e659c67e74973cb17b6d945b87d21115f Mon Sep 17 00:00:00 2001
From: Krishnan Parthasarathi <krisis@users.noreply.github.com>
Date: Fri, 10 May 2019 15:41:08 -0700
Subject: [PATCH] Retry requests that timeout using full-jitter backoff (#119)

---
 minio-hs.cabal           |  6 ++++++
 src/Network/Minio/API.hs | 40 +++++++++++++++++++++++++++++++++++++---
 2 files changed, 43 insertions(+), 3 deletions(-)

diff --git a/minio-hs.cabal b/minio-hs.cabal
index a26c6a6..de9c165 100644
--- a/minio-hs.cabal
+++ b/minio-hs.cabal
@@ -61,6 +61,7 @@ library
                      , cryptonite-conduit >= 0.2
                      , digest >= 0.0.1
                      , directory
+                     , exceptions
                      , filepath >= 1.4
                      , http-client >= 0.5
                      , http-conduit >= 2.3
@@ -69,6 +70,7 @@ library
                      , memory >= 0.14
                      , raw-strings-qq >= 1
                      , resourcet >= 1.2
+                     , retry
                      , text >= 1.2
                      , time >= 1.8
                      , transformers >= 0.5
@@ -152,6 +154,7 @@ test-suite minio-hs-live-server-test
                      , cryptonite-conduit
                      , digest
                      , directory
+                     , exceptions
                      , filepath
                      , http-client
                      , http-conduit
@@ -161,6 +164,7 @@ test-suite minio-hs-live-server-test
                      , QuickCheck
                      , raw-strings-qq >= 1
                      , resourcet
+                     , retry
                      , tasty
                      , tasty-hunit
                      , tasty-quickcheck
@@ -196,6 +200,7 @@ test-suite minio-hs-test
                      , filepath
                      , digest
                      , directory
+                     , exceptions
                      , http-client
                      , http-conduit
                      , http-types
@@ -204,6 +209,7 @@ test-suite minio-hs-test
                      , QuickCheck
                      , raw-strings-qq >= 1
                      , resourcet
+                     , retry
                      , tasty
                      , tasty-hunit
                      , tasty-quickcheck
diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs
index a8d5c7a..0b8578c 100644
--- a/src/Network/Minio/API.hs
+++ b/src/Network/Minio/API.hs
@@ -28,6 +28,9 @@ module Network.Minio.API
   , checkObjectNameValidity
   ) where
 
+import           Control.Retry             (fullJitterBackoff,
+                                            limitRetriesByCumulativeDelay,
+                                            retrying)
 import qualified Data.ByteString           as B
 import qualified Data.Char                 as C
 import qualified Data.Conduit              as C
@@ -140,19 +143,50 @@ buildRequest ri = do
         , NC.requestBody = getRequestBody (riPayload s3Req)
         }
 
+
+retryAPIRequest :: Minio a -> Minio a
+retryAPIRequest apiCall = do
+  resE <- retrying retryPolicy (const shouldRetry) $
+          const $ try apiCall
+  either throwIO return resE
+  where
+    -- Retry using the full-jitter backoff method for up to 10 mins
+    -- total
+    retryPolicy = limitRetriesByCumulativeDelay tenMins
+                  $ fullJitterBackoff oneMilliSecond
+
+    oneMilliSecond = 1000 -- in microseconds
+    tenMins = 10 * 60 * 1000000 -- in microseconds
+    -- retry on connection related failure
+    shouldRetry :: Either NC.HttpException a -> Minio Bool
+    shouldRetry resE =
+      case resE of
+        -- API request returned successfully
+        Right _ -> return False
+        -- API request failed with a retryable exception
+        Left httpExn@(NC.HttpExceptionRequest _ exn) ->
+          case (exn :: NC.HttpExceptionContent) of
+            NC.ResponseTimeout     -> return True
+            NC.ConnectionTimeout   -> return True
+            NC.ConnectionFailure _ -> return True
+            -- We received an unexpected exception
+            _                      -> throwIO httpExn
+        -- We received an unexpected exception
+        Left someOtherExn -> throwIO someOtherExn
+
+
 executeRequest :: S3ReqInfo -> Minio (Response LByteString)
 executeRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
-  httpLbs req mgr
-
+  retryAPIRequest $ httpLbs req mgr
 
 mkStreamRequest :: S3ReqInfo
                 -> Minio (Response (C.ConduitM () ByteString Minio ()))
 mkStreamRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
-  http req mgr
+  retryAPIRequest $ http req mgr
 
 -- Bucket name validity check according to AWS rules.
 isValidBucketName :: Bucket -> Bool