From 70893eaa15241ab8162de7e686e71e30ae6e96fe Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sun, 28 Jul 2024 00:48:32 -0700 Subject: [PATCH] sandwich-contexts-kubernetes: add getLoadedImages and improve kind binary stuff --- demos/demo-kubernetes-kind/app/Main.hs | 5 +++ demos/demo-kubernetes-minikube/app/Main.hs | 5 +++ .../Sandwich/Contexts/Kubernetes/Images.hs | 31 ++++++++++++++-- .../Contexts/Kubernetes/KindCluster.hs | 30 ++++++++++------ .../Contexts/Kubernetes/KindCluster/Images.hs | 36 +++++++++++++++++-- .../Contexts/Kubernetes/KindCluster/Setup.hs | 26 +++++++++----- .../Kubernetes/MinikubeCluster/Images.hs | 21 ++++++----- 7 files changed, 123 insertions(+), 31 deletions(-) diff --git a/demos/demo-kubernetes-kind/app/Main.hs b/demos/demo-kubernetes-kind/app/Main.hs index af7163f2..665a46bf 100644 --- a/demos/demo-kubernetes-kind/app/Main.hs +++ b/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 diff --git a/demos/demo-kubernetes-minikube/app/Main.hs b/demos/demo-kubernetes-minikube/app/Main.hs index fb6eb409..c582e6ad 100644 --- a/demos/demo-kubernetes-minikube/app/Main.hs +++ b/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 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 7bffecff..86b4d535 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs +++ b/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}'|] diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs index 0476cf5a..9d37e5e1 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs +++ b/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,7 +155,7 @@ 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 @@ -158,19 +163,22 @@ withKindCluster :: ( -> 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) ) 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 7f05753f..45672c71 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 @@ -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 _ = [] diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs index 623e0192..c334e41d 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs +++ b/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 }) "")) 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 d2dbdb39..682fd5fc 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 @@ -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)) ""