From 663960e92d7c5e10ce5a042c367daea3395d8df2 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Sun, 28 Jul 2024 21:10:57 -0700
Subject: [PATCH] sandwich-contexts-kubernetes: add some HasCallStack

---
 .../lib/Test/Sandwich/Contexts/Kubernetes/Images.hs    | 10 +++++-----
 .../Sandwich/Contexts/Kubernetes/KindCluster/Images.hs |  6 ++++--
 .../Contexts/Kubernetes/MinikubeCluster/Forwards.hs    |  2 +-
 .../Contexts/Kubernetes/MinikubeCluster/Images.hs      |  3 ++-
 4 files changed, 12 insertions(+), 9 deletions(-)

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 7cbfeb6b..c08b1af1 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
@@ -25,7 +25,7 @@ import Test.Sandwich.Contexts.Kubernetes.Types
 
 -- | Get the images loaded onto the cluster.
 getLoadedImages :: (
-  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m, HasKubernetesClusterContext context
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m, HasKubernetesClusterContext context
   )
   -- | List of image names
   => m (Set Text)
@@ -33,7 +33,7 @@ getLoadedImages = getContext kubernetesCluster >>= getLoadedImages'
 
 -- | Same as 'getLoadedImages', but allows you to pass in the 'KubernetesClusterContext', rather than requiring one in context.
 getLoadedImages' :: (
-  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   )
   -- | Cluster context
   => KubernetesClusterContext
@@ -52,7 +52,7 @@ getLoadedImages' kcc@(KubernetesClusterContext {kubernetesClusterType, kubernete
 -- image archive, *or* the name of an image in your local Docker daemon. It will load the image onto the cluster,
 -- and return the modified image name (i.e. the name by which the cluster knows the image).
 loadImage :: (
-  MonadUnliftIO m, MonadLoggerIO m, MonadFail m
+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m
   , HasBaseContextMonad context m, HasKubernetesClusterContext context
   )
   -- | Image name
@@ -67,7 +67,7 @@ loadImage image env = do
 
 -- | Same as 'loadImage', but allows you to pass in the 'KubernetesClusterContext', rather than requiring one in context.
 loadImage' :: (
-  MonadUnliftIO m, MonadLoggerIO m, MonadFail m, HasBaseContextMonad context m
+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m, HasBaseContextMonad context m
   )
   -- | Cluster context
   => KubernetesClusterContext
@@ -89,7 +89,7 @@ loadImage' (KubernetesClusterContext {kubernetesClusterType, kubernetesClusterNa
 -- | Helper to introduce a list of images into a Kubernetes cluster.
 -- Stores the list of transformed image names under the "kubernetesClusterImages" label.
 introduceImages :: (
-  MonadUnliftIO m, HasBaseContext context, HasKubernetesClusterContext context
+  HasCallStack, MonadUnliftIO m, HasBaseContext context, HasKubernetesClusterContext context
   ) => [Text] -> SpecFree (LabelValue "kubernetesClusterImages" [Text] :> context) m () -> SpecFree context m ()
 introduceImages images = introduceWith "Introduce cluster images" kubernetesClusterImages $ \action ->
   forM images (\x -> loadImage x Nothing) >>= (void . action)
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
index 45672c71..f72ba623 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
@@ -27,7 +27,7 @@ import UnliftIO.Temporary
 
 
 loadImage :: (
-  MonadUnliftIO m, MonadLogger m
+  HasCallStack, MonadUnliftIO m, MonadLogger m
   )
   -- | Kind binary
   => FilePath
@@ -61,7 +61,9 @@ loadImage kindBinary clusterName image env = do
             }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
       return $ tweak image
 
-getLoadedImages :: (MonadUnliftIO m, MonadLogger m) => KubernetesClusterContext -> Text -> FilePath -> Maybe [(String, String)] -> m (Set Text)
+getLoadedImages :: (
+  HasCallStack, MonadUnliftIO m, MonadLogger m
+  ) => KubernetesClusterContext -> Text -> FilePath -> Maybe [(String, String)] -> m (Set Text)
 getLoadedImages kcc driver kindBinary env = do
   chosenNode <- getNodes kcc kindBinary env >>= \case
     (x:_) -> pure x
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
index d54a5bec..8245f130 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
@@ -25,7 +25,7 @@ import UnliftIO.Process
 
 
 withForwardKubernetesService' :: (
-  MonadLoggerIO m, MonadUnliftIO m
+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m
   ) => KubernetesClusterContext -> Text -> Text -> Text -> (URI -> m a) -> m a
 withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) profile namespace service action = do
   baseEnv <- liftIO getEnvironment
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
index 90930a7f..a3f671c0 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
@@ -29,7 +29,7 @@ import UnliftIO.Temporary
 
 
 loadImage :: (
-  MonadUnliftIO m, MonadLoggerIO m, MonadFail m
+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m
   ) => FilePath -> Text -> [Text] -> Text -> m Text
 loadImage minikubeBinary clusterName minikubeFlags image = do
   case isAbsolute (toString image) of
@@ -67,6 +67,7 @@ loadImage minikubeBinary clusterName minikubeFlags image = do
       imageLoad (toString image) True >> return image
 
   where
+    imageLoad :: (MonadLoggerIO m, HasCallStack) => String -> Bool -> m ()
     imageLoad toLoad daemon = do
       let extraFlags = case "--rootless" `L.elem` minikubeFlags of
                          True -> ["--rootless"]