sandwich-contexts-kubernetes: add some HasCallStack

codedownio · Jul 29, 2024 · 663960e · 663960e
1 parent c1db2bf
commit 663960e
Show file tree

Hide file tree

Showing 4 changed files with 12 additions and 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
@@ -25,15 +25,15 @@ 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)
 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
@@ -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/...ich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs b/...ich-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
@@ -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"]