sandwich-contexts-kubernetes: more on image load API

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs

@@ -53,7 +53,7 @@ loadImage kindBinary clusterName imageLoadSpec env = do
               env = env
               }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
         readUncompressedImageName (toString image)
-    ImageLoadSpecDockerImage image pullPolicy -> do
+    ImageLoadSpecDocker image pullPolicy -> do
       _ <- dockerPullIfNecessary image pullPolicy
 
       createProcessWithLogging (
@@ -62,7 +62,7 @@ loadImage kindBinary clusterName imageLoadSpec env = do
             }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
       return image
-    ImageLoadSpecPodmanImage image pullPolicy -> do
+    ImageLoadSpecPodman image pullPolicy -> do
       _ <- podmanPullIfNecessary image pullPolicy
 
       _ <- expectationFailure [i|Not implemented yet.|]

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs

@@ -64,11 +64,11 @@ loadImage minikubeBinary clusterName minikubeFlags imageLoadSpec = do
               readImageName (toString image)
           _ -> expectationFailure [i|Unexpected image extension in #{image}. Wanted .tar, .tar.gz, or uncompressed directory.|]
 
-    ImageLoadSpecDockerImage image pullPolicy -> do
+    ImageLoadSpecDocker image pullPolicy -> do
       _ <- dockerPullIfNecessary image pullPolicy
       imageLoad (toString image) True >> return image
 
-    ImageLoadSpecPodmanImage image pullPolicy -> do
+    ImageLoadSpecPodman image pullPolicy -> do
       _ <- podmanPullIfNecessary image pullPolicy
       imageLoad (toString image) True >> return image
 

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs

@@ -128,7 +128,7 @@ withSeaweedFS' kcc@(KubernetesClusterContext {kubernetesClusterKubeConfigPath})
     info [i|Doing make docker-build|]
     runOperatorCmd "make docker-build" []
 
-    newImageName <- loadImage' kcc (ImageLoadSpecDockerImage "chrislusf/seaweedfs-operator:v0.0.1" IfNotPresent)
+    newImageName <- loadImage' kcc (ImageLoadSpecDocker "chrislusf/seaweedfs-operator:v0.0.1" IfNotPresent)
 
     info [i|------------------ Installing SeaweedFS operator ------------------|]
 

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Types.hs

@@ -58,10 +58,10 @@ data ImageLoadSpec =
   -- | A .tar or .tar.gz file
   ImageLoadSpecTarball FilePath
   -- | An image pulled via Docker
-  | ImageLoadSpecDockerImage { imageName :: Text
+  | ImageLoadSpecDocker { imageName :: Text
                              , pullPolicy :: ImagePullPolicy }
   -- | An image pulled via Podman
-  | ImageLoadSpecPodmanImage { imageName :: Text
+  | ImageLoadSpecPodman { imageName :: Text
                              , pullPolicy :: ImagePullPolicy }
   deriving (Show, Eq)
 

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs

@@ -115,5 +115,5 @@ getImageNameFromManifestJson path contents = do
 
 imageLoadSpecToImageName :: (MonadUnliftIO m, MonadLogger m) => ImageLoadSpec -> m Text
 imageLoadSpecToImageName (ImageLoadSpecTarball image) = readImageName image
-imageLoadSpecToImageName (ImageLoadSpecDockerImage image _) = pure image
-imageLoadSpecToImageName (ImageLoadSpecPodmanImage image _) = pure image
+imageLoadSpecToImageName (ImageLoadSpecDocker image _) = pure image
+imageLoadSpecToImageName (ImageLoadSpecPodman image _) = pure image

sandwich-contexts-kubernetes/test/Spec.hs

@@ -28,6 +28,16 @@ spec = introduceNixContext nixpkgsReleaseDefault $
     describe "Kind" $ introduceKindClusterViaNix defaultKindClusterOptions $
       loadImageTests
 
+imageLoadSpecs :: [ImageLoadSpec]
+imageLoadSpecs = [
+  ImageLoadSpecDocker "busybox:latest" IfNotPresent
+  , ImageLoadSpecDocker "registry.k8s.io/pause:3.9" IfNotPresent
+  , ImageLoadSpecDocker "gcr.io/distroless/static-debian11:latest" IfNotPresent
+  ]
+
+imageLabel :: Label "image" Text
+imageLabel = Label
+
 loadImageTests :: (
   MonadUnliftIO m
   , HasBaseContext context, HasKubernetesClusterContext context, HasFile context "kubectl"
@@ -37,54 +47,62 @@ loadImageTests = do
     kcc <- getContext kubernetesCluster
     info [i|Got Kubernetes cluster context: #{kcc}|]
 
-  forM_ ["busybox:latest", "registry.k8s.io/pause:3.9", "gcr.io/distroless/static-debian11:latest"] $ \image ->
-    it [i|#{image}|] $ do
-      -- dockerPullIfNecessary image
-
-      transformedImageName <- loadImage (ImageLoadSpecDockerImage image IfNotPresent)
-
-      transformedImageName `shouldBe` image
-
-      images <- getLoadedImages
-      forM_ images $ \img ->
-        info [i|loaded image: #{img}|]
-
-      clusterContainsImage transformedImageName >>= \case
-        False -> expectationFailure [i|Cluster didn't contain image '#{transformedImageName}'|]
-        True -> return ()
-
-      podName <- ("test-pod-" <>) <$> randomAlpha 8
-
-      -- namespace <- ("test-namespace-" <>) <$> randomAlpha 8
-      -- withKubernetesNamespace' (toText namespace) $
-      let namespace = "default"
-
-      runWithKubectl $ \kubectlBinary env -> do
-        -- Wait for service account to exist; see
-        -- https://github.com/kubernetes/kubernetes/issues/66689
-        waitUntil 60 $
-          createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace, "get", "serviceaccount", "default", "-o", "name"]) { env = Just env })
-            >>= waitForProcess >>= (`shouldBe` ExitSuccess)
-
-        let deletePod = createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace, "delete", "pod", podName]) { env = Just env })
-                          >>= waitForProcess >>= (`shouldBe` ExitSuccess)
-
-        flip finally deletePod $ do
-          createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace
-                                                        , "run", podName
-                                                        , "--image", toString transformedImageName
-                                                        , "--image-pull-policy=IfNotPresent"
-                                                        , "--command", "--", "/bin/sh", "-c", "sleep infinity"
-                                                        ]) { env = Just env })
-            >>= waitForProcess >>= (`shouldBe` ExitSuccess)
-
-          waitUntil 300 $ do
-            events <- readCreateProcessWithLogging ((proc kubectlBinary ["--namespace", namespace
-                                                                        , "get", "events"
-                                                                        , "--field-selector", [i|involvedObject.kind=Pod,involvedObject.name=#{podName}|]
-                                                                        ]) { env = Just env }) ""
-            info [i|events: #{events}|]
-            events `shouldContain` "already present on machine"
+  forM_ imageLoadSpecs $ \ils ->
+    introduce [i|#{ils} load|] imageLabel (loadImage ils) (const $ return ()) $ do
+      it "Doesn't transform Docker/Podman image names" $ do
+        image <- getContext imageLabel
+        case ils of
+          ImageLoadSpecTarball {} -> return ()
+          ImageLoadSpecDocker initialImage _ -> image `shouldBe` initialImage
+          ImageLoadSpecPodman initialImage _ -> image `shouldBe` initialImage
+
+      it "Cluster contains the image" $ do
+        images <- getLoadedImages
+        forM_ images $ \img ->
+          info [i|loaded image: #{img}|]
+
+        image <- getContext imageLabel
+        clusterContainsImage image >>= \case
+          False -> expectationFailure [i|Cluster didn't contain image '#{image}'|]
+          True -> return ()
+
+      it "Creates a pod and the cluster finds the image already present" $ do
+        image <- getContext imageLabel
+        podName <- ("test-pod-" <>) <$> randomAlpha 8
+
+        -- namespace <- ("test-namespace-" <>) <$> randomAlpha 8
+        -- withKubernetesNamespace' (toText namespace) $
+        let namespace = "default"
+
+        runWithKubectl $ \kubectlBinary env -> do
+          -- Wait for service account to exist; see
+          -- https://github.com/kubernetes/kubernetes/issues/66689
+          waitUntil 60 $
+            createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace
+                                                          , "get", "serviceaccount", "default"
+                                                          , "-o", "name"]) { env = Just env })
+              >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+
+          let deletePod = createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace
+                                                                        , "delete", "pod", podName]) { env = Just env })
+                            >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+
+          flip finally deletePod $ do
+            createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace
+                                                          , "run", podName
+                                                          , "--image", toString image
+                                                          , "--image-pull-policy=IfNotPresent"
+                                                          , "--command", "--", "/bin/sh", "-c", "sleep infinity"
+                                                          ]) { env = Just env })
+              >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+
+            waitUntil 300 $ do
+              events <- readCreateProcessWithLogging ((proc kubectlBinary ["--namespace", namespace
+                                                                          , "get", "events"
+                                                                          , "--field-selector", [i|involvedObject.kind=Pod,involvedObject.name=#{podName}|]
+                                                                          ]) { env = Just env }) ""
+              info [i|events: #{events}|]
+              events `shouldContain` "already present on machine"