sandwich-contexts-kubernetes: more

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 ()

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

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,15 +57,15 @@ 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)
 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)

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 ()

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 (..)

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

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] = [

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 (

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)])

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
                        }
                    }
              )

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