sandwich-contexts-kubernetes: add getLoadedImages and improve kind bi…

…nary stuff

demos/demo-kubernetes-kind/app/Main.hs

@@ -15,6 +15,7 @@ import Relude
 import Test.Sandwich
 import Test.Sandwich.Contexts.FakeSmtpServer
 import Test.Sandwich.Contexts.Files
+import Test.Sandwich.Contexts.Kubernetes.Images
 import Test.Sandwich.Contexts.Kubernetes.KindCluster
 import Test.Sandwich.Contexts.Kubernetes.MinioOperator
 import Test.Sandwich.Contexts.Kubernetes.MinioS3Server
@@ -32,6 +33,10 @@ spec = describe "Introducing a Kubernetes cluster" $ do
           kcc <- getContext kubernetesCluster
           info [i|Got Kubernetes cluster context: #{kcc}|]
 
+        it "prints the loaded images" $ do
+          images <- getLoadedImages
+          forM_ images $ \image -> info [i|Image: #{image}|]
+
         introduceBinaryViaNixPackage @"kubectl" "kubectl" $
           introduceBinaryViaNixDerivation @"kubectl-minio" kubectlMinioDerivation $
           introduceMinioOperator $ do

demos/demo-kubernetes-minikube/app/Main.hs

@@ -17,6 +17,7 @@ import System.Exit
 import Test.Sandwich
 import Test.Sandwich.Contexts.FakeSmtpServer
 import Test.Sandwich.Contexts.Files
+import Test.Sandwich.Contexts.Kubernetes.Images
 import Test.Sandwich.Contexts.Kubernetes.MinikubeCluster
 import Test.Sandwich.Contexts.Kubernetes.MinioOperator
 import Test.Sandwich.Contexts.Kubernetes.MinioS3Server
@@ -36,6 +37,10 @@ spec = describe "Introducing a Kubernetes cluster" $ do
           kcc <- getContext kubernetesCluster
           info [i|Got Kubernetes cluster context: #{kcc}|]
 
+        it "prints the loaded images" $ do
+          images <- getLoadedImages
+          forM_ images $ \image -> info [i|Image: #{image}|]
+
         introduceBinaryViaNixPackage @"kubectl" "kubectl" $
           introduceBinaryViaNixDerivation @"kubectl-minio" kubectlMinioDerivation $
           introduceMinioOperator $ do

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

@@ -4,7 +4,9 @@
 {-# LANGUAGE TypeOperators #-}
 
 module Test.Sandwich.Contexts.Kubernetes.Images (
-  loadImage
+  getLoadedImages
+
+  , loadImage
   , loadImage'
 
   , introduceImages
@@ -21,6 +23,31 @@ import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images as Min
 import Test.Sandwich.Contexts.Kubernetes.Types
 
 
+-- | Get the images loaded onto the cluster.
+getLoadedImages :: (
+  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
+  )
+  -- | Cluster context
+  => KubernetesClusterContext
+  -- | List of image names
+  -> m (Set Text)
+getLoadedImages' kcc@(KubernetesClusterContext {kubernetesClusterType, kubernetesClusterName}) = do
+  timeAction [i|Getting loaded images|] $ do
+    case kubernetesClusterType of
+      (KubernetesClusterKind {..}) ->
+        Kind.getLoadedImages kcc kindClusterDriver kindBinary Nothing
+        -- Kind.loadImage kindBinary kindClusterName image env
+      (KubernetesClusterMinikube {..}) ->
+        Minikube.getLoadedImages minikubeBinary kubernetesClusterName minikubeFlags
+
 -- | Load an image into a Kubernetes cluster. The image you pass may be an absolute path to a .tar or .tar.gz
 -- 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).
@@ -47,7 +74,7 @@ loadImage' :: (
   -> Text
   -- | Environment variables (currently used only for Kind clusters)
   -> Maybe [(String, String)]
-  -- | Callback with transformed image names (see above)
+  -- | The transformed image name
   -> m Text
 loadImage' (KubernetesClusterContext {kubernetesClusterType, kubernetesClusterName}) image env = do
   debug [i|Loading container image '#{image}'|]

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

@@ -103,9 +103,9 @@ defaultKindClusterOptions = KindClusterOptions {
 -- * Introduce
 
 -- | Alias to make type signatures shorter
-type KindContext context = LabelValue "kubernetesCluster" KubernetesClusterContext :> LabelValue "file-kind" (EnvironmentFile "kind") :> context
+type KindContext context = LabelValue "kubernetesCluster" KubernetesClusterContext :> LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> LabelValue "file-kind" (EnvironmentFile "kind") :> context
 
--- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the kind binary from the Nix context.
+-- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the kind and kubectl binaries from the Nix context.
 introduceKindClusterViaNix :: (
   HasBaseContext context, MonadUnliftIO m, MonadMask m, HasNixContext context
   )
@@ -117,9 +117,10 @@ introduceKindClusterViaNix :: (
   -> SpecFree context m ()
 introduceKindClusterViaNix kindClusterOptions spec =
   introduceBinaryViaNixPackage @"kind" "kind" $
-    introduceWith "introduce kind cluster" kubernetesCluster (void . withKindCluster kindClusterOptions) spec
+    introduceBinaryViaNixPackage @"kubectl" "kubectl" $
+      introduceWith "introduce kind cluster" kubernetesCluster (void . withKindCluster kindClusterOptions) spec
 
--- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the kind binary from the PATH.
+-- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the kind and kubectl binaries from the PATH.
 introduceKindClusterViaEnvironment :: (
   HasBaseContext context, MonadMask m, MonadUnliftIO m
   )
@@ -129,19 +130,23 @@ introduceKindClusterViaEnvironment :: (
   -> SpecFree context m ()
 introduceKindClusterViaEnvironment kindClusterOptions spec =
   introduceBinaryViaEnvironment @"kind" $
+    introduceBinaryViaEnvironment @"kubectl" $
     introduceWith "introduce kind cluster" kubernetesCluster (void . withKindCluster kindClusterOptions) spec
 
--- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), passing in the kind binary.
+-- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), passing in the kind and kubectl binaries.
 introduceKindCluster' :: (
   HasBaseContext context, MonadMask m, MonadUnliftIO m
   )
   -- | Path to kind binary
   => FilePath
+  -- | Path to kubectl binary
+  -> FilePath
   -> KindClusterOptions
   -> SpecFree (KindContext context) m ()
   -> SpecFree context m ()
-introduceKindCluster' kindBinary kindClusterOptions spec =
+introduceKindCluster' kindBinary kubectlBinary kindClusterOptions spec =
   introduceFile @"kind" kindBinary $
+    introduceFile @"kubectl" kubectlBinary $
     introduceWith "introduce kind cluster" kubernetesCluster (void . withKindCluster kindClusterOptions) $
       spec
 
@@ -150,27 +155,30 @@ introduceKindCluster' kindBinary kindClusterOptions spec =
 -- | Bracket-style variant of 'introduceKindCluster'.
 withKindCluster :: (
   MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m
-  , HasBaseContextMonad context m, HasFile context "kind"
+  , HasBaseContextMonad context m, HasFile context "kind", HasFile context "kubectl"
   )
   -- | Options
   => KindClusterOptions
   -> (KubernetesClusterContext -> m a)
   -> m a
 withKindCluster opts action = do
   kindBinary <- askFile @"kind"
-  withKindCluster' kindBinary opts action
+  kubectlBinary <- askFile @"kubectl"
+  withKindCluster' kindBinary kubectlBinary opts action
 
--- | Same as 'withKindCluster', but allows you to pass in the path to the kind binary.
+-- | Same as 'withKindCluster', but allows you to pass in the paths to the kind and kubectl binaries.
 withKindCluster' :: (
   MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m
   , HasBaseContextMonad context m
   )
   -- | Path to the kind binary
   => FilePath
+  -- | Path to the kubectl binary
+  -> FilePath
   -> KindClusterOptions
   -> (KubernetesClusterContext -> m a)
   -> m a
-withKindCluster' kindBinary opts@(KindClusterOptions {..}) action = do
+withKindCluster' kindBinary kubectlBinary opts@(KindClusterOptions {..}) action = do
   clusterName <- case kindClusterName of
     KindClusterNameExactly t -> pure t
     KindClusterNameAutogenerate maybePrefix -> do
@@ -205,7 +213,7 @@ withKindCluster' kindBinary opts@(KindClusterOptions {..}) action = do
                                                   })
                void $ waitForProcess ps
            ))
-           (\kcc -> bracket_ (setUpKindCluster kcc environmentToUse driver)
+           (\kcc -> bracket_ (setUpKindCluster kcc kindBinary kubectlBinary environmentToUse driver)
                              (return ())
                              (action kcc)
            )

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

@@ -3,16 +3,24 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Test.Sandwich.Contexts.Kubernetes.KindCluster.Images where
+module Test.Sandwich.Contexts.Kubernetes.KindCluster.Images (
+  getLoadedImages
+  , loadImage
+  ) where
 
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
+import Data.Aeson as A
+import qualified Data.Set as Set
 import Data.String.Interpolate
-import Data.Text as T
+import qualified Data.Vector as V
 import Relude
 import System.Exit
 import System.FilePath
 import Test.Sandwich
+import Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup
+import Test.Sandwich.Contexts.Kubernetes.Types
+import Test.Sandwich.Contexts.Kubernetes.Util.Aeson
 import Test.Sandwich.Contexts.Kubernetes.Util.Container
 import UnliftIO.Process
 import UnliftIO.Temporary
@@ -52,3 +60,27 @@ loadImage kindBinary clusterName image env = do
             env = env
             }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
       return $ tweak image
+
+getLoadedImages :: (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
+    [] -> expectationFailure [i|Couldn't identify a Kind node.|]
+
+  output <- readCreateProcessWithLogging (
+    (proc (toString driver) [
+        "exec"
+        , toString chosenNode
+        , "crictl", "images", "-o", "json"
+        ]) { env = env }
+    ) ""
+
+  case A.eitherDecode (encodeUtf8 output) of
+    Left err -> expectationFailure [i|Couldn't decode JSON (#{err}): #{output}|]
+    Right (A.Object (aesonLookup "images" -> Just (A.Array images))) -> return $ Set.fromList $ concatMap extractRepoTags images
+    _ -> expectationFailure [i|Unexpected format in JSON: #{output}|]
+
+  where
+    extractRepoTags :: A.Value -> [Text]
+    extractRepoTags (A.Object (aesonLookup "repoTags" -> Just (A.Array xs))) = [t | A.String t <- V.toList xs]
+    extractRepoTags _ = []

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

@@ -4,7 +4,10 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup where
+module Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup (
+  setUpKindCluster
+  , getNodes
+  ) where
 
 import Control.Monad
 import Control.Monad.Catch ( MonadMask)
@@ -24,21 +27,21 @@ import UnliftIO.Process
 
 setUpKindCluster :: (
   MonadLoggerIO m, MonadUnliftIO m, MonadMask m
-  ) => KubernetesClusterContext -> Maybe [(String, String)] -> Text -> m ()
-setUpKindCluster kcc@(KubernetesClusterContext {..}) environmentToUse driver = do
+  ) => KubernetesClusterContext -> FilePath -> FilePath -> Maybe [(String, String)] -> Text -> m ()
+setUpKindCluster kcc@(KubernetesClusterContext {..}) kindBinary kubectlBinary environmentToUse driver = do
   baseEnv <- maybe getEnvironment return environmentToUse
   let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
   let runWithKubeConfig cmd = createProcessWithLogging ((shell cmd) { env = Just env, delegate_ctlc = True })
 
   info [i|Installing ingress-nginx|]
-  runWithKubeConfig [i|kubectl apply -f https://raw.githubusercontent.com/kubernetes/ingress-nginx/main/deploy/static/provider/kind/deploy.yaml|]
+  runWithKubeConfig [i|#{kubectlBinary} apply -f https://raw.githubusercontent.com/kubernetes/ingress-nginx/main/deploy/static/provider/kind/deploy.yaml|]
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
   -- void $ runWithKubeConfig [i|kubectl patch deployments -n ingress-nginx nginx-ingress-controller -p '{"spec":{"template":{"spec":{"containers":[{"name":"nginx-ingress-controller","ports":[{"containerPort":80,"hostPort":0},{"containerPort":443,"hostPort":0}]}],"nodeSelector":{"ingress-ready":"true"},"tolerations":[{"key":"node-role.kubernetes.io/master","operator":"Equal","effect":"NoSchedule"}]}}}}'|]
   info [i|Waiting for ingress-nginx|]
   flip runReaderT (LabelValue @"kubernetesCluster" kcc) $
     waitForPodsToExist "ingress-nginx" (M.singleton "app.kubernetes.io/component" "controller") 120.0 Nothing
   info [i|controller pod existed|]
-  runWithKubeConfig [iii|kubectl wait pod
+  runWithKubeConfig [iii|#{kubectlBinary} wait pod
                          --namespace ingress-nginx
                          --for=condition=ready
                          --selector=app.kubernetes.io/component=controller
@@ -50,14 +53,21 @@ setUpKindCluster kcc@(KubernetesClusterContext {..}) environmentToUse driver = d
   -- void $ runWithKubeConfig [i|helm install metrics-server-release bitnami/metrics-server|]
 
   info [i|Installing metrics server|]
-  runWithKubeConfig [i|kubectl apply -f https://github.com/kubernetes-sigs/metrics-server/releases/download/v0.6.4/components.yaml|]
+  runWithKubeConfig [i|#{kubectlBinary} apply -f https://github.com/kubernetes-sigs/metrics-server/releases/download/v0.6.4/components.yaml|]
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
-  runWithKubeConfig [i|kubectl patch -n kube-system deployment metrics-server --type=json -p '[{"op":"add","path":"/spec/template/spec/containers/0/args/-","value":"--kubelet-insecure-tls"}]'|]
+  runWithKubeConfig [i|#{kubectlBinary} patch -n kube-system deployment metrics-server --type=json -p '[{"op":"add","path":"/spec/template/spec/containers/0/args/-","value":"--kubelet-insecure-tls"}]'|]
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   when (driver == "docker") $ do
     info [i|Fixing perms on /dev/fuse|] -- Needed on NixOS where it gets mounted 0600, don't know why
-    nodes <- ((words . toText) <$> (readCreateProcess ((shell [i|kind get nodes --name "#{kubernetesClusterName}"|]) { env = Just env }) ""))
+    nodes <- getNodes kcc kindBinary environmentToUse
     forM_ nodes $ \node -> do
       info [i|  (#{node}) Fixing /dev/fuse|]
       void $ readCreateProcess (shell [i|#{driver} exec "#{node}" chmod 0666 /dev/fuse|]) ""
+
+
+getNodes :: MonadUnliftIO m => KubernetesClusterContext -> FilePath -> Maybe [(String, String)] -> m [Text]
+getNodes (KubernetesClusterContext {..}) kindBinary environmentToUse = do
+  baseEnv <- maybe getEnvironment return environmentToUse
+  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
+  ((words . toText) <$> (readCreateProcess ((shell [i|#{kindBinary} get nodes --name "#{kubernetesClusterName}"|]) { env = Just env }) ""))

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

@@ -3,12 +3,16 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images where
+module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images (
+  loadImage
+  , getLoadedImages
+  ) where
 
 import Control.Monad
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import qualified Data.List as L
+import qualified Data.Set as Set
 import Data.String.Interpolate
 import Data.Text as T
 import Relude
@@ -30,7 +34,7 @@ loadImage minikubeBinary clusterName minikubeFlags image = do
         True -> ["--rootless"]
         False -> []
 
-  image' <- case isAbsolute (toString image) of
+  case isAbsolute (toString image) of
     True -> do
       initialStream :: Text <- doesDirectoryExist (toString image) >>= \case
         True ->
@@ -63,9 +67,10 @@ loadImage minikubeBinary clusterName minikubeFlags image = do
       createProcessWithLogging (shell cmd) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
       return $ tweak image
 
-  -- TODO: remove this?
-  let cmd = [iii|#{minikubeBinary} image ls --profile #{clusterName}|]
-  imageList <- readCreateProcessWithLogging (shell cmd) ""
-  info [i|Loaded image list: #{imageList}|]
-
-  return image'
+getLoadedImages :: (MonadUnliftIO m, MonadLogger m) => FilePath -> Text -> [Text] -> m (Set Text)
+getLoadedImages minikubeBinary clusterName minikubeFlags = do
+  -- TODO: use "--format json" and parse?
+  (Set.fromList . T.words . toText) <$> readCreateProcessWithLogging (
+    proc minikubeBinary (["image", "ls"
+                         , "--profile", toString clusterName
+                         ] <> fmap toString minikubeFlags)) ""