sandwich-contexts-kubernetes: try to catch failure on minikube image …

…load + avoid littering /tmp/build.12345.tar files
codedownio · Jul 28, 2024 · a6db7ac · a6db7ac
1 parent 70893ea
commit a6db7ac
Show file tree

Hide file tree

Showing 2 changed files with 46 additions and 33 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
@@ -52,7 +52,8 @@ 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, MonadLogger m, HasBaseContextMonad context m, HasKubernetesClusterContext context
+  MonadUnliftIO m, MonadLogger m, MonadFail m
+  , HasBaseContextMonad context m, HasKubernetesClusterContext context
   )
   -- | Image name
   => Text
@@ -66,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, MonadLogger m, HasBaseContextMonad context m
+  MonadUnliftIO m, MonadLogger m, MonadFail m, HasBaseContextMonad context m
   )
   -- | Cluster context
   => KubernetesClusterContext

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
@@ -22,50 +22,62 @@ import Test.Sandwich
 import Test.Sandwich.Contexts.Kubernetes.Util.Container
 import UnliftIO.Directory
 import UnliftIO.Process
+import UnliftIO.Temporary
 
 
 loadImage :: (
-  MonadUnliftIO m, MonadLogger m
+  MonadUnliftIO m, MonadLogger m, MonadFail m, MonadReader context m, HasBaseContext context
   ) => FilePath -> Text -> [Text] -> Text -> m Text
 loadImage minikubeBinary clusterName minikubeFlags image = do
-  let tweak = ("docker.io/" <>)
-
-  let extraFlags = case "--rootless" `L.elem` minikubeFlags of
-        True -> ["--rootless"]
-        False -> []
+  Just dir <- getCurrentFolder
 
   case isAbsolute (toString image) of
     True -> do
-      initialStream :: Text <- doesDirectoryExist (toString image) >>= \case
+      -- File or directory image
+      doesDirectoryExist (toString image) >>= \case
         True ->
-          -- Uncompressed directory: tar it up (but don't zip)
-          pure [i|tar -C "#{image}" --dereference --hard-dereference --xform s:'^./':: -c .|]
+          -- Uncompressed directory: tar it up (but don't zip).
+          -- Formerly we would execute a shell with a pipe to direct the tar output directly into "minikube image load".
+          -- But then "minikube image load" would just write its own tarball in /tmp, like /tmp/build.12345.tar, and
+          -- leave it there!
+          withTempDirectory dir "image-tarball" $ \tempDir -> do
+            let tarFile = tempDir </> "image.tar"
+            -- TODO: don't depend on external tar file
+            createProcessWithLogging (shell [i|tar -C "#{image}" --dereference --hard-dereference --xform s:'^./':: -c . > "#{tarFile}"|])
+              >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+            imageLoad tarFile
+            readImageName (toString image)
         False -> case takeExtension (toString image) of
-          ".tar" -> pure [i|cat "#{image}"|]
-          ".gz" -> pure [i|cat "#{image}" | gzip -d|]
+          ".tar" -> do
+            imageLoad (toString image)
+            readImageName (toString image)
+          ".gz" -> do
+            withTempDirectory dir "image-tarball" $ \tempDir -> do
+              let tarFile = tempDir </> "image.tar"
+              -- TODO: don't depend on external gzip file
+              createProcessWithLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])
+                >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+              imageLoad tarFile
+              readImageName (toString image)
           _ -> expectationFailure [i|Unexpected image extension in #{image}. Wanted .tar, .tar.gz, or uncompressed directory.|]
 
-      let cmd = [iii|#{initialStream} | #{minikubeBinary} image load -
-                     --profile #{clusterName}
-                     --logtostderr
-                     #{T.unwords extraFlags}
-                     --alsologtostderr --v=2
-                     |]
-      debug [i|loadImages': #{cmd}|]
-      createProcessWithLogging (shell cmd) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
-      tweak <$> readImageName (toString image)
+    False ->
+      -- Docker/Podman image
+      imageLoad (toString image) >> return image
+
+  where
+    imageLoad toLoad = do
+      let extraFlags = case "--rootless" `L.elem` minikubeFlags of
+                         True -> ["--rootless"]
+                         False -> []
 
-    False -> do
-      let cmd = [iii|#{minikubeBinary} image load #{image}
-                     --profile #{clusterName}
-                     --logtostderr
-                     --daemon=true
-                     #{T.unwords extraFlags}
-                     --alsologtostderr --v=2
-                     |]
-      debug [i|loadImages': #{cmd}|]
-      createProcessWithLogging (shell cmd) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
-      return $ tweak image
+      createProcessWithLogging (
+        proc minikubeBinary (["image", "load", toLoad
+                             , "--profile", toString clusterName
+                             , "--logtostderr=true", "--v=2"
+                             , "--daemon=true"
+                             ] <> extraFlags)
+        ) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
 getLoadedImages :: (MonadUnliftIO m, MonadLogger m) => FilePath -> Text -> [Text] -> m (Set Text)
 getLoadedImages minikubeBinary clusterName minikubeFlags = do