From f35d70a07a61e982b21ea98b5c8a612761404ab8 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Thu, 10 Oct 2024 02:21:05 -0700 Subject: [PATCH] sandwich-contexts-kubernetes: more --- demos/demo-kubernetes-longhorn/app/Main.hs | 18 +++--- .../Sandwich/Contexts/Kubernetes/Cluster.hs | 7 ++- .../Sandwich/Contexts/Kubernetes/Images.hs | 55 ++++++++++--------- .../Contexts/Kubernetes/KataContainers.hs | 6 +- .../Contexts/Kubernetes/KindCluster.hs | 6 +- .../Contexts/Kubernetes/KindCluster/Images.hs | 20 +++---- .../KindCluster/ServiceForwardIngress.hs | 4 +- .../KindCluster/ServiceForwardPortForward.hs | 2 +- .../Sandwich/Contexts/Kubernetes/Kubectl.hs | 2 +- .../Contexts/Kubernetes/MinikubeCluster.hs | 12 ++-- .../Kubernetes/MinikubeCluster/Forwards.hs | 6 +- .../Kubernetes/MinikubeCluster/Images.hs | 20 +++---- .../Contexts/Kubernetes/MinioOperator.hs | 11 ++-- .../Contexts/Kubernetes/MinioS3Server.hs | 8 +-- .../Sandwich/Contexts/Kubernetes/Namespace.hs | 11 ++-- .../Sandwich/Contexts/Kubernetes/SeaweedFS.hs | 6 +- .../Sandwich/Contexts/Kubernetes/Types.hs | 49 ++++++++++++----- sandwich-contexts-kubernetes/package.yaml | 1 - .../sandwich-contexts-kubernetes.cabal | 2 +- 19 files changed, 136 insertions(+), 110 deletions(-) diff --git a/demos/demo-kubernetes-longhorn/app/Main.hs b/demos/demo-kubernetes-longhorn/app/Main.hs index 6193c7ee..92b0428c 100644 --- a/demos/demo-kubernetes-longhorn/app/Main.hs +++ b/demos/demo-kubernetes-longhorn/app/Main.hs @@ -16,7 +16,7 @@ import System.Exit import Test.Sandwich import Test.Sandwich.Contexts.FakeSmtpServer import Test.Sandwich.Contexts.Files -import Test.Sandwich.Contexts.Kubernetes.Longhorn +-- import Test.Sandwich.Contexts.Kubernetes.Longhorn import Test.Sandwich.Contexts.Kubernetes.MinikubeCluster import Test.Sandwich.Contexts.Kubernetes.MinioOperator import Test.Sandwich.Contexts.Kubernetes.MinioS3Server @@ -37,15 +37,15 @@ spec = describe "Introducing a Kubernetes cluster" $ do kcc <- getContext kubernetesCluster info [i|Got Kubernetes cluster context: #{kcc}|] - introduceLonghorn defaultLonghornOptions $ do - it "Has a Longhorn context" $ do - x <- getContext longhorn - info [i|Got Longhorn context: #{x}|] + -- introduceLonghorn defaultLonghornOptions $ do + -- it "Has a Longhorn context" $ do + -- x <- getContext longhorn + -- info [i|Got Longhorn context: #{x}|] - it "Pauses for 5 minutes for examination" $ do - kcc <- getContext kubernetesCluster - debug [i|export KUBECONFIG='#{kubernetesClusterKubeConfigPath kcc}'|] - threadDelay 300_000_000 + -- it "Pauses for 5 minutes for examination" $ do + -- kcc <- getContext kubernetesCluster + -- debug [i|export KUBECONFIG='#{kubernetesClusterKubeConfigPath kcc}'|] + -- threadDelay 300_000_000 main :: IO () diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Cluster.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Cluster.hs index f747ed3b..b05e3495 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Cluster.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Cluster.hs @@ -48,8 +48,9 @@ module Test.Sandwich.Contexts.Kubernetes.Cluster ( , module Test.Sandwich.Contexts.Kubernetes.KubectlPortForward -- * Types - , KubernetesClusterContext (..) , kubernetesCluster + , KubernetesClusterContext(..) + , KubernetesClusterType(..) , HasKubernetesClusterContext -- * Util @@ -80,7 +81,7 @@ import qualified Test.Sandwich.Contexts.Kubernetes.Util as Util -- | Forward a Kubernetes service, so that it can be reached at a local URI. withForwardKubernetesService :: ( - MonadMask m, KubectlBasic m context + MonadMask m, KubectlBasic context m ) -- | Namespace => Text @@ -111,6 +112,6 @@ withForwardKubernetesService' :: ( -> (URI -> m a) -> m a withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) _kubectlBinary = - Minikube.withForwardKubernetesService' kcc minikubeProfileName + Minikube.withForwardKubernetesService' kcc kubernetesClusterTypeMinikubeProfileName withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) kubectlBinary = Kind.withForwardKubernetesService' kcc kubectlBinary 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 5739600b..6e835956 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs @@ -10,22 +10,24 @@ This module contains tools for managing images on a Kubernetes cluster. -} module Test.Sandwich.Contexts.Kubernetes.Images ( - -- * Querying - getLoadedImages + -- * Introduce a set of images + introduceImages + + -- * Query images + , getLoadedImages , getLoadedImages' , clusterContainsImage , clusterContainsImage' - -- * Loading - , introduceImages - + -- * Load images , loadImageIfNecessary , loadImageIfNecessary' , loadImage , loadImage' + -- * Retry helpers , withImageLoadRetry , withImageLoadRetry' @@ -55,7 +57,7 @@ import Test.Sandwich.Contexts.Kubernetes.Util.Images -- | Get the images loaded onto the cluster. getLoadedImages :: ( - HasCallStack, KubernetesClusterBasic m context + HasCallStack, KubernetesClusterBasic context m ) -- | List of image names => m (Set Text) @@ -63,7 +65,7 @@ getLoadedImages = getContext kubernetesCluster >>= getLoadedImages' -- | Same as 'getLoadedImages', but allows you to pass in the 'KubernetesClusterContext'. getLoadedImages' :: ( - HasCallStack, KubernetesBasic m context + HasCallStack, KubernetesBasic context m ) -- | Cluster context => KubernetesClusterContext @@ -73,17 +75,17 @@ getLoadedImages' kcc@(KubernetesClusterContext {kubernetesClusterType, kubernete timeAction [i|Getting loaded images|] $ do case kubernetesClusterType of (KubernetesClusterKind {..}) -> - Kind.getLoadedImages kcc kindClusterDriver kindBinary Nothing + Kind.getLoadedImagesKind kcc kubernetesClusterTypeKindClusterDriver kubernetesClusterTypeKindBinary Nothing -- Kind.loadImage kindBinary kindClusterName image env (KubernetesClusterMinikube {..}) -> -- Note: don't pass minikubeFlags here. These are pretty much intended for "minikube start" only. -- TODO: clarify the documentation and possibly add an extra field where extra options can be passed -- to "minikube image" commands. - Minikube.getLoadedImages minikubeBinary kubernetesClusterName [] + Minikube.getLoadedImagesMinikube kubernetesClusterTypeMinikubeBinary kubernetesClusterName [] -- | Test if a cluster has a given image loaded. clusterContainsImage :: ( - HasCallStack, KubernetesClusterBasic m context + HasCallStack, KubernetesClusterBasic context m ) -- | Image => Text @@ -104,13 +106,13 @@ clusterContainsImage' :: ( clusterContainsImage' kcc@(KubernetesClusterContext {kubernetesClusterType, kubernetesClusterName}) image = do case kubernetesClusterType of KubernetesClusterKind {..} -> - Kind.clusterContainsImage kcc kindClusterDriver kindBinary kindClusterEnvironment image + Kind.clusterContainsImageKind kcc kubernetesClusterTypeKindClusterDriver kubernetesClusterTypeKindBinary kubernetesClusterTypeKindClusterEnvironment image KubernetesClusterMinikube {..} -> - Minikube.clusterContainsImage minikubeBinary kubernetesClusterName [] image + Minikube.clusterContainsImageMinikube kubernetesClusterTypeMinikubeBinary kubernetesClusterName [] image -- | Same as 'loadImage', but first checks if the given image is already present on the cluster. loadImageIfNecessary :: ( - HasCallStack, MonadFail m, KubernetesClusterBasic m context + HasCallStack, MonadFail m, KubernetesClusterBasic context m ) -- | Image load spec => ImageLoadSpec @@ -121,7 +123,7 @@ loadImageIfNecessary image = do -- | Same as 'loadImage', but allows you to pass in the 'KubernetesClusterContext', rather than requiring one in context. loadImageIfNecessary' :: ( - HasCallStack, MonadFail m, KubernetesBasic m context + HasCallStack, MonadFail m, KubernetesBasic context m ) -- | Cluster context => KubernetesClusterContext @@ -133,11 +135,10 @@ loadImageIfNecessary' kcc imageLoadSpec = do unlessM (imageLoadSpecToImageName imageLoadSpec >>= clusterContainsImage' kcc) $ void $ loadImage' kcc imageLoadSpec --- | 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, +-- | Load an image into a Kubernetes cluster. This 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 :: ( - HasCallStack, MonadFail m, KubernetesClusterBasic m context + HasCallStack, MonadFail m, KubernetesClusterBasic context m ) -- | Image load spec => ImageLoadSpec @@ -149,7 +150,7 @@ loadImage image = do -- | Same as 'loadImage', but allows you to pass in the 'KubernetesClusterContext'. loadImage' :: ( - HasCallStack, MonadFail m, KubernetesBasic m context + HasCallStack, MonadFail m, KubernetesBasic context m ) -- | Cluster context => KubernetesClusterContext @@ -162,10 +163,10 @@ loadImage' (KubernetesClusterContext {kubernetesClusterType, kubernetesClusterNa timeAction [i|Loading container image '#{imageLoadSpec}'|] $ do case kubernetesClusterType of (KubernetesClusterKind {..}) -> - Kind.loadImage kindBinary kindClusterName imageLoadSpec kindClusterEnvironment + Kind.loadImageKind kubernetesClusterTypeKindBinary kubernetesClusterTypeKindClusterName imageLoadSpec kubernetesClusterTypeKindClusterEnvironment (KubernetesClusterMinikube {..}) -> -- Don't pass minikubeFlags; see comment above. - Minikube.loadImage minikubeBinary kubernetesClusterName [] imageLoadSpec + Minikube.loadImageMinikube kubernetesClusterTypeMinikubeBinary kubernetesClusterName [] imageLoadSpec -- Because of the possible silent failure in "minikube image load", confirm that this -- image made it onto the cluster. @@ -182,12 +183,12 @@ loadImage' (KubernetesClusterContext {kubernetesClusterType, kubernetesClusterNa -- loadedImages `shouldContain` [image'] -- return image' --- | Same as 'withImageLoadRetry'', but with a reasonable default retry policy. +-- | A combinator to wrap around your 'loadImage' or 'loadImageIfNecessary' calls to retry +-- on failure. Image loads sometimes fail on Minikube (version 1.33.0 at time of writing). withImageLoadRetry :: (MonadLoggerIO m, MonadMask m) => ImageLoadSpec -> m a -> m a withImageLoadRetry = withImageLoadRetry' (exponentialBackoff 50000 <> limitRetries 5) --- | A combinator to wrap around your 'loadImage' or 'loadImageIfNecessary' calls to retry --- on failure. Image loads sometimes fail on Minikube (version 1.33.0 at time of writing). +-- | Same as 'withImageLoadRetry', but allows you to specify the retry policy. withImageLoadRetry' :: (MonadLoggerIO m, MonadMask m) => RetryPolicyM m -> ImageLoadSpec -> m a -> m a withImageLoadRetry' policy ils action = recovering policy [\_status -> Handler (\(e :: FailureReason) -> do @@ -199,7 +200,11 @@ withImageLoadRetry' policy ils action = -- | Helper to introduce a list of images into a Kubernetes cluster. -- Stores the list of transformed image names under the "kubernetesClusterImages" label. introduceImages :: ( - HasCallStack, KubernetesClusterBasic m context - ) => [ImageLoadSpec] -> SpecFree (LabelValue "kubernetesClusterImages" [Text] :> context) m () -> SpecFree context m () + HasCallStack, KubernetesClusterBasic context m + ) + -- | Images to load + => [ImageLoadSpec] + -> SpecFree (LabelValue "kubernetesClusterImages" [Text] :> context) m () + -> SpecFree context m () introduceImages images = introduceWith "Introduce cluster images" kubernetesClusterImages $ \action -> forM images (\x -> loadImage x) >>= (void . action) diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers.hs index 0ff8fb83..5a565d58 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers.hs @@ -104,8 +104,10 @@ withKataContainers' kcc@(KubernetesClusterContext {..}) kubectlBinary options@(K case kubernetesClusterType of KubernetesClusterKind {} -> expectationFailure [i|Can't install Kata Containers on Kind at present.|] KubernetesClusterMinikube {..} -> do - output <- readCreateProcessWithLogging (proc minikubeBinary ["--profile", toString minikubeProfileName - , "ssh", [i|egrep -c 'vmx|svm' /proc/cpuinfo|]]) "" + output <- readCreateProcessWithLogging (proc kubernetesClusterTypeMinikubeBinary [ + "--profile", toString kubernetesClusterTypeMinikubeProfileName + , "ssh", [i|egrep -c 'vmx|svm' /proc/cpuinfo|] + ]) "" case readMay output of Just (0 :: Int) -> expectationFailure [i|Preflight check: didn't find "vmx" or "svm" in /proc/cpuinfo. Please make sure virtualization support is enabled.|] Just _ -> return () 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 32c7fdac..e5b74e85 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs @@ -14,9 +14,9 @@ module Test.Sandwich.Contexts.Kubernetes.KindCluster ( , withKindCluster' -- * Image management - , Images.clusterContainsImage - , Images.getLoadedImages - , Images.loadImage + , Images.clusterContainsImageKind + , Images.getLoadedImagesKind + , Images.loadImageKind -- * Re-exported types , KubernetesClusterContext (..) 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 72d811cd..cd20a300 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 @@ -4,9 +4,9 @@ {-# LANGUAGE TypeOperators #-} module Test.Sandwich.Contexts.Kubernetes.KindCluster.Images ( - getLoadedImages - , clusterContainsImage - , loadImage + getLoadedImagesKind + , clusterContainsImageKind + , loadImageKind ) where import Control.Monad.IO.Unlift @@ -28,7 +28,7 @@ import UnliftIO.Process import UnliftIO.Temporary -loadImage :: ( +loadImageKind :: ( HasCallStack, MonadUnliftIO m, MonadLoggerIO m ) -- | Kind binary @@ -41,7 +41,7 @@ loadImage :: ( -> Maybe [(String, String)] -- | Callback with transformed image names (see above) -> m Text -loadImage kindBinary clusterName imageLoadSpec env = do +loadImageKind kindBinary clusterName imageLoadSpec env = do case imageLoadSpec of ImageLoadSpecTarball image -> do doesDirectoryExist (toString image) >>= \case @@ -90,10 +90,10 @@ loadImage kindBinary clusterName imageLoadSpec env = do env = env }) >>= waitForProcess >>= (`shouldBe` ExitSuccess) -getLoadedImages :: ( +getLoadedImagesKind :: ( HasCallStack, MonadUnliftIO m, MonadLogger m ) => KubernetesClusterContext -> Text -> FilePath -> Maybe [(String, String)] -> m (Set Text) -getLoadedImages kcc driver kindBinary env = do +getLoadedImagesKind kcc driver kindBinary env = do chosenNode <- getNodes kcc kindBinary env >>= \case (x:_) -> pure x [] -> expectationFailure [i|Couldn't identify a Kind node.|] @@ -116,15 +116,15 @@ getLoadedImages kcc driver kindBinary env = do extractRepoTags (A.Object (aesonLookup "repoTags" -> Just (A.Array xs))) = [t | A.String t <- V.toList xs] extractRepoTags _ = [] -clusterContainsImage :: ( +clusterContainsImageKind :: ( HasCallStack, MonadUnliftIO m, MonadLogger m ) => KubernetesClusterContext -> Text -> FilePath -> Maybe [(String, String)] -> Text -> m Bool -clusterContainsImage kcc driver kindBinary env image = do +clusterContainsImageKind kcc driver kindBinary env image = do imageName <- case isAbsolute (toString image) of False -> pure image True -> readImageName (toString image) - loadedImages <- getLoadedImages kcc driver kindBinary env + loadedImages <- getLoadedImagesKind kcc driver kindBinary env return ( imageName `Set.member` loadedImages diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs index d6660e12..a738f392 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs @@ -37,7 +37,7 @@ withForwardKubernetesService' :: ( MonadUnliftIO m, MonadLoggerIO m ) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) kubectlBinary namespace service action = do - baseEnv <- maybe getEnvironment return kindClusterEnvironment + baseEnv <- maybe getEnvironment return kubernetesClusterTypeKindClusterEnvironment let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv) randomHost <- generateRandomHostname @@ -61,7 +61,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=( Just x -> pure x hostAndPort <- (T.strip . toText) <$> readCreateProcessWithLogging ( - proc (toString kindClusterDriver) [ + proc (toString kubernetesClusterTypeKindClusterDriver) [ "port", toString controlPlaneNode, "80/tcp" ]) "" let caddyArgs :: [String] = [ diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs index 17c6c330..3c27f9b8 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs @@ -27,7 +27,7 @@ withForwardKubernetesService' :: ( , HasBaseContextMonad context m ) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) kubectlBinary namespace service action = do - baseEnv <- maybe getEnvironment return kindClusterEnvironment + baseEnv <- maybe getEnvironment return kubernetesClusterTypeKindClusterEnvironment let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv) portRaw <- (toString . T.strip . toText) <$> readCreateProcessWithLogging ( diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Kubectl.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Kubectl.hs index 002903f4..55ff6566 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Kubectl.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Kubectl.hs @@ -25,7 +25,7 @@ import UnliftIO.Environment -- -- Useful for running Kubectl commands with 'System.Process.createProcess' etc. askKubectlArgs :: ( - KubectlBasic m context + KubectlBasic context m ) -- | Returns the @kubectl@ binary and environment variables. => m (FilePath, [(String, String)]) diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster.hs index 1cc3433d..c489191b 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster.hs @@ -16,9 +16,9 @@ module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster ( , withMinikubeCluster'' -- * Image management - , Images.clusterContainsImage - , Images.getLoadedImages - , Images.loadImage + , Images.clusterContainsImageMinikube + , Images.getLoadedImagesMinikube + , Images.loadImageMinikube -- * Re-exported cluster types , kubernetesCluster @@ -209,9 +209,9 @@ withMinikubeCluster'' clusterName minikubeBinary options@(MinikubeClusterOptions , kubernetesClusterNumNodes = minikubeClusterNumNodes , kubernetesClusterClientConfig = (m, c) , kubernetesClusterType = KubernetesClusterMinikube { - minikubeBinary = minikubeBinary - , minikubeProfileName = toText clusterName - , minikubeFlags = minikubeClusterExtraFlags + kubernetesClusterTypeMinikubeBinary = minikubeBinary + , kubernetesClusterTypeMinikubeProfileName = toText clusterName + , kubernetesClusterTypeMinikubeFlags = minikubeClusterExtraFlags } } ) diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs index 8245f130..c2bd0797 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs @@ -31,7 +31,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=( baseEnv <- liftIO getEnvironment let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv) - let extraFlags = case "--rootless" `L.elem` minikubeFlags of + let extraFlags = case "--rootless" `L.elem` kubernetesClusterTypeMinikubeFlags of True -> ["--rootless"] False -> [] @@ -42,7 +42,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=( , "service" , toString service , "--url"] - info [i|#{minikubeBinary} #{T.unwords $ fmap toText args}|] + info [i|#{kubernetesClusterTypeMinikubeBinary} #{T.unwords $ fmap toText args}|] (stdoutRead, stdoutWrite) <- liftIO createPipe (stderrRead, stderrWrite) <- liftIO createPipe @@ -52,7 +52,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=( info [i|minikube service stderr: #{line}|] withAsync forwardStderr $ \_ -> do - let cp = (proc minikubeBinary args) { + let cp = (proc kubernetesClusterTypeMinikubeBinary args) { env = Just env , std_out = UseHandle stdoutWrite , std_err = UseHandle stderrWrite 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 ae536754..4773d03f 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 @@ -4,9 +4,9 @@ {-# LANGUAGE TypeOperators #-} module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images ( - getLoadedImages - , clusterContainsImage - , loadImage + getLoadedImagesMinikube + , clusterContainsImageMinikube + , loadImageMinikube ) where import Control.Monad @@ -31,7 +31,7 @@ import UnliftIO.Temporary -- | Load an image onto a cluster. This image can come from a variety of sources, as specified by the 'ImageLoadSpec'. -loadImage :: ( +loadImageMinikube :: ( HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m ) -- | Path to @minikube@ binary @@ -42,7 +42,7 @@ loadImage :: ( -> [Text] -> ImageLoadSpec -> m Text -loadImage minikubeBinary clusterName minikubeFlags imageLoadSpec = do +loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do case imageLoadSpec of ImageLoadSpecTarball image -> do -- File or directory image @@ -129,7 +129,7 @@ loadImage minikubeBinary clusterName minikubeFlags imageLoadSpec = do check3 bytes = bytes =~ ("failed pushing to:[[:blank:]]*[^[:space:]]+$" :: Text) -- | Get the loaded images on a cluster, by cluster name. -getLoadedImages :: ( +getLoadedImagesMinikube :: ( MonadUnliftIO m, MonadLogger m ) -- | Path to @minikube@ binary @@ -139,7 +139,7 @@ getLoadedImages :: ( -- | Extra flags to pass to @minikube@ -> [Text] -> m (Set Text) -getLoadedImages minikubeBinary clusterName minikubeFlags = do +getLoadedImagesMinikube minikubeBinary clusterName minikubeFlags = do -- TODO: use "--format json" and parse? (Set.fromList . T.words . toText) <$> readCreateProcessWithLogging ( proc minikubeBinary (["image", "ls" @@ -147,7 +147,7 @@ getLoadedImages minikubeBinary clusterName minikubeFlags = do ] <> fmap toString minikubeFlags)) "" -- | Test if the cluster contains a given image, by cluster name. -clusterContainsImage :: ( +clusterContainsImageMinikube :: ( MonadUnliftIO m, MonadLogger m ) -- | Path to @minikube@ binary @@ -159,12 +159,12 @@ clusterContainsImage :: ( -- | Image name -> Text -> m Bool -clusterContainsImage minikubeBinary clusterName minikubeFlags image = do +clusterContainsImageMinikube minikubeBinary clusterName minikubeFlags image = do imageName <- case isAbsolute (toString image) of False -> pure image True -> readImageName (toString image) - loadedImages <- getLoadedImages minikubeBinary clusterName minikubeFlags + loadedImages <- getLoadedImagesMinikube minikubeBinary clusterName minikubeFlags return ( imageName `Set.member` loadedImages diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs index abc89b6b..52fd29d9 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs @@ -30,7 +30,6 @@ module Test.Sandwich.Contexts.Kubernetes.MinioOperator ( import Control.Monad import Control.Monad.IO.Unlift -import Control.Monad.Logger import Data.Aeson (FromJSON) import Data.String.Interpolate import Data.Text as T @@ -66,7 +65,7 @@ defaultMinioOperatorOptions = MinioOperatorOptions { -- | Install the [MinIO Kubernetes operator](https://min.io/docs/minio/kubernetes/upstream/operations/installation.html) onto a Kubernetes cluster. introduceMinioOperator :: ( - KubectlBasic m context + KubectlBasicWithoutReader context m ) -- | Options => MinioOperatorOptions @@ -78,7 +77,7 @@ introduceMinioOperator options = introduceWith "introduce MinIO operator" minioO -- | Same as 'introduceMinioOperator', but allows you to pass in the @kubectl@ binary path. introduceMinioOperator' :: ( - MonadUnliftIO m, MonadFail m, HasKubernetesClusterContext context, HasBaseContext context + HasCallStack, MonadFail m, MonadUnliftIO m, HasKubernetesClusterContext context, HasBaseContext context ) -- | Path to @kubectl@ binary => FilePath @@ -92,8 +91,7 @@ introduceMinioOperator' kubectlBinary options = introduceWith "introduce MinIO o -- | Bracket-style variant of 'introduceMinioOperator'. withMinioOperator :: ( - MonadLoggerIO m, MonadUnliftIO m, MonadFail m - , HasBaseContextMonad context m, HasFile context "kubectl" + HasCallStack, MonadFail m, KubectlBasic context m ) -- | Options => MinioOperatorOptions @@ -106,8 +104,7 @@ withMinioOperator options kcc action = do -- | Same as 'withMinioOperator', but allows you to pass in the @kubectl@ binary path. withMinioOperator' :: ( - MonadLoggerIO m, MonadUnliftIO m, MonadFail m - , HasBaseContextMonad context m + HasCallStack, MonadFail m, KubernetesBasic context m ) -- | Path to @kubectl@ binary => FilePath diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs index 519bbab9..a3b597b4 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs @@ -76,7 +76,7 @@ data KustomizationDir = -- | Introduce a MinIO server on a Kubernetes cluster. -- Must have a 'minioOperator' context. introduceK8SMinioS3Server :: ( - MonadMask m, Typeable context, KubectlBasic m context, HasMinioOperatorContext context + MonadMask m, Typeable context, KubectlBasicWithoutReader context m, HasMinioOperatorContext context ) -- | Options => MinioS3ServerOptions @@ -90,7 +90,7 @@ introduceK8SMinioS3Server options = do -- | Same as 'introduceK8SMinioS3Server', but allows you to pass in the 'KubernetesClusterContext'. introduceK8SMinioS3Server' :: ( - MonadMask m, Typeable context, KubectlBasic m context, HasMinioOperatorContext context + MonadMask m, Typeable context, KubectlBasic context m, HasMinioOperatorContext context ) => KubernetesClusterContext -- | Options @@ -104,7 +104,7 @@ introduceK8SMinioS3Server' kubernetesClusterContext options = -- | Bracket-style variant of 'introduceK8SMinioS3Server'. withK8SMinioS3Server :: ( - Typeable context, MonadMask m, MonadFail m, KubectlBasic m context + Typeable context, MonadMask m, MonadFail m, KubectlBasic context m ) => KubernetesClusterContext -> MinioOperatorContext @@ -118,7 +118,7 @@ withK8SMinioS3Server kcc moc options action = do -- | Same as 'withK8SMinioS3Server', but allows you to pass in the kubectl and kubectl-minio binaries. withK8SMinioS3Server' :: forall m context. ( - Typeable context, MonadMask m, MonadFail m, KubernetesBasic m context + Typeable context, MonadMask m, MonadFail m, KubernetesBasic context m ) -- | Path to kubectl binary => FilePath diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs index fd6c5348..d95e9787 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs @@ -27,17 +27,18 @@ import UnliftIO.Process -- -- If you're installing something via Helm 3, you may not need this as you can just pass @--create-namespace@. withKubernetesNamespace :: ( - KubectlBasic m context + KubectlBasicWithoutReader context m ) -- | Namespace to create => Text -> SpecFree context m () -> SpecFree context m () -withKubernetesNamespace namespace = around [i|Create the '#{namespace}' kubernetes namespace|] (void . bracket_ (createKubernetesNamespace namespace) (destroyKubernetesNamespace False namespace)) +withKubernetesNamespace namespace = around [i|Create the '#{namespace}' kubernetes namespace|] + (void . bracket_ (createKubernetesNamespace namespace) (destroyKubernetesNamespace False namespace)) -- | Same as 'withKubernetesNamespace', but works in an arbitrary monad with reader context. withKubernetesNamespace' :: ( - KubectlBasic m context + KubectlBasic context m ) -- | Namespace to create => Text @@ -47,7 +48,7 @@ withKubernetesNamespace' namespace = bracket_ (createKubernetesNamespace namespa -- | Create a Kubernetes namespace. createKubernetesNamespace :: ( - KubectlBasic m context + KubectlBasic context m ) => Text -> m () createKubernetesNamespace namespace = do let args = ["create", "namespace", toString namespace] @@ -57,7 +58,7 @@ createKubernetesNamespace namespace = do -- | Destroy a Kubernetes namespace. destroyKubernetesNamespace :: ( - KubectlBasic m context + KubectlBasic context m ) => Bool -> Text -> m () destroyKubernetesNamespace force namespace = do let args = ["delete", "namespace", toString namespace] diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs index 023e08a8..7ea93d58 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs @@ -79,7 +79,7 @@ type ContextWithSeaweedFS context = -- | Introduce [SeaweedFS](https://github.com/seaweedfs/seaweedfs) on the Kubernetes cluster, in a given namespace. introduceSeaweedFS :: ( - KubernetesClusterBasic m context, HasNixContext context + KubernetesClusterBasicWithoutReader context m, HasNixContext context ) -- | Namespace => Text @@ -90,7 +90,7 @@ introduceSeaweedFS namespace options = introduceBinaryViaNixPackage @"kubectl" " -- | Bracket-style version of 'introduceSeaweedFS'. withSeaweedFS :: forall context m a. ( - HasCallStack, MonadFail m, KubectlBasic m context, HasNixContext context + HasCallStack, MonadFail m, KubectlBasic context m, HasNixContext context ) -- | Namespace => Text @@ -104,7 +104,7 @@ withSeaweedFS namespace options action = do -- | Same as 'withSeaweedFS', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary path. withSeaweedFS' :: forall context m a. ( - HasCallStack, MonadFail m, NixContextBasic m context + HasCallStack, MonadFail m, NixContextBasic context m ) -- | Cluster context => KubernetesClusterContext diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Types.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Types.hs index d1c0477a..509fbcd3 100644 --- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Types.hs +++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Types.hs @@ -26,14 +26,14 @@ instance Show Manager where -- * Kubernetes cluster data KubernetesClusterType = - KubernetesClusterKind { kindBinary :: FilePath - , kindClusterName :: Text - , kindClusterDriver :: Text - , kindClusterEnvironment :: Maybe [(String, String)] + KubernetesClusterKind { kubernetesClusterTypeKindBinary :: FilePath + , kubernetesClusterTypeKindClusterName :: Text + , kubernetesClusterTypeKindClusterDriver :: Text + , kubernetesClusterTypeKindClusterEnvironment :: Maybe [(String, String)] } - | KubernetesClusterMinikube { minikubeBinary :: FilePath - , minikubeProfileName :: Text - , minikubeFlags :: [Text] + | KubernetesClusterMinikube { kubernetesClusterTypeMinikubeBinary :: FilePath + , kubernetesClusterTypeMinikubeProfileName :: Text + , kubernetesClusterTypeMinikubeFlags :: [Text] } deriving (Show, Eq) @@ -49,31 +49,52 @@ kubernetesCluster :: Label "kubernetesCluster" KubernetesClusterContext kubernetesCluster = Label type HasKubernetesClusterContext context = HasLabel context "kubernetesCluster" KubernetesClusterContext --- * Context +-- * Contexts with MonadReader -type KubernetesBasic m context = ( +type KubernetesBasic context m = ( MonadLoggerIO m , MonadUnliftIO m , HasBaseContextMonad context m ) -type KubernetesClusterBasic m context = ( - KubernetesBasic m context +type KubernetesClusterBasic context m = ( + KubernetesBasic context m , HasKubernetesClusterContext context ) -type KubectlBasic m context = ( - KubernetesClusterBasic m context +type KubectlBasic context m = ( + KubernetesClusterBasic context m , HasFile context "kubectl" ) -type NixContextBasic m context = ( +type NixContextBasic context m = ( MonadLoggerIO m , MonadUnliftIO m , HasBaseContextMonad context m , HasNixContext context ) +-- * Context with MonadReader + +type KubernetesBasicWithoutReader context m = ( + MonadLoggerIO m + , MonadUnliftIO m + , HasBaseContext context + ) + +type KubernetesClusterBasicWithoutReader context m = ( + MonadUnliftIO m + , HasBaseContext context + , HasKubernetesClusterContext context + ) + +type KubectlBasicWithoutReader context m = ( + MonadUnliftIO m + , HasBaseContext context + , HasKubernetesClusterContext context + , HasFile context "kubectl" + ) + -- * Kubernetes cluster images kubernetesClusterImages :: Label "kubernetesClusterImages" [Text] diff --git a/sandwich-contexts-kubernetes/package.yaml b/sandwich-contexts-kubernetes/package.yaml index 35d757b7..81e0f388 100644 --- a/sandwich-contexts-kubernetes/package.yaml +++ b/sandwich-contexts-kubernetes/package.yaml @@ -43,7 +43,6 @@ library: - Test.Sandwich.Contexts.Kubernetes.MinioS3Server - Test.Sandwich.Contexts.Kubernetes.Namespace - Test.Sandwich.Contexts.Kubernetes.SeaweedFS - - Test.Sandwich.Contexts.Kubernetes.Types dependencies: - aeson - bytestring diff --git a/sandwich-contexts-kubernetes/sandwich-contexts-kubernetes.cabal b/sandwich-contexts-kubernetes/sandwich-contexts-kubernetes.cabal index 622662cc..2f52c71f 100644 --- a/sandwich-contexts-kubernetes/sandwich-contexts-kubernetes.cabal +++ b/sandwich-contexts-kubernetes/sandwich-contexts-kubernetes.cabal @@ -25,7 +25,6 @@ library Test.Sandwich.Contexts.Kubernetes.MinioS3Server Test.Sandwich.Contexts.Kubernetes.Namespace Test.Sandwich.Contexts.Kubernetes.SeaweedFS - Test.Sandwich.Contexts.Kubernetes.Types other-modules: Test.Sandwich.Contexts.Kubernetes.FindImages Test.Sandwich.Contexts.Kubernetes.KindCluster.Config @@ -41,6 +40,7 @@ library Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images Test.Sandwich.Contexts.Kubernetes.MinioS3Server.Parsing Test.Sandwich.Contexts.Kubernetes.Run + Test.Sandwich.Contexts.Kubernetes.Types Test.Sandwich.Contexts.Kubernetes.Util Test.Sandwich.Contexts.Kubernetes.Util.Aeson Test.Sandwich.Contexts.Kubernetes.Util.Container