From 53c9aea808e4052ade9bafee31f7dcf1ee5e7e9b Mon Sep 17 00:00:00 2001
From: thomasjm <tom@codedown.io>
Date: Thu, 1 Aug 2024 23:53:33 -0700
Subject: [PATCH] sandwich-contexts-kubernetes: add withImageLoadRetry

---
 .../Sandwich/Contexts/Kubernetes/Images.hs    | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
index 2054c8dd..0b9dd5cb 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
@@ -16,6 +16,9 @@ module Test.Sandwich.Contexts.Kubernetes.Images (
   , loadImage
   , loadImage'
 
+  , withImageLoadRetry
+  , withImageLoadRetry'
+
   , introduceImages
 
   , findAllImages
@@ -25,8 +28,10 @@ module Test.Sandwich.Contexts.Kubernetes.Images (
   , ImagePullPolicy(..)
   ) where
 
+import Control.Monad.Catch (Handler(..), MonadMask)
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
+import Control.Retry
 import Data.String.Interpolate
 import Data.Text as T
 import Relude
@@ -169,6 +174,20 @@ loadImage' (KubernetesClusterContext {kubernetesClusterType, kubernetesClusterNa
         -- loadedImages `shouldContain` [image']
         -- return image'
 
+-- | Same as 'withImageLoadRetry'', but with a reasonable default retry policy.
+withImageLoadRetry :: (MonadLoggerIO m, MonadMask m) => ImageLoadSpec -> m a -> m a
+withImageLoadRetry = withImageLoadRetry' (exponentialBackoff 50000 <> limitRetries 5)
+
+-- | A combinator to wrap around your 'loadImage' or 'loadImageIfNecessary' calls to retry
+-- on failure. Image loads sometimes fail on Minikube (version 1.33.0 at time of writing).
+withImageLoadRetry' :: (MonadLoggerIO m, MonadMask m) => RetryPolicyM m -> ImageLoadSpec -> m a -> m a
+withImageLoadRetry' policy ils action =
+  recovering policy [\_status -> Handler (\(e :: FailureReason) -> do
+                                             warn [i|#{ils}: retrying load due to exception: #{e}|]
+                                             return True)] $ \_ ->
+    action
+
+
 -- | Helper to introduce a list of images into a Kubernetes cluster.
 -- Stores the list of transformed image names under the "kubernetesClusterImages" label.
 introduceImages :: (